gcc/fortran/module.c

   1 /* Handle modules, which amounts to loading and saving symbols and
   2    their attendant structures.
   3    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4    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           /* If the symbol is PRIVATE and in COMMON, load_commons will
2315              generate a fixup symbol, which must be associated.  */
2316           if (p->fixup)
2317             resolve_fixups (p->fixup, p->u.rsym.sym);
2318           p->fixup = NULL;
2319         }
2320
2321       if (p->type == P_UNKNOWN)
2322         p->type = P_SYMBOL;
2323
2324       if (p->u.rsym.state == UNUSED)
2325         p->u.rsym.state = NEEDED;
2326
2327       if (p->u.rsym.symtree != NULL)
2328         {
2329           *stp = p->u.rsym.symtree;
2330         }
2331       else
2332         {
2333           f = gfc_getmem (sizeof (fixup_t));
2334
2335           f->next = p->u.rsym.stfixup;
2336           p->u.rsym.stfixup = f;
2337
2338           f->pointer = (void **) stp;
2339         }
2340     }
2341 }
2342
2343
2344 static void
2345 mio_iterator (gfc_iterator **ip)
2346 {
2347   gfc_iterator *iter;
2348
2349   mio_lparen ();
2350
2351   if (iomode == IO_OUTPUT)
2352     {
2353       if (*ip == NULL)
2354         goto done;
2355     }
2356   else
2357     {
2358       if (peek_atom () == ATOM_RPAREN)
2359         {
2360           *ip = NULL;
2361           goto done;
2362         }
2363
2364       *ip = gfc_get_iterator ();
2365     }
2366
2367   iter = *ip;
2368
2369   mio_expr (&iter->var);
2370   mio_expr (&iter->start);
2371   mio_expr (&iter->end);
2372   mio_expr (&iter->step);
2373
2374 done:
2375   mio_rparen ();
2376 }
2377
2378
2379 static void
2380 mio_constructor (gfc_constructor **cp)
2381 {
2382   gfc_constructor *c, *tail;
2383
2384   mio_lparen ();
2385
2386   if (iomode == IO_OUTPUT)
2387     {
2388       for (c = *cp; c; c = c->next)
2389         {
2390           mio_lparen ();
2391           mio_expr (&c->expr);
2392           mio_iterator (&c->iterator);
2393           mio_rparen ();
2394         }
2395     }
2396   else
2397     {
2398       *cp = NULL;
2399       tail = NULL;
2400
2401       while (peek_atom () != ATOM_RPAREN)
2402         {
2403           c = gfc_get_constructor ();
2404
2405           if (tail == NULL)
2406             *cp = c;
2407           else
2408             tail->next = c;
2409
2410           tail = c;
2411
2412           mio_lparen ();
2413           mio_expr (&c->expr);
2414           mio_iterator (&c->iterator);
2415           mio_rparen ();
2416         }
2417     }
2418
2419   mio_rparen ();
2420 }
2421
2422
2423 static const mstring ref_types[] = {
2424     minit ("ARRAY", REF_ARRAY),
2425     minit ("COMPONENT", REF_COMPONENT),
2426     minit ("SUBSTRING", REF_SUBSTRING),
2427     minit (NULL, -1)
2428 };
2429
2430
2431 static void
2432 mio_ref (gfc_ref **rp)
2433 {
2434   gfc_ref *r;
2435
2436   mio_lparen ();
2437
2438   r = *rp;
2439   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2440
2441   switch (r->type)
2442     {
2443     case REF_ARRAY:
2444       mio_array_ref (&r->u.ar);
2445       break;
2446
2447     case REF_COMPONENT:
2448       mio_symbol_ref (&r->u.c.sym);
2449       mio_component_ref (&r->u.c.component, r->u.c.sym);
2450       break;
2451
2452     case REF_SUBSTRING:
2453       mio_expr (&r->u.ss.start);
2454       mio_expr (&r->u.ss.end);
2455       mio_charlen (&r->u.ss.length);
2456       break;
2457     }
2458
2459   mio_rparen ();
2460 }
2461
2462
2463 static void
2464 mio_ref_list (gfc_ref **rp)
2465 {
2466   gfc_ref *ref, *head, *tail;
2467
2468   mio_lparen ();
2469
2470   if (iomode == IO_OUTPUT)
2471     {
2472       for (ref = *rp; ref; ref = ref->next)
2473         mio_ref (&ref);
2474     }
2475   else
2476     {
2477       head = tail = NULL;
2478
2479       while (peek_atom () != ATOM_RPAREN)
2480         {
2481           if (head == NULL)
2482             head = tail = gfc_get_ref ();
2483           else
2484             {
2485               tail->next = gfc_get_ref ();
2486               tail = tail->next;
2487             }
2488
2489           mio_ref (&tail);
2490         }
2491
2492       *rp = head;
2493     }
2494
2495   mio_rparen ();
2496 }
2497
2498
2499 /* Read and write an integer value.  */
2500
2501 static void
2502 mio_gmp_integer (mpz_t *integer)
2503 {
2504   char *p;
2505
2506   if (iomode == IO_INPUT)
2507     {
2508       if (parse_atom () != ATOM_STRING)
2509         bad_module ("Expected integer string");
2510
2511       mpz_init (*integer);
2512       if (mpz_set_str (*integer, atom_string, 10))
2513         bad_module ("Error converting integer");
2514
2515       gfc_free (atom_string);
2516     }
2517   else
2518     {
2519       p = mpz_get_str (NULL, 10, *integer);
2520       write_atom (ATOM_STRING, p);
2521       gfc_free (p);
2522     }
2523 }
2524
2525
2526 static void
2527 mio_gmp_real (mpfr_t *real)
2528 {
2529   mp_exp_t exponent;
2530   char *p;
2531
2532   if (iomode == IO_INPUT)
2533     {
2534       if (parse_atom () != ATOM_STRING)
2535         bad_module ("Expected real string");
2536
2537       mpfr_init (*real);
2538       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2539       gfc_free (atom_string);
2540     }
2541   else
2542     {
2543       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2544
2545       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
2546         {
2547           write_atom (ATOM_STRING, p);
2548           gfc_free (p);
2549           return;
2550         }
2551
2552       atom_string = gfc_getmem (strlen (p) + 20);
2553
2554       sprintf (atom_string, "0.%s@%ld", p, exponent);
2555
2556       /* Fix negative numbers.  */
2557       if (atom_string[2] == '-')
2558         {
2559           atom_string[0] = '-';
2560           atom_string[1] = '0';
2561           atom_string[2] = '.';
2562         }
2563
2564       write_atom (ATOM_STRING, atom_string);
2565
2566       gfc_free (atom_string);
2567       gfc_free (p);
2568     }
2569 }
2570
2571
2572 /* Save and restore the shape of an array constructor.  */
2573
2574 static void
2575 mio_shape (mpz_t **pshape, int rank)
2576 {
2577   mpz_t *shape;
2578   atom_type t;
2579   int n;
2580
2581   /* A NULL shape is represented by ().  */
2582   mio_lparen ();
2583
2584   if (iomode == IO_OUTPUT)
2585     {
2586       shape = *pshape;
2587       if (!shape)
2588         {
2589           mio_rparen ();
2590           return;
2591         }
2592     }
2593   else
2594     {
2595       t = peek_atom ();
2596       if (t == ATOM_RPAREN)
2597         {
2598           *pshape = NULL;
2599           mio_rparen ();
2600           return;
2601         }
2602
2603       shape = gfc_get_shape (rank);
2604       *pshape = shape;
2605     }
2606
2607   for (n = 0; n < rank; n++)
2608     mio_gmp_integer (&shape[n]);
2609
2610   mio_rparen ();
2611 }
2612
2613
2614 static const mstring expr_types[] = {
2615     minit ("OP", EXPR_OP),
2616     minit ("FUNCTION", EXPR_FUNCTION),
2617     minit ("CONSTANT", EXPR_CONSTANT),
2618     minit ("VARIABLE", EXPR_VARIABLE),
2619     minit ("SUBSTRING", EXPR_SUBSTRING),
2620     minit ("STRUCTURE", EXPR_STRUCTURE),
2621     minit ("ARRAY", EXPR_ARRAY),
2622     minit ("NULL", EXPR_NULL),
2623     minit (NULL, -1)
2624 };
2625
2626 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2627    generic operators, not in expressions.  INTRINSIC_USER is also
2628    replaced by the correct function name by the time we see it.  */
2629
2630 static const mstring intrinsics[] =
2631 {
2632     minit ("UPLUS", INTRINSIC_UPLUS),
2633     minit ("UMINUS", INTRINSIC_UMINUS),
2634     minit ("PLUS", INTRINSIC_PLUS),
2635     minit ("MINUS", INTRINSIC_MINUS),
2636     minit ("TIMES", INTRINSIC_TIMES),
2637     minit ("DIVIDE", INTRINSIC_DIVIDE),
2638     minit ("POWER", INTRINSIC_POWER),
2639     minit ("CONCAT", INTRINSIC_CONCAT),
2640     minit ("AND", INTRINSIC_AND),
2641     minit ("OR", INTRINSIC_OR),
2642     minit ("EQV", INTRINSIC_EQV),
2643     minit ("NEQV", INTRINSIC_NEQV),
2644     minit ("EQ_SIGN", INTRINSIC_EQ),
2645     minit ("EQ", INTRINSIC_EQ_OS),
2646     minit ("NE_SIGN", INTRINSIC_NE),
2647     minit ("NE", INTRINSIC_NE_OS),
2648     minit ("GT_SIGN", INTRINSIC_GT),
2649     minit ("GT", INTRINSIC_GT_OS),
2650     minit ("GE_SIGN", INTRINSIC_GE),
2651     minit ("GE", INTRINSIC_GE_OS),
2652     minit ("LT_SIGN", INTRINSIC_LT),
2653     minit ("LT", INTRINSIC_LT_OS),
2654     minit ("LE_SIGN", INTRINSIC_LE),
2655     minit ("LE", INTRINSIC_LE_OS),
2656     minit ("NOT", INTRINSIC_NOT),
2657     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2658     minit (NULL, -1)
2659 };
2660
2661
2662 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
2663
2664 static void
2665 fix_mio_expr (gfc_expr *e)
2666 {
2667   gfc_symtree *ns_st = NULL;
2668   const char *fname;
2669
2670   if (iomode != IO_OUTPUT)
2671     return;
2672
2673   if (e->symtree)
2674     {
2675       /* If this is a symtree for a symbol that came from a contained module
2676          namespace, it has a unique name and we should look in the current
2677          namespace to see if the required, non-contained symbol is available
2678          yet. If so, the latter should be written.  */
2679       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2680         ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2681                                   e->symtree->n.sym->name);
2682
2683       /* On the other hand, if the existing symbol is the module name or the
2684          new symbol is a dummy argument, do not do the promotion.  */
2685       if (ns_st && ns_st->n.sym
2686           && ns_st->n.sym->attr.flavor != FL_MODULE
2687           && !e->symtree->n.sym->attr.dummy)
2688         e->symtree = ns_st;
2689     }
2690   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2691     {
2692       /* In some circumstances, a function used in an initialization
2693          expression, in one use associated module, can fail to be
2694          coupled to its symtree when used in a specification
2695          expression in another module.  */
2696       fname = e->value.function.esym ? e->value.function.esym->name
2697                                      : e->value.function.isym->name;
2698       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2699     }
2700 }
2701
2702
2703 /* Read and write expressions.  The form "()" is allowed to indicate a
2704    NULL expression.  */
2705
2706 static void
2707 mio_expr (gfc_expr **ep)
2708 {
2709   gfc_expr *e;
2710   atom_type t;
2711   int flag;
2712
2713   mio_lparen ();
2714
2715   if (iomode == IO_OUTPUT)
2716     {
2717       if (*ep == NULL)
2718         {
2719           mio_rparen ();
2720           return;
2721         }
2722
2723       e = *ep;
2724       MIO_NAME (expr_t) (e->expr_type, expr_types);
2725     }
2726   else
2727     {
2728       t = parse_atom ();
2729       if (t == ATOM_RPAREN)
2730         {
2731           *ep = NULL;
2732           return;
2733         }
2734
2735       if (t != ATOM_NAME)
2736         bad_module ("Expected expression type");
2737
2738       e = *ep = gfc_get_expr ();
2739       e->where = gfc_current_locus;
2740       e->expr_type = (expr_t) find_enum (expr_types);
2741     }
2742
2743   mio_typespec (&e->ts);
2744   mio_integer (&e->rank);
2745
2746   fix_mio_expr (e);
2747
2748   switch (e->expr_type)
2749     {
2750     case EXPR_OP:
2751       e->value.op.operator
2752         = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2753
2754       switch (e->value.op.operator)
2755         {
2756         case INTRINSIC_UPLUS:
2757         case INTRINSIC_UMINUS:
2758         case INTRINSIC_NOT:
2759         case INTRINSIC_PARENTHESES:
2760           mio_expr (&e->value.op.op1);
2761           break;
2762
2763         case INTRINSIC_PLUS:
2764         case INTRINSIC_MINUS:
2765         case INTRINSIC_TIMES:
2766         case INTRINSIC_DIVIDE:
2767         case INTRINSIC_POWER:
2768         case INTRINSIC_CONCAT:
2769         case INTRINSIC_AND:
2770         case INTRINSIC_OR:
2771         case INTRINSIC_EQV:
2772         case INTRINSIC_NEQV:
2773         case INTRINSIC_EQ:
2774         case INTRINSIC_EQ_OS:
2775         case INTRINSIC_NE:
2776         case INTRINSIC_NE_OS:
2777         case INTRINSIC_GT:
2778         case INTRINSIC_GT_OS:
2779         case INTRINSIC_GE:
2780         case INTRINSIC_GE_OS:
2781         case INTRINSIC_LT:
2782         case INTRINSIC_LT_OS:
2783         case INTRINSIC_LE:
2784         case INTRINSIC_LE_OS:
2785           mio_expr (&e->value.op.op1);
2786           mio_expr (&e->value.op.op2);
2787           break;
2788
2789         default:
2790           bad_module ("Bad operator");
2791         }
2792
2793       break;
2794
2795     case EXPR_FUNCTION:
2796       mio_symtree_ref (&e->symtree);
2797       mio_actual_arglist (&e->value.function.actual);
2798
2799       if (iomode == IO_OUTPUT)
2800         {
2801           e->value.function.name
2802             = mio_allocated_string (e->value.function.name);
2803           flag = e->value.function.esym != NULL;
2804           mio_integer (&flag);
2805           if (flag)
2806             mio_symbol_ref (&e->value.function.esym);
2807           else
2808             write_atom (ATOM_STRING, e->value.function.isym->name);
2809         }
2810       else
2811         {
2812           require_atom (ATOM_STRING);
2813           e->value.function.name = gfc_get_string (atom_string);
2814           gfc_free (atom_string);
2815
2816           mio_integer (&flag);
2817           if (flag)
2818             mio_symbol_ref (&e->value.function.esym);
2819           else
2820             {
2821               require_atom (ATOM_STRING);
2822               e->value.function.isym = gfc_find_function (atom_string);
2823               gfc_free (atom_string);
2824             }
2825         }
2826
2827       break;
2828
2829     case EXPR_VARIABLE:
2830       mio_symtree_ref (&e->symtree);
2831       mio_ref_list (&e->ref);
2832       break;
2833
2834     case EXPR_SUBSTRING:
2835       e->value.character.string
2836         = CONST_CAST (char *, mio_allocated_string (e->value.character.string));
2837       mio_ref_list (&e->ref);
2838       break;
2839
2840     case EXPR_STRUCTURE:
2841     case EXPR_ARRAY:
2842       mio_constructor (&e->value.constructor);
2843       mio_shape (&e->shape, e->rank);
2844       break;
2845
2846     case EXPR_CONSTANT:
2847       switch (e->ts.type)
2848         {
2849         case BT_INTEGER:
2850           mio_gmp_integer (&e->value.integer);
2851           break;
2852
2853         case BT_REAL:
2854           gfc_set_model_kind (e->ts.kind);
2855           mio_gmp_real (&e->value.real);
2856           break;
2857
2858         case BT_COMPLEX:
2859           gfc_set_model_kind (e->ts.kind);
2860           mio_gmp_real (&e->value.complex.r);
2861           mio_gmp_real (&e->value.complex.i);
2862           break;
2863
2864         case BT_LOGICAL:
2865           mio_integer (&e->value.logical);
2866           break;
2867
2868         case BT_CHARACTER:
2869           mio_integer (&e->value.character.length);
2870           e->value.character.string
2871             = CONST_CAST (char *, mio_allocated_string (e->value.character.string));
2872           break;
2873
2874         default:
2875           bad_module ("Bad type in constant expression");
2876         }
2877
2878       break;
2879
2880     case EXPR_NULL:
2881       break;
2882     }
2883
2884   mio_rparen ();
2885 }
2886
2887
2888 /* Read and write namelists.  */
2889
2890 static void
2891 mio_namelist (gfc_symbol *sym)
2892 {
2893   gfc_namelist *n, *m;
2894   const char *check_name;
2895
2896   mio_lparen ();
2897
2898   if (iomode == IO_OUTPUT)
2899     {
2900       for (n = sym->namelist; n; n = n->next)
2901         mio_symbol_ref (&n->sym);
2902     }
2903   else
2904     {
2905       /* This departure from the standard is flagged as an error.
2906          It does, in fact, work correctly. TODO: Allow it
2907          conditionally?  */
2908       if (sym->attr.flavor == FL_NAMELIST)
2909         {
2910           check_name = find_use_name (sym->name, false);
2911           if (check_name && strcmp (check_name, sym->name) != 0)
2912             gfc_error ("Namelist %s cannot be renamed by USE "
2913                        "association to %s", sym->name, check_name);
2914         }
2915
2916       m = NULL;
2917       while (peek_atom () != ATOM_RPAREN)
2918         {
2919           n = gfc_get_namelist ();
2920           mio_symbol_ref (&n->sym);
2921
2922           if (sym->namelist == NULL)
2923             sym->namelist = n;
2924           else
2925             m->next = n;
2926
2927           m = n;
2928         }
2929       sym->namelist_tail = m;
2930     }
2931
2932   mio_rparen ();
2933 }
2934
2935
2936 /* Save/restore lists of gfc_interface stuctures.  When loading an
2937    interface, we are really appending to the existing list of
2938    interfaces.  Checking for duplicate and ambiguous interfaces has to
2939    be done later when all symbols have been loaded.  */
2940
2941 pointer_info *
2942 mio_interface_rest (gfc_interface **ip)
2943 {
2944   gfc_interface *tail, *p;
2945   pointer_info *pi = NULL;
2946
2947   if (iomode == IO_OUTPUT)
2948     {
2949       if (ip != NULL)
2950         for (p = *ip; p; p = p->next)
2951           mio_symbol_ref (&p->sym);
2952     }
2953   else
2954     {
2955       if (*ip == NULL)
2956         tail = NULL;
2957       else
2958         {
2959           tail = *ip;
2960           while (tail->next)
2961             tail = tail->next;
2962         }
2963
2964       for (;;)
2965         {
2966           if (peek_atom () == ATOM_RPAREN)
2967             break;
2968
2969           p = gfc_get_interface ();
2970           p->where = gfc_current_locus;
2971           pi = mio_symbol_ref (&p->sym);
2972
2973           if (tail == NULL)
2974             *ip = p;
2975           else
2976             tail->next = p;
2977
2978           tail = p;
2979         }
2980     }
2981
2982   mio_rparen ();
2983   return pi;
2984 }
2985
2986
2987 /* Save/restore a nameless operator interface.  */
2988
2989 static void
2990 mio_interface (gfc_interface **ip)
2991 {
2992   mio_lparen ();
2993   mio_interface_rest (ip);
2994 }
2995
2996
2997 /* Save/restore a named operator interface.  */
2998
2999 static void
3000 mio_symbol_interface (const char **name, const char **module,
3001                       gfc_interface **ip)
3002 {
3003   mio_lparen ();
3004   mio_pool_string (name);
3005   mio_pool_string (module);
3006   mio_interface_rest (ip);
3007 }
3008
3009
3010 static void
3011 mio_namespace_ref (gfc_namespace **nsp)
3012 {
3013   gfc_namespace *ns;
3014   pointer_info *p;
3015
3016   p = mio_pointer_ref (nsp);
3017
3018   if (p->type == P_UNKNOWN)
3019     p->type = P_NAMESPACE;
3020
3021   if (iomode == IO_INPUT && p->integer != 0)
3022     {
3023       ns = (gfc_namespace *) p->u.pointer;
3024       if (ns == NULL)
3025         {
3026           ns = gfc_get_namespace (NULL, 0);
3027           associate_integer_pointer (p, ns);
3028         }
3029       else
3030         ns->refs++;
3031     }
3032 }
3033
3034
3035 /* Unlike most other routines, the address of the symbol node is already
3036    fixed on input and the name/module has already been filled in.  */
3037
3038 static void
3039 mio_symbol (gfc_symbol *sym)
3040 {
3041   int intmod = INTMOD_NONE;
3042
3043   gfc_formal_arglist *formal;
3044
3045   mio_lparen ();
3046
3047   mio_symbol_attribute (&sym->attr);
3048   mio_typespec (&sym->ts);
3049
3050   /* Contained procedures don't have formal namespaces.  Instead we output the
3051      procedure namespace.  The will contain the formal arguments.  */
3052   if (iomode == IO_OUTPUT)
3053     {
3054       formal = sym->formal;
3055       while (formal && !formal->sym)
3056         formal = formal->next;
3057
3058       if (formal)
3059         mio_namespace_ref (&formal->sym->ns);
3060       else
3061         mio_namespace_ref (&sym->formal_ns);
3062     }
3063   else
3064     {
3065       mio_namespace_ref (&sym->formal_ns);
3066       if (sym->formal_ns)
3067         {
3068           sym->formal_ns->proc_name = sym;
3069           sym->refs++;
3070         }
3071     }
3072
3073   /* Save/restore common block links.  */
3074   mio_symbol_ref (&sym->common_next);
3075
3076   mio_formal_arglist (sym);
3077
3078   if (sym->attr.flavor == FL_PARAMETER)
3079     mio_expr (&sym->value);
3080
3081   mio_array_spec (&sym->as);
3082
3083   mio_symbol_ref (&sym->result);
3084
3085   if (sym->attr.cray_pointee)
3086     mio_symbol_ref (&sym->cp_pointer);
3087
3088   /* Note that components are always saved, even if they are supposed
3089      to be private.  Component access is checked during searching.  */
3090
3091   mio_component_list (&sym->components);
3092
3093   if (sym->components != NULL)
3094     sym->component_access
3095       = MIO_NAME (gfc_access) (sym->component_access, access_types);
3096
3097   mio_namelist (sym);
3098
3099   /* Add the fields that say whether this is from an intrinsic module,
3100      and if so, what symbol it is within the module.  */
3101 /*   mio_integer (&(sym->from_intmod)); */
3102   if (iomode == IO_OUTPUT)
3103     {
3104       intmod = sym->from_intmod;
3105       mio_integer (&intmod);
3106     }
3107   else
3108     {
3109       mio_integer (&intmod);
3110       sym->from_intmod = intmod;
3111     }
3112
3113   mio_integer (&(sym->intmod_sym_id));
3114
3115   mio_rparen ();
3116 }
3117
3118
3119 /************************* Top level subroutines *************************/
3120
3121 /* Given a root symtree node and a symbol, try to find a symtree that
3122    references the symbol that is not a unique name.  */
3123
3124 static gfc_symtree *
3125 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3126 {
3127   gfc_symtree *s = NULL;
3128
3129   if (st == NULL)
3130     return s;
3131
3132   s = find_symtree_for_symbol (st->right, sym);
3133   if (s != NULL)
3134     return s;
3135   s = find_symtree_for_symbol (st->left, sym);
3136   if (s != NULL)
3137     return s;
3138
3139   if (st->n.sym == sym && !check_unique_name (st->name))
3140     return st;
3141
3142   return s;
3143 }
3144
3145
3146 /* A recursive function to look for a speficic symbol by name and by
3147    module.  Whilst several symtrees might point to one symbol, its
3148    is sufficient for the purposes here than one exist.  Note that
3149    generic interfaces are distinguished as are symbols that have been
3150    renamed in another module.  */
3151 static gfc_symtree *
3152 find_symbol (gfc_symtree *st, const char *name,
3153              const char *module, int generic)
3154 {
3155   int c;
3156   gfc_symtree *retval, *s;
3157
3158   if (st == NULL || st->n.sym == NULL)
3159     return NULL;
3160
3161   c = strcmp (name, st->n.sym->name);
3162   if (c == 0 && st->n.sym->module
3163              && strcmp (module, st->n.sym->module) == 0
3164              && !check_unique_name (st->name))
3165     {
3166       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3167
3168       /* Detect symbols that are renamed by use association in another
3169          module by the absence of a symtree and null attr.use_rename,
3170          since the latter is not transmitted in the module file.  */
3171       if (((!generic && !st->n.sym->attr.generic)
3172                 || (generic && st->n.sym->attr.generic))
3173             && !(s == NULL && !st->n.sym->attr.use_rename))
3174         return st;
3175     }
3176
3177   retval = find_symbol (st->left, name, module, generic);
3178
3179   if (retval == NULL)
3180     retval = find_symbol (st->right, name, module, generic);
3181
3182   return retval;
3183 }
3184
3185
3186 /* Skip a list between balanced left and right parens.  */
3187
3188 static void
3189 skip_list (void)
3190 {
3191   int level;
3192
3193   level = 0;
3194   do
3195     {
3196       switch (parse_atom ())
3197         {
3198         case ATOM_LPAREN:
3199           level++;
3200           break;
3201
3202         case ATOM_RPAREN:
3203           level--;
3204           break;
3205
3206         case ATOM_STRING:
3207           gfc_free (atom_string);
3208           break;
3209
3210         case ATOM_NAME:
3211         case ATOM_INTEGER:
3212           break;
3213         }
3214     }
3215   while (level > 0);
3216 }
3217
3218
3219 /* Load operator interfaces from the module.  Interfaces are unusual
3220    in that they attach themselves to existing symbols.  */
3221
3222 static void
3223 load_operator_interfaces (void)
3224 {
3225   const char *p;
3226   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3227   gfc_user_op *uop;
3228   pointer_info *pi = NULL;
3229   int n, i;
3230
3231   mio_lparen ();
3232
3233   while (peek_atom () != ATOM_RPAREN)
3234     {
3235       mio_lparen ();
3236
3237       mio_internal_string (name);
3238       mio_internal_string (module);
3239
3240       n = number_use_names (name, true);
3241       n = n ? n : 1;
3242
3243       for (i = 1; i <= n; i++)
3244         {
3245           /* Decide if we need to load this one or not.  */
3246           p = find_use_name_n (name, &i, true);
3247
3248           if (p == NULL)
3249             {
3250               while (parse_atom () != ATOM_RPAREN);
3251               continue;
3252             }
3253
3254           if (i == 1)
3255             {
3256               uop = gfc_get_uop (p);
3257               pi = mio_interface_rest (&uop->operator);
3258             }
3259           else
3260             {
3261               if (gfc_find_uop (p, NULL))
3262                 continue;
3263               uop = gfc_get_uop (p);
3264               uop->operator = gfc_get_interface ();
3265               uop->operator->where = gfc_current_locus;
3266               add_fixup (pi->integer, &uop->operator->sym);
3267             }
3268         }
3269     }
3270
3271   mio_rparen ();
3272 }
3273
3274
3275 /* Load interfaces from the module.  Interfaces are unusual in that
3276    they attach themselves to existing symbols.  */
3277
3278 static void
3279 load_generic_interfaces (void)
3280 {
3281   const char *p;
3282   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3283   gfc_symbol *sym;
3284   gfc_interface *generic = NULL;
3285   int n, i, renamed;
3286
3287   mio_lparen ();
3288
3289   while (peek_atom () != ATOM_RPAREN)
3290     {
3291       mio_lparen ();
3292
3293       mio_internal_string (name);
3294       mio_internal_string (module);
3295
3296       n = number_use_names (name, false);
3297       renamed = n ? 1 : 0;
3298       n = n ? n : 1;
3299
3300       for (i = 1; i <= n; i++)
3301         {
3302           gfc_symtree *st;
3303           /* Decide if we need to load this one or not.  */
3304           p = find_use_name_n (name, &i, false);
3305
3306           st = find_symbol (gfc_current_ns->sym_root,
3307                             name, module_name, 1);
3308
3309           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3310             {
3311               /* Skip the specific names for these cases.  */
3312               while (i == 1 && parse_atom () != ATOM_RPAREN);
3313
3314               continue;
3315             }
3316
3317           /* If the symbol exists already and is being USEd without being
3318              in an ONLY clause, do not load a new symtree(11.3.2).  */
3319           if (!only_flag && st)
3320             sym = st->n.sym;
3321
3322           if (!sym)
3323             {
3324               /* Make the symbol inaccessible if it has been added by a USE
3325                  statement without an ONLY(11.3.2).  */
3326               if (st && only_flag
3327                      && !st->n.sym->attr.use_only
3328                      && !st->n.sym->attr.use_rename
3329                      && strcmp (st->n.sym->module, module_name) == 0)
3330                 {
3331                   sym = st->n.sym;
3332                   gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3333                   st = gfc_get_unique_symtree (gfc_current_ns);
3334                   st->n.sym = sym;
3335                   sym = NULL;
3336                 }
3337               else if (st)
3338                 {
3339                   sym = st->n.sym;
3340                   if (strcmp (st->name, p) != 0)
3341                     {
3342                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
3343                       st->n.sym = sym;
3344                       sym->refs++;
3345                     }
3346                 }
3347
3348               /* Since we haven't found a valid generic interface, we had
3349                  better make one.  */
3350               if (!sym)
3351                 {
3352                   gfc_get_symbol (p, NULL, &sym);
3353                   sym->name = gfc_get_string (name);
3354                   sym->module = gfc_get_string (module_name);
3355                   sym->attr.flavor = FL_PROCEDURE;
3356                   sym->attr.generic = 1;
3357                   sym->attr.use_assoc = 1;
3358                 }
3359             }
3360           else
3361             {
3362               /* Unless sym is a generic interface, this reference
3363                  is ambiguous.  */
3364               if (st == NULL)
3365                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3366
3367               sym = st->n.sym;
3368
3369               if (st && !sym->attr.generic
3370                      && sym->module
3371                      && strcmp(module, sym->module))
3372                 st->ambiguous = 1;
3373             }
3374
3375           sym->attr.use_only = only_flag;
3376           sym->attr.use_rename = renamed;
3377
3378           if (i == 1)
3379             {
3380               mio_interface_rest (&sym->generic);
3381               generic = sym->generic;
3382             }
3383           else if (!sym->generic)
3384             {
3385               sym->generic = generic;
3386               sym->attr.generic_copy = 1;
3387             }
3388         }
3389     }
3390
3391   mio_rparen ();
3392 }
3393
3394
3395 /* Load common blocks.  */
3396
3397 static void
3398 load_commons (void)
3399 {
3400   char name[GFC_MAX_SYMBOL_LEN + 1];
3401   gfc_common_head *p;
3402
3403   mio_lparen ();
3404
3405   while (peek_atom () != ATOM_RPAREN)
3406     {
3407       int flags;
3408       mio_lparen ();
3409       mio_internal_string (name);
3410
3411       p = gfc_get_common (name, 1);
3412
3413       mio_symbol_ref (&p->head);
3414       mio_integer (&flags);
3415       if (flags & 1)
3416         p->saved = 1;
3417       if (flags & 2)
3418         p->threadprivate = 1;
3419       p->use_assoc = 1;
3420
3421       /* Get whether this was a bind(c) common or not.  */
3422       mio_integer (&p->is_bind_c);
3423       /* Get the binding label.  */
3424       mio_internal_string (p->binding_label);
3425
3426       mio_rparen ();
3427     }
3428
3429   mio_rparen ();
3430 }
3431
3432
3433 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
3434    so that unused variables are not loaded and so that the expression can
3435    be safely freed.  */
3436
3437 static void
3438 load_equiv (void)
3439 {
3440   gfc_equiv *head, *tail, *end, *eq;
3441   bool unused;
3442
3443   mio_lparen ();
3444   in_load_equiv = true;
3445
3446   end = gfc_current_ns->equiv;
3447   while (end != NULL && end->next != NULL)
3448     end = end->next;
3449
3450   while (peek_atom () != ATOM_RPAREN) {
3451     mio_lparen ();
3452     head = tail = NULL;
3453
3454     while(peek_atom () != ATOM_RPAREN)
3455       {
3456         if (head == NULL)
3457           head = tail = gfc_get_equiv ();
3458         else
3459           {
3460             tail->eq = gfc_get_equiv ();
3461             tail = tail->eq;
3462           }
3463
3464         mio_pool_string (&tail->module);
3465         mio_expr (&tail->expr);
3466       }
3467
3468     /* Unused equivalence members have a unique name.  */
3469     unused = true;
3470     for (eq = head; eq; eq = eq->eq)
3471       {
3472         if (!check_unique_name (eq->expr->symtree->name))
3473           {
3474             unused = false;
3475             break;
3476           }
3477       }
3478
3479     if (unused)
3480       {
3481         for (eq = head; eq; eq = head)
3482           {
3483             head = eq->eq;
3484             gfc_free_expr (eq->expr);
3485             gfc_free (eq);
3486           }
3487       }
3488
3489     if (end == NULL)
3490       gfc_current_ns->equiv = head;
3491     else
3492       end->next = head;
3493
3494     if (head != NULL)
3495       end = head;
3496
3497     mio_rparen ();
3498   }
3499
3500   mio_rparen ();
3501   in_load_equiv = false;
3502 }
3503
3504
3505 /* Recursive function to traverse the pointer_info tree and load a
3506    needed symbol.  We return nonzero if we load a symbol and stop the
3507    traversal, because the act of loading can alter the tree.  */
3508
3509 static int
3510 load_needed (pointer_info *p)
3511 {
3512   gfc_namespace *ns;
3513   pointer_info *q;
3514   gfc_symbol *sym;
3515   int rv;
3516
3517   rv = 0;
3518   if (p == NULL)
3519     return rv;
3520
3521   rv |= load_needed (p->left);
3522   rv |= load_needed (p->right);
3523
3524   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3525     return rv;
3526
3527   p->u.rsym.state = USED;
3528
3529   set_module_locus (&p->u.rsym.where);
3530
3531   sym = p->u.rsym.sym;
3532   if (sym == NULL)
3533     {
3534       q = get_integer (p->u.rsym.ns);
3535
3536       ns = (gfc_namespace *) q->u.pointer;
3537       if (ns == NULL)
3538         {
3539           /* Create an interface namespace if necessary.  These are
3540              the namespaces that hold the formal parameters of module
3541              procedures.  */
3542
3543           ns = gfc_get_namespace (NULL, 0);
3544           associate_integer_pointer (q, ns);
3545         }
3546
3547       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
3548          doesn't go pear-shaped if the symbol is used.  */
3549       if (!ns->proc_name)
3550         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
3551                                  1, &ns->proc_name);
3552
3553       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3554       sym->module = gfc_get_string (p->u.rsym.module);
3555       strcpy (sym->binding_label, p->u.rsym.binding_label);
3556
3557       associate_integer_pointer (p, sym);
3558     }
3559
3560   mio_symbol (sym);
3561   sym->attr.use_assoc = 1;
3562   if (only_flag)
3563     sym->attr.use_only = 1;
3564   if (p->u.rsym.renamed)
3565     sym->attr.use_rename = 1;
3566
3567   return 1;
3568 }
3569
3570
3571 /* Recursive function for cleaning up things after a module has been read.  */
3572
3573 static void
3574 read_cleanup (pointer_info *p)
3575 {
3576   gfc_symtree *st;
3577   pointer_info *q;
3578
3579   if (p == NULL)
3580     return;
3581
3582   read_cleanup (p->left);
3583   read_cleanup (p->right);
3584
3585   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3586     {
3587       /* Add hidden symbols to the symtree.  */
3588       q = get_integer (p->u.rsym.ns);
3589       st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
3590
3591       st->n.sym = p->u.rsym.sym;
3592       st->n.sym->refs++;
3593
3594       /* Fixup any symtree references.  */
3595       p->u.rsym.symtree = st;
3596       resolve_fixups (p->u.rsym.stfixup, st);
3597       p->u.rsym.stfixup = NULL;
3598     }
3599
3600   /* Free unused symbols.  */
3601   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3602     gfc_free_symbol (p->u.rsym.sym);
3603 }
3604
3605
3606 /* Read a module file.  */
3607
3608 static void
3609 read_module (void)
3610 {
3611   module_locus operator_interfaces, user_operators;
3612   const char *p;
3613   char name[GFC_MAX_SYMBOL_LEN + 1];
3614   gfc_intrinsic_op i;
3615   int ambiguous, j, nuse, symbol;
3616   pointer_info *info, *q;
3617   gfc_use_rename *u;
3618   gfc_symtree *st;
3619   gfc_symbol *sym;
3620
3621   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
3622   skip_list ();
3623
3624   get_module_locus (&user_operators);
3625   skip_list ();
3626   skip_list ();
3627
3628   /* Skip commons and equivalences for now.  */
3629   skip_list ();
3630   skip_list ();
3631
3632   mio_lparen ();
3633
3634   /* Create the fixup nodes for all the symbols.  */
3635
3636   while (peek_atom () != ATOM_RPAREN)
3637     {
3638       require_atom (ATOM_INTEGER);
3639       info = get_integer (atom_int);
3640
3641       info->type = P_SYMBOL;
3642       info->u.rsym.state = UNUSED;
3643
3644       mio_internal_string (info->u.rsym.true_name);
3645       mio_internal_string (info->u.rsym.module);
3646       mio_internal_string (info->u.rsym.binding_label);
3647
3648
3649       require_atom (ATOM_INTEGER);
3650       info->u.rsym.ns = atom_int;
3651
3652       get_module_locus (&info->u.rsym.where);
3653       skip_list ();
3654
3655       /* See if the symbol has already been loaded by a previous module.
3656          If so, we reference the existing symbol and prevent it from
3657          being loaded again.  This should not happen if the symbol being
3658          read is an index for an assumed shape dummy array (ns != 1).  */
3659
3660       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3661
3662       if (sym == NULL
3663           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3664         continue;
3665
3666       info->u.rsym.state = USED;
3667       info->u.rsym.sym = sym;
3668
3669       /* Some symbols do not have a namespace (eg. formal arguments),
3670          so the automatic "unique symtree" mechanism must be suppressed
3671          by marking them as referenced.  */
3672       q = get_integer (info->u.rsym.ns);
3673       if (q->u.pointer == NULL)
3674         {
3675           info->u.rsym.referenced = 1;
3676           continue;
3677         }
3678
3679       /* If possible recycle the symtree that references the symbol.
3680          If a symtree is not found and the module does not import one,
3681          a unique-name symtree is found by read_cleanup.  */
3682       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3683       if (st != NULL)
3684         {
3685           info->u.rsym.symtree = st;
3686           info->u.rsym.referenced = 1;
3687         }
3688     }
3689
3690   mio_rparen ();
3691
3692   /* Parse the symtree lists.  This lets us mark which symbols need to
3693      be loaded.  Renaming is also done at this point by replacing the
3694      symtree name.  */
3695
3696   mio_lparen ();
3697
3698   while (peek_atom () != ATOM_RPAREN)
3699     {
3700       mio_internal_string (name);
3701       mio_integer (&ambiguous);
3702       mio_integer (&symbol);
3703
3704       info = get_integer (symbol);
3705
3706       /* See how many use names there are.  If none, go through the start
3707          of the loop at least once.  */
3708       nuse = number_use_names (name, false);
3709       info->u.rsym.renamed = nuse ? 1 : 0;
3710
3711       if (nuse == 0)
3712         nuse = 1;
3713
3714       for (j = 1; j <= nuse; j++)
3715         {
3716           /* Get the jth local name for this symbol.  */
3717           p = find_use_name_n (name, &j, false);
3718
3719           if (p == NULL && strcmp (name, module_name) == 0)
3720             p = name;
3721
3722           /* Skip symtree nodes not in an ONLY clause, unless there
3723              is an existing symtree loaded from another USE statement.  */
3724           if (p == NULL)
3725             {
3726               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3727               if (st != NULL)
3728                 info->u.rsym.symtree = st;
3729               continue;
3730             }
3731
3732           /* If a symbol of the same name and module exists already,
3733              this symbol, which is not in an ONLY clause, must not be
3734              added to the namespace(11.3.2).  Note that find_symbol
3735              only returns the first occurrence that it finds.  */
3736           if (!only_flag && !info->u.rsym.renamed
3737                 && strcmp (name, module_name) != 0
3738                 && find_symbol (gfc_current_ns->sym_root, name,
3739                                 module_name, 0))
3740             continue;
3741
3742           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3743
3744           if (st != NULL)
3745             {
3746               /* Check for ambiguous symbols.  */
3747               if (st->n.sym != info->u.rsym.sym)
3748                 st->ambiguous = 1;
3749               info->u.rsym.symtree = st;
3750             }
3751           else
3752             {
3753               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3754
3755               /* Delete the symtree if the symbol has been added by a USE
3756                  statement without an ONLY(11.3.2). Remember that the rsym
3757                  will be the same as the symbol found in the symtree, for
3758                  this case.*/
3759               if (st && (only_flag || info->u.rsym.renamed)
3760                      && !st->n.sym->attr.use_only
3761                      && !st->n.sym->attr.use_rename
3762                      && info->u.rsym.sym == st->n.sym)
3763                 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3764
3765               /* Create a symtree node in the current namespace for this
3766                  symbol.  */
3767               st = check_unique_name (p)
3768                    ? gfc_get_unique_symtree (gfc_current_ns)
3769                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3770               st->ambiguous = ambiguous;
3771
3772               sym = info->u.rsym.sym;
3773
3774               /* Create a symbol node if it doesn't already exist.  */
3775               if (sym == NULL)
3776                 {
3777                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3778                                                      gfc_current_ns);
3779                   sym = info->u.rsym.sym;
3780                   sym->module = gfc_get_string (info->u.rsym.module);
3781
3782                   /* TODO: hmm, can we test this?  Do we know it will be
3783                      initialized to zeros?  */
3784                   if (info->u.rsym.binding_label[0] != '\0')
3785                     strcpy (sym->binding_label, info->u.rsym.binding_label);
3786                 }
3787
3788               st->n.sym = sym;
3789               st->n.sym->refs++;
3790
3791               if (strcmp (name, p) != 0)
3792                 sym->attr.use_rename = 1;
3793
3794               /* Store the symtree pointing to this symbol.  */
3795               info->u.rsym.symtree = st;
3796
3797               if (info->u.rsym.state == UNUSED)
3798                 info->u.rsym.state = NEEDED;
3799               info->u.rsym.referenced = 1;
3800             }
3801         }
3802     }
3803
3804   mio_rparen ();
3805
3806   /* Load intrinsic operator interfaces.  */
3807   set_module_locus (&operator_interfaces);
3808   mio_lparen ();
3809
3810   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3811     {
3812       if (i == INTRINSIC_USER)
3813         continue;
3814
3815       if (only_flag)
3816         {
3817           u = find_use_operator (i);
3818
3819           if (u == NULL)
3820             {
3821               skip_list ();
3822               continue;
3823             }
3824
3825           u->found = 1;
3826         }
3827
3828       mio_interface (&gfc_current_ns->operator[i]);
3829     }
3830
3831   mio_rparen ();
3832
3833   /* Load generic and user operator interfaces.  These must follow the
3834      loading of symtree because otherwise symbols can be marked as
3835      ambiguous.  */
3836
3837   set_module_locus (&user_operators);
3838
3839   load_operator_interfaces ();
3840   load_generic_interfaces ();
3841
3842   load_commons ();
3843   load_equiv ();
3844
3845   /* At this point, we read those symbols that are needed but haven't
3846      been loaded yet.  If one symbol requires another, the other gets
3847      marked as NEEDED if its previous state was UNUSED.  */
3848
3849   while (load_needed (pi_root));
3850
3851   /* Make sure all elements of the rename-list were found in the module.  */
3852
3853   for (u = gfc_rename_list; u; u = u->next)
3854     {
3855       if (u->found)
3856         continue;
3857
3858       if (u->operator == INTRINSIC_NONE)
3859         {
3860           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3861                      u->use_name, &u->where, module_name);
3862           continue;
3863         }
3864
3865       if (u->operator == INTRINSIC_USER)
3866         {
3867           gfc_error ("User operator '%s' referenced at %L not found "
3868                      "in module '%s'", u->use_name, &u->where, module_name);
3869           continue;
3870         }
3871
3872       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3873                  "in module '%s'", gfc_op2string (u->operator), &u->where,
3874                  module_name);
3875     }
3876
3877   gfc_check_interfaces (gfc_current_ns);
3878
3879   /* Clean up symbol nodes that were never loaded, create references
3880      to hidden symbols.  */
3881
3882   read_cleanup (pi_root);
3883 }
3884
3885
3886 /* Given an access type that is specific to an entity and the default
3887    access, return nonzero if the entity is publicly accessible.  If the
3888    element is declared as PUBLIC, then it is public; if declared
3889    PRIVATE, then private, and otherwise it is public unless the default
3890    access in this context has been declared PRIVATE.  */
3891
3892 bool
3893 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3894 {
3895   if (specific_access == ACCESS_PUBLIC)
3896     return TRUE;
3897   if (specific_access == ACCESS_PRIVATE)
3898     return FALSE;
3899
3900   if (gfc_option.flag_module_private)
3901     return default_access == ACCESS_PUBLIC;
3902   else
3903     return default_access != ACCESS_PRIVATE;
3904 }
3905
3906
3907 /* A structure to remember which commons we've already written.  */
3908
3909 struct written_common
3910 {
3911   BBT_HEADER(written_common);
3912   const char *name, *label;
3913 };
3914
3915 static struct written_common *written_commons = NULL;
3916
3917 /* Comparison function used for balancing the binary tree.  */
3918
3919 static int
3920 compare_written_commons (void *a1, void *b1)
3921 {
3922   const char *aname = ((struct written_common *) a1)->name;
3923   const char *alabel = ((struct written_common *) a1)->label;
3924   const char *bname = ((struct written_common *) b1)->name;
3925   const char *blabel = ((struct written_common *) b1)->label;
3926   int c = strcmp (aname, bname);
3927
3928   return (c != 0 ? c : strcmp (alabel, blabel));
3929 }
3930
3931 /* Free a list of written commons.  */
3932
3933 static void
3934 free_written_common (struct written_common *w)
3935 {
3936   if (!w)
3937     return;
3938
3939   if (w->left)
3940     free_written_common (w->left);
3941   if (w->right)
3942     free_written_common (w->right);
3943
3944   gfc_free (w);
3945 }
3946
3947 /* Write a common block to the module -- recursive helper function.  */
3948
3949 static void
3950 write_common_0 (gfc_symtree *st)
3951 {
3952   gfc_common_head *p;
3953   const char * name;
3954   int flags;
3955   const char *label;
3956   struct written_common *w;
3957   bool write_me = true;
3958
3959   if (st == NULL)
3960     return;
3961
3962   write_common_0 (st->left);
3963
3964   /* We will write out the binding label, or the name if no label given.  */
3965   name = st->n.common->name;
3966   p = st->n.common;
3967   label = p->is_bind_c ? p->binding_label : p->name;
3968
3969   /* Check if we've already output this common.  */
3970   w = written_commons;
3971   while (w)
3972     {
3973       int c = strcmp (name, w->name);
3974       c = (c != 0 ? c : strcmp (label, w->label));
3975       if (c == 0)
3976         write_me = false;
3977
3978       w = (c < 0) ? w->left : w->right;
3979     }
3980
3981   if (write_me)
3982     {
3983       /* Write the common to the module.  */
3984       mio_lparen ();
3985       mio_pool_string (&name);
3986
3987       mio_symbol_ref (&p->head);
3988       flags = p->saved ? 1 : 0;
3989       if (p->threadprivate)
3990         flags |= 2;
3991       mio_integer (&flags);
3992
3993       /* Write out whether the common block is bind(c) or not.  */
3994       mio_integer (&(p->is_bind_c));
3995
3996       mio_pool_string (&label);
3997       mio_rparen ();
3998
3999       /* Record that we have written this common.  */
4000       w = gfc_getmem (sizeof (struct written_common));
4001       w->name = p->name;
4002       w->label = label;
4003       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4004     }
4005
4006   write_common_0 (st->right);
4007 }
4008
4009
4010 /* Write a common, by initializing the list of written commons, calling
4011    the recursive function write_common_0() and cleaning up afterwards.  */
4012
4013 static void
4014 write_common (gfc_symtree *st)
4015 {
4016   written_commons = NULL;
4017   write_common_0 (st);
4018   free_written_common (written_commons);
4019   written_commons = NULL;
4020 }
4021
4022
4023 /* Write the blank common block to the module.  */
4024
4025 static void
4026 write_blank_common (void)
4027 {
4028   const char * name = BLANK_COMMON_NAME;
4029   int saved;
4030   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4031      this, but it hasn't been checked.  Just making it so for now.  */
4032   int is_bind_c = 0;
4033
4034   if (gfc_current_ns->blank_common.head == NULL)
4035     return;
4036
4037   mio_lparen ();
4038
4039   mio_pool_string (&name);
4040
4041   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4042   saved = gfc_current_ns->blank_common.saved;
4043   mio_integer (&saved);
4044
4045   /* Write out whether the common block is bind(c) or not.  */
4046   mio_integer (&is_bind_c);
4047
4048   /* Write out the binding label, which is BLANK_COMMON_NAME, though
4049      it doesn't matter because the label isn't used.  */
4050   mio_pool_string (&name);
4051
4052   mio_rparen ();
4053 }
4054
4055
4056 /* Write equivalences to the module.  */
4057
4058 static void
4059 write_equiv (void)
4060 {
4061   gfc_equiv *eq, *e;
4062   int num;
4063
4064   num = 0;
4065   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4066     {
4067       mio_lparen ();
4068
4069       for (e = eq; e; e = e->eq)
4070         {
4071           if (e->module == NULL)
4072             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4073           mio_allocated_string (e->module);
4074           mio_expr (&e->expr);
4075         }
4076
4077       num++;
4078       mio_rparen ();
4079     }
4080 }
4081
4082
4083 /* Write a symbol to the module.  */
4084
4085 static void
4086 write_symbol (int n, gfc_symbol *sym)
4087 {
4088   const char *label;
4089
4090   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4091     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4092
4093   mio_integer (&n);
4094   mio_pool_string (&sym->name);
4095
4096   mio_pool_string (&sym->module);
4097   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4098     {
4099       label = sym->binding_label;
4100       mio_pool_string (&label);
4101     }
4102   else
4103     mio_pool_string (&sym->name);
4104
4105   mio_pointer_ref (&sym->ns);
4106
4107   mio_symbol (sym);
4108   write_char ('\n');
4109 }
4110
4111
4112 /* Recursive traversal function to write the initial set of symbols to
4113    the module.  We check to see if the symbol should be written
4114    according to the access specification.  */
4115
4116 static void
4117 write_symbol0 (gfc_symtree *st)
4118 {
4119   gfc_symbol *sym;
4120   pointer_info *p;
4121   bool dont_write = false;
4122
4123   if (st == NULL)
4124     return;
4125
4126   write_symbol0 (st->left);
4127
4128   sym = st->n.sym;
4129   if (sym->module == NULL)
4130     sym->module = gfc_get_string (module_name);
4131
4132   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4133       && !sym->attr.subroutine && !sym->attr.function)
4134     dont_write = true;
4135
4136   if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
4137     dont_write = true;
4138
4139   if (!dont_write)
4140     {
4141       p = get_pointer (sym);
4142       if (p->type == P_UNKNOWN)
4143         p->type = P_SYMBOL;
4144
4145       if (p->u.wsym.state != WRITTEN)
4146         {
4147           write_symbol (p->integer, sym);
4148           p->u.wsym.state = WRITTEN;
4149         }
4150     }
4151
4152   write_symbol0 (st->right);
4153 }
4154
4155
4156 /* Recursive traversal function to write the secondary set of symbols
4157    to the module file.  These are symbols that were not public yet are
4158    needed by the public symbols or another dependent symbol.  The act
4159    of writing a symbol can modify the pointer_info tree, so we cease
4160    traversal if we find a symbol to write.  We return nonzero if a
4161    symbol was written and pass that information upwards.  */
4162
4163 static int
4164 write_symbol1 (pointer_info *p)
4165 {
4166   int result;
4167
4168   if (!p)
4169     return 0;
4170
4171   result = write_symbol1 (p->left);
4172
4173   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4174     {
4175       p->u.wsym.state = WRITTEN;
4176       write_symbol (p->integer, p->u.wsym.sym);
4177       result = 1;
4178     }
4179
4180   result |= write_symbol1 (p->right);
4181   return result;
4182 }
4183
4184
4185 /* Write operator interfaces associated with a symbol.  */
4186
4187 static void
4188 write_operator (gfc_user_op *uop)
4189 {
4190   static char nullstring[] = "";
4191   const char *p = nullstring;
4192
4193   if (uop->operator == NULL
4194       || !gfc_check_access (uop->access, uop->ns->default_access))
4195     return;
4196
4197   mio_symbol_interface (&uop->name, &p, &uop->operator);
4198 }
4199
4200
4201 /* Write generic interfaces from the namespace sym_root.  */
4202
4203 static void
4204 write_generic (gfc_symtree *st)
4205 {
4206   gfc_symbol *sym;
4207
4208   if (st == NULL)
4209     return;
4210
4211   write_generic (st->left);
4212   write_generic (st->right);
4213
4214   sym = st->n.sym;
4215   if (!sym || check_unique_name (st->name))
4216     return;
4217
4218   if (sym->generic == NULL
4219       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
4220     return;
4221
4222   if (sym->module == NULL)
4223     sym->module = gfc_get_string (module_name);
4224
4225   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
4226 }
4227
4228
4229 static void
4230 write_symtree (gfc_symtree *st)
4231 {
4232   gfc_symbol *sym;
4233   pointer_info *p;
4234
4235   sym = st->n.sym;
4236   if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4237       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4238           && !sym->attr.subroutine && !sym->attr.function))
4239     return;
4240
4241   if (check_unique_name (st->name))
4242     return;
4243
4244   p = find_pointer (sym);
4245   if (p == NULL)
4246     gfc_internal_error ("write_symtree(): Symbol not written");
4247
4248   mio_pool_string (&st->name);
4249   mio_integer (&st->ambiguous);
4250   mio_integer (&p->integer);
4251 }
4252
4253
4254 static void
4255 write_module (void)
4256 {
4257   gfc_intrinsic_op i;
4258
4259   /* Write the operator interfaces.  */
4260   mio_lparen ();
4261
4262   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4263     {
4264       if (i == INTRINSIC_USER)
4265         continue;
4266
4267       mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4268                                        gfc_current_ns->default_access)
4269                      ? &gfc_current_ns->operator[i] : NULL);
4270     }
4271
4272   mio_rparen ();
4273   write_char ('\n');
4274   write_char ('\n');
4275
4276   mio_lparen ();
4277   gfc_traverse_user_op (gfc_current_ns, write_operator);
4278   mio_rparen ();
4279   write_char ('\n');
4280   write_char ('\n');
4281
4282   mio_lparen ();
4283   write_generic (gfc_current_ns->sym_root);
4284   mio_rparen ();
4285   write_char ('\n');
4286   write_char ('\n');
4287
4288   mio_lparen ();
4289   write_blank_common ();
4290   write_common (gfc_current_ns->common_root);
4291   mio_rparen ();
4292   write_char ('\n');
4293   write_char ('\n');
4294
4295   mio_lparen ();
4296   write_equiv ();
4297   mio_rparen ();
4298   write_char ('\n');
4299   write_char ('\n');
4300
4301   /* Write symbol information.  First we traverse all symbols in the
4302      primary namespace, writing those that need to be written.
4303      Sometimes writing one symbol will cause another to need to be
4304      written.  A list of these symbols ends up on the write stack, and
4305      we end by popping the bottom of the stack and writing the symbol
4306      until the stack is empty.  */
4307
4308   mio_lparen ();
4309
4310   write_symbol0 (gfc_current_ns->sym_root);
4311   while (write_symbol1 (pi_root))
4312     /* Nothing.  */;
4313
4314   mio_rparen ();
4315
4316   write_char ('\n');
4317   write_char ('\n');
4318
4319   mio_lparen ();
4320   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4321   mio_rparen ();
4322 }
4323
4324
4325 /* Read a MD5 sum from the header of a module file.  If the file cannot
4326    be opened, or we have any other error, we return -1.  */
4327
4328 static int
4329 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4330 {
4331   FILE *file;
4332   char buf[1024];
4333   int n;
4334
4335   /* Open the file.  */
4336   if ((file = fopen (filename, "r")) == NULL)
4337     return -1;
4338
4339   /* Read two lines.  */
4340   if (fgets (buf, sizeof (buf) - 1, file) == NULL
4341       || fgets (buf, sizeof (buf) - 1, file) == NULL)
4342     {
4343       fclose (file);
4344       return -1;
4345     }
4346
4347   /* Close the file.  */
4348   fclose (file);
4349
4350   /* If the header is not what we expect, or is too short, bail out.  */
4351   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4352     return -1;
4353
4354   /* Now, we have a real MD5, read it into the array.  */
4355   for (n = 0; n < 16; n++)
4356     {
4357       unsigned int x;
4358
4359       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4360        return -1;
4361
4362       md5[n] = x;
4363     }
4364
4365   return 0;
4366 }
4367
4368
4369 /* Given module, dump it to disk.  If there was an error while
4370    processing the module, dump_flag will be set to zero and we delete
4371    the module file, even if it was already there.  */
4372
4373 void
4374 gfc_dump_module (const char *name, int dump_flag)
4375 {
4376   int n;
4377   char *filename, *filename_tmp, *p;
4378   time_t now;
4379   fpos_t md5_pos;
4380   unsigned char md5_new[16], md5_old[16];
4381
4382   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4383   if (gfc_option.module_dir != NULL)
4384     {
4385       n += strlen (gfc_option.module_dir);
4386       filename = (char *) alloca (n);
4387       strcpy (filename, gfc_option.module_dir);
4388       strcat (filename, name);
4389     }
4390   else
4391     {
4392       filename = (char *) alloca (n);
4393       strcpy (filename, name);
4394     }
4395   strcat (filename, MODULE_EXTENSION);
4396
4397   /* Name of the temporary file used to write the module.  */
4398   filename_tmp = (char *) alloca (n + 1);
4399   strcpy (filename_tmp, filename);
4400   strcat (filename_tmp, "0");
4401
4402   /* There was an error while processing the module.  We delete the
4403      module file, even if it was already there.  */
4404   if (!dump_flag)
4405     {
4406       unlink (filename);
4407       return;
4408     }
4409
4410   /* Write the module to the temporary file.  */
4411   module_fp = fopen (filename_tmp, "w");
4412   if (module_fp == NULL)
4413     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4414                      filename_tmp, strerror (errno));
4415
4416   /* Write the header, including space reserved for the MD5 sum.  */
4417   now = time (NULL);
4418   p = ctime (&now);
4419
4420   *strchr (p, '\n') = '\0';
4421
4422   fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4423            gfc_source_file, p);
4424   fgetpos (module_fp, &md5_pos);
4425   fputs ("00000000000000000000000000000000 -- "
4426         "If you edit this, you'll get what you deserve.\n\n", module_fp);
4427
4428   /* Initialize the MD5 context that will be used for output.  */
4429   md5_init_ctx (&ctx);
4430
4431   /* Write the module itself.  */
4432   iomode = IO_OUTPUT;
4433   strcpy (module_name, name);
4434
4435   init_pi_tree ();
4436
4437   write_module ();
4438
4439   free_pi_tree (pi_root);
4440   pi_root = NULL;
4441
4442   write_char ('\n');
4443
4444   /* Write the MD5 sum to the header of the module file.  */
4445   md5_finish_ctx (&ctx, md5_new);
4446   fsetpos (module_fp, &md5_pos);
4447   for (n = 0; n < 16; n++)
4448     fprintf (module_fp, "%02x", md5_new[n]);
4449
4450   if (fclose (module_fp))
4451     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4452                      filename_tmp, strerror (errno));
4453
4454   /* Read the MD5 from the header of the old module file and compare.  */
4455   if (read_md5_from_module_file (filename, md5_old) != 0
4456       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4457     {
4458       /* Module file have changed, replace the old one.  */
4459       unlink (filename);
4460       rename (filename_tmp, filename);
4461     }
4462   else
4463     unlink (filename_tmp);
4464 }
4465
4466
4467 static void
4468 sort_iso_c_rename_list (void)
4469 {
4470   gfc_use_rename *tmp_list = NULL;
4471   gfc_use_rename *curr;
4472   gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4473   int c_kind;
4474   int i;
4475
4476   for (curr = gfc_rename_list; curr; curr = curr->next)
4477     {
4478       c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4479       if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4480         {
4481           gfc_error ("Symbol '%s' referenced at %L does not exist in "
4482                      "intrinsic module ISO_C_BINDING.", curr->use_name,
4483                      &curr->where);
4484         }
4485       else
4486         /* Put it in the list.  */
4487         kinds_used[c_kind] = curr;
4488     }
4489
4490   /* Make a new (sorted) rename list.  */
4491   i = 0;
4492   while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4493     i++;
4494
4495   if (i < ISOCBINDING_NUMBER)
4496     {
4497       tmp_list = kinds_used[i];
4498
4499       i++;
4500       curr = tmp_list;
4501       for (; i < ISOCBINDING_NUMBER; i++)
4502         if (kinds_used[i] != NULL)
4503           {
4504             curr->next = kinds_used[i];
4505             curr = curr->next;
4506             curr->next = NULL;
4507           }
4508     }
4509
4510   gfc_rename_list = tmp_list;
4511 }
4512
4513
4514 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4515    the current namespace for all named constants, pointer types, and
4516    procedures in the module unless the only clause was used or a rename
4517    list was provided.  */
4518
4519 static void
4520 import_iso_c_binding_module (void)
4521 {
4522   gfc_symbol *mod_sym = NULL;
4523   gfc_symtree *mod_symtree = NULL;
4524   const char *iso_c_module_name = "__iso_c_binding";
4525   gfc_use_rename *u;
4526   int i;
4527   char *local_name;
4528
4529   /* Look only in the current namespace.  */
4530   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4531
4532   if (mod_symtree == NULL)
4533     {
4534       /* symtree doesn't already exist in current namespace.  */
4535       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4536
4537       if (mod_symtree != NULL)
4538         mod_sym = mod_symtree->n.sym;
4539       else
4540         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4541                             "create symbol for %s", iso_c_module_name);
4542
4543       mod_sym->attr.flavor = FL_MODULE;
4544       mod_sym->attr.intrinsic = 1;
4545       mod_sym->module = gfc_get_string (iso_c_module_name);
4546       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4547     }
4548
4549   /* Generate the symbols for the named constants representing
4550      the kinds for intrinsic data types.  */
4551   if (only_flag)
4552     {
4553       /* Sort the rename list because there are dependencies between types
4554          and procedures (e.g., c_loc needs c_ptr).  */
4555       sort_iso_c_rename_list ();
4556
4557       for (u = gfc_rename_list; u; u = u->next)
4558         {
4559           i = get_c_kind (u->use_name, c_interop_kinds_table);
4560
4561           if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4562             {
4563               gfc_error ("Symbol '%s' referenced at %L does not exist in "
4564                          "intrinsic module ISO_C_BINDING.", u->use_name,
4565                          &u->where);
4566               continue;
4567             }
4568
4569           generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4570         }
4571     }
4572   else
4573     {
4574       for (i = 0; i < ISOCBINDING_NUMBER; i++)
4575         {
4576           local_name = NULL;
4577           for (u = gfc_rename_list; u; u = u->next)
4578             {
4579               if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4580                 {
4581                   local_name = u->local_name;
4582                   u->found = 1;
4583                   break;
4584                 }
4585             }
4586           generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4587         }
4588
4589       for (u = gfc_rename_list; u; u = u->next)
4590         {
4591           if (u->found)
4592             continue;
4593
4594           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4595                      "module ISO_C_BINDING", u->use_name, &u->where);
4596         }
4597     }
4598 }
4599
4600
4601 /* Add an integer named constant from a given module.  */
4602
4603 static void
4604 create_int_parameter (const char *name, int value, const char *modname,
4605                       intmod_id module, int id)
4606 {
4607   gfc_symtree *tmp_symtree;
4608   gfc_symbol *sym;
4609
4610   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4611   if (tmp_symtree != NULL)
4612     {
4613       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4614         return;
4615       else
4616         gfc_error ("Symbol '%s' already declared", name);
4617     }
4618
4619   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4620   sym = tmp_symtree->n.sym;
4621
4622   sym->module = gfc_get_string (modname);
4623   sym->attr.flavor = FL_PARAMETER;
4624   sym->ts.type = BT_INTEGER;
4625   sym->ts.kind = gfc_default_integer_kind;
4626   sym->value = gfc_int_expr (value);
4627   sym->attr.use_assoc = 1;
4628   sym->from_intmod = module;
4629   sym->intmod_sym_id = id;
4630 }
4631
4632
4633 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
4634
4635 static void
4636 use_iso_fortran_env_module (void)
4637 {
4638   static char mod[] = "iso_fortran_env";
4639   const char *local_name;
4640   gfc_use_rename *u;
4641   gfc_symbol *mod_sym;
4642   gfc_symtree *mod_symtree;
4643   int i;
4644
4645   intmod_sym symbol[] = {
4646 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4647 #include "iso-fortran-env.def"
4648 #undef NAMED_INTCST
4649     { ISOFORTRANENV_INVALID, NULL, -1234 } };
4650
4651   i = 0;
4652 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4653 #include "iso-fortran-env.def"
4654 #undef NAMED_INTCST
4655
4656   /* Generate the symbol for the module itself.  */
4657   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4658   if (mod_symtree == NULL)
4659     {
4660       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4661       gcc_assert (mod_symtree);
4662       mod_sym = mod_symtree->n.sym;
4663
4664       mod_sym->attr.flavor = FL_MODULE;
4665       mod_sym->attr.intrinsic = 1;
4666       mod_sym->module = gfc_get_string (mod);
4667       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4668     }
4669   else
4670     if (!mod_symtree->n.sym->attr.intrinsic)
4671       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4672                  "non-intrinsic module name used previously", mod);
4673
4674   /* Generate the symbols for the module integer named constants.  */
4675   if (only_flag)
4676     for (u = gfc_rename_list; u; u = u->next)
4677       {
4678         for (i = 0; symbol[i].name; i++)
4679           if (strcmp (symbol[i].name, u->use_name) == 0)
4680             break;
4681
4682         if (symbol[i].name == NULL)
4683           {
4684             gfc_error ("Symbol '%s' referenced at %L does not exist in "
4685                        "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4686                        &u->where);
4687             continue;
4688           }
4689
4690         if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4691             && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4692           gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4693                            "from intrinsic module ISO_FORTRAN_ENV at %L is "
4694                            "incompatible with option %s", &u->where,
4695                            gfc_option.flag_default_integer
4696                              ? "-fdefault-integer-8" : "-fdefault-real-8");
4697
4698         create_int_parameter (u->local_name[0] ? u->local_name
4699                                                : symbol[i].name,
4700                               symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4701                               symbol[i].id);
4702       }
4703   else
4704     {
4705       for (i = 0; symbol[i].name; i++)
4706         {
4707           local_name = NULL;
4708           for (u = gfc_rename_list; u; u = u->next)
4709             {
4710               if (strcmp (symbol[i].name, u->use_name) == 0)
4711                 {
4712                   local_name = u->local_name;
4713                   u->found = 1;
4714                   break;
4715                 }
4716             }
4717
4718           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4719               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4720             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4721                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
4722                              "incompatible with option %s",
4723                              gfc_option.flag_default_integer
4724                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
4725
4726           create_int_parameter (local_name ? local_name : symbol[i].name,
4727                                 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4728                                 symbol[i].id);
4729         }
4730
4731       for (u = gfc_rename_list; u; u = u->next)
4732         {
4733           if (u->found)
4734             continue;
4735
4736           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4737                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4738         }
4739     }
4740 }
4741
4742
4743 /* Process a USE directive.  */
4744
4745 void
4746 gfc_use_module (void)
4747 {
4748   char *filename;
4749   gfc_state_data *p;
4750   int c, line, start;
4751   gfc_symtree *mod_symtree;
4752
4753   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4754                               + 1);
4755   strcpy (filename, module_name);
4756   strcat (filename, MODULE_EXTENSION);
4757
4758   /* First, try to find an non-intrinsic module, unless the USE statement
4759      specified that the module is intrinsic.  */
4760   module_fp = NULL;
4761   if (!specified_int)
4762     module_fp = gfc_open_included_file (filename, true, true);
4763
4764   /* Then, see if it's an intrinsic one, unless the USE statement
4765      specified that the module is non-intrinsic.  */
4766   if (module_fp == NULL && !specified_nonint)
4767     {
4768       if (strcmp (module_name, "iso_fortran_env") == 0
4769           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4770                              "intrinsic module at %C") != FAILURE)
4771        {
4772          use_iso_fortran_env_module ();
4773          return;
4774        }
4775
4776       if (strcmp (module_name, "iso_c_binding") == 0
4777           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4778                              "ISO_C_BINDING module at %C") != FAILURE)
4779         {
4780           import_iso_c_binding_module();
4781           return;
4782         }
4783
4784       module_fp = gfc_open_intrinsic_module (filename);
4785
4786       if (module_fp == NULL && specified_int)
4787         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4788                          module_name);
4789     }
4790
4791   if (module_fp == NULL)
4792     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4793                      filename, strerror (errno));
4794
4795   /* Check that we haven't already USEd an intrinsic module with the
4796      same name.  */
4797
4798   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4799   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4800     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4801                "intrinsic module name used previously", module_name);
4802
4803   iomode = IO_INPUT;
4804   module_line = 1;
4805   module_column = 1;
4806   start = 0;
4807
4808   /* Skip the first two lines of the module, after checking that this is
4809      a gfortran module file.  */
4810   line = 0;
4811   while (line < 2)
4812     {
4813       c = module_char ();
4814       if (c == EOF)
4815         bad_module ("Unexpected end of module");
4816       if (start++ < 2)
4817         parse_name (c);
4818       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4819           || (start == 2 && strcmp (atom_name, " module") != 0))
4820         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4821                          "file", filename);
4822
4823       if (c == '\n')
4824         line++;
4825     }
4826
4827   /* Make sure we're not reading the same module that we may be building.  */
4828   for (p = gfc_state_stack; p; p = p->previous)
4829     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4830       gfc_fatal_error ("Can't USE the same module we're building!");
4831
4832   init_pi_tree ();
4833   init_true_name_tree ();
4834
4835   read_module ();
4836
4837   free_true_name (true_name_root);
4838   true_name_root = NULL;
4839
4840   free_pi_tree (pi_root);
4841   pi_root = NULL;
4842
4843   fclose (module_fp);
4844 }
4845
4846
4847 void
4848 gfc_module_init_2 (void)
4849 {
4850   last_atom = ATOM_LPAREN;
4851 }
4852
4853
4854 void
4855 gfc_module_done_2 (void)
4856 {
4857   free_rename ();
4858 }