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