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.  */