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