gcc/fortran/module.c

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