gcc/fortran/module.c

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