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                 info->u.rsym.symtree = st;
4646               continue;
4647             }
4648
4649           /* If a symbol of the same name and module exists already,
4650              this symbol, which is not in an ONLY clause, must not be
4651              added to the namespace(11.3.2).  Note that find_symbol
4652              only returns the first occurrence that it finds.  */
4653           if (!only_flag && !info->u.rsym.renamed
4654                 && strcmp (name, module_name) != 0
4655                 && find_symbol (gfc_current_ns->sym_root, name,
4656                                 module_name, 0))
4657             continue;
4658
4659           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4660
4661           if (st != NULL)
4662             {
4663               /* Check for ambiguous symbols.  */
4664               if (check_for_ambiguous (st->n.sym, info))
4665                 st->ambiguous = 1;
4666               info->u.rsym.symtree = st;
4667             }
4668           else
4669             {
4670               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4671
4672               /* Create a symtree node in the current namespace for this
4673                  symbol.  */
4674               st = check_unique_name (p)
4675                    ? gfc_get_unique_symtree (gfc_current_ns)
4676                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4677               st->ambiguous = ambiguous;
4678
4679               sym = info->u.rsym.sym;
4680
4681               /* Create a symbol node if it doesn't already exist.  */
4682               if (sym == NULL)
4683                 {
4684                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4685                                                      gfc_current_ns);
4686                   info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
4687                   sym = info->u.rsym.sym;
4688                   sym->module = gfc_get_string (info->u.rsym.module);
4689
4690                   if (info->u.rsym.binding_label)
4691                     sym->binding_label =
4692                       IDENTIFIER_POINTER (get_identifier
4693                                           (info->u.rsym.binding_label));
4694                 }
4695
4696               st->n.sym = sym;
4697               st->n.sym->refs++;
4698
4699               if (strcmp (name, p) != 0)
4700                 sym->attr.use_rename = 1;
4701
4702               if (name[0] != '_'
4703                   || (strncmp (name, "__vtab_", 5) != 0
4704                       && strncmp (name, "__vtype_", 6) != 0))
4705                 sym->attr.use_only = only_flag;
4706
4707               /* Store the symtree pointing to this symbol.  */
4708               info->u.rsym.symtree = st;
4709
4710               if (info->u.rsym.state == UNUSED)
4711                 info->u.rsym.state = NEEDED;
4712               info->u.rsym.referenced = 1;
4713             }
4714         }
4715     }
4716
4717   mio_rparen ();
4718
4719   /* Load intrinsic operator interfaces.  */
4720   set_module_locus (&operator_interfaces);
4721   mio_lparen ();
4722
4723   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4724     {
4725       if (i == INTRINSIC_USER)
4726         continue;
4727
4728       if (only_flag)
4729         {
4730           u = find_use_operator ((gfc_intrinsic_op) i);
4731
4732           if (u == NULL)
4733             {
4734               skip_list ();
4735               continue;
4736             }
4737
4738           u->found = 1;
4739         }
4740
4741       mio_interface (&gfc_current_ns->op[i]);
4742       if (u && !gfc_current_ns->op[i])
4743         u->found = 0;
4744     }
4745
4746   mio_rparen ();
4747
4748   /* Load generic and user operator interfaces.  These must follow the
4749      loading of symtree because otherwise symbols can be marked as
4750      ambiguous.  */
4751
4752   set_module_locus (&user_operators);
4753
4754   load_operator_interfaces ();
4755   load_generic_interfaces ();
4756
4757   load_commons ();
4758   load_equiv ();
4759
4760   /* At this point, we read those symbols that are needed but haven't
4761      been loaded yet.  If one symbol requires another, the other gets
4762      marked as NEEDED if its previous state was UNUSED.  */
4763
4764   while (load_needed (pi_root));
4765
4766   /* Make sure all elements of the rename-list were found in the module.  */
4767
4768   for (u = gfc_rename_list; u; u = u->next)
4769     {
4770       if (u->found)
4771         continue;
4772
4773       if (u->op == INTRINSIC_NONE)
4774         {
4775           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4776                      u->use_name, &u->where, module_name);
4777           continue;
4778         }
4779
4780       if (u->op == INTRINSIC_USER)
4781         {
4782           gfc_error ("User operator '%s' referenced at %L not found "
4783                      "in module '%s'", u->use_name, &u->where, module_name);
4784           continue;
4785         }
4786
4787       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4788                  "in module '%s'", gfc_op2string (u->op), &u->where,
4789                  module_name);
4790     }
4791
4792   /* Now we should be in a position to fill f2k_derived with derived type
4793      extensions, since everything has been loaded.  */
4794   set_module_locus (&extensions);
4795   load_derived_extensions ();
4796
4797   /* Clean up symbol nodes that were never loaded, create references
4798      to hidden symbols.  */
4799
4800   read_cleanup (pi_root);
4801 }
4802
4803
4804 /* Given an access type that is specific to an entity and the default
4805    access, return nonzero if the entity is publicly accessible.  If the
4806    element is declared as PUBLIC, then it is public; if declared
4807    PRIVATE, then private, and otherwise it is public unless the default
4808    access in this context has been declared PRIVATE.  */
4809
4810 static bool
4811 check_access (gfc_access specific_access, gfc_access default_access)
4812 {
4813   if (specific_access == ACCESS_PUBLIC)
4814     return TRUE;
4815   if (specific_access == ACCESS_PRIVATE)
4816     return FALSE;
4817
4818   if (gfc_option.flag_module_private)
4819     return default_access == ACCESS_PUBLIC;
4820   else
4821     return default_access != ACCESS_PRIVATE;
4822 }
4823
4824
4825 bool
4826 gfc_check_symbol_access (gfc_symbol *sym)
4827 {
4828   if (sym->attr.vtab || sym->attr.vtype)
4829     return true;
4830   else
4831     return check_access (sym->attr.access, sym->ns->default_access);
4832 }
4833
4834
4835 /* A structure to remember which commons we've already written.  */
4836
4837 struct written_common
4838 {
4839   BBT_HEADER(written_common);
4840   const char *name, *label;
4841 };
4842
4843 static struct written_common *written_commons = NULL;
4844
4845 /* Comparison function used for balancing the binary tree.  */
4846
4847 static int
4848 compare_written_commons (void *a1, void *b1)
4849 {
4850   const char *aname = ((struct written_common *) a1)->name;
4851   const char *alabel = ((struct written_common *) a1)->label;
4852   const char *bname = ((struct written_common *) b1)->name;
4853   const char *blabel = ((struct written_common *) b1)->label;
4854   int c = strcmp (aname, bname);
4855
4856   return (c != 0 ? c : strcmp (alabel, blabel));
4857 }
4858
4859 /* Free a list of written commons.  */
4860
4861 static void
4862 free_written_common (struct written_common *w)
4863 {
4864   if (!w)
4865     return;
4866
4867   if (w->left)
4868     free_written_common (w->left);
4869   if (w->right)
4870     free_written_common (w->right);
4871
4872   free (w);
4873 }
4874
4875 /* Write a common block to the module -- recursive helper function.  */
4876
4877 static void
4878 write_common_0 (gfc_symtree *st, bool this_module)
4879 {
4880   gfc_common_head *p;
4881   const char * name;
4882   int flags;
4883   const char *label;
4884   struct written_common *w;
4885   bool write_me = true;
4886
4887   if (st == NULL)
4888     return;
4889
4890   write_common_0 (st->left, this_module);
4891
4892   /* We will write out the binding label, or "" if no label given.  */
4893   name = st->n.common->name;
4894   p = st->n.common;
4895   label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
4896
4897   /* Check if we've already output this common.  */
4898   w = written_commons;
4899   while (w)
4900     {
4901       int c = strcmp (name, w->name);
4902       c = (c != 0 ? c : strcmp (label, w->label));
4903       if (c == 0)
4904         write_me = false;
4905
4906       w = (c < 0) ? w->left : w->right;
4907     }
4908
4909   if (this_module && p->use_assoc)
4910     write_me = false;
4911
4912   if (write_me)
4913     {
4914       /* Write the common to the module.  */
4915       mio_lparen ();
4916       mio_pool_string (&name);
4917
4918       mio_symbol_ref (&p->head);
4919       flags = p->saved ? 1 : 0;
4920       if (p->threadprivate)
4921         flags |= 2;
4922       mio_integer (&flags);
4923
4924       /* Write out whether the common block is bind(c) or not.  */
4925       mio_integer (&(p->is_bind_c));
4926
4927       mio_pool_string (&label);
4928       mio_rparen ();
4929
4930       /* Record that we have written this common.  */
4931       w = XCNEW (struct written_common);
4932       w->name = p->name;
4933       w->label = label;
4934       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4935     }
4936
4937   write_common_0 (st->right, this_module);
4938 }
4939
4940
4941 /* Write a common, by initializing the list of written commons, calling
4942    the recursive function write_common_0() and cleaning up afterwards.  */
4943
4944 static void
4945 write_common (gfc_symtree *st)
4946 {
4947   written_commons = NULL;
4948   write_common_0 (st, true);
4949   write_common_0 (st, false);
4950   free_written_common (written_commons);
4951   written_commons = NULL;
4952 }
4953
4954
4955 /* Write the blank common block to the module.  */
4956
4957 static void
4958 write_blank_common (void)
4959 {
4960   const char * name = BLANK_COMMON_NAME;
4961   int saved;
4962   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4963      this, but it hasn't been checked.  Just making it so for now.  */
4964   int is_bind_c = 0;
4965
4966   if (gfc_current_ns->blank_common.head == NULL)
4967     return;
4968
4969   mio_lparen ();
4970
4971   mio_pool_string (&name);
4972
4973   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4974   saved = gfc_current_ns->blank_common.saved;
4975   mio_integer (&saved);
4976
4977   /* Write out whether the common block is bind(c) or not.  */
4978   mio_integer (&is_bind_c);
4979
4980   /* Write out an empty binding label.  */
4981   write_atom (ATOM_STRING, "");
4982
4983   mio_rparen ();
4984 }
4985
4986
4987 /* Write equivalences to the module.  */
4988
4989 static void
4990 write_equiv (void)
4991 {
4992   gfc_equiv *eq, *e;
4993   int num;
4994
4995   num = 0;
4996   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4997     {
4998       mio_lparen ();
4999
5000       for (e = eq; e; e = e->eq)
5001         {
5002           if (e->module == NULL)
5003             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5004           mio_allocated_string (e->module);
5005           mio_expr (&e->expr);
5006         }
5007
5008       num++;
5009       mio_rparen ();
5010     }
5011 }
5012
5013
5014 /* Write derived type extensions to the module.  */
5015
5016 static void
5017 write_dt_extensions (gfc_symtree *st)
5018 {
5019   if (!gfc_check_symbol_access (st->n.sym))
5020     return;
5021   if (!(st->n.sym->ns && st->n.sym->ns->proc_name
5022         && st->n.sym->ns->proc_name->attr.flavor == FL_MODULE))
5023     return;
5024
5025   mio_lparen ();
5026   mio_pool_string (&st->name);
5027   if (st->n.sym->module != NULL)
5028     mio_pool_string (&st->n.sym->module);
5029   else
5030     {
5031       char name[GFC_MAX_SYMBOL_LEN + 1];
5032       if (iomode == IO_OUTPUT)
5033         strcpy (name, module_name);
5034       mio_internal_string (name);
5035       if (iomode == IO_INPUT)
5036         module_name = gfc_get_string (name);
5037     }
5038   mio_rparen ();
5039 }
5040
5041 static void
5042 write_derived_extensions (gfc_symtree *st)
5043 {
5044   if (!((st->n.sym->attr.flavor == FL_DERIVED)
5045           && (st->n.sym->f2k_derived != NULL)
5046           && (st->n.sym->f2k_derived->sym_root != NULL)))
5047     return;
5048
5049   mio_lparen ();
5050   mio_symbol_ref (&(st->n.sym));
5051   gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
5052                         write_dt_extensions);
5053   mio_rparen ();
5054 }
5055
5056
5057 /* Write a symbol to the module.  */
5058
5059 static void
5060 write_symbol (int n, gfc_symbol *sym)
5061 {
5062   const char *label;
5063
5064   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5065     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
5066
5067   mio_integer (&n);
5068
5069   if (sym->attr.flavor == FL_DERIVED)
5070     {
5071       const char *name;
5072       name = dt_upper_string (sym->name);
5073       mio_pool_string (&name);
5074     }
5075   else
5076     mio_pool_string (&sym->name);
5077
5078   mio_pool_string (&sym->module);
5079   if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5080     {
5081       label = sym->binding_label;
5082       mio_pool_string (&label);
5083     }
5084   else
5085     write_atom (ATOM_STRING, "");
5086
5087   mio_pointer_ref (&sym->ns);
5088
5089   mio_symbol (sym);
5090   write_char ('\n');
5091 }
5092
5093
5094 /* Recursive traversal function to write the initial set of symbols to
5095    the module.  We check to see if the symbol should be written
5096    according to the access specification.  */
5097
5098 static void
5099 write_symbol0 (gfc_symtree *st)
5100 {
5101   gfc_symbol *sym;
5102   pointer_info *p;
5103   bool dont_write = false;
5104
5105   if (st == NULL)
5106     return;
5107
5108   write_symbol0 (st->left);
5109
5110   sym = st->n.sym;
5111   if (sym->module == NULL)
5112     sym->module = module_name;
5113
5114   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5115       && !sym->attr.subroutine && !sym->attr.function)
5116     dont_write = true;
5117
5118   if (!gfc_check_symbol_access (sym))
5119     dont_write = true;
5120
5121   if (!dont_write)
5122     {
5123       p = get_pointer (sym);
5124       if (p->type == P_UNKNOWN)
5125         p->type = P_SYMBOL;
5126
5127       if (p->u.wsym.state != WRITTEN)
5128         {
5129           write_symbol (p->integer, sym);
5130           p->u.wsym.state = WRITTEN;
5131         }
5132     }
5133
5134   write_symbol0 (st->right);
5135 }
5136
5137
5138 /* Recursive traversal function to write the secondary set of symbols
5139    to the module file.  These are symbols that were not public yet are
5140    needed by the public symbols or another dependent symbol.  The act
5141    of writing a symbol can modify the pointer_info tree, so we cease
5142    traversal if we find a symbol to write.  We return nonzero if a
5143    symbol was written and pass that information upwards.  */
5144
5145 static int
5146 write_symbol1 (pointer_info *p)
5147 {
5148   int result;
5149
5150   if (!p)
5151     return 0;
5152
5153   result = write_symbol1 (p->left);
5154
5155   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
5156     {
5157       p->u.wsym.state = WRITTEN;
5158       write_symbol (p->integer, p->u.wsym.sym);
5159       result = 1;
5160     }
5161
5162   result |= write_symbol1 (p->right);
5163   return result;
5164 }
5165
5166
5167 /* Write operator interfaces associated with a symbol.  */
5168
5169 static void
5170 write_operator (gfc_user_op *uop)
5171 {
5172   static char nullstring[] = "";
5173   const char *p = nullstring;
5174
5175   if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
5176     return;
5177
5178   mio_symbol_interface (&uop->name, &p, &uop->op);
5179 }
5180
5181
5182 /* Write generic interfaces from the namespace sym_root.  */
5183
5184 static void
5185 write_generic (gfc_symtree *st)
5186 {
5187   gfc_symbol *sym;
5188
5189   if (st == NULL)
5190     return;
5191
5192   write_generic (st->left);
5193   write_generic (st->right);
5194
5195   sym = st->n.sym;
5196   if (!sym || check_unique_name (st->name))
5197     return;
5198
5199   if (sym->generic == NULL || !gfc_check_symbol_access (sym))
5200     return;
5201
5202   if (sym->module == NULL)
5203     sym->module = module_name;
5204
5205   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
5206 }
5207
5208
5209 static void
5210 write_symtree (gfc_symtree *st)
5211 {
5212   gfc_symbol *sym;
5213   pointer_info *p;
5214
5215   sym = st->n.sym;
5216
5217   /* A symbol in an interface body must not be visible in the
5218      module file.  */
5219   if (sym->ns != gfc_current_ns
5220         && sym->ns->proc_name
5221         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
5222     return;
5223
5224   if (!gfc_check_symbol_access (sym)
5225       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5226           && !sym->attr.subroutine && !sym->attr.function))
5227     return;
5228
5229   if (check_unique_name (st->name))
5230     return;
5231
5232   p = find_pointer (sym);
5233   if (p == NULL)
5234     gfc_internal_error ("write_symtree(): Symbol not written");
5235
5236   mio_pool_string (&st->name);
5237   mio_integer (&st->ambiguous);
5238   mio_integer (&p->integer);
5239 }
5240
5241
5242 static void
5243 write_module (void)
5244 {
5245   int i;
5246
5247   /* Write the operator interfaces.  */
5248   mio_lparen ();
5249
5250   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5251     {
5252       if (i == INTRINSIC_USER)
5253         continue;
5254
5255       mio_interface (check_access (gfc_current_ns->operator_access[i],
5256                                    gfc_current_ns->default_access)
5257                      ? &gfc_current_ns->op[i] : NULL);
5258     }
5259
5260   mio_rparen ();
5261   write_char ('\n');
5262   write_char ('\n');
5263
5264   mio_lparen ();
5265   gfc_traverse_user_op (gfc_current_ns, write_operator);
5266   mio_rparen ();
5267   write_char ('\n');
5268   write_char ('\n');
5269
5270   mio_lparen ();
5271   write_generic (gfc_current_ns->sym_root);
5272   mio_rparen ();
5273   write_char ('\n');
5274   write_char ('\n');
5275
5276   mio_lparen ();
5277   write_blank_common ();
5278   write_common (gfc_current_ns->common_root);
5279   mio_rparen ();
5280   write_char ('\n');
5281   write_char ('\n');
5282
5283   mio_lparen ();
5284   write_equiv ();
5285   mio_rparen ();
5286   write_char ('\n');
5287   write_char ('\n');
5288
5289   mio_lparen ();
5290   gfc_traverse_symtree (gfc_current_ns->sym_root,
5291                         write_derived_extensions);
5292   mio_rparen ();
5293   write_char ('\n');
5294   write_char ('\n');
5295
5296   /* Write symbol information.  First we traverse all symbols in the
5297      primary namespace, writing those that need to be written.
5298      Sometimes writing one symbol will cause another to need to be
5299      written.  A list of these symbols ends up on the write stack, and
5300      we end by popping the bottom of the stack and writing the symbol
5301      until the stack is empty.  */
5302
5303   mio_lparen ();
5304
5305   write_symbol0 (gfc_current_ns->sym_root);
5306   while (write_symbol1 (pi_root))
5307     /* Nothing.  */;
5308
5309   mio_rparen ();
5310
5311   write_char ('\n');
5312   write_char ('\n');
5313
5314   mio_lparen ();
5315   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5316   mio_rparen ();
5317 }
5318
5319
5320 /* Read a MD5 sum from the header of a module file.  If the file cannot
5321    be opened, or we have any other error, we return -1.  */
5322
5323 static int
5324 read_md5_from_module_file (const char * filename, unsigned char md5[16])
5325 {
5326   FILE *file;
5327   char buf[1024];
5328   int n;
5329
5330   /* Open the file.  */
5331   if ((file = fopen (filename, "r")) == NULL)
5332     return -1;
5333
5334   /* Read the first line.  */
5335   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5336     {
5337       fclose (file);
5338       return -1;
5339     }
5340
5341   /* The file also needs to be overwritten if the version number changed.  */
5342   n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
5343   if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
5344     {
5345       fclose (file);
5346       return -1;
5347     }
5348
5349   /* Read a second line.  */
5350   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5351     {
5352       fclose (file);
5353       return -1;
5354     }
5355
5356   /* Close the file.  */
5357   fclose (file);
5358
5359   /* If the header is not what we expect, or is too short, bail out.  */
5360   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
5361     return -1;
5362
5363   /* Now, we have a real MD5, read it into the array.  */
5364   for (n = 0; n < 16; n++)
5365     {
5366       unsigned int x;
5367
5368       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
5369        return -1;
5370
5371       md5[n] = x;
5372     }
5373
5374   return 0;
5375 }
5376
5377
5378 /* Given module, dump it to disk.  If there was an error while
5379    processing the module, dump_flag will be set to zero and we delete
5380    the module file, even if it was already there.  */
5381
5382 void
5383 gfc_dump_module (const char *name, int dump_flag)
5384 {
5385   int n;
5386   char *filename, *filename_tmp;
5387   fpos_t md5_pos;
5388   unsigned char md5_new[16], md5_old[16];
5389
5390   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
5391   if (gfc_option.module_dir != NULL)
5392     {
5393       n += strlen (gfc_option.module_dir);
5394       filename = (char *) alloca (n);
5395       strcpy (filename, gfc_option.module_dir);
5396       strcat (filename, name);
5397     }
5398   else
5399     {
5400       filename = (char *) alloca (n);
5401       strcpy (filename, name);
5402     }
5403   strcat (filename, MODULE_EXTENSION);
5404
5405   /* Name of the temporary file used to write the module.  */
5406   filename_tmp = (char *) alloca (n + 1);
5407   strcpy (filename_tmp, filename);
5408   strcat (filename_tmp, "0");
5409
5410   /* There was an error while processing the module.  We delete the
5411      module file, even if it was already there.  */
5412   if (!dump_flag)
5413     {
5414       unlink (filename);
5415       return;
5416     }
5417
5418   if (gfc_cpp_makedep ())
5419     gfc_cpp_add_target (filename);
5420
5421   /* Write the module to the temporary file.  */
5422   module_fp = fopen (filename_tmp, "w");
5423   if (module_fp == NULL)
5424     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5425                      filename_tmp, xstrerror (errno));
5426
5427   /* Write the header, including space reserved for the MD5 sum.  */
5428   fprintf (module_fp, "GFORTRAN module version '%s' created from %s\n"
5429            "MD5:", MOD_VERSION, gfc_source_file);
5430   fgetpos (module_fp, &md5_pos);
5431   fputs ("00000000000000000000000000000000 -- "
5432         "If you edit this, you'll get what you deserve.\n\n", module_fp);
5433
5434   /* Initialize the MD5 context that will be used for output.  */
5435   md5_init_ctx (&ctx);
5436
5437   /* Write the module itself.  */
5438   iomode = IO_OUTPUT;
5439   module_name = gfc_get_string (name);
5440
5441   init_pi_tree ();
5442
5443   write_module ();
5444
5445   free_pi_tree (pi_root);
5446   pi_root = NULL;
5447
5448   write_char ('\n');
5449
5450   /* Write the MD5 sum to the header of the module file.  */
5451   md5_finish_ctx (&ctx, md5_new);
5452   fsetpos (module_fp, &md5_pos);
5453   for (n = 0; n < 16; n++)
5454     fprintf (module_fp, "%02x", md5_new[n]);
5455
5456   if (fclose (module_fp))
5457     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5458                      filename_tmp, xstrerror (errno));
5459
5460   /* Read the MD5 from the header of the old module file and compare.  */
5461   if (read_md5_from_module_file (filename, md5_old) != 0
5462       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
5463     {
5464       /* Module file have changed, replace the old one.  */
5465       if (unlink (filename) && errno != ENOENT)
5466         gfc_fatal_error ("Can't delete module file '%s': %s", filename,
5467                          xstrerror (errno));
5468       if (rename (filename_tmp, filename))
5469         gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5470                          filename_tmp, filename, xstrerror (errno));
5471     }
5472   else
5473     {
5474       if (unlink (filename_tmp))
5475         gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5476                          filename_tmp, xstrerror (errno));
5477     }
5478 }
5479
5480
5481 static void
5482 create_intrinsic_function (const char *name, gfc_isym_id id,
5483                            const char *modname, intmod_id module)
5484 {
5485   gfc_intrinsic_sym *isym;
5486   gfc_symtree *tmp_symtree;
5487   gfc_symbol *sym;
5488
5489   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5490   if (tmp_symtree)
5491     {
5492       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5493         return;
5494       gfc_error ("Symbol '%s' already declared", name);
5495     }
5496
5497   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5498   sym = tmp_symtree->n.sym;
5499
5500   isym = gfc_intrinsic_function_by_id (id);
5501   gcc_assert (isym);
5502
5503   sym->attr.flavor = FL_PROCEDURE;
5504   sym->attr.intrinsic = 1;
5505
5506   sym->module = gfc_get_string (modname);
5507   sym->attr.use_assoc = 1;
5508   sym->from_intmod = module;
5509   sym->intmod_sym_id = id;
5510 }
5511
5512
5513 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5514    the current namespace for all named constants, pointer types, and
5515    procedures in the module unless the only clause was used or a rename
5516    list was provided.  */
5517
5518 static void
5519 import_iso_c_binding_module (void)
5520 {
5521   gfc_symbol *mod_sym = NULL;
5522   gfc_symtree *mod_symtree = NULL;
5523   const char *iso_c_module_name = "__iso_c_binding";
5524   gfc_use_rename *u;
5525   int i;
5526
5527   /* Look only in the current namespace.  */
5528   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5529
5530   if (mod_symtree == NULL)
5531     {
5532       /* symtree doesn't already exist in current namespace.  */
5533       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
5534                         false);
5535
5536       if (mod_symtree != NULL)
5537         mod_sym = mod_symtree->n.sym;
5538       else
5539         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5540                             "create symbol for %s", iso_c_module_name);
5541
5542       mod_sym->attr.flavor = FL_MODULE;
5543       mod_sym->attr.intrinsic = 1;
5544       mod_sym->module = gfc_get_string (iso_c_module_name);
5545       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
5546     }
5547
5548   /* Generate the symbols for the named constants representing
5549      the kinds for intrinsic data types.  */
5550   for (i = 0; i < ISOCBINDING_NUMBER; i++)
5551     {
5552       bool found = false;
5553       for (u = gfc_rename_list; u; u = u->next)
5554         if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5555           {
5556             bool not_in_std;
5557             const char *name;
5558             u->found = 1;
5559             found = true;
5560
5561             switch (i)
5562               {
5563 #define NAMED_FUNCTION(a,b,c,d) \
5564                 case a: \
5565                   not_in_std = (gfc_option.allow_std & d) == 0; \
5566                   name = b; \
5567                   break;
5568 #include "iso-c-binding.def"
5569 #undef NAMED_FUNCTION
5570 #define NAMED_INTCST(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_INTCST
5577 #define NAMED_REALCST(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_REALCST
5584 #define NAMED_CMPXCST(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_CMPXCST
5591                 default:
5592                   not_in_std = false;
5593                   name = "";
5594               }
5595
5596             if (not_in_std)
5597               {
5598                 gfc_error ("The symbol '%s', referenced at %L, is not "
5599                            "in the selected standard", name, &u->where);
5600                 continue;
5601               }
5602
5603             switch (i)
5604               {
5605 #define NAMED_FUNCTION(a,b,c,d) \
5606                 case a: \
5607                   create_intrinsic_function (u->local_name[0] ? u->local_name \
5608                                                               : u->use_name, \
5609                                              (gfc_isym_id) c, \
5610                                              iso_c_module_name, \
5611                                              INTMOD_ISO_C_BINDING); \
5612                   break;
5613 #include "iso-c-binding.def"
5614 #undef NAMED_FUNCTION
5615
5616                 default:
5617                   generate_isocbinding_symbol (iso_c_module_name,
5618                                                (iso_c_binding_symbol) i,
5619                                                u->local_name[0] ? u->local_name
5620                                                                 : u->use_name);
5621               }
5622           }
5623
5624       if (!found && !only_flag)
5625         {
5626           /* Skip, if the symbol is not in the enabled standard.  */
5627           switch (i)
5628             {
5629 #define NAMED_FUNCTION(a,b,c,d) \
5630               case a: \
5631                 if ((gfc_option.allow_std & d) == 0) \
5632                   continue; \
5633                 break;
5634 #include "iso-c-binding.def"
5635 #undef NAMED_FUNCTION
5636
5637 #define NAMED_INTCST(a,b,c,d) \
5638               case a: \
5639                 if ((gfc_option.allow_std & d) == 0) \
5640                   continue; \
5641                 break;
5642 #include "iso-c-binding.def"
5643 #undef NAMED_INTCST
5644 #define NAMED_REALCST(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_REALCST
5651 #define NAMED_CMPXCST(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_CMPXCST
5658               default:
5659                 ; /* Not GFC_STD_* versioned. */
5660             }
5661
5662           switch (i)
5663             {
5664 #define NAMED_FUNCTION(a,b,c,d) \
5665               case a: \
5666                 create_intrinsic_function (b, (gfc_isym_id) c, \
5667                                            iso_c_module_name, \
5668                                            INTMOD_ISO_C_BINDING); \
5669                   break;
5670 #include "iso-c-binding.def"
5671 #undef NAMED_FUNCTION
5672
5673               default:
5674                 generate_isocbinding_symbol (iso_c_module_name,
5675                                              (iso_c_binding_symbol) i, NULL);
5676             }
5677         }
5678    }
5679
5680    for (u = gfc_rename_list; u; u = u->next)
5681      {
5682       if (u->found)
5683         continue;
5684
5685       gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5686                  "module ISO_C_BINDING", u->use_name, &u->where);
5687      }
5688 }
5689
5690
5691 /* Add an integer named constant from a given module.  */
5692
5693 static void
5694 create_int_parameter (const char *name, int value, const char *modname,
5695                       intmod_id module, int id)
5696 {
5697   gfc_symtree *tmp_symtree;
5698   gfc_symbol *sym;
5699
5700   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5701   if (tmp_symtree != NULL)
5702     {
5703       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5704         return;
5705       else
5706         gfc_error ("Symbol '%s' already declared", name);
5707     }
5708
5709   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5710   sym = tmp_symtree->n.sym;
5711
5712   sym->module = gfc_get_string (modname);
5713   sym->attr.flavor = FL_PARAMETER;
5714   sym->ts.type = BT_INTEGER;
5715   sym->ts.kind = gfc_default_integer_kind;
5716   sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
5717   sym->attr.use_assoc = 1;
5718   sym->from_intmod = module;
5719   sym->intmod_sym_id = id;
5720 }
5721
5722
5723 /* Value is already contained by the array constructor, but not
5724    yet the shape.  */
5725
5726 static void
5727 create_int_parameter_array (const char *name, int size, gfc_expr *value,
5728                             const char *modname, intmod_id module, int id)
5729 {
5730   gfc_symtree *tmp_symtree;
5731   gfc_symbol *sym;
5732
5733   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5734   if (tmp_symtree != NULL)
5735     {
5736       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5737         return;
5738       else
5739         gfc_error ("Symbol '%s' already declared", name);
5740     }
5741
5742   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5743   sym = tmp_symtree->n.sym;
5744
5745   sym->module = gfc_get_string (modname);
5746   sym->attr.flavor = FL_PARAMETER;
5747   sym->ts.type = BT_INTEGER;
5748   sym->ts.kind = gfc_default_integer_kind;
5749   sym->attr.use_assoc = 1;
5750   sym->from_intmod = module;
5751   sym->intmod_sym_id = id;
5752   sym->attr.dimension = 1;
5753   sym->as = gfc_get_array_spec ();
5754   sym->as->rank = 1;
5755   sym->as->type = AS_EXPLICIT;
5756   sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5757   sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
5758
5759   sym->value = value;
5760   sym->value->shape = gfc_get_shape (1);
5761   mpz_init_set_ui (sym->value->shape[0], size);
5762 }
5763
5764
5765 /* Add an derived type for a given module.  */
5766
5767 static void
5768 create_derived_type (const char *name, const char *modname,
5769                       intmod_id module, int id)
5770 {
5771   gfc_symtree *tmp_symtree;
5772   gfc_symbol *sym, *dt_sym;
5773   gfc_interface *intr, *head;
5774
5775   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5776   if (tmp_symtree != NULL)
5777     {
5778       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5779         return;
5780       else
5781         gfc_error ("Symbol '%s' already declared", name);
5782     }
5783
5784   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5785   sym = tmp_symtree->n.sym;
5786   sym->module = gfc_get_string (modname);
5787   sym->from_intmod = module;
5788   sym->intmod_sym_id = id;
5789   sym->attr.flavor = FL_PROCEDURE;
5790   sym->attr.function = 1;
5791   sym->attr.generic = 1;
5792
5793   gfc_get_sym_tree (dt_upper_string (sym->name),
5794                     gfc_current_ns, &tmp_symtree, false);
5795   dt_sym = tmp_symtree->n.sym;
5796   dt_sym->name = gfc_get_string (sym->name);
5797   dt_sym->attr.flavor = FL_DERIVED;
5798   dt_sym->attr.private_comp = 1;
5799   dt_sym->attr.zero_comp = 1;
5800   dt_sym->attr.use_assoc = 1;
5801   dt_sym->module = gfc_get_string (modname);
5802   dt_sym->from_intmod = module;
5803   dt_sym->intmod_sym_id = id;
5804
5805   head = sym->generic;
5806   intr = gfc_get_interface ();
5807   intr->sym = dt_sym;
5808   intr->where = gfc_current_locus;
5809   intr->next = head;
5810   sym->generic = intr;
5811   sym->attr.if_source = IFSRC_DECL;
5812 }
5813
5814
5815 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
5816
5817 static void
5818 use_iso_fortran_env_module (void)
5819 {
5820   static char mod[] = "iso_fortran_env";
5821   gfc_use_rename *u;
5822   gfc_symbol *mod_sym;
5823   gfc_symtree *mod_symtree;
5824   gfc_expr *expr;
5825   int i, j;
5826
5827   intmod_sym symbol[] = {
5828 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5829 #include "iso-fortran-env.def"
5830 #undef NAMED_INTCST
5831 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
5832 #include "iso-fortran-env.def"
5833 #undef NAMED_KINDARRAY
5834 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
5835 #include "iso-fortran-env.def"
5836 #undef NAMED_DERIVED_TYPE
5837 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
5838 #include "iso-fortran-env.def"
5839 #undef NAMED_FUNCTION
5840     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5841
5842   i = 0;
5843 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5844 #include "iso-fortran-env.def"
5845 #undef NAMED_INTCST
5846
5847   /* Generate the symbol for the module itself.  */
5848   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5849   if (mod_symtree == NULL)
5850     {
5851       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
5852       gcc_assert (mod_symtree);
5853       mod_sym = mod_symtree->n.sym;
5854
5855       mod_sym->attr.flavor = FL_MODULE;
5856       mod_sym->attr.intrinsic = 1;
5857       mod_sym->module = gfc_get_string (mod);
5858       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5859     }
5860   else
5861     if (!mod_symtree->n.sym->attr.intrinsic)
5862       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5863                  "non-intrinsic module name used previously", mod);
5864
5865   /* Generate the symbols for the module integer named constants.  */
5866
5867   for (i = 0; symbol[i].name; i++)
5868     {
5869       bool found = false;
5870       for (u = gfc_rename_list; u; u = u->next)
5871         {
5872           if (strcmp (symbol[i].name, u->use_name) == 0)
5873             {
5874               found = true;
5875               u->found = 1;
5876
5877               if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
5878                                   "referenced at %L, is not in the selected "
5879                                   "standard", symbol[i].name,
5880                                   &u->where) == FAILURE)
5881                 continue;
5882
5883               if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5884                   && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5885                 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
5886                                  "constant from intrinsic module "
5887                                  "ISO_FORTRAN_ENV at %L is incompatible with "
5888                                  "option %s", &u->where,
5889                                  gfc_option.flag_default_integer
5890                                    ? "-fdefault-integer-8"
5891                                    : "-fdefault-real-8");
5892               switch (symbol[i].id)
5893                 {
5894 #define NAMED_INTCST(a,b,c,d) \
5895                 case a:
5896 #include "iso-fortran-env.def"
5897 #undef NAMED_INTCST
5898                   create_int_parameter (u->local_name[0] ? u->local_name
5899                                                          : u->use_name,
5900                                         symbol[i].value, mod,
5901                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5902                   break;
5903
5904 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5905                 case a:\
5906                   expr = gfc_get_array_expr (BT_INTEGER, \
5907                                              gfc_default_integer_kind,\
5908                                              NULL); \
5909                   for (j = 0; KINDS[j].kind != 0; j++) \
5910                     gfc_constructor_append_expr (&expr->value.constructor, \
5911                         gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5912                                           KINDS[j].kind), NULL); \
5913                   create_int_parameter_array (u->local_name[0] ? u->local_name \
5914                                                          : u->use_name, \
5915                                               j, expr, mod, \
5916                                               INTMOD_ISO_FORTRAN_ENV, \
5917                                               symbol[i].id); \
5918                   break;
5919 #include "iso-fortran-env.def"
5920 #undef NAMED_KINDARRAY
5921
5922 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
5923                 case a:
5924 #include "iso-fortran-env.def"
5925                   create_derived_type (u->local_name[0] ? u->local_name
5926                                                         : u->use_name,
5927                                        mod, INTMOD_ISO_FORTRAN_ENV,
5928                                        symbol[i].id);
5929                   break;
5930 #undef NAMED_DERIVED_TYPE
5931
5932 #define NAMED_FUNCTION(a,b,c,d) \
5933                 case a:
5934 #include "iso-fortran-env.def"
5935 #undef NAMED_FUNCTION
5936                   create_intrinsic_function (u->local_name[0] ? u->local_name
5937                                                               : u->use_name,
5938                                              (gfc_isym_id) symbol[i].value, mod,
5939                                              INTMOD_ISO_FORTRAN_ENV);
5940                   break;
5941
5942                 default:
5943                   gcc_unreachable ();
5944                 }
5945             }
5946         }
5947
5948       if (!found && !only_flag)
5949         {
5950           if ((gfc_option.allow_std & symbol[i].standard) == 0)
5951             continue;
5952
5953           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5954               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5955             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5956                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
5957                              "incompatible with option %s",
5958                              gfc_option.flag_default_integer
5959                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
5960
5961           switch (symbol[i].id)
5962             {
5963 #define NAMED_INTCST(a,b,c,d) \
5964             case a:
5965 #include "iso-fortran-env.def"
5966 #undef NAMED_INTCST
5967               create_int_parameter (symbol[i].name, symbol[i].value, mod,
5968                                     INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5969               break;
5970
5971 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5972             case a:\
5973               expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
5974                                          NULL); \
5975               for (j = 0; KINDS[j].kind != 0; j++) \
5976                 gfc_constructor_append_expr (&expr->value.constructor, \
5977                       gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5978                                         KINDS[j].kind), NULL); \
5979             create_int_parameter_array (symbol[i].name, j, expr, mod, \
5980                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
5981             break;
5982 #include "iso-fortran-env.def"
5983 #undef NAMED_KINDARRAY
5984
5985 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
5986           case a:
5987 #include "iso-fortran-env.def"
5988             create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
5989                                  symbol[i].id);
5990             break;
5991 #undef NAMED_DERIVED_TYPE
5992
5993 #define NAMED_FUNCTION(a,b,c,d) \
5994                 case a:
5995 #include "iso-fortran-env.def"
5996 #undef NAMED_FUNCTION
5997                   create_intrinsic_function (symbol[i].name,
5998                                              (gfc_isym_id) symbol[i].value, mod,
5999                                              INTMOD_ISO_FORTRAN_ENV);
6000                   break;
6001
6002           default:
6003             gcc_unreachable ();
6004           }
6005         }
6006     }
6007
6008   for (u = gfc_rename_list; u; u = u->next)
6009     {
6010       if (u->found)
6011         continue;
6012
6013       gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6014                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
6015     }
6016 }
6017
6018
6019 /* Process a USE directive.  */
6020
6021 static void
6022 gfc_use_module (gfc_use_list *module)
6023 {
6024   char *filename;
6025   gfc_state_data *p;
6026   int c, line, start;
6027   gfc_symtree *mod_symtree;
6028   gfc_use_list *use_stmt;
6029   locus old_locus = gfc_current_locus;
6030
6031   gfc_current_locus = module->where;
6032   module_name = module->module_name;
6033   gfc_rename_list = module->rename;
6034   only_flag = module->only_flag;
6035
6036   filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
6037                                + 1);
6038   strcpy (filename, module_name);
6039   strcat (filename, MODULE_EXTENSION);
6040
6041   /* First, try to find an non-intrinsic module, unless the USE statement
6042      specified that the module is intrinsic.  */
6043   module_fp = NULL;
6044   if (!module->intrinsic)
6045     module_fp = gfc_open_included_file (filename, true, true);
6046
6047   /* Then, see if it's an intrinsic one, unless the USE statement
6048      specified that the module is non-intrinsic.  */
6049   if (module_fp == NULL && !module->non_intrinsic)
6050     {
6051       if (strcmp (module_name, "iso_fortran_env") == 0
6052           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
6053                              "intrinsic module at %C") != FAILURE)
6054        {
6055          use_iso_fortran_env_module ();
6056          gfc_current_locus = old_locus;
6057          module->intrinsic = true;
6058          return;
6059        }
6060
6061       if (strcmp (module_name, "iso_c_binding") == 0
6062           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
6063                              "ISO_C_BINDING module at %C") != FAILURE)
6064         {
6065           import_iso_c_binding_module();
6066           gfc_current_locus = old_locus;
6067           module->intrinsic = true;
6068           return;
6069         }
6070
6071       module_fp = gfc_open_intrinsic_module (filename);
6072
6073       if (module_fp == NULL && module->intrinsic)
6074         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6075                          module_name);
6076     }
6077
6078   if (module_fp == NULL)
6079     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6080                      filename, xstrerror (errno));
6081
6082   /* Check that we haven't already USEd an intrinsic module with the
6083      same name.  */
6084
6085   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
6086   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
6087     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6088                "intrinsic module name used previously", module_name);
6089
6090   iomode = IO_INPUT;
6091   module_line = 1;
6092   module_column = 1;
6093   start = 0;
6094
6095   /* Skip the first two lines of the module, after checking that this is
6096      a gfortran module file.  */
6097   line = 0;
6098   while (line < 2)
6099     {
6100       c = module_char ();
6101       if (c == EOF)
6102         bad_module ("Unexpected end of module");
6103       if (start++ < 3)
6104         parse_name (c);
6105       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
6106           || (start == 2 && strcmp (atom_name, " module") != 0))
6107         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
6108                          "file", filename);
6109       if (start == 3)
6110         {
6111           if (strcmp (atom_name, " version") != 0
6112               || module_char () != ' '
6113               || parse_atom () != ATOM_STRING)
6114             gfc_fatal_error ("Parse error when checking module version"
6115                              " for file '%s' opened at %C", filename);
6116
6117           if (strcmp (atom_string, MOD_VERSION))
6118             {
6119               gfc_fatal_error ("Wrong module version '%s' (expected '%s') "
6120                                "for file '%s' opened at %C", atom_string,
6121                                MOD_VERSION, filename);
6122             }
6123
6124           free (atom_string);
6125         }
6126
6127       if (c == '\n')
6128         line++;
6129     }
6130
6131   /* Make sure we're not reading the same module that we may be building.  */
6132   for (p = gfc_state_stack; p; p = p->previous)
6133     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
6134       gfc_fatal_error ("Can't USE the same module we're building!");
6135
6136   init_pi_tree ();
6137   init_true_name_tree ();
6138
6139   read_module ();
6140
6141   free_true_name (true_name_root);
6142   true_name_root = NULL;
6143
6144   free_pi_tree (pi_root);
6145   pi_root = NULL;
6146
6147   fclose (module_fp);
6148
6149   use_stmt = gfc_get_use_list ();
6150   *use_stmt = *module;
6151   use_stmt->next = gfc_current_ns->use_stmts;
6152   gfc_current_ns->use_stmts = use_stmt;
6153
6154   gfc_current_locus = old_locus;
6155 }
6156
6157
6158 /* Remove duplicated intrinsic operators from the rename list. */
6159
6160 static void
6161 rename_list_remove_duplicate (gfc_use_rename *list)
6162 {
6163   gfc_use_rename *seek, *last;
6164
6165   for (; list; list = list->next)
6166     if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
6167       {
6168         last = list;
6169         for (seek = list->next; seek; seek = last->next)
6170           {
6171             if (list->op == seek->op)
6172               {
6173                 last->next = seek->next;
6174                 free (seek);
6175               }
6176             else
6177               last = seek;
6178           }
6179       }
6180 }
6181
6182
6183 /* Process all USE directives.  */
6184
6185 void
6186 gfc_use_modules (void)
6187 {
6188   gfc_use_list *next, *seek, *last;
6189
6190   for (next = module_list; next; next = next->next)
6191     {
6192       bool non_intrinsic = next->non_intrinsic;
6193       bool intrinsic = next->intrinsic;
6194       bool neither = !non_intrinsic && !intrinsic;
6195
6196       for (seek = next->next; seek; seek = seek->next)
6197         {
6198           if (next->module_name != seek->module_name)
6199             continue;
6200
6201           if (seek->non_intrinsic)
6202             non_intrinsic = true;
6203           else if (seek->intrinsic)
6204             intrinsic = true;
6205           else
6206             neither = true;
6207         }
6208
6209       if (intrinsic && neither && !non_intrinsic)
6210         {
6211           char *filename;
6212           FILE *fp;
6213
6214           filename = XALLOCAVEC (char,
6215                                  strlen (next->module_name)
6216                                  + strlen (MODULE_EXTENSION) + 1);
6217           strcpy (filename, next->module_name);
6218           strcat (filename, MODULE_EXTENSION);
6219           fp = gfc_open_included_file (filename, true, true);
6220           if (fp != NULL)
6221             {
6222               non_intrinsic = true;
6223               fclose (fp);
6224             }
6225         }
6226
6227       last = next;
6228       for (seek = next->next; seek; seek = last->next)
6229         {
6230           if (next->module_name != seek->module_name)
6231             {
6232               last = seek;
6233               continue;
6234             }
6235
6236           if ((!next->intrinsic && !seek->intrinsic)
6237               || (next->intrinsic && seek->intrinsic)
6238               || !non_intrinsic)
6239             {
6240               if (!seek->only_flag)
6241                 next->only_flag = false;
6242               if (seek->rename)
6243                 {
6244                   gfc_use_rename *r = seek->rename;
6245                   while (r->next)
6246                     r = r->next;
6247                   r->next = next->rename;
6248                   next->rename = seek->rename;
6249                 }
6250               last->next = seek->next;
6251               free (seek);
6252             }
6253           else
6254             last = seek;
6255         }
6256     }
6257
6258   for (; module_list; module_list = next)
6259     {
6260       next = module_list->next;
6261       rename_list_remove_duplicate (module_list->rename);
6262       gfc_use_module (module_list);
6263       if (module_list->intrinsic)
6264         free_rename (module_list->rename);
6265       free (module_list);
6266     }
6267   gfc_rename_list = NULL;
6268 }
6269
6270
6271 void
6272 gfc_free_use_stmts (gfc_use_list *use_stmts)
6273 {
6274   gfc_use_list *next;
6275   for (; use_stmts; use_stmts = next)
6276     {
6277       gfc_use_rename *next_rename;
6278
6279       for (; use_stmts->rename; use_stmts->rename = next_rename)
6280         {
6281           next_rename = use_stmts->rename->next;
6282           free (use_stmts->rename);
6283         }
6284       next = use_stmts->next;
6285       free (use_stmts);
6286     }
6287 }
6288
6289
6290 void
6291 gfc_module_init_2 (void)
6292 {
6293   last_atom = ATOM_LPAREN;
6294   gfc_rename_list = NULL;
6295   module_list = NULL;
6296 }
6297
6298
6299 void
6300 gfc_module_done_2 (void)
6301 {
6302   free_rename (gfc_rename_list);
6303   gfc_rename_list = NULL;
6304 }