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