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