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