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