gcc/fortran/module.c

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