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
3612   if (iomode == IO_OUTPUT)
3613     mio_namespace_ref (&sym->formal_ns);
3614   else
3615     {
3616       mio_namespace_ref (&sym->formal_ns);
3617       if (sym->formal_ns)
3618         {
3619           sym->formal_ns->proc_name = sym;
3620           sym->refs++;
3621         }
3622     }
3623
3624   /* Save/restore common block links.  */
3625   mio_symbol_ref (&sym->common_next);
3626
3627   mio_formal_arglist (&sym->formal);
3628
3629   if (sym->attr.flavor == FL_PARAMETER)
3630     mio_expr (&sym->value);
3631
3632   mio_array_spec (&sym->as);
3633
3634   mio_symbol_ref (&sym->result);
3635
3636   if (sym->attr.cray_pointee)
3637     mio_symbol_ref (&sym->cp_pointer);
3638
3639   /* Note that components are always saved, even if they are supposed
3640      to be private.  Component access is checked during searching.  */
3641
3642   mio_component_list (&sym->components, sym->attr.vtype);
3643
3644   if (sym->components != NULL)
3645     sym->component_access
3646       = MIO_NAME (gfc_access) (sym->component_access, access_types);
3647
3648   /* Load/save the f2k_derived namespace of a derived-type symbol.  */
3649   mio_full_f2k_derived (sym);
3650
3651   mio_namelist (sym);
3652
3653   /* Add the fields that say whether this is from an intrinsic module,
3654      and if so, what symbol it is within the module.  */
3655 /*   mio_integer (&(sym->from_intmod)); */
3656   if (iomode == IO_OUTPUT)
3657     {
3658       intmod = sym->from_intmod;
3659       mio_integer (&intmod);
3660     }
3661   else
3662     {
3663       mio_integer (&intmod);
3664       sym->from_intmod = (intmod_id) intmod;
3665     }
3666
3667   mio_integer (&(sym->intmod_sym_id));
3668
3669   if (sym->attr.flavor == FL_DERIVED)
3670     mio_integer (&(sym->hash_value));
3671
3672   mio_rparen ();
3673 }
3674
3675
3676 /************************* Top level subroutines *************************/
3677
3678 /* Given a root symtree node and a symbol, try to find a symtree that
3679    references the symbol that is not a unique name.  */
3680
3681 static gfc_symtree *
3682 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3683 {
3684   gfc_symtree *s = NULL;
3685
3686   if (st == NULL)
3687     return s;
3688
3689   s = find_symtree_for_symbol (st->right, sym);
3690   if (s != NULL)
3691     return s;
3692   s = find_symtree_for_symbol (st->left, sym);
3693   if (s != NULL)
3694     return s;
3695
3696   if (st->n.sym == sym && !check_unique_name (st->name))
3697     return st;
3698
3699   return s;
3700 }
3701
3702
3703 /* A recursive function to look for a specific symbol by name and by
3704    module.  Whilst several symtrees might point to one symbol, its
3705    is sufficient for the purposes here than one exist.  Note that
3706    generic interfaces are distinguished as are symbols that have been
3707    renamed in another module.  */
3708 static gfc_symtree *
3709 find_symbol (gfc_symtree *st, const char *name,
3710              const char *module, int generic)
3711 {
3712   int c;
3713   gfc_symtree *retval, *s;
3714
3715   if (st == NULL || st->n.sym == NULL)
3716     return NULL;
3717
3718   c = strcmp (name, st->n.sym->name);
3719   if (c == 0 && st->n.sym->module
3720              && strcmp (module, st->n.sym->module) == 0
3721              && !check_unique_name (st->name))
3722     {
3723       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3724
3725       /* Detect symbols that are renamed by use association in another
3726          module by the absence of a symtree and null attr.use_rename,
3727          since the latter is not transmitted in the module file.  */
3728       if (((!generic && !st->n.sym->attr.generic)
3729                 || (generic && st->n.sym->attr.generic))
3730             && !(s == NULL && !st->n.sym->attr.use_rename))
3731         return st;
3732     }
3733
3734   retval = find_symbol (st->left, name, module, generic);
3735
3736   if (retval == NULL)
3737     retval = find_symbol (st->right, name, module, generic);
3738
3739   return retval;
3740 }
3741
3742
3743 /* Skip a list between balanced left and right parens.  */
3744
3745 static void
3746 skip_list (void)
3747 {
3748   int level;
3749
3750   level = 0;
3751   do
3752     {
3753       switch (parse_atom ())
3754         {
3755         case ATOM_LPAREN:
3756           level++;
3757           break;
3758
3759         case ATOM_RPAREN:
3760           level--;
3761           break;
3762
3763         case ATOM_STRING:
3764           free (atom_string);
3765           break;
3766
3767         case ATOM_NAME:
3768         case ATOM_INTEGER:
3769           break;
3770         }
3771     }
3772   while (level > 0);
3773 }
3774
3775
3776 /* Load operator interfaces from the module.  Interfaces are unusual
3777    in that they attach themselves to existing symbols.  */
3778
3779 static void
3780 load_operator_interfaces (void)
3781 {
3782   const char *p;
3783   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3784   gfc_user_op *uop;
3785   pointer_info *pi = NULL;
3786   int n, i;
3787
3788   mio_lparen ();
3789
3790   while (peek_atom () != ATOM_RPAREN)
3791     {
3792       mio_lparen ();
3793
3794       mio_internal_string (name);
3795       mio_internal_string (module);
3796
3797       n = number_use_names (name, true);
3798       n = n ? n : 1;
3799
3800       for (i = 1; i <= n; i++)
3801         {
3802           /* Decide if we need to load this one or not.  */
3803           p = find_use_name_n (name, &i, true);
3804
3805           if (p == NULL)
3806             {
3807               while (parse_atom () != ATOM_RPAREN);
3808               continue;
3809             }
3810
3811           if (i == 1)
3812             {
3813               uop = gfc_get_uop (p);
3814               pi = mio_interface_rest (&uop->op);
3815             }
3816           else
3817             {
3818               if (gfc_find_uop (p, NULL))
3819                 continue;
3820               uop = gfc_get_uop (p);
3821               uop->op = gfc_get_interface ();
3822               uop->op->where = gfc_current_locus;
3823               add_fixup (pi->integer, &uop->op->sym);
3824             }
3825         }
3826     }
3827
3828   mio_rparen ();
3829 }
3830
3831
3832 /* Load interfaces from the module.  Interfaces are unusual in that
3833    they attach themselves to existing symbols.  */
3834
3835 static void
3836 load_generic_interfaces (void)
3837 {
3838   const char *p;
3839   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3840   gfc_symbol *sym;
3841   gfc_interface *generic = NULL, *gen = NULL;
3842   int n, i, renamed;
3843   bool ambiguous_set = false;
3844
3845   mio_lparen ();
3846
3847   while (peek_atom () != ATOM_RPAREN)
3848     {
3849       mio_lparen ();
3850
3851       mio_internal_string (name);
3852       mio_internal_string (module);
3853
3854       n = number_use_names (name, false);
3855       renamed = n ? 1 : 0;
3856       n = n ? n : 1;
3857
3858       for (i = 1; i <= n; i++)
3859         {
3860           gfc_symtree *st;
3861           /* Decide if we need to load this one or not.  */
3862           p = find_use_name_n (name, &i, false);
3863
3864           st = find_symbol (gfc_current_ns->sym_root,
3865                             name, module_name, 1);
3866
3867           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3868             {
3869               /* Skip the specific names for these cases.  */
3870               while (i == 1 && parse_atom () != ATOM_RPAREN);
3871
3872               continue;
3873             }
3874
3875           /* If the symbol exists already and is being USEd without being
3876              in an ONLY clause, do not load a new symtree(11.3.2).  */
3877           if (!only_flag && st)
3878             sym = st->n.sym;
3879
3880           if (!sym)
3881             {
3882               /* Make the symbol inaccessible if it has been added by a USE
3883                  statement without an ONLY(11.3.2).  */
3884               if (st && only_flag
3885                      && !st->n.sym->attr.use_only
3886                      && !st->n.sym->attr.use_rename
3887                      && strcmp (st->n.sym->module, module_name) == 0)
3888                 {
3889                   sym = st->n.sym;
3890                   gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3891                   st = gfc_get_unique_symtree (gfc_current_ns);
3892                   st->n.sym = sym;
3893                   sym = NULL;
3894                 }
3895               else if (st)
3896                 {
3897                   sym = st->n.sym;
3898                   if (strcmp (st->name, p) != 0)
3899                     {
3900                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
3901                       st->n.sym = sym;
3902                       sym->refs++;
3903                     }
3904                 }
3905
3906               /* Since we haven't found a valid generic interface, we had
3907                  better make one.  */
3908               if (!sym)
3909                 {
3910                   gfc_get_symbol (p, NULL, &sym);
3911                   sym->name = gfc_get_string (name);
3912                   sym->module = gfc_get_string (module_name);
3913                   sym->attr.flavor = FL_PROCEDURE;
3914                   sym->attr.generic = 1;
3915                   sym->attr.use_assoc = 1;
3916                 }
3917             }
3918           else
3919             {
3920               /* Unless sym is a generic interface, this reference
3921                  is ambiguous.  */
3922               if (st == NULL)
3923                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3924
3925               sym = st->n.sym;
3926
3927               if (st && !sym->attr.generic
3928                      && !st->ambiguous
3929                      && sym->module
3930                      && strcmp(module, sym->module))
3931                 {
3932                   ambiguous_set = true;
3933                   st->ambiguous = 1;
3934                 }
3935             }
3936
3937           sym->attr.use_only = only_flag;
3938           sym->attr.use_rename = renamed;
3939
3940           if (i == 1)
3941             {
3942               mio_interface_rest (&sym->generic);
3943               generic = sym->generic;
3944             }
3945           else if (!sym->generic)
3946             {
3947               sym->generic = generic;
3948               sym->attr.generic_copy = 1;
3949             }
3950
3951           /* If a procedure that is not generic has generic interfaces
3952              that include itself, it is generic! We need to take care
3953              to retain symbols ambiguous that were already so.  */
3954           if (sym->attr.use_assoc
3955                 && !sym->attr.generic
3956                 && sym->attr.flavor == FL_PROCEDURE)
3957             {
3958               for (gen = generic; gen; gen = gen->next)
3959                 {
3960                   if (gen->sym == sym)
3961                     {
3962                       sym->attr.generic = 1;
3963                       if (ambiguous_set)
3964                         st->ambiguous = 0;
3965                       break;
3966                     }
3967                 }
3968             }
3969
3970         }
3971     }
3972
3973   mio_rparen ();
3974 }
3975
3976
3977 /* Load common blocks.  */
3978
3979 static void
3980 load_commons (void)
3981 {
3982   char name[GFC_MAX_SYMBOL_LEN + 1];
3983   gfc_common_head *p;
3984
3985   mio_lparen ();
3986
3987   while (peek_atom () != ATOM_RPAREN)
3988     {
3989       int flags;
3990       mio_lparen ();
3991       mio_internal_string (name);
3992
3993       p = gfc_get_common (name, 1);
3994
3995       mio_symbol_ref (&p->head);
3996       mio_integer (&flags);
3997       if (flags & 1)
3998         p->saved = 1;
3999       if (flags & 2)
4000         p->threadprivate = 1;
4001       p->use_assoc = 1;
4002
4003       /* Get whether this was a bind(c) common or not.  */
4004       mio_integer (&p->is_bind_c);
4005       /* Get the binding label.  */
4006       mio_internal_string (p->binding_label);
4007
4008       mio_rparen ();
4009     }
4010
4011   mio_rparen ();
4012 }
4013
4014
4015 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
4016    so that unused variables are not loaded and so that the expression can
4017    be safely freed.  */
4018
4019 static void
4020 load_equiv (void)
4021 {
4022   gfc_equiv *head, *tail, *end, *eq;
4023   bool unused;
4024
4025   mio_lparen ();
4026   in_load_equiv = true;
4027
4028   end = gfc_current_ns->equiv;
4029   while (end != NULL && end->next != NULL)
4030     end = end->next;
4031
4032   while (peek_atom () != ATOM_RPAREN) {
4033     mio_lparen ();
4034     head = tail = NULL;
4035
4036     while(peek_atom () != ATOM_RPAREN)
4037       {
4038         if (head == NULL)
4039           head = tail = gfc_get_equiv ();
4040         else
4041           {
4042             tail->eq = gfc_get_equiv ();
4043             tail = tail->eq;
4044           }
4045
4046         mio_pool_string (&tail->module);
4047         mio_expr (&tail->expr);
4048       }
4049
4050     /* Unused equivalence members have a unique name.  In addition, it
4051        must be checked that the symbols are from the same module.  */
4052     unused = true;
4053     for (eq = head; eq; eq = eq->eq)
4054       {
4055         if (eq->expr->symtree->n.sym->module
4056               && head->expr->symtree->n.sym->module
4057               && strcmp (head->expr->symtree->n.sym->module,
4058                          eq->expr->symtree->n.sym->module) == 0
4059               && !check_unique_name (eq->expr->symtree->name))
4060           {
4061             unused = false;
4062             break;
4063           }
4064       }
4065
4066     if (unused)
4067       {
4068         for (eq = head; eq; eq = head)
4069           {
4070             head = eq->eq;
4071             gfc_free_expr (eq->expr);
4072             free (eq);
4073           }
4074       }
4075
4076     if (end == NULL)
4077       gfc_current_ns->equiv = head;
4078     else
4079       end->next = head;
4080
4081     if (head != NULL)
4082       end = head;
4083
4084     mio_rparen ();
4085   }
4086
4087   mio_rparen ();
4088   in_load_equiv = false;
4089 }
4090
4091
4092 /* This function loads the sym_root of f2k_derived with the extensions to
4093    the derived type.  */
4094 static void
4095 load_derived_extensions (void)
4096 {
4097   int symbol, j;
4098   gfc_symbol *derived;
4099   gfc_symbol *dt;
4100   gfc_symtree *st;
4101   pointer_info *info;
4102   char name[GFC_MAX_SYMBOL_LEN + 1];
4103   char module[GFC_MAX_SYMBOL_LEN + 1];
4104   const char *p;
4105
4106   mio_lparen ();
4107   while (peek_atom () != ATOM_RPAREN)
4108     {
4109       mio_lparen ();
4110       mio_integer (&symbol);
4111       info = get_integer (symbol);
4112       derived = info->u.rsym.sym;
4113
4114       /* This one is not being loaded.  */
4115       if (!info || !derived)
4116         {
4117           while (peek_atom () != ATOM_RPAREN)
4118             skip_list ();
4119           continue;
4120         }
4121
4122       gcc_assert (derived->attr.flavor == FL_DERIVED);
4123       if (derived->f2k_derived == NULL)
4124         derived->f2k_derived = gfc_get_namespace (NULL, 0);
4125
4126       while (peek_atom () != ATOM_RPAREN)
4127         {
4128           mio_lparen ();
4129           mio_internal_string (name);
4130           mio_internal_string (module);
4131
4132           /* Only use one use name to find the symbol.  */
4133           j = 1;
4134           p = find_use_name_n (name, &j, false);
4135           if (p)
4136             {
4137               st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4138               dt = st->n.sym;
4139               st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4140               if (st == NULL)
4141                 {
4142                   /* Only use the real name in f2k_derived to ensure a single
4143                     symtree.  */
4144                   st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
4145                   st->n.sym = dt;
4146                   st->n.sym->refs++;
4147                 }
4148             }
4149           mio_rparen ();
4150         }
4151       mio_rparen ();
4152     }
4153   mio_rparen ();
4154 }
4155
4156
4157 /* Recursive function to traverse the pointer_info tree and load a
4158    needed symbol.  We return nonzero if we load a symbol and stop the
4159    traversal, because the act of loading can alter the tree.  */
4160
4161 static int
4162 load_needed (pointer_info *p)
4163 {
4164   gfc_namespace *ns;
4165   pointer_info *q;
4166   gfc_symbol *sym;
4167   int rv;
4168
4169   rv = 0;
4170   if (p == NULL)
4171     return rv;
4172
4173   rv |= load_needed (p->left);
4174   rv |= load_needed (p->right);
4175
4176   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4177     return rv;
4178
4179   p->u.rsym.state = USED;
4180
4181   set_module_locus (&p->u.rsym.where);
4182
4183   sym = p->u.rsym.sym;
4184   if (sym == NULL)
4185     {
4186       q = get_integer (p->u.rsym.ns);
4187
4188       ns = (gfc_namespace *) q->u.pointer;
4189       if (ns == NULL)
4190         {
4191           /* Create an interface namespace if necessary.  These are
4192              the namespaces that hold the formal parameters of module
4193              procedures.  */
4194
4195           ns = gfc_get_namespace (NULL, 0);
4196           associate_integer_pointer (q, ns);
4197         }
4198
4199       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4200          doesn't go pear-shaped if the symbol is used.  */
4201       if (!ns->proc_name)
4202         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4203                                  1, &ns->proc_name);
4204
4205       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4206       sym->module = gfc_get_string (p->u.rsym.module);
4207       strcpy (sym->binding_label, p->u.rsym.binding_label);
4208
4209       associate_integer_pointer (p, sym);
4210     }
4211
4212   mio_symbol (sym);
4213   sym->attr.use_assoc = 1;
4214   if (only_flag)
4215     sym->attr.use_only = 1;
4216   if (p->u.rsym.renamed)
4217     sym->attr.use_rename = 1;
4218
4219   return 1;
4220 }
4221
4222
4223 /* Recursive function for cleaning up things after a module has been read.  */
4224
4225 static void
4226 read_cleanup (pointer_info *p)
4227 {
4228   gfc_symtree *st;
4229   pointer_info *q;
4230
4231   if (p == NULL)
4232     return;
4233
4234   read_cleanup (p->left);
4235   read_cleanup (p->right);
4236
4237   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4238     {
4239       gfc_namespace *ns;
4240       /* Add hidden symbols to the symtree.  */
4241       q = get_integer (p->u.rsym.ns);
4242       ns = (gfc_namespace *) q->u.pointer;
4243
4244       if (!p->u.rsym.sym->attr.vtype
4245             && !p->u.rsym.sym->attr.vtab)
4246         st = gfc_get_unique_symtree (ns);
4247       else
4248         {
4249           /* There is no reason to use 'unique_symtrees' for vtabs or
4250              vtypes - their name is fine for a symtree and reduces the
4251              namespace pollution.  */
4252           st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
4253           if (!st)
4254             st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
4255         }
4256
4257       st->n.sym = p->u.rsym.sym;
4258       st->n.sym->refs++;
4259
4260       /* Fixup any symtree references.  */
4261       p->u.rsym.symtree = st;
4262       resolve_fixups (p->u.rsym.stfixup, st);
4263       p->u.rsym.stfixup = NULL;
4264     }
4265
4266   /* Free unused symbols.  */
4267   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
4268     gfc_free_symbol (p->u.rsym.sym);
4269 }
4270
4271
4272 /* It is not quite enough to check for ambiguity in the symbols by
4273    the loaded symbol and the new symbol not being identical.  */
4274 static bool
4275 check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
4276 {
4277   gfc_symbol *rsym;
4278   module_locus locus;
4279   symbol_attribute attr;
4280
4281   if (st_sym->ns->proc_name && st_sym->name == st_sym->ns->proc_name->name)
4282     {
4283       gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4284                  "current program unit", st_sym->name, module_name);
4285       return true;
4286     }
4287
4288   rsym = info->u.rsym.sym;
4289   if (st_sym == rsym)
4290     return false;
4291
4292   if (st_sym->attr.vtab || st_sym->attr.vtype)
4293     return false;
4294
4295   /* If the existing symbol is generic from a different module and
4296      the new symbol is generic there can be no ambiguity.  */
4297   if (st_sym->attr.generic
4298         && st_sym->module
4299         && strcmp (st_sym->module, module_name))
4300     {
4301       /* The new symbol's attributes have not yet been read.  Since
4302          we need attr.generic, read it directly.  */
4303       get_module_locus (&locus);
4304       set_module_locus (&info->u.rsym.where);
4305       mio_lparen ();
4306       attr.generic = 0;
4307       mio_symbol_attribute (&attr);
4308       set_module_locus (&locus);
4309       if (attr.generic)
4310         return false;
4311     }
4312
4313   return true;
4314 }
4315
4316
4317 /* Read a module file.  */
4318
4319 static void
4320 read_module (void)
4321 {
4322   module_locus operator_interfaces, user_operators, extensions;
4323   const char *p;
4324   char name[GFC_MAX_SYMBOL_LEN + 1];
4325   int i;
4326   int ambiguous, j, nuse, symbol;
4327   pointer_info *info, *q;
4328   gfc_use_rename *u;
4329   gfc_symtree *st;
4330   gfc_symbol *sym;
4331
4332   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
4333   skip_list ();
4334
4335   get_module_locus (&user_operators);
4336   skip_list ();
4337   skip_list ();
4338
4339   /* Skip commons, equivalences and derived type extensions for now.  */
4340   skip_list ();
4341   skip_list ();
4342
4343   get_module_locus (&extensions);
4344   skip_list ();
4345
4346   mio_lparen ();
4347
4348   /* Create the fixup nodes for all the symbols.  */
4349
4350   while (peek_atom () != ATOM_RPAREN)
4351     {
4352       require_atom (ATOM_INTEGER);
4353       info = get_integer (atom_int);
4354
4355       info->type = P_SYMBOL;
4356       info->u.rsym.state = UNUSED;
4357
4358       mio_internal_string (info->u.rsym.true_name);
4359       mio_internal_string (info->u.rsym.module);
4360       mio_internal_string (info->u.rsym.binding_label);
4361
4362
4363       require_atom (ATOM_INTEGER);
4364       info->u.rsym.ns = atom_int;
4365
4366       get_module_locus (&info->u.rsym.where);
4367       skip_list ();
4368
4369       /* See if the symbol has already been loaded by a previous module.
4370          If so, we reference the existing symbol and prevent it from
4371          being loaded again.  This should not happen if the symbol being
4372          read is an index for an assumed shape dummy array (ns != 1).  */
4373
4374       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4375
4376       if (sym == NULL
4377           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4378         continue;
4379
4380       info->u.rsym.state = USED;
4381       info->u.rsym.sym = sym;
4382
4383       /* Some symbols do not have a namespace (eg. formal arguments),
4384          so the automatic "unique symtree" mechanism must be suppressed
4385          by marking them as referenced.  */
4386       q = get_integer (info->u.rsym.ns);
4387       if (q->u.pointer == NULL)
4388         {
4389           info->u.rsym.referenced = 1;
4390           continue;
4391         }
4392
4393       /* If possible recycle the symtree that references the symbol.
4394          If a symtree is not found and the module does not import one,
4395          a unique-name symtree is found by read_cleanup.  */
4396       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
4397       if (st != NULL)
4398         {
4399           info->u.rsym.symtree = st;
4400           info->u.rsym.referenced = 1;
4401         }
4402     }
4403
4404   mio_rparen ();
4405
4406   /* Parse the symtree lists.  This lets us mark which symbols need to
4407      be loaded.  Renaming is also done at this point by replacing the
4408      symtree name.  */
4409
4410   mio_lparen ();
4411
4412   while (peek_atom () != ATOM_RPAREN)
4413     {
4414       mio_internal_string (name);
4415       mio_integer (&ambiguous);
4416       mio_integer (&symbol);
4417
4418       info = get_integer (symbol);
4419
4420       /* See how many use names there are.  If none, go through the start
4421          of the loop at least once.  */
4422       nuse = number_use_names (name, false);
4423       info->u.rsym.renamed = nuse ? 1 : 0;
4424
4425       if (nuse == 0)
4426         nuse = 1;
4427
4428       for (j = 1; j <= nuse; j++)
4429         {
4430           /* Get the jth local name for this symbol.  */
4431           p = find_use_name_n (name, &j, false);
4432
4433           if (p == NULL && strcmp (name, module_name) == 0)
4434             p = name;
4435
4436           /* Exception: Always import vtabs & vtypes.  */
4437           if (p == NULL && (strncmp (name, "__vtab_", 5) == 0
4438                             || strncmp (name, "__vtype_", 6) == 0))
4439             p = name;
4440
4441           /* Skip symtree nodes not in an ONLY clause, unless there
4442              is an existing symtree loaded from another USE statement.  */
4443           if (p == NULL)
4444             {
4445               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4446               if (st != NULL)
4447                 info->u.rsym.symtree = st;
4448               continue;
4449             }
4450
4451           /* If a symbol of the same name and module exists already,
4452              this symbol, which is not in an ONLY clause, must not be
4453              added to the namespace(11.3.2).  Note that find_symbol
4454              only returns the first occurrence that it finds.  */
4455           if (!only_flag && !info->u.rsym.renamed
4456                 && strcmp (name, module_name) != 0
4457                 && find_symbol (gfc_current_ns->sym_root, name,
4458                                 module_name, 0))
4459             continue;
4460
4461           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4462
4463           if (st != NULL)
4464             {
4465               /* Check for ambiguous symbols.  */
4466               if (check_for_ambiguous (st->n.sym, info))
4467                 st->ambiguous = 1;
4468               info->u.rsym.symtree = st;
4469             }
4470           else
4471             {
4472               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4473
4474               /* Delete the symtree if the symbol has been added by a USE
4475                  statement without an ONLY(11.3.2).  Remember that the rsym
4476                  will be the same as the symbol found in the symtree, for
4477                  this case.  */
4478               if (st && (only_flag || info->u.rsym.renamed)
4479                      && !st->n.sym->attr.use_only
4480                      && !st->n.sym->attr.use_rename
4481                      && info->u.rsym.sym == st->n.sym)
4482                 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
4483
4484               /* Create a symtree node in the current namespace for this
4485                  symbol.  */
4486               st = check_unique_name (p)
4487                    ? gfc_get_unique_symtree (gfc_current_ns)
4488                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4489               st->ambiguous = ambiguous;
4490
4491               sym = info->u.rsym.sym;
4492
4493               /* Create a symbol node if it doesn't already exist.  */
4494               if (sym == NULL)
4495                 {
4496                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4497                                                      gfc_current_ns);
4498                   sym = info->u.rsym.sym;
4499                   sym->module = gfc_get_string (info->u.rsym.module);
4500
4501                   /* TODO: hmm, can we test this?  Do we know it will be
4502                      initialized to zeros?  */
4503                   if (info->u.rsym.binding_label[0] != '\0')
4504                     strcpy (sym->binding_label, info->u.rsym.binding_label);
4505                 }
4506
4507               st->n.sym = sym;
4508               st->n.sym->refs++;
4509
4510               if (strcmp (name, p) != 0)
4511                 sym->attr.use_rename = 1;
4512
4513               /* We need to set the only_flag here so that symbols from the
4514                  same USE...ONLY but earlier are not deleted from the tree in
4515                  the gfc_delete_symtree above.  */
4516               sym->attr.use_only = only_flag;
4517
4518               /* Store the symtree pointing to this symbol.  */
4519               info->u.rsym.symtree = st;
4520
4521               if (info->u.rsym.state == UNUSED)
4522                 info->u.rsym.state = NEEDED;
4523               info->u.rsym.referenced = 1;
4524             }
4525         }
4526     }
4527
4528   mio_rparen ();
4529
4530   /* Load intrinsic operator interfaces.  */
4531   set_module_locus (&operator_interfaces);
4532   mio_lparen ();
4533
4534   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4535     {
4536       if (i == INTRINSIC_USER)
4537         continue;
4538
4539       if (only_flag)
4540         {
4541           u = find_use_operator ((gfc_intrinsic_op) i);
4542
4543           if (u == NULL)
4544             {
4545               skip_list ();
4546               continue;
4547             }
4548
4549           u->found = 1;
4550         }
4551
4552       mio_interface (&gfc_current_ns->op[i]);
4553     }
4554
4555   mio_rparen ();
4556
4557   /* Load generic and user operator interfaces.  These must follow the
4558      loading of symtree because otherwise symbols can be marked as
4559      ambiguous.  */
4560
4561   set_module_locus (&user_operators);
4562
4563   load_operator_interfaces ();
4564   load_generic_interfaces ();
4565
4566   load_commons ();
4567   load_equiv ();
4568
4569   /* At this point, we read those symbols that are needed but haven't
4570      been loaded yet.  If one symbol requires another, the other gets
4571      marked as NEEDED if its previous state was UNUSED.  */
4572
4573   while (load_needed (pi_root));
4574
4575   /* Make sure all elements of the rename-list were found in the module.  */
4576
4577   for (u = gfc_rename_list; u; u = u->next)
4578     {
4579       if (u->found)
4580         continue;
4581
4582       if (u->op == INTRINSIC_NONE)
4583         {
4584           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4585                      u->use_name, &u->where, module_name);
4586           continue;
4587         }
4588
4589       if (u->op == INTRINSIC_USER)
4590         {
4591           gfc_error ("User operator '%s' referenced at %L not found "
4592                      "in module '%s'", u->use_name, &u->where, module_name);
4593           continue;
4594         }
4595
4596       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4597                  "in module '%s'", gfc_op2string (u->op), &u->where,
4598                  module_name);
4599     }
4600
4601   /* Now we should be in a position to fill f2k_derived with derived type
4602      extensions, since everything has been loaded.  */
4603   set_module_locus (&extensions);
4604   load_derived_extensions ();
4605
4606   /* Clean up symbol nodes that were never loaded, create references
4607      to hidden symbols.  */
4608
4609   read_cleanup (pi_root);
4610 }
4611
4612
4613 /* Given an access type that is specific to an entity and the default
4614    access, return nonzero if the entity is publicly accessible.  If the
4615    element is declared as PUBLIC, then it is public; if declared
4616    PRIVATE, then private, and otherwise it is public unless the default
4617    access in this context has been declared PRIVATE.  */
4618
4619 static bool
4620 check_access (gfc_access specific_access, gfc_access default_access)
4621 {
4622   if (specific_access == ACCESS_PUBLIC)
4623     return TRUE;
4624   if (specific_access == ACCESS_PRIVATE)
4625     return FALSE;
4626
4627   if (gfc_option.flag_module_private)
4628     return default_access == ACCESS_PUBLIC;
4629   else
4630     return default_access != ACCESS_PRIVATE;
4631 }
4632
4633
4634 bool
4635 gfc_check_symbol_access (gfc_symbol *sym)
4636 {
4637   if (sym->attr.vtab || sym->attr.vtype)
4638     return true;
4639   else
4640     return check_access (sym->attr.access, sym->ns->default_access);
4641 }
4642
4643
4644 /* A structure to remember which commons we've already written.  */
4645
4646 struct written_common
4647 {
4648   BBT_HEADER(written_common);
4649   const char *name, *label;
4650 };
4651
4652 static struct written_common *written_commons = NULL;
4653
4654 /* Comparison function used for balancing the binary tree.  */
4655
4656 static int
4657 compare_written_commons (void *a1, void *b1)
4658 {
4659   const char *aname = ((struct written_common *) a1)->name;
4660   const char *alabel = ((struct written_common *) a1)->label;
4661   const char *bname = ((struct written_common *) b1)->name;
4662   const char *blabel = ((struct written_common *) b1)->label;
4663   int c = strcmp (aname, bname);
4664
4665   return (c != 0 ? c : strcmp (alabel, blabel));
4666 }
4667
4668 /* Free a list of written commons.  */
4669
4670 static void
4671 free_written_common (struct written_common *w)
4672 {
4673   if (!w)
4674     return;
4675
4676   if (w->left)
4677     free_written_common (w->left);
4678   if (w->right)
4679     free_written_common (w->right);
4680
4681   free (w);
4682 }
4683
4684 /* Write a common block to the module -- recursive helper function.  */
4685
4686 static void
4687 write_common_0 (gfc_symtree *st, bool this_module)
4688 {
4689   gfc_common_head *p;
4690   const char * name;
4691   int flags;
4692   const char *label;
4693   struct written_common *w;
4694   bool write_me = true;
4695
4696   if (st == NULL)
4697     return;
4698
4699   write_common_0 (st->left, this_module);
4700
4701   /* We will write out the binding label, or the name if no label given.  */
4702   name = st->n.common->name;
4703   p = st->n.common;
4704   label = p->is_bind_c ? p->binding_label : p->name;
4705
4706   /* Check if we've already output this common.  */
4707   w = written_commons;
4708   while (w)
4709     {
4710       int c = strcmp (name, w->name);
4711       c = (c != 0 ? c : strcmp (label, w->label));
4712       if (c == 0)
4713         write_me = false;
4714
4715       w = (c < 0) ? w->left : w->right;
4716     }
4717
4718   if (this_module && p->use_assoc)
4719     write_me = false;
4720
4721   if (write_me)
4722     {
4723       /* Write the common to the module.  */
4724       mio_lparen ();
4725       mio_pool_string (&name);
4726
4727       mio_symbol_ref (&p->head);
4728       flags = p->saved ? 1 : 0;
4729       if (p->threadprivate)
4730         flags |= 2;
4731       mio_integer (&flags);
4732
4733       /* Write out whether the common block is bind(c) or not.  */
4734       mio_integer (&(p->is_bind_c));
4735
4736       mio_pool_string (&label);
4737       mio_rparen ();
4738
4739       /* Record that we have written this common.  */
4740       w = XCNEW (struct written_common);
4741       w->name = p->name;
4742       w->label = label;
4743       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4744     }
4745
4746   write_common_0 (st->right, this_module);
4747 }
4748
4749
4750 /* Write a common, by initializing the list of written commons, calling
4751    the recursive function write_common_0() and cleaning up afterwards.  */
4752
4753 static void
4754 write_common (gfc_symtree *st)
4755 {
4756   written_commons = NULL;
4757   write_common_0 (st, true);
4758   write_common_0 (st, false);
4759   free_written_common (written_commons);
4760   written_commons = NULL;
4761 }
4762
4763
4764 /* Write the blank common block to the module.  */
4765
4766 static void
4767 write_blank_common (void)
4768 {
4769   const char * name = BLANK_COMMON_NAME;
4770   int saved;
4771   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4772      this, but it hasn't been checked.  Just making it so for now.  */
4773   int is_bind_c = 0;
4774
4775   if (gfc_current_ns->blank_common.head == NULL)
4776     return;
4777
4778   mio_lparen ();
4779
4780   mio_pool_string (&name);
4781
4782   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4783   saved = gfc_current_ns->blank_common.saved;
4784   mio_integer (&saved);
4785
4786   /* Write out whether the common block is bind(c) or not.  */
4787   mio_integer (&is_bind_c);
4788
4789   /* Write out the binding label, which is BLANK_COMMON_NAME, though
4790      it doesn't matter because the label isn't used.  */
4791   mio_pool_string (&name);
4792
4793   mio_rparen ();
4794 }
4795
4796
4797 /* Write equivalences to the module.  */
4798
4799 static void
4800 write_equiv (void)
4801 {
4802   gfc_equiv *eq, *e;
4803   int num;
4804
4805   num = 0;
4806   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4807     {
4808       mio_lparen ();
4809
4810       for (e = eq; e; e = e->eq)
4811         {
4812           if (e->module == NULL)
4813             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4814           mio_allocated_string (e->module);
4815           mio_expr (&e->expr);
4816         }
4817
4818       num++;
4819       mio_rparen ();
4820     }
4821 }
4822
4823
4824 /* Write derived type extensions to the module.  */
4825
4826 static void
4827 write_dt_extensions (gfc_symtree *st)
4828 {
4829   if (!gfc_check_symbol_access (st->n.sym))
4830     return;
4831   if (!(st->n.sym->ns && st->n.sym->ns->proc_name
4832         && st->n.sym->ns->proc_name->attr.flavor == FL_MODULE))
4833     return;
4834
4835   mio_lparen ();
4836   mio_pool_string (&st->n.sym->name);
4837   if (st->n.sym->module != NULL)
4838     mio_pool_string (&st->n.sym->module);
4839   else
4840     mio_internal_string (module_name);
4841   mio_rparen ();
4842 }
4843
4844 static void
4845 write_derived_extensions (gfc_symtree *st)
4846 {
4847   if (!((st->n.sym->attr.flavor == FL_DERIVED)
4848           && (st->n.sym->f2k_derived != NULL)
4849           && (st->n.sym->f2k_derived->sym_root != NULL)))
4850     return;
4851
4852   mio_lparen ();
4853   mio_symbol_ref (&(st->n.sym));
4854   gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
4855                         write_dt_extensions);
4856   mio_rparen ();
4857 }
4858
4859
4860 /* Write a symbol to the module.  */
4861
4862 static void
4863 write_symbol (int n, gfc_symbol *sym)
4864 {
4865   const char *label;
4866
4867   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4868     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4869
4870   mio_integer (&n);
4871   mio_pool_string (&sym->name);
4872
4873   mio_pool_string (&sym->module);
4874   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4875     {
4876       label = sym->binding_label;
4877       mio_pool_string (&label);
4878     }
4879   else
4880     mio_pool_string (&sym->name);
4881
4882   mio_pointer_ref (&sym->ns);
4883
4884   mio_symbol (sym);
4885   write_char ('\n');
4886 }
4887
4888
4889 /* Recursive traversal function to write the initial set of symbols to
4890    the module.  We check to see if the symbol should be written
4891    according to the access specification.  */
4892
4893 static void
4894 write_symbol0 (gfc_symtree *st)
4895 {
4896   gfc_symbol *sym;
4897   pointer_info *p;
4898   bool dont_write = false;
4899
4900   if (st == NULL)
4901     return;
4902
4903   write_symbol0 (st->left);
4904
4905   sym = st->n.sym;
4906   if (sym->module == NULL)
4907     sym->module = gfc_get_string (module_name);
4908
4909   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4910       && !sym->attr.subroutine && !sym->attr.function)
4911     dont_write = true;
4912
4913   if (!gfc_check_symbol_access (sym))
4914     dont_write = true;
4915
4916   if (!dont_write)
4917     {
4918       p = get_pointer (sym);
4919       if (p->type == P_UNKNOWN)
4920         p->type = P_SYMBOL;
4921
4922       if (p->u.wsym.state != WRITTEN)
4923         {
4924           write_symbol (p->integer, sym);
4925           p->u.wsym.state = WRITTEN;
4926         }
4927     }
4928
4929   write_symbol0 (st->right);
4930 }
4931
4932
4933 /* Recursive traversal function to write the secondary set of symbols
4934    to the module file.  These are symbols that were not public yet are
4935    needed by the public symbols or another dependent symbol.  The act
4936    of writing a symbol can modify the pointer_info tree, so we cease
4937    traversal if we find a symbol to write.  We return nonzero if a
4938    symbol was written and pass that information upwards.  */
4939
4940 static int
4941 write_symbol1 (pointer_info *p)
4942 {
4943   int result;
4944
4945   if (!p)
4946     return 0;
4947
4948   result = write_symbol1 (p->left);
4949
4950   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4951     {
4952       p->u.wsym.state = WRITTEN;
4953       write_symbol (p->integer, p->u.wsym.sym);
4954       result = 1;
4955     }
4956
4957   result |= write_symbol1 (p->right);
4958   return result;
4959 }
4960
4961
4962 /* Write operator interfaces associated with a symbol.  */
4963
4964 static void
4965 write_operator (gfc_user_op *uop)
4966 {
4967   static char nullstring[] = "";
4968   const char *p = nullstring;
4969
4970   if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
4971     return;
4972
4973   mio_symbol_interface (&uop->name, &p, &uop->op);
4974 }
4975
4976
4977 /* Write generic interfaces from the namespace sym_root.  */
4978
4979 static void
4980 write_generic (gfc_symtree *st)
4981 {
4982   gfc_symbol *sym;
4983
4984   if (st == NULL)
4985     return;
4986
4987   write_generic (st->left);
4988   write_generic (st->right);
4989
4990   sym = st->n.sym;
4991   if (!sym || check_unique_name (st->name))
4992     return;
4993
4994   if (sym->generic == NULL || !gfc_check_symbol_access (sym))
4995     return;
4996
4997   if (sym->module == NULL)
4998     sym->module = gfc_get_string (module_name);
4999
5000   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
5001 }
5002
5003
5004 static void
5005 write_symtree (gfc_symtree *st)
5006 {
5007   gfc_symbol *sym;
5008   pointer_info *p;
5009
5010   sym = st->n.sym;
5011
5012   /* A symbol in an interface body must not be visible in the
5013      module file.  */
5014   if (sym->ns != gfc_current_ns
5015         && sym->ns->proc_name
5016         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
5017     return;
5018
5019   if (!gfc_check_symbol_access (sym)
5020       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5021           && !sym->attr.subroutine && !sym->attr.function))
5022     return;
5023
5024   if (check_unique_name (st->name))
5025     return;
5026
5027   p = find_pointer (sym);
5028   if (p == NULL)
5029     gfc_internal_error ("write_symtree(): Symbol not written");
5030
5031   mio_pool_string (&st->name);
5032   mio_integer (&st->ambiguous);
5033   mio_integer (&p->integer);
5034 }
5035
5036
5037 static void
5038 write_module (void)
5039 {
5040   int i;
5041
5042   /* Write the operator interfaces.  */
5043   mio_lparen ();
5044
5045   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5046     {
5047       if (i == INTRINSIC_USER)
5048         continue;
5049
5050       mio_interface (check_access (gfc_current_ns->operator_access[i],
5051                                    gfc_current_ns->default_access)
5052                      ? &gfc_current_ns->op[i] : NULL);
5053     }
5054
5055   mio_rparen ();
5056   write_char ('\n');
5057   write_char ('\n');
5058
5059   mio_lparen ();
5060   gfc_traverse_user_op (gfc_current_ns, write_operator);
5061   mio_rparen ();
5062   write_char ('\n');
5063   write_char ('\n');
5064
5065   mio_lparen ();
5066   write_generic (gfc_current_ns->sym_root);
5067   mio_rparen ();
5068   write_char ('\n');
5069   write_char ('\n');
5070
5071   mio_lparen ();
5072   write_blank_common ();
5073   write_common (gfc_current_ns->common_root);
5074   mio_rparen ();
5075   write_char ('\n');
5076   write_char ('\n');
5077
5078   mio_lparen ();
5079   write_equiv ();
5080   mio_rparen ();
5081   write_char ('\n');
5082   write_char ('\n');
5083
5084   mio_lparen ();
5085   gfc_traverse_symtree (gfc_current_ns->sym_root,
5086                         write_derived_extensions);
5087   mio_rparen ();
5088   write_char ('\n');
5089   write_char ('\n');
5090
5091   /* Write symbol information.  First we traverse all symbols in the
5092      primary namespace, writing those that need to be written.
5093      Sometimes writing one symbol will cause another to need to be
5094      written.  A list of these symbols ends up on the write stack, and
5095      we end by popping the bottom of the stack and writing the symbol
5096      until the stack is empty.  */
5097
5098   mio_lparen ();
5099
5100   write_symbol0 (gfc_current_ns->sym_root);
5101   while (write_symbol1 (pi_root))
5102     /* Nothing.  */;
5103
5104   mio_rparen ();
5105
5106   write_char ('\n');
5107   write_char ('\n');
5108
5109   mio_lparen ();
5110   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5111   mio_rparen ();
5112 }
5113
5114
5115 /* Read a MD5 sum from the header of a module file.  If the file cannot
5116    be opened, or we have any other error, we return -1.  */
5117
5118 static int
5119 read_md5_from_module_file (const char * filename, unsigned char md5[16])
5120 {
5121   FILE *file;
5122   char buf[1024];
5123   int n;
5124
5125   /* Open the file.  */
5126   if ((file = fopen (filename, "r")) == NULL)
5127     return -1;
5128
5129   /* Read the first line.  */
5130   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5131     {
5132       fclose (file);
5133       return -1;
5134     }
5135
5136   /* The file also needs to be overwritten if the version number changed.  */
5137   n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
5138   if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
5139     {
5140       fclose (file);
5141       return -1;
5142     }
5143
5144   /* Read a second line.  */
5145   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5146     {
5147       fclose (file);
5148       return -1;
5149     }
5150
5151   /* Close the file.  */
5152   fclose (file);
5153
5154   /* If the header is not what we expect, or is too short, bail out.  */
5155   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
5156     return -1;
5157
5158   /* Now, we have a real MD5, read it into the array.  */
5159   for (n = 0; n < 16; n++)
5160     {
5161       unsigned int x;
5162
5163       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
5164        return -1;
5165
5166       md5[n] = x;
5167     }
5168
5169   return 0;
5170 }
5171
5172
5173 /* Given module, dump it to disk.  If there was an error while
5174    processing the module, dump_flag will be set to zero and we delete
5175    the module file, even if it was already there.  */
5176
5177 void
5178 gfc_dump_module (const char *name, int dump_flag)
5179 {
5180   int n;
5181   char *filename, *filename_tmp, *p;
5182   time_t now;
5183   fpos_t md5_pos;
5184   unsigned char md5_new[16], md5_old[16];
5185
5186   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
5187   if (gfc_option.module_dir != NULL)
5188     {
5189       n += strlen (gfc_option.module_dir);
5190       filename = (char *) alloca (n);
5191       strcpy (filename, gfc_option.module_dir);
5192       strcat (filename, name);
5193     }
5194   else
5195     {
5196       filename = (char *) alloca (n);
5197       strcpy (filename, name);
5198     }
5199   strcat (filename, MODULE_EXTENSION);
5200
5201   /* Name of the temporary file used to write the module.  */
5202   filename_tmp = (char *) alloca (n + 1);
5203   strcpy (filename_tmp, filename);
5204   strcat (filename_tmp, "0");
5205
5206   /* There was an error while processing the module.  We delete the
5207      module file, even if it was already there.  */
5208   if (!dump_flag)
5209     {
5210       unlink (filename);
5211       return;
5212     }
5213
5214   if (gfc_cpp_makedep ())
5215     gfc_cpp_add_target (filename);
5216
5217   /* Write the module to the temporary file.  */
5218   module_fp = fopen (filename_tmp, "w");
5219   if (module_fp == NULL)
5220     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5221                      filename_tmp, xstrerror (errno));
5222
5223   /* Write the header, including space reserved for the MD5 sum.  */
5224   now = time (NULL);
5225   p = ctime (&now);
5226
5227   *strchr (p, '\n') = '\0';
5228
5229   fprintf (module_fp, "GFORTRAN module version '%s' created from %s on %s\n"
5230            "MD5:", MOD_VERSION, gfc_source_file, p);
5231   fgetpos (module_fp, &md5_pos);
5232   fputs ("00000000000000000000000000000000 -- "
5233         "If you edit this, you'll get what you deserve.\n\n", module_fp);
5234
5235   /* Initialize the MD5 context that will be used for output.  */
5236   md5_init_ctx (&ctx);
5237
5238   /* Write the module itself.  */
5239   iomode = IO_OUTPUT;
5240   strcpy (module_name, name);
5241
5242   init_pi_tree ();
5243
5244   write_module ();
5245
5246   free_pi_tree (pi_root);
5247   pi_root = NULL;
5248
5249   write_char ('\n');
5250
5251   /* Write the MD5 sum to the header of the module file.  */
5252   md5_finish_ctx (&ctx, md5_new);
5253   fsetpos (module_fp, &md5_pos);
5254   for (n = 0; n < 16; n++)
5255     fprintf (module_fp, "%02x", md5_new[n]);
5256
5257   if (fclose (module_fp))
5258     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5259                      filename_tmp, xstrerror (errno));
5260
5261   /* Read the MD5 from the header of the old module file and compare.  */
5262   if (read_md5_from_module_file (filename, md5_old) != 0
5263       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
5264     {
5265       /* Module file have changed, replace the old one.  */
5266       if (unlink (filename) && errno != ENOENT)
5267         gfc_fatal_error ("Can't delete module file '%s': %s", filename,
5268                          xstrerror (errno));
5269       if (rename (filename_tmp, filename))
5270         gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5271                          filename_tmp, filename, xstrerror (errno));
5272     }
5273   else
5274     {
5275       if (unlink (filename_tmp))
5276         gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5277                          filename_tmp, xstrerror (errno));
5278     }
5279 }
5280
5281
5282 static void
5283 create_intrinsic_function (const char *name, gfc_isym_id id,
5284                            const char *modname, intmod_id module)
5285 {
5286   gfc_intrinsic_sym *isym;
5287   gfc_symtree *tmp_symtree;
5288   gfc_symbol *sym;
5289
5290   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5291   if (tmp_symtree)
5292     {
5293       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5294         return;
5295       gfc_error ("Symbol '%s' already declared", name);
5296     }
5297
5298   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5299   sym = tmp_symtree->n.sym;
5300
5301   isym = gfc_intrinsic_function_by_id (id);
5302   gcc_assert (isym);
5303
5304   sym->attr.flavor = FL_PROCEDURE;
5305   sym->attr.intrinsic = 1;
5306
5307   sym->module = gfc_get_string (modname);
5308   sym->attr.use_assoc = 1;
5309   sym->from_intmod = module;
5310   sym->intmod_sym_id = id;
5311 }
5312
5313
5314 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5315    the current namespace for all named constants, pointer types, and
5316    procedures in the module unless the only clause was used or a rename
5317    list was provided.  */
5318
5319 static void
5320 import_iso_c_binding_module (void)
5321 {
5322   gfc_symbol *mod_sym = NULL;
5323   gfc_symtree *mod_symtree = NULL;
5324   const char *iso_c_module_name = "__iso_c_binding";
5325   gfc_use_rename *u;
5326   int i;
5327
5328   /* Look only in the current namespace.  */
5329   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5330
5331   if (mod_symtree == NULL)
5332     {
5333       /* symtree doesn't already exist in current namespace.  */
5334       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
5335                         false);
5336
5337       if (mod_symtree != NULL)
5338         mod_sym = mod_symtree->n.sym;
5339       else
5340         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5341                             "create symbol for %s", iso_c_module_name);
5342
5343       mod_sym->attr.flavor = FL_MODULE;
5344       mod_sym->attr.intrinsic = 1;
5345       mod_sym->module = gfc_get_string (iso_c_module_name);
5346       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
5347     }
5348
5349   /* Generate the symbols for the named constants representing
5350      the kinds for intrinsic data types.  */
5351   for (i = 0; i < ISOCBINDING_NUMBER; i++)
5352     {
5353       bool found = false;
5354       for (u = gfc_rename_list; u; u = u->next)
5355         if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5356           {
5357             u->found = 1;
5358             found = true;
5359             switch (i)
5360               {
5361 #define NAMED_FUNCTION(a,b,c,d) \
5362                 case a: \
5363                   create_intrinsic_function (u->local_name[0] ? u->local_name \
5364                                                               : u->use_name, \
5365                                              (gfc_isym_id) c, \
5366                                              iso_c_module_name, \
5367                                              INTMOD_ISO_C_BINDING); \
5368                   break;
5369 #include "iso-c-binding.def"
5370 #undef NAMED_FUNCTION
5371
5372                 default:
5373                   generate_isocbinding_symbol (iso_c_module_name,
5374                                                (iso_c_binding_symbol) i,
5375                                                u->local_name[0] ? u->local_name
5376                                                                 : u->use_name);
5377               }
5378           }
5379
5380       if (!found && !only_flag)
5381         switch (i)
5382           {
5383 #define NAMED_FUNCTION(a,b,c,d) \
5384             case a: \
5385               if ((gfc_option.allow_std & d) == 0) \
5386                 continue; \
5387               create_intrinsic_function (b, (gfc_isym_id) c, \
5388                                          iso_c_module_name, \
5389                                          INTMOD_ISO_C_BINDING); \
5390                   break;
5391 #include "iso-c-binding.def"
5392 #undef NAMED_FUNCTION
5393
5394             default:
5395               generate_isocbinding_symbol (iso_c_module_name,
5396                                            (iso_c_binding_symbol) i, NULL);
5397           }
5398    }
5399
5400    for (u = gfc_rename_list; u; u = u->next)
5401      {
5402       if (u->found)
5403         continue;
5404
5405       gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5406                  "module ISO_C_BINDING", u->use_name, &u->where);
5407      }
5408 }
5409
5410
5411 /* Add an integer named constant from a given module.  */
5412
5413 static void
5414 create_int_parameter (const char *name, int value, const char *modname,
5415                       intmod_id module, int id)
5416 {
5417   gfc_symtree *tmp_symtree;
5418   gfc_symbol *sym;
5419
5420   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5421   if (tmp_symtree != NULL)
5422     {
5423       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5424         return;
5425       else
5426         gfc_error ("Symbol '%s' already declared", name);
5427     }
5428
5429   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5430   sym = tmp_symtree->n.sym;
5431
5432   sym->module = gfc_get_string (modname);
5433   sym->attr.flavor = FL_PARAMETER;
5434   sym->ts.type = BT_INTEGER;
5435   sym->ts.kind = gfc_default_integer_kind;
5436   sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
5437   sym->attr.use_assoc = 1;
5438   sym->from_intmod = module;
5439   sym->intmod_sym_id = id;
5440 }
5441
5442
5443 /* Value is already contained by the array constructor, but not
5444    yet the shape.  */
5445
5446 static void
5447 create_int_parameter_array (const char *name, int size, gfc_expr *value,
5448                             const char *modname, intmod_id module, int id)
5449 {
5450   gfc_symtree *tmp_symtree;
5451   gfc_symbol *sym;
5452
5453   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5454   if (tmp_symtree != NULL)
5455     {
5456       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5457         return;
5458       else
5459         gfc_error ("Symbol '%s' already declared", name);
5460     }
5461
5462   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5463   sym = tmp_symtree->n.sym;
5464
5465   sym->module = gfc_get_string (modname);
5466   sym->attr.flavor = FL_PARAMETER;
5467   sym->ts.type = BT_INTEGER;
5468   sym->ts.kind = gfc_default_integer_kind;
5469   sym->attr.use_assoc = 1;
5470   sym->from_intmod = module;
5471   sym->intmod_sym_id = id;
5472   sym->attr.dimension = 1;
5473   sym->as = gfc_get_array_spec ();
5474   sym->as->rank = 1;
5475   sym->as->type = AS_EXPLICIT;
5476   sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5477   sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
5478
5479   sym->value = value;
5480   sym->value->shape = gfc_get_shape (1);
5481   mpz_init_set_ui (sym->value->shape[0], size);
5482 }
5483
5484
5485 /* Add an derived type for a given module.  */
5486
5487 static void
5488 create_derived_type (const char *name, const char *modname,
5489                       intmod_id module, int id)
5490 {
5491   gfc_symtree *tmp_symtree;
5492   gfc_symbol *sym;
5493
5494   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5495   if (tmp_symtree != NULL)
5496     {
5497       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5498         return;
5499       else
5500         gfc_error ("Symbol '%s' already declared", name);
5501     }
5502
5503   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5504   sym = tmp_symtree->n.sym;
5505
5506   sym->module = gfc_get_string (modname);
5507   sym->from_intmod = module;
5508   sym->intmod_sym_id = id;
5509   sym->attr.flavor = FL_DERIVED;
5510   sym->attr.private_comp = 1;
5511   sym->attr.zero_comp = 1;
5512   sym->attr.use_assoc = 1;
5513 }
5514
5515
5516
5517 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
5518
5519 static void
5520 use_iso_fortran_env_module (void)
5521 {
5522   static char mod[] = "iso_fortran_env";
5523   gfc_use_rename *u;
5524   gfc_symbol *mod_sym;
5525   gfc_symtree *mod_symtree;
5526   gfc_expr *expr;
5527   int i, j;
5528
5529   intmod_sym symbol[] = {
5530 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5531 #include "iso-fortran-env.def"
5532 #undef NAMED_INTCST
5533 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
5534 #include "iso-fortran-env.def"
5535 #undef NAMED_KINDARRAY
5536 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
5537 #include "iso-fortran-env.def"
5538 #undef NAMED_DERIVED_TYPE
5539 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
5540 #include "iso-fortran-env.def"
5541 #undef NAMED_FUNCTION
5542     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5543
5544   i = 0;
5545 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5546 #include "iso-fortran-env.def"
5547 #undef NAMED_INTCST
5548
5549   /* Generate the symbol for the module itself.  */
5550   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5551   if (mod_symtree == NULL)
5552     {
5553       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
5554       gcc_assert (mod_symtree);
5555       mod_sym = mod_symtree->n.sym;
5556
5557       mod_sym->attr.flavor = FL_MODULE;
5558       mod_sym->attr.intrinsic = 1;
5559       mod_sym->module = gfc_get_string (mod);
5560       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5561     }
5562   else
5563     if (!mod_symtree->n.sym->attr.intrinsic)
5564       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5565                  "non-intrinsic module name used previously", mod);
5566
5567   /* Generate the symbols for the module integer named constants.  */
5568
5569   for (i = 0; symbol[i].name; i++)
5570     {
5571       bool found = false;
5572       for (u = gfc_rename_list; u; u = u->next)
5573         {
5574           if (strcmp (symbol[i].name, u->use_name) == 0)
5575             {
5576               found = true;
5577               u->found = 1;
5578
5579               if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
5580                                   "referrenced at %C, is not in the selected "
5581                                   "standard", symbol[i].name) == FAILURE)
5582                 continue;
5583
5584               if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5585                   && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5586                 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
5587                                  "constant from intrinsic module "
5588                                  "ISO_FORTRAN_ENV at %C is incompatible with "
5589                                  "option %s",
5590                                  gfc_option.flag_default_integer
5591                                    ? "-fdefault-integer-8"
5592                                    : "-fdefault-real-8");
5593               switch (symbol[i].id)
5594                 {
5595 #define NAMED_INTCST(a,b,c,d) \
5596                 case a:
5597 #include "iso-fortran-env.def"
5598 #undef NAMED_INTCST
5599                   create_int_parameter (u->local_name[0] ? u->local_name
5600                                                          : u->use_name,
5601                                         symbol[i].value, mod,
5602                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5603                   break;
5604
5605 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5606                 case a:\
5607                   expr = gfc_get_array_expr (BT_INTEGER, \
5608                                              gfc_default_integer_kind,\
5609                                              NULL); \
5610                   for (j = 0; KINDS[j].kind != 0; j++) \
5611                     gfc_constructor_append_expr (&expr->value.constructor, \
5612                         gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5613                                           KINDS[j].kind), NULL); \
5614                   create_int_parameter_array (u->local_name[0] ? u->local_name \
5615                                                          : u->use_name, \
5616                                               j, expr, mod, \
5617                                               INTMOD_ISO_FORTRAN_ENV, \
5618                                               symbol[i].id); \
5619                   break;
5620 #include "iso-fortran-env.def"
5621 #undef NAMED_KINDARRAY
5622
5623 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
5624                 case a:
5625 #include "iso-fortran-env.def"
5626                   create_derived_type (u->local_name[0] ? u->local_name
5627                                                         : u->use_name,
5628                                        mod, INTMOD_ISO_FORTRAN_ENV,
5629                                        symbol[i].id);
5630                   break;
5631 #undef NAMED_DERIVED_TYPE
5632
5633 #define NAMED_FUNCTION(a,b,c,d) \
5634                 case a:
5635 #include "iso-fortran-env.def"
5636 #undef NAMED_FUNCTION
5637                   create_intrinsic_function (u->local_name[0] ? u->local_name
5638                                                               : u->use_name,
5639                                              (gfc_isym_id) symbol[i].value, mod,
5640                                              INTMOD_ISO_FORTRAN_ENV);
5641                   break;
5642
5643                 default:
5644                   gcc_unreachable ();
5645                 }
5646             }
5647         }
5648
5649       if (!found && !only_flag)
5650         {
5651           if ((gfc_option.allow_std & symbol[i].standard) == 0)
5652             continue;
5653
5654           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5655               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5656             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5657                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
5658                              "incompatible with option %s",
5659                              gfc_option.flag_default_integer
5660                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
5661
5662           switch (symbol[i].id)
5663             {
5664 #define NAMED_INTCST(a,b,c,d) \
5665             case a:
5666 #include "iso-fortran-env.def"
5667 #undef NAMED_INTCST
5668               create_int_parameter (symbol[i].name, symbol[i].value, mod,
5669                                     INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5670               break;
5671
5672 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5673             case a:\
5674               expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
5675                                          NULL); \
5676               for (j = 0; KINDS[j].kind != 0; j++) \
5677                 gfc_constructor_append_expr (&expr->value.constructor, \
5678                       gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5679                                         KINDS[j].kind), NULL); \
5680             create_int_parameter_array (symbol[i].name, j, expr, mod, \
5681                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
5682             break;
5683 #include "iso-fortran-env.def"
5684 #undef NAMED_KINDARRAY
5685
5686 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
5687           case a:
5688 #include "iso-fortran-env.def"
5689             create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
5690                                  symbol[i].id);
5691             break;
5692 #undef NAMED_DERIVED_TYPE
5693
5694 #define NAMED_FUNCTION(a,b,c,d) \
5695                 case a:
5696 #include "iso-fortran-env.def"
5697 #undef NAMED_FUNCTION
5698                   create_intrinsic_function (symbol[i].name,
5699                                              (gfc_isym_id) symbol[i].value, mod,
5700                                              INTMOD_ISO_FORTRAN_ENV);
5701                   break;
5702
5703           default:
5704             gcc_unreachable ();
5705           }
5706         }
5707     }
5708
5709   for (u = gfc_rename_list; u; u = u->next)
5710     {
5711       if (u->found)
5712         continue;
5713
5714       gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5715                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
5716     }
5717 }
5718
5719
5720 /* Process a USE directive.  */
5721
5722 void
5723 gfc_use_module (void)
5724 {
5725   char *filename;
5726   gfc_state_data *p;
5727   int c, line, start;
5728   gfc_symtree *mod_symtree;
5729   gfc_use_list *use_stmt;
5730
5731   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
5732                               + 1);
5733   strcpy (filename, module_name);
5734   strcat (filename, MODULE_EXTENSION);
5735
5736   /* First, try to find an non-intrinsic module, unless the USE statement
5737      specified that the module is intrinsic.  */
5738   module_fp = NULL;
5739   if (!specified_int)
5740     module_fp = gfc_open_included_file (filename, true, true);
5741
5742   /* Then, see if it's an intrinsic one, unless the USE statement
5743      specified that the module is non-intrinsic.  */
5744   if (module_fp == NULL && !specified_nonint)
5745     {
5746       if (strcmp (module_name, "iso_fortran_env") == 0
5747           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
5748                              "intrinsic module at %C") != FAILURE)
5749        {
5750          use_iso_fortran_env_module ();
5751          return;
5752        }
5753
5754       if (strcmp (module_name, "iso_c_binding") == 0
5755           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
5756                              "ISO_C_BINDING module at %C") != FAILURE)
5757         {
5758           import_iso_c_binding_module();
5759           return;
5760         }
5761
5762       module_fp = gfc_open_intrinsic_module (filename);
5763
5764       if (module_fp == NULL && specified_int)
5765         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5766                          module_name);
5767     }
5768
5769   if (module_fp == NULL)
5770     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5771                      filename, xstrerror (errno));
5772
5773   /* Check that we haven't already USEd an intrinsic module with the
5774      same name.  */
5775
5776   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
5777   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
5778     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5779                "intrinsic module name used previously", module_name);
5780
5781   iomode = IO_INPUT;
5782   module_line = 1;
5783   module_column = 1;
5784   start = 0;
5785
5786   /* Skip the first two lines of the module, after checking that this is
5787      a gfortran module file.  */
5788   line = 0;
5789   while (line < 2)
5790     {
5791       c = module_char ();
5792       if (c == EOF)
5793         bad_module ("Unexpected end of module");
5794       if (start++ < 3)
5795         parse_name (c);
5796       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
5797           || (start == 2 && strcmp (atom_name, " module") != 0))
5798         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5799                          "file", filename);
5800       if (start == 3)
5801         {
5802           if (strcmp (atom_name, " version") != 0
5803               || module_char () != ' '
5804               || parse_atom () != ATOM_STRING)
5805             gfc_fatal_error ("Parse error when checking module version"
5806                              " for file '%s' opened at %C", filename);
5807
5808           if (strcmp (atom_string, MOD_VERSION))
5809             {
5810               gfc_fatal_error ("Wrong module version '%s' (expected '%s') "
5811                                "for file '%s' opened at %C", atom_string,
5812                                MOD_VERSION, filename);
5813             }
5814
5815           free (atom_string);
5816         }
5817
5818       if (c == '\n')
5819         line++;
5820     }
5821
5822   /* Make sure we're not reading the same module that we may be building.  */
5823   for (p = gfc_state_stack; p; p = p->previous)
5824     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
5825       gfc_fatal_error ("Can't USE the same module we're building!");
5826
5827   init_pi_tree ();
5828   init_true_name_tree ();
5829
5830   read_module ();
5831
5832   free_true_name (true_name_root);
5833   true_name_root = NULL;
5834
5835   free_pi_tree (pi_root);
5836   pi_root = NULL;
5837
5838   fclose (module_fp);
5839
5840   use_stmt = gfc_get_use_list ();
5841   use_stmt->module_name = gfc_get_string (module_name);
5842   use_stmt->only_flag = only_flag;
5843   use_stmt->rename = gfc_rename_list;
5844   use_stmt->where = use_locus;
5845   gfc_rename_list = NULL;
5846   use_stmt->next = gfc_current_ns->use_stmts;
5847   gfc_current_ns->use_stmts = use_stmt;
5848 }
5849
5850
5851 void
5852 gfc_free_use_stmts (gfc_use_list *use_stmts)
5853 {
5854   gfc_use_list *next;
5855   for (; use_stmts; use_stmts = next)
5856     {
5857       gfc_use_rename *next_rename;
5858
5859       for (; use_stmts->rename; use_stmts->rename = next_rename)
5860         {
5861           next_rename = use_stmts->rename->next;
5862           free (use_stmts->rename);
5863         }
5864       next = use_stmts->next;
5865       free (use_stmts);
5866     }
5867 }
5868
5869
5870 void
5871 gfc_module_init_2 (void)
5872 {
5873   last_atom = ATOM_LPAREN;
5874 }
5875
5876
5877 void
5878 gfc_module_done_2 (void)
5879 {
5880   free_rename ();
5881 }