gcc/fortran/module.c

   1 /* Handle modules, which amounts to loading and saving symbols and
   2    their attendant structures.
   3    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   4    2009, 2010, 2011, 2012
   5    Free Software Foundation, Inc.
   6    Contributed by Andy Vaught
   7
   8 This file is part of GCC.
   9
  10 GCC is free software; you can redistribute it and/or modify it under
  11 the terms of the GNU General Public License as published by the Free
  12 Software Foundation; either version 3, or (at your option) any later
  13 version.
  14
  15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  17 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  18 for more details.
  19
  20 You should have received a copy of the GNU General Public License
  21 along with GCC; see the file COPYING3.  If not see
  22 <http://www.gnu.org/licenses/>.  */
  23
  24 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
  25    sequence of atoms, which can be left or right parenthesis, names,
  26    integers or strings.  Parenthesis are always matched which allows
  27    us to skip over sections at high speed without having to know
  28    anything about the internal structure of the lists.  A "name" is
  29    usually a fortran 95 identifier, but can also start with '@' in
  30    order to reference a hidden symbol.
  31
  32    The first line of a module is an informational message about what
  33    created the module, the file it came from and when it was created.
  34    The second line is a warning for people not to edit the module.
  35    The rest of the module looks like:
  36
  37    ( ( <Interface info for UPLUS> )
  38      ( <Interface info for UMINUS> )
  39      ...
  40    )
  41    ( ( <name of operator interface> <module of op interface> <i/f1> ... )
  42      ...
  43    )
  44    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
  45      ...
  46    )
  47    ( ( <common name> <symbol> <saved flag>)
  48      ...
  49    )
  50
  51    ( equivalence list )
  52
  53    ( <Symbol Number (in no particular order)>
  54      <True name of symbol>
  55      <Module name of symbol>
  56      ( <symbol information> )
  57      ...
  58    )
  59    ( <Symtree name>
  60      <Ambiguous flag>
  61      <Symbol number>
  62      ...
  63    )
  64
  65    In general, symbols refer to other symbols by their symbol number,
  66    which are zero based.  Symbols are written to the module in no
  67    particular order.  */
  68
  69 #include "config.h"
  70 #include "system.h"
  71 #include "gfortran.h"
  72 #include "arith.h"
  73 #include "match.h"
  74 #include "parse.h" /* FIXME */
  75 #include "md5.h"
  76 #include "constructor.h"
  77 #include "cpp.h"
  78 #include "tree.h"
  79
  80 #define MODULE_EXTENSION ".mod"
  81
  82 /* Don't put any single quote (') in MOD_VERSION,
  83    if yout want it to be recognized.  */
  84 #define MOD_VERSION "9"
  85
  86
  87 /* Structure that describes a position within a module file.  */
  88
  89 typedef struct
  90 {
  91   int column, line;
  92   fpos_t pos;
  93 }
  94 module_locus;
  95
  96 /* Structure for list of symbols of intrinsic modules.  */
  97 typedef struct
  98 {
  99   int id;
 100   const char *name;
 101   int value;
 102   int standard;
 103 }
 104 intmod_sym;
 105
 106
 107 typedef enum
 108 {
 109   P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
 110 }
 111 pointer_t;
 112
 113 /* The fixup structure lists pointers to pointers that have to
 114    be updated when a pointer value becomes known.  */
 115
 116 typedef struct fixup_t
 117 {
 118   void **pointer;
 119   struct fixup_t *next;
 120 }
 121 fixup_t;
 122
 123
 124 /* Structure for holding extra info needed for pointers being read.  */
 125
 126 enum gfc_rsym_state
 127 {
 128   UNUSED,
 129   NEEDED,
 130   USED
 131 };
 132
 133 enum gfc_wsym_state
 134 {
 135   UNREFERENCED = 0,
 136   NEEDS_WRITE,
 137   WRITTEN
 138 };
 139
 140 typedef struct pointer_info
 141 {
 142   BBT_HEADER (pointer_info);
 143   int integer;
 144   pointer_t type;
 145
 146   /* The first component of each member of the union is the pointer
 147      being stored.  */
 148
 149   fixup_t *fixup;
 150
 151   union
 152   {
 153     void *pointer;      /* Member for doing pointer searches.  */
 154
 155     struct
 156     {
 157       gfc_symbol *sym;
 158       char *true_name, *module, *binding_label;
 159       fixup_t *stfixup;
 160       gfc_symtree *symtree;
 161       enum gfc_rsym_state state;
 162       int ns, referenced, renamed;
 163       module_locus where;
 164     }
 165     rsym;
 166
 167     struct
 168     {
 169       gfc_symbol *sym;
 170       enum gfc_wsym_state state;
 171     }
 172     wsym;
 173   }
 174   u;
 175
 176 }
 177 pointer_info;
 178
 179 #define gfc_get_pointer_info() XCNEW (pointer_info)
 180
 181
 182 /* Local variables */
 183
 184 /* The FILE for the module we're reading or writing.  */
 185 static FILE *module_fp;
 186
 187 /* MD5 context structure.  */
 188 static struct md5_ctx ctx;
 189
 190 /* The name of the module we're reading (USE'ing) or writing.  */
 191 static const char *module_name;
 192 static gfc_use_list *module_list;
 193
 194 static int module_line, module_column, only_flag;
 195 static int prev_module_line, prev_module_column, prev_character;
 196
 197 static enum
 198 { IO_INPUT, IO_OUTPUT }
 199 iomode;
 200
 201 static gfc_use_rename *gfc_rename_list;
 202 static pointer_info *pi_root;
 203 static int symbol_number;       /* Counter for assigning symbol numbers */
 204
 205 /* Tells mio_expr_ref to make symbols for unused equivalence members.  */
 206 static bool in_load_equiv;
 207
 208
 209
 210 /*****************************************************************/
 211
 212 /* Pointer/integer conversion.  Pointers between structures are stored
 213    as integers in the module file.  The next couple of subroutines
 214    handle this translation for reading and writing.  */
 215
 216 /* Recursively free the tree of pointer structures.  */
 217
 218 static void
 219 free_pi_tree (pointer_info *p)
 220 {
 221   if (p == NULL)
 222     return;
 223
 224   if (p->fixup != NULL)
 225     gfc_internal_error ("free_pi_tree(): Unresolved fixup");
 226
 227   free_pi_tree (p->left);
 228   free_pi_tree (p->right);
 229
 230   if (iomode == IO_INPUT)
 231     {
 232       XDELETEVEC (p->u.rsym.true_name);
 233       XDELETEVEC (p->u.rsym.module);
 234       XDELETEVEC (p->u.rsym.binding_label);
 235     }
 236
 237   free (p);
 238 }
 239
 240
 241 /* Compare pointers when searching by pointer.  Used when writing a
 242    module.  */
 243
 244 static int
 245 compare_pointers (void *_sn1, void *_sn2)
 246 {
 247   pointer_info *sn1, *sn2;
 248
 249   sn1 = (pointer_info *) _sn1;
 250   sn2 = (pointer_info *) _sn2;
 251
 252   if (sn1->u.pointer < sn2->u.pointer)
 253     return -1;
 254   if (sn1->u.pointer > sn2->u.pointer)
 255     return 1;
 256
 257   return 0;
 258 }
 259
 260
 261 /* Compare integers when searching by integer.  Used when reading a
 262    module.  */
 263
 264 static int
 265 compare_integers (void *_sn1, void *_sn2)
 266 {
 267   pointer_info *sn1, *sn2;
 268
 269   sn1 = (pointer_info *) _sn1;
 270   sn2 = (pointer_info *) _sn2;
 271
 272   if (sn1->integer < sn2->integer)
 273     return -1;
 274   if (sn1->integer > sn2->integer)
 275     return 1;
 276
 277   return 0;
 278 }
 279
 280
 281 /* Initialize the pointer_info tree.  */
 282
 283 static void
 284 init_pi_tree (void)
 285 {
 286   compare_fn compare;
 287   pointer_info *p;
 288
 289   pi_root = NULL;
 290   compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
 291
 292   /* Pointer 0 is the NULL pointer.  */
 293   p = gfc_get_pointer_info ();
 294   p->u.pointer = NULL;
 295   p->integer = 0;
 296   p->type = P_OTHER;
 297
 298   gfc_insert_bbt (&pi_root, p, compare);
 299
 300   /* Pointer 1 is the current namespace.  */
 301   p = gfc_get_pointer_info ();
 302   p->u.pointer = gfc_current_ns;
 303   p->integer = 1;
 304   p->type = P_NAMESPACE;
 305
 306   gfc_insert_bbt (&pi_root, p, compare);
 307
 308   symbol_number = 2;
 309 }
 310
 311
 312 /* During module writing, call here with a pointer to something,
 313    returning the pointer_info node.  */
 314
 315 static pointer_info *
 316 find_pointer (void *gp)
 317 {
 318   pointer_info *p;
 319
 320   p = pi_root;
 321   while (p != NULL)
 322     {
 323       if (p->u.pointer == gp)
 324         break;
 325       p = (gp < p->u.pointer) ? p->left : p->right;
 326     }
 327
 328   return p;
 329 }
 330
 331
 332 /* Given a pointer while writing, returns the pointer_info tree node,
 333    creating it if it doesn't exist.  */
 334
 335 static pointer_info *
 336 get_pointer (void *gp)
 337 {
 338   pointer_info *p;
 339
 340   p = find_pointer (gp);
 341   if (p != NULL)
 342     return p;
 343
 344   /* Pointer doesn't have an integer.  Give it one.  */
 345   p = gfc_get_pointer_info ();
 346
 347   p->u.pointer = gp;
 348   p->integer = symbol_number++;
 349
 350   gfc_insert_bbt (&pi_root, p, compare_pointers);
 351
 352   return p;
 353 }
 354
 355
 356 /* Given an integer during reading, find it in the pointer_info tree,
 357    creating the node if not found.  */
 358
 359 static pointer_info *
 360 get_integer (int integer)
 361 {
 362   pointer_info *p, t;
 363   int c;
 364
 365   t.integer = integer;
 366
 367   p = pi_root;
 368   while (p != NULL)
 369     {
 370       c = compare_integers (&t, p);
 371       if (c == 0)
 372         break;
 373
 374       p = (c < 0) ? p->left : p->right;
 375     }
 376
 377   if (p != NULL)
 378     return p;
 379
 380   p = gfc_get_pointer_info ();
 381   p->integer = integer;
 382   p->u.pointer = NULL;
 383
 384   gfc_insert_bbt (&pi_root, p, compare_integers);
 385
 386   return p;
 387 }
 388
 389
 390 /* Recursive function to find a pointer within a tree by brute force.  */
 391
 392 static pointer_info *
 393 fp2 (pointer_info *p, const void *target)
 394 {
 395   pointer_info *q;
 396
 397   if (p == NULL)
 398     return NULL;
 399
 400   if (p->u.pointer == target)
 401     return p;
 402
 403   q = fp2 (p->left, target);
 404   if (q != NULL)
 405     return q;
 406
 407   return fp2 (p->right, target);
 408 }
 409
 410
 411 /* During reading, find a pointer_info node from the pointer value.
 412    This amounts to a brute-force search.  */
 413
 414 static pointer_info *
 415 find_pointer2 (void *p)
 416 {
 417   return fp2 (pi_root, p);
 418 }
 419
 420
 421 /* Resolve any fixups using a known pointer.  */
 422
 423 static void
 424 resolve_fixups (fixup_t *f, void *gp)
 425 {
 426   fixup_t *next;
 427
 428   for (; f; f = next)
 429     {
 430       next = f->next;
 431       *(f->pointer) = gp;
 432       free (f);
 433     }
 434 }
 435
 436
 437 /* Convert a string such that it starts with a lower-case character. Used
 438    to convert the symtree name of a derived-type to the symbol name or to
 439    the name of the associated generic function.  */
 440
 441 static const char *
 442 dt_lower_string (const char *name)
 443 {
 444   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
 445     return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
 446                            &name[1]);
 447   return gfc_get_string (name);
 448 }
 449
 450
 451 /* Convert a string such that it starts with an upper-case character. Used to
 452    return the symtree-name for a derived type; the symbol name itself and the
 453    symtree/symbol name of the associated generic function start with a lower-
 454    case character.  */
 455
 456 static const char *
 457 dt_upper_string (const char *name)
 458 {
 459   if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
 460     return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
 461                            &name[1]);
 462   return gfc_get_string (name);
 463 }
 464
 465 /* Call here during module reading when we know what pointer to
 466    associate with an integer.  Any fixups that exist are resolved at
 467    this time.  */
 468
 469 static void
 470 associate_integer_pointer (pointer_info *p, void *gp)
 471 {
 472   if (p->u.pointer != NULL)
 473     gfc_internal_error ("associate_integer_pointer(): Already associated");
 474
 475   p->u.pointer = gp;
 476
 477   resolve_fixups (p->fixup, gp);
 478
 479   p->fixup = NULL;
 480 }
 481
 482
 483 /* During module reading, given an integer and a pointer to a pointer,
 484    either store the pointer from an already-known value or create a
 485    fixup structure in order to store things later.  Returns zero if
 486    the reference has been actually stored, or nonzero if the reference
 487    must be fixed later (i.e., associate_integer_pointer must be called
 488    sometime later.  Returns the pointer_info structure.  */
 489
 490 static pointer_info *
 491 add_fixup (int integer, void *gp)
 492 {
 493   pointer_info *p;
 494   fixup_t *f;
 495   char **cp;
 496
 497   p = get_integer (integer);
 498
 499   if (p->integer == 0 || p->u.pointer != NULL)
 500     {
 501       cp = (char **) gp;
 502       *cp = (char *) p->u.pointer;
 503     }
 504   else
 505     {
 506       f = XCNEW (fixup_t);
 507
 508       f->next = p->fixup;
 509       p->fixup = f;
 510
 511       f->pointer = (void **) gp;
 512     }
 513
 514   return p;
 515 }
 516
 517
 518 /*****************************************************************/
 519
 520 /* Parser related subroutines */
 521
 522 /* Free the rename list left behind by a USE statement.  */
 523
 524 static void
 525 free_rename (gfc_use_rename *list)
 526 {
 527   gfc_use_rename *next;
 528
 529   for (; list; list = next)
 530     {
 531       next = list->next;
 532       free (list);
 533     }
 534 }
 535
 536
 537 /* Match a USE statement.  */
 538
 539 match
 540 gfc_match_use (void)
 541 {
 542   char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
 543   gfc_use_rename *tail = NULL, *new_use;
 544   interface_type type, type2;
 545   gfc_intrinsic_op op;
 546   match m;
 547   gfc_use_list *use_list;
 548
 549   use_list = gfc_get_use_list ();
 550
 551   if (gfc_match (" , ") == MATCH_YES)
 552     {
 553       if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
 554         {
 555           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
 556                               "nature in USE statement at %C") == FAILURE)
 557             goto cleanup;
 558
 559           if (strcmp (module_nature, "intrinsic") == 0)
 560             use_list->intrinsic = true;
 561           else
 562             {
 563               if (strcmp (module_nature, "non_intrinsic") == 0)
 564                 use_list->non_intrinsic = true;
 565               else
 566                 {
 567                   gfc_error ("Module nature in USE statement at %C shall "
 568                              "be either INTRINSIC or NON_INTRINSIC");
 569                   goto cleanup;
 570                 }
 571             }
 572         }
 573       else
 574         {
 575           /* Help output a better error message than "Unclassifiable
 576              statement".  */
 577           gfc_match (" %n", module_nature);
 578           if (strcmp (module_nature, "intrinsic") == 0
 579               || strcmp (module_nature, "non_intrinsic") == 0)
 580             gfc_error ("\"::\" was expected after module nature at %C "
 581                        "but was not found");
 582           free (use_list);
 583           return m;
 584         }
 585     }
 586   else
 587     {
 588       m = gfc_match (" ::");
 589       if (m == MATCH_YES &&
 590           gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
 591                           "\"USE :: module\" at %C") == FAILURE)
 592         goto cleanup;
 593
 594       if (m != MATCH_YES)
 595         {
 596           m = gfc_match ("% ");
 597           if (m != MATCH_YES)
 598             {
 599               free (use_list);
 600               return m;
 601             }
 602         }
 603     }
 604
 605   use_list->where = gfc_current_locus;
 606
 607   m = gfc_match_name (name);
 608   if (m != MATCH_YES)
 609     {
 610       free (use_list);
 611       return m;
 612     }
 613
 614   use_list->module_name = gfc_get_string (name);
 615
 616   if (gfc_match_eos () == MATCH_YES)
 617     goto done;
 618
 619   if (gfc_match_char (',') != MATCH_YES)
 620     goto syntax;
 621
 622   if (gfc_match (" only :") == MATCH_YES)
 623     use_list->only_flag = true;
 624
 625   if (gfc_match_eos () == MATCH_YES)
 626     goto done;
 627
 628   for (;;)
 629     {
 630       /* Get a new rename struct and add it to the rename list.  */
 631       new_use = gfc_get_use_rename ();
 632       new_use->where = gfc_current_locus;
 633       new_use->found = 0;
 634
 635       if (use_list->rename == NULL)
 636         use_list->rename = new_use;
 637       else
 638         tail->next = new_use;
 639       tail = new_use;
 640
 641       /* See what kind of interface we're dealing with.  Assume it is
 642          not an operator.  */
 643       new_use->op = INTRINSIC_NONE;
 644       if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
 645         goto cleanup;
 646
 647       switch (type)
 648         {
 649         case INTERFACE_NAMELESS:
 650           gfc_error ("Missing generic specification in USE statement at %C");
 651           goto cleanup;
 652
 653         case INTERFACE_USER_OP:
 654         case INTERFACE_GENERIC:
 655           m = gfc_match (" =>");
 656
 657           if (type == INTERFACE_USER_OP && m == MATCH_YES
 658               && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
 659                                   "operators in USE statements at %C")
 660                  == FAILURE))
 661             goto cleanup;
 662
 663           if (type == INTERFACE_USER_OP)
 664             new_use->op = INTRINSIC_USER;
 665
 666           if (use_list->only_flag)
 667             {
 668               if (m != MATCH_YES)
 669                 strcpy (new_use->use_name, name);
 670               else
 671                 {
 672                   strcpy (new_use->local_name, name);
 673                   m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
 674                   if (type != type2)
 675                     goto syntax;
 676                   if (m == MATCH_NO)
 677                     goto syntax;
 678                   if (m == MATCH_ERROR)
 679                     goto cleanup;
 680                 }
 681             }
 682           else
 683             {
 684               if (m != MATCH_YES)
 685                 goto syntax;
 686               strcpy (new_use->local_name, name);
 687
 688               m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
 689               if (type != type2)
 690                 goto syntax;
 691               if (m == MATCH_NO)
 692                 goto syntax;
 693               if (m == MATCH_ERROR)
 694                 goto cleanup;
 695             }
 696
 697           if (strcmp (new_use->use_name, use_list->module_name) == 0
 698               || strcmp (new_use->local_name, use_list->module_name) == 0)
 699             {
 700               gfc_error ("The name '%s' at %C has already been used as "
 701                          "an external module name.", use_list->module_name);
 702               goto cleanup;
 703             }
 704           break;
 705
 706         case INTERFACE_INTRINSIC_OP:
 707           new_use->op = op;
 708           break;
 709
 710         default:
 711           gcc_unreachable ();
 712         }
 713
 714       if (gfc_match_eos () == MATCH_YES)
 715         break;
 716       if (gfc_match_char (',') != MATCH_YES)
 717         goto syntax;
 718     }
 719
 720 done:
 721   if (module_list)
 722     {
 723       gfc_use_list *last = module_list;
 724       while (last->next)
 725         last = last->next;
 726       last->next = use_list;
 727     }
 728   else
 729     module_list = use_list;
 730
 731   return MATCH_YES;
 732
 733 syntax:
 734   gfc_syntax_error (ST_USE);
 735
 736 cleanup:
 737   free_rename (use_list->rename);
 738   free (use_list);
 739   return MATCH_ERROR;
 740 }
 741
 742
 743 /* Given a name and a number, inst, return the inst name
 744    under which to load this symbol. Returns NULL if this
 745    symbol shouldn't be loaded. If inst is zero, returns
 746    the number of instances of this name. If interface is
 747    true, a user-defined operator is sought, otherwise only
 748    non-operators are sought.  */
 749
 750 static const char *
 751 find_use_name_n (const char *name, int *inst, bool interface)
 752 {
 753   gfc_use_rename *u;
 754   const char *low_name = NULL;
 755   int i;
 756
 757   /* For derived types.  */
 758   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
 759     low_name = dt_lower_string (name);
 760
 761   i = 0;
 762   for (u = gfc_rename_list; u; u = u->next)
 763     {
 764       if ((!low_name && strcmp (u->use_name, name) != 0)
 765           || (low_name && strcmp (u->use_name, low_name) != 0)
 766           || (u->op == INTRINSIC_USER && !interface)
 767           || (u->op != INTRINSIC_USER &&  interface))
 768         continue;
 769       if (++i == *inst)
 770         break;
 771     }
 772
 773   if (!*inst)
 774     {
 775       *inst = i;
 776       return NULL;
 777     }
 778
 779   if (u == NULL)
 780     return only_flag ? NULL : name;
 781
 782   u->found = 1;
 783
 784   if (low_name)
 785     {
 786       if (u->local_name[0] == '\0')
 787         return name;
 788       return dt_upper_string (u->local_name);
 789     }
 790
 791   return (u->local_name[0] != '\0') ? u->local_name : name;
 792 }
 793
 794
 795 /* Given a name, return the name under which to load this symbol.
 796    Returns NULL if this symbol shouldn't be loaded.  */
 797
 798 static const char *
 799 find_use_name (const char *name, bool interface)
 800 {
 801   int i = 1;
 802   return find_use_name_n (name, &i, interface);
 803 }
 804
 805
 806 /* Given a real name, return the number of use names associated with it.  */
 807
 808 static int
 809 number_use_names (const char *name, bool interface)
 810 {
 811   int i = 0;
 812   find_use_name_n (name, &i, interface);
 813   return i;
 814 }
 815
 816
 817 /* Try to find the operator in the current list.  */
 818
 819 static gfc_use_rename *
 820 find_use_operator (gfc_intrinsic_op op)
 821 {
 822   gfc_use_rename *u;
 823
 824   for (u = gfc_rename_list; u; u = u->next)
 825     if (u->op == op)
 826       return u;
 827
 828   return NULL;
 829 }
 830
 831
 832 /*****************************************************************/
 833
 834 /* The next couple of subroutines maintain a tree used to avoid a
 835    brute-force search for a combination of true name and module name.
 836    While symtree names, the name that a particular symbol is known by
 837    can changed with USE statements, we still have to keep track of the
 838    true names to generate the correct reference, and also avoid
 839    loading the same real symbol twice in a program unit.
 840
 841    When we start reading, the true name tree is built and maintained
 842    as symbols are read.  The tree is searched as we load new symbols
 843    to see if it already exists someplace in the namespace.  */
 844
 845 typedef struct true_name
 846 {
 847   BBT_HEADER (true_name);
 848   const char *name;
 849   gfc_symbol *sym;
 850 }
 851 true_name;
 852
 853 static true_name *true_name_root;
 854
 855
 856 /* Compare two true_name structures.  */
 857
 858 static int
 859 compare_true_names (void *_t1, void *_t2)
 860 {
 861   true_name *t1, *t2;
 862   int c;
 863
 864   t1 = (true_name *) _t1;
 865   t2 = (true_name *) _t2;
 866
 867   c = ((t1->sym->module > t2->sym->module)
 868        - (t1->sym->module < t2->sym->module));
 869   if (c != 0)
 870     return c;
 871
 872   return strcmp (t1->name, t2->name);
 873 }
 874
 875
 876 /* Given a true name, search the true name tree to see if it exists
 877    within the main namespace.  */
 878
 879 static gfc_symbol *
 880 find_true_name (const char *name, const char *module)
 881 {
 882   true_name t, *p;
 883   gfc_symbol sym;
 884   int c;
 885
 886   t.name = gfc_get_string (name);
 887   if (module != NULL)
 888     sym.module = gfc_get_string (module);
 889   else
 890     sym.module = NULL;
 891   t.sym = &sym;
 892
 893   p = true_name_root;
 894   while (p != NULL)
 895     {
 896       c = compare_true_names ((void *) (&t), (void *) p);
 897       if (c == 0)
 898         return p->sym;
 899
 900       p = (c < 0) ? p->left : p->right;
 901     }
 902
 903   return NULL;
 904 }
 905
 906
 907 /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
 908
 909 static void
 910 add_true_name (gfc_symbol *sym)
 911 {
 912   true_name *t;
 913
 914   t = XCNEW (true_name);
 915   t->sym = sym;
 916   if (sym->attr.flavor == FL_DERIVED)
 917     t->name = dt_upper_string (sym->name);
 918   else
 919     t->name = sym->name;
 920
 921   gfc_insert_bbt (&true_name_root, t, compare_true_names);
 922 }
 923
 924
 925 /* Recursive function to build the initial true name tree by
 926    recursively traversing the current namespace.  */
 927
 928 static void
 929 build_tnt (gfc_symtree *st)
 930 {
 931   const char *name;
 932   if (st == NULL)
 933     return;
 934
 935   build_tnt (st->left);
 936   build_tnt (st->right);
 937
 938   if (st->n.sym->attr.flavor == FL_DERIVED)
 939     name = dt_upper_string (st->n.sym->name);
 940   else
 941     name = st->n.sym->name;
 942
 943   if (find_true_name (name, st->n.sym->module) != NULL)
 944     return;
 945
 946   add_true_name (st->n.sym);
 947 }
 948
 949
 950 /* Initialize the true name tree with the current namespace.  */
 951
 952 static void
 953 init_true_name_tree (void)
 954 {
 955   true_name_root = NULL;
 956   build_tnt (gfc_current_ns->sym_root);
 957 }
 958
 959
 960 /* Recursively free a true name tree node.  */
 961
 962 static void
 963 free_true_name (true_name *t)
 964 {
 965   if (t == NULL)
 966     return;
 967   free_true_name (t->left);
 968   free_true_name (t->right);
 969
 970   free (t);
 971 }
 972
 973
 974 /*****************************************************************/
 975
 976 /* Module reading and writing.  */
 977
 978 typedef enum
 979 {
 980   ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
 981 }
 982 atom_type;
 983
 984 static atom_type last_atom;
 985
 986
 987 /* The name buffer must be at least as long as a symbol name.  Right
 988    now it's not clear how we're going to store numeric constants--
 989    probably as a hexadecimal string, since this will allow the exact
 990    number to be preserved (this can't be done by a decimal
 991    representation).  Worry about that later.  TODO!  */
 992
 993 #define MAX_ATOM_SIZE 100
 994
 995 static int atom_int;
 996 static char *atom_string, atom_name[MAX_ATOM_SIZE];
 997
 998
 999 /* Report problems with a module.  Error reporting is not very
1000    elaborate, since this sorts of errors shouldn't really happen.
1001    This subroutine never returns.  */
1002
1003 static void bad_module (const char *) ATTRIBUTE_NORETURN;
1004
1005 static void
1006 bad_module (const char *msgid)
1007 {
1008   fclose (module_fp);
1009
1010   switch (iomode)
1011     {
1012     case IO_INPUT:
1013       gfc_fatal_error ("Reading module %s at line %d column %d: %s",
1014                        module_name, module_line, module_column, msgid);
1015       break;
1016     case IO_OUTPUT:
1017       gfc_fatal_error ("Writing module %s at line %d column %d: %s",
1018                        module_name, module_line, module_column, msgid);
1019       break;
1020     default:
1021       gfc_fatal_error ("Module %s at line %d column %d: %s",
1022                        module_name, module_line, module_column, msgid);
1023       break;
1024     }
1025 }
1026
1027
1028 /* Set the module's input pointer.  */
1029
1030 static void
1031 set_module_locus (module_locus *m)
1032 {
1033   module_column = m->column;
1034   module_line = m->line;
1035   fsetpos (module_fp, &m->pos);
1036 }
1037
1038
1039 /* Get the module's input pointer so that we can restore it later.  */
1040
1041 static void
1042 get_module_locus (module_locus *m)
1043 {
1044   m->column = module_column;
1045   m->line = module_line;
1046   fgetpos (module_fp, &m->pos);
1047 }
1048
1049
1050 /* Get the next character in the module, updating our reckoning of
1051    where we are.  */
1052
1053 static int
1054 module_char (void)
1055 {
1056   int c;
1057
1058   c = getc (module_fp);
1059
1060   if (c == EOF)
1061     bad_module ("Unexpected EOF");
1062
1063   prev_module_line = module_line;
1064   prev_module_column = module_column;
1065   prev_character = c;
1066
1067   if (c == '\n')
1068     {
1069       module_line++;
1070       module_column = 0;
1071     }
1072
1073   module_column++;
1074   return c;
1075 }
1076
1077 /* Unget a character while remembering the line and column.  Works for
1078    a single character only.  */
1079
1080 static void
1081 module_unget_char (void)
1082 {
1083   module_line = prev_module_line;
1084   module_column = prev_module_column;
1085   ungetc (prev_character, module_fp);
1086 }
1087
1088 /* Parse a string constant.  The delimiter is guaranteed to be a
1089    single quote.  */
1090
1091 static void
1092 parse_string (void)
1093 {
1094   int c;
1095   size_t cursz = 30;
1096   size_t len = 0;
1097
1098   atom_string = XNEWVEC (char, cursz);
1099
1100   for ( ; ; )
1101     {
1102       c = module_char ();
1103
1104       if (c == '\'')
1105         {
1106           int c2 = module_char ();
1107           if (c2 != '\'')
1108             {
1109               module_unget_char ();
1110               break;
1111             }
1112         }
1113
1114       if (len >= cursz)
1115         {
1116           cursz *= 2;
1117           atom_string = XRESIZEVEC (char, atom_string, cursz);
1118         }
1119       atom_string[len] = c;
1120       len++;
1121     }
1122
1123   atom_string = XRESIZEVEC (char, atom_string, len + 1);
1124   atom_string[len] = '\0';      /* C-style string for debug purposes.  */
1125 }
1126
1127
1128 /* Parse a small integer.  */
1129
1130 static void
1131 parse_integer (int c)
1132 {
1133   atom_int = c - '0';
1134
1135   for (;;)
1136     {
1137       c = module_char ();
1138       if (!ISDIGIT (c))
1139         {
1140           module_unget_char ();
1141           break;
1142         }
1143
1144       atom_int = 10 * atom_int + c - '0';
1145       if (atom_int > 99999999)
1146         bad_module ("Integer overflow");
1147     }
1148
1149 }
1150
1151
1152 /* Parse a name.  */
1153
1154 static void
1155 parse_name (int c)
1156 {
1157   char *p;
1158   int len;
1159
1160   p = atom_name;
1161
1162   *p++ = c;
1163   len = 1;
1164
1165   for (;;)
1166     {
1167       c = module_char ();
1168       if (!ISALNUM (c) && c != '_' && c != '-')
1169         {
1170           module_unget_char ();
1171           break;
1172         }
1173
1174       *p++ = c;
1175       if (++len > GFC_MAX_SYMBOL_LEN)
1176         bad_module ("Name too long");
1177     }
1178
1179   *p = '\0';
1180
1181 }
1182
1183
1184 /* Read the next atom in the module's input stream.  */
1185
1186 static atom_type
1187 parse_atom (void)
1188 {
1189   int c;
1190
1191   do
1192     {
1193       c = module_char ();
1194     }
1195   while (c == ' ' || c == '\r' || c == '\n');
1196
1197   switch (c)
1198     {
1199     case '(':
1200       return ATOM_LPAREN;
1201
1202     case ')':
1203       return ATOM_RPAREN;
1204
1205     case '\'':
1206       parse_string ();
1207       return ATOM_STRING;
1208
1209     case '0':
1210     case '1':
1211     case '2':
1212     case '3':
1213     case '4':
1214     case '5':
1215     case '6':
1216     case '7':
1217     case '8':
1218     case '9':
1219       parse_integer (c);
1220       return ATOM_INTEGER;
1221
1222     case 'a':
1223     case 'b':
1224     case 'c':
1225     case 'd':
1226     case 'e':
1227     case 'f':
1228     case 'g':
1229     case 'h':
1230     case 'i':
1231     case 'j':
1232     case 'k':
1233     case 'l':
1234     case 'm':
1235     case 'n':
1236     case 'o':
1237     case 'p':
1238     case 'q':
1239     case 'r':
1240     case 's':
1241     case 't':
1242     case 'u':
1243     case 'v':
1244     case 'w':
1245     case 'x':
1246     case 'y':
1247     case 'z':
1248     case 'A':
1249     case 'B':
1250     case 'C':
1251     case 'D':
1252     case 'E':
1253     case 'F':
1254     case 'G':
1255     case 'H':
1256     case 'I':
1257     case 'J':
1258     case 'K':
1259     case 'L':
1260     case 'M':
1261     case 'N':
1262     case 'O':
1263     case 'P':
1264     case 'Q':
1265     case 'R':
1266     case 'S':
1267     case 'T':
1268     case 'U':
1269     case 'V':
1270     case 'W':
1271     case 'X':
1272     case 'Y':
1273     case 'Z':
1274       parse_name (c);
1275       return ATOM_NAME;
1276
1277     default:
1278       bad_module ("Bad name");
1279     }
1280
1281   /* Not reached.  */
1282 }
1283
1284
1285 /* Peek at the next atom on the input.  */
1286
1287 static atom_type
1288 peek_atom (void)
1289 {
1290   int c;
1291
1292   do
1293     {
1294       c = module_char ();
1295     }
1296   while (c == ' ' || c == '\r' || c == '\n');
1297
1298   switch (c)
1299     {
1300     case '(':
1301       module_unget_char ();
1302       return ATOM_LPAREN;
1303
1304     case ')':
1305       module_unget_char ();
1306       return ATOM_RPAREN;
1307
1308     case '\'':
1309       module_unget_char ();
1310       return ATOM_STRING;
1311
1312     case '0':
1313     case '1':
1314     case '2':
1315     case '3':
1316     case '4':
1317     case '5':
1318     case '6':
1319     case '7':
1320     case '8':
1321     case '9':
1322       module_unget_char ();
1323       return ATOM_INTEGER;
1324
1325     case 'a':
1326     case 'b':
1327     case 'c':
1328     case 'd':
1329     case 'e':
1330     case 'f':
1331     case 'g':
1332     case 'h':
1333     case 'i':
1334     case 'j':
1335     case 'k':
1336     case 'l':
1337     case 'm':
1338     case 'n':
1339     case 'o':
1340     case 'p':
1341     case 'q':
1342     case 'r':
1343     case 's':
1344     case 't':
1345     case 'u':
1346     case 'v':
1347     case 'w':
1348     case 'x':
1349     case 'y':
1350     case 'z':
1351     case 'A':
1352     case 'B':
1353     case 'C':
1354     case 'D':
1355     case 'E':
1356     case 'F':
1357     case 'G':
1358     case 'H':
1359     case 'I':
1360     case 'J':
1361     case 'K':
1362     case 'L':
1363     case 'M':
1364     case 'N':
1365     case 'O':
1366     case 'P':
1367     case 'Q':
1368     case 'R':
1369     case 'S':
1370     case 'T':
1371     case 'U':
1372     case 'V':
1373     case 'W':
1374     case 'X':
1375     case 'Y':
1376     case 'Z':
1377       module_unget_char ();
1378       return ATOM_NAME;
1379
1380     default:
1381       bad_module ("Bad name");
1382     }
1383 }
1384
1385
1386 /* Read the next atom from the input, requiring that it be a
1387    particular kind.  */
1388
1389 static void
1390 require_atom (atom_type type)
1391 {
1392   atom_type t;
1393   const char *p;
1394   int column, line;
1395
1396   column = module_column;
1397   line = module_line;
1398
1399   t = parse_atom ();
1400   if (t != type)
1401     {
1402       switch (type)
1403         {
1404         case ATOM_NAME:
1405           p = _("Expected name");
1406           break;
1407         case ATOM_LPAREN:
1408           p = _("Expected left parenthesis");
1409           break;
1410         case ATOM_RPAREN:
1411           p = _("Expected right parenthesis");
1412           break;
1413         case ATOM_INTEGER:
1414           p = _("Expected integer");
1415           break;
1416         case ATOM_STRING:
1417           p = _("Expected string");
1418           break;
1419         default:
1420           gfc_internal_error ("require_atom(): bad atom type required");
1421         }
1422
1423       module_column = column;
1424       module_line = line;
1425       bad_module (p);
1426     }
1427 }
1428
1429
1430 /* Given a pointer to an mstring array, require that the current input
1431    be one of the strings in the array.  We return the enum value.  */
1432
1433 static int
1434 find_enum (const mstring *m)
1435 {
1436   int i;
1437
1438   i = gfc_string2code (m, atom_name);
1439   if (i >= 0)
1440     return i;
1441
1442   bad_module ("find_enum(): Enum not found");
1443
1444   /* Not reached.  */
1445 }
1446
1447
1448 /* Read a string. The caller is responsible for freeing.  */
1449
1450 static char*
1451 read_string (void)
1452 {
1453   char* p;
1454   require_atom (ATOM_STRING);
1455   p = atom_string;
1456   atom_string = NULL;
1457   return p;
1458 }
1459
1460
1461 /**************** Module output subroutines ***************************/
1462
1463 /* Output a character to a module file.  */
1464
1465 static void
1466 write_char (char out)
1467 {
1468   if (putc (out, module_fp) == EOF)
1469     gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1470
1471   /* Add this to our MD5.  */
1472   md5_process_bytes (&out, sizeof (out), &ctx);
1473
1474   if (out != '\n')
1475     module_column++;
1476   else
1477     {
1478       module_column = 1;
1479       module_line++;
1480     }
1481 }
1482
1483
1484 /* Write an atom to a module.  The line wrapping isn't perfect, but it
1485    should work most of the time.  This isn't that big of a deal, since
1486    the file really isn't meant to be read by people anyway.  */
1487
1488 static void
1489 write_atom (atom_type atom, const void *v)
1490 {
1491   char buffer[20];
1492   int i, len;
1493   const char *p;
1494
1495   switch (atom)
1496     {
1497     case ATOM_STRING:
1498     case ATOM_NAME:
1499       p = (const char *) v;
1500       break;
1501
1502     case ATOM_LPAREN:
1503       p = "(";
1504       break;
1505
1506     case ATOM_RPAREN:
1507       p = ")";
1508       break;
1509
1510     case ATOM_INTEGER:
1511       i = *((const int *) v);
1512       if (i < 0)
1513         gfc_internal_error ("write_atom(): Writing negative integer");
1514
1515       sprintf (buffer, "%d", i);
1516       p = buffer;
1517       break;
1518
1519     default:
1520       gfc_internal_error ("write_atom(): Trying to write dab atom");
1521
1522     }
1523
1524   if(p == NULL || *p == '\0')
1525      len = 0;
1526   else
1527   len = strlen (p);
1528
1529   if (atom != ATOM_RPAREN)
1530     {
1531       if (module_column + len > 72)
1532         write_char ('\n');
1533       else
1534         {
1535
1536           if (last_atom != ATOM_LPAREN && module_column != 1)
1537             write_char (' ');
1538         }
1539     }
1540
1541   if (atom == ATOM_STRING)
1542     write_char ('\'');
1543
1544   while (p != NULL && *p)
1545     {
1546       if (atom == ATOM_STRING && *p == '\'')
1547         write_char ('\'');
1548       write_char (*p++);
1549     }
1550
1551   if (atom == ATOM_STRING)
1552     write_char ('\'');
1553
1554   last_atom = atom;
1555 }
1556
1557
1558
1559 /***************** Mid-level I/O subroutines *****************/
1560
1561 /* These subroutines let their caller read or write atoms without
1562    caring about which of the two is actually happening.  This lets a
1563    subroutine concentrate on the actual format of the data being
1564    written.  */
1565
1566 static void mio_expr (gfc_expr **);
1567 pointer_info *mio_symbol_ref (gfc_symbol **);
1568 pointer_info *mio_interface_rest (gfc_interface **);
1569 static void mio_symtree_ref (gfc_symtree **);
1570
1571 /* Read or write an enumerated value.  On writing, we return the input
1572    value for the convenience of callers.  We avoid using an integer
1573    pointer because enums are sometimes inside bitfields.  */
1574
1575 static int
1576 mio_name (int t, const mstring *m)
1577 {
1578   if (iomode == IO_OUTPUT)
1579     write_atom (ATOM_NAME, gfc_code2string (m, t));
1580   else
1581     {
1582       require_atom (ATOM_NAME);
1583       t = find_enum (m);
1584     }
1585
1586   return t;
1587 }
1588
1589 /* Specialization of mio_name.  */
1590
1591 #define DECL_MIO_NAME(TYPE) \
1592  static inline TYPE \
1593  MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1594  { \
1595    return (TYPE) mio_name ((int) t, m); \
1596  }
1597 #define MIO_NAME(TYPE) mio_name_##TYPE
1598
1599 static void
1600 mio_lparen (void)
1601 {
1602   if (iomode == IO_OUTPUT)
1603     write_atom (ATOM_LPAREN, NULL);
1604   else
1605     require_atom (ATOM_LPAREN);
1606 }
1607
1608
1609 static void
1610 mio_rparen (void)
1611 {
1612   if (iomode == IO_OUTPUT)
1613     write_atom (ATOM_RPAREN, NULL);
1614   else
1615     require_atom (ATOM_RPAREN);
1616 }
1617
1618
1619 static void
1620 mio_integer (int *ip)
1621 {
1622   if (iomode == IO_OUTPUT)
1623     write_atom (ATOM_INTEGER, ip);
1624   else
1625     {
1626       require_atom (ATOM_INTEGER);
1627       *ip = atom_int;
1628     }
1629 }
1630
1631
1632 /* Read or write a gfc_intrinsic_op value.  */
1633
1634 static void
1635 mio_intrinsic_op (gfc_intrinsic_op* op)
1636 {
1637   /* FIXME: Would be nicer to do this via the operators symbolic name.  */
1638   if (iomode == IO_OUTPUT)
1639     {
1640       int converted = (int) *op;
1641       write_atom (ATOM_INTEGER, &converted);
1642     }
1643   else
1644     {
1645       require_atom (ATOM_INTEGER);
1646       *op = (gfc_intrinsic_op) atom_int;
1647     }
1648 }
1649
1650
1651 /* Read or write a character pointer that points to a string on the heap.  */
1652
1653 static const char *
1654 mio_allocated_string (const char *s)
1655 {
1656   if (iomode == IO_OUTPUT)
1657     {
1658       write_atom (ATOM_STRING, s);
1659       return s;
1660     }
1661   else
1662     {
1663       require_atom (ATOM_STRING);
1664       return atom_string;
1665     }
1666 }
1667
1668
1669 /* Functions for quoting and unquoting strings.  */
1670
1671 static char *
1672 quote_string (const gfc_char_t *s, const size_t slength)
1673 {
1674   const gfc_char_t *p;
1675   char *res, *q;
1676   size_t len = 0, i;
1677
1678   /* Calculate the length we'll need: a backslash takes two ("\\"),
1679      non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
1680   for (p = s, i = 0; i < slength; p++, i++)
1681     {
1682       if (*p == '\\')
1683         len += 2;
1684       else if (!gfc_wide_is_printable (*p))
1685         len += 10;
1686       else
1687         len++;
1688     }
1689
1690   q = res = XCNEWVEC (char, len + 1);
1691   for (p = s, i = 0; i < slength; p++, i++)
1692     {
1693       if (*p == '\\')
1694         *q++ = '\\', *q++ = '\\';
1695       else if (!gfc_wide_is_printable (*p))
1696         {
1697           sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1698                    (unsigned HOST_WIDE_INT) *p);
1699           q += 10;
1700         }
1701       else
1702         *q++ = (unsigned char) *p;
1703     }
1704
1705   res[len] = '\0';
1706   return res;
1707 }
1708
1709 static gfc_char_t *
1710 unquote_string (const char *s)
1711 {
1712   size_t len, i;
1713   const char *p;
1714   gfc_char_t *res;
1715
1716   for (p = s, len = 0; *p; p++, len++)
1717     {
1718       if (*p != '\\')
1719         continue;
1720
1721       if (p[1] == '\\')
1722         p++;
1723       else if (p[1] == 'U')
1724         p += 9; /* That is a "\U????????". */
1725       else
1726         gfc_internal_error ("unquote_string(): got bad string");
1727     }
1728
1729   res = gfc_get_wide_string (len + 1);
1730   for (i = 0, p = s; i < len; i++, p++)
1731     {
1732       gcc_assert (*p);
1733
1734       if (*p != '\\')
1735         res[i] = (unsigned char) *p;
1736       else if (p[1] == '\\')
1737         {
1738           res[i] = (unsigned char) '\\';
1739           p++;
1740         }
1741       else
1742         {
1743           /* We read the 8-digits hexadecimal constant that follows.  */
1744           int j;
1745           unsigned n;
1746           gfc_char_t c = 0;
1747
1748           gcc_assert (p[1] == 'U');
1749           for (j = 0; j < 8; j++)
1750             {
1751               c = c << 4;
1752               gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1753               c += n;
1754             }
1755
1756           res[i] = c;
1757           p += 9;
1758         }
1759     }
1760
1761   res[len] = '\0';
1762   return res;
1763 }
1764
1765
1766 /* Read or write a character pointer that points to a wide string on the
1767    heap, performing quoting/unquoting of nonprintable characters using the
1768    form \U???????? (where each ? is a hexadecimal digit).
1769    Length is the length of the string, only known and used in output mode.  */
1770
1771 static const gfc_char_t *
1772 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1773 {
1774   if (iomode == IO_OUTPUT)
1775     {
1776       char *quoted = quote_string (s, length);
1777       write_atom (ATOM_STRING, quoted);
1778       free (quoted);
1779       return s;
1780     }
1781   else
1782     {
1783       gfc_char_t *unquoted;
1784
1785       require_atom (ATOM_STRING);
1786       unquoted = unquote_string (atom_string);
1787       free (atom_string);
1788       return unquoted;
1789     }
1790 }
1791
1792
1793 /* Read or write a string that is in static memory.  */
1794
1795 static void
1796 mio_pool_string (const char **stringp)
1797 {
1798   /* TODO: one could write the string only once, and refer to it via a
1799      fixup pointer.  */
1800
1801   /* As a special case we have to deal with a NULL string.  This
1802      happens for the 'module' member of 'gfc_symbol's that are not in a
1803      module.  We read / write these as the empty string.  */
1804   if (iomode == IO_OUTPUT)
1805     {
1806       const char *p = *stringp == NULL ? "" : *stringp;
1807       write_atom (ATOM_STRING, p);
1808     }
1809   else
1810     {
1811       require_atom (ATOM_STRING);
1812       *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1813       free (atom_string);
1814     }
1815 }
1816
1817
1818 /* Read or write a string that is inside of some already-allocated
1819    structure.  */
1820
1821 static void
1822 mio_internal_string (char *string)
1823 {
1824   if (iomode == IO_OUTPUT)
1825     write_atom (ATOM_STRING, string);
1826   else
1827     {
1828       require_atom (ATOM_STRING);
1829       strcpy (string, atom_string);
1830       free (atom_string);
1831     }
1832 }
1833
1834
1835 typedef enum
1836 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1837   AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1838   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1839   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1840   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
1841   AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
1842   AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
1843   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1844   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1845   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
1846   AB_IMPLICIT_PURE
1847 }
1848 ab_attribute;
1849
1850 static const mstring attr_bits[] =
1851 {
1852     minit ("ALLOCATABLE", AB_ALLOCATABLE),
1853     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
1854     minit ("DIMENSION", AB_DIMENSION),
1855     minit ("CODIMENSION", AB_CODIMENSION),
1856     minit ("CONTIGUOUS", AB_CONTIGUOUS),
1857     minit ("EXTERNAL", AB_EXTERNAL),
1858     minit ("INTRINSIC", AB_INTRINSIC),
1859     minit ("OPTIONAL", AB_OPTIONAL),
1860     minit ("POINTER", AB_POINTER),
1861     minit ("VOLATILE", AB_VOLATILE),
1862     minit ("TARGET", AB_TARGET),
1863     minit ("THREADPRIVATE", AB_THREADPRIVATE),
1864     minit ("DUMMY", AB_DUMMY),
1865     minit ("RESULT", AB_RESULT),
1866     minit ("DATA", AB_DATA),
1867     minit ("IN_NAMELIST", AB_IN_NAMELIST),
1868     minit ("IN_COMMON", AB_IN_COMMON),
1869     minit ("FUNCTION", AB_FUNCTION),
1870     minit ("SUBROUTINE", AB_SUBROUTINE),
1871     minit ("SEQUENCE", AB_SEQUENCE),
1872     minit ("ELEMENTAL", AB_ELEMENTAL),
1873     minit ("PURE", AB_PURE),
1874     minit ("RECURSIVE", AB_RECURSIVE),
1875     minit ("GENERIC", AB_GENERIC),
1876     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1877     minit ("CRAY_POINTER", AB_CRAY_POINTER),
1878     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1879     minit ("IS_BIND_C", AB_IS_BIND_C),
1880     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1881     minit ("IS_ISO_C", AB_IS_ISO_C),
1882     minit ("VALUE", AB_VALUE),
1883     minit ("ALLOC_COMP", AB_ALLOC_COMP),
1884     minit ("COARRAY_COMP", AB_COARRAY_COMP),
1885     minit ("LOCK_COMP", AB_LOCK_COMP),
1886     minit ("POINTER_COMP", AB_POINTER_COMP),
1887     minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
1888     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1889     minit ("ZERO_COMP", AB_ZERO_COMP),
1890     minit ("PROTECTED", AB_PROTECTED),
1891     minit ("ABSTRACT", AB_ABSTRACT),
1892     minit ("IS_CLASS", AB_IS_CLASS),
1893     minit ("PROCEDURE", AB_PROCEDURE),
1894     minit ("PROC_POINTER", AB_PROC_POINTER),
1895     minit ("VTYPE", AB_VTYPE),
1896     minit ("VTAB", AB_VTAB),
1897     minit ("CLASS_POINTER", AB_CLASS_POINTER),
1898     minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
1899     minit (NULL, -1)
1900 };
1901
1902 /* For binding attributes.  */
1903 static const mstring binding_passing[] =
1904 {
1905     minit ("PASS", 0),
1906     minit ("NOPASS", 1),
1907     minit (NULL, -1)
1908 };
1909 static const mstring binding_overriding[] =
1910 {
1911     minit ("OVERRIDABLE", 0),
1912     minit ("NON_OVERRIDABLE", 1),
1913     minit ("DEFERRED", 2),
1914     minit (NULL, -1)
1915 };
1916 static const mstring binding_generic[] =
1917 {
1918     minit ("SPECIFIC", 0),
1919     minit ("GENERIC", 1),
1920     minit (NULL, -1)
1921 };
1922 static const mstring binding_ppc[] =
1923 {
1924     minit ("NO_PPC", 0),
1925     minit ("PPC", 1),
1926     minit (NULL, -1)
1927 };
1928
1929 /* Specialization of mio_name.  */
1930 DECL_MIO_NAME (ab_attribute)
1931 DECL_MIO_NAME (ar_type)
1932 DECL_MIO_NAME (array_type)
1933 DECL_MIO_NAME (bt)
1934 DECL_MIO_NAME (expr_t)
1935 DECL_MIO_NAME (gfc_access)
1936 DECL_MIO_NAME (gfc_intrinsic_op)
1937 DECL_MIO_NAME (ifsrc)
1938 DECL_MIO_NAME (save_state)
1939 DECL_MIO_NAME (procedure_type)
1940 DECL_MIO_NAME (ref_type)
1941 DECL_MIO_NAME (sym_flavor)
1942 DECL_MIO_NAME (sym_intent)
1943 #undef DECL_MIO_NAME
1944
1945 /* Symbol attributes are stored in list with the first three elements
1946    being the enumerated fields, while the remaining elements (if any)
1947    indicate the individual attribute bits.  The access field is not
1948    saved-- it controls what symbols are exported when a module is
1949    written.  */
1950
1951 static void
1952 mio_symbol_attribute (symbol_attribute *attr)
1953 {
1954   atom_type t;
1955   unsigned ext_attr,extension_level;
1956
1957   mio_lparen ();
1958
1959   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1960   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1961   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1962   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1963   attr->save = MIO_NAME (save_state) (attr->save, save_status);
1964
1965   ext_attr = attr->ext_attr;
1966   mio_integer ((int *) &ext_attr);
1967   attr->ext_attr = ext_attr;
1968
1969   extension_level = attr->extension;
1970   mio_integer ((int *) &extension_level);
1971   attr->extension = extension_level;
1972
1973   if (iomode == IO_OUTPUT)
1974     {
1975       if (attr->allocatable)
1976         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1977       if (attr->asynchronous)
1978         MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
1979       if (attr->dimension)
1980         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1981       if (attr->codimension)
1982         MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
1983       if (attr->contiguous)
1984         MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
1985       if (attr->external)
1986         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1987       if (attr->intrinsic)
1988         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1989       if (attr->optional)
1990         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1991       if (attr->pointer)
1992         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1993       if (attr->class_pointer)
1994         MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
1995       if (attr->is_protected)
1996         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1997       if (attr->value)
1998         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1999       if (attr->volatile_)
2000         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2001       if (attr->target)
2002         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2003       if (attr->threadprivate)
2004         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2005       if (attr->dummy)
2006         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2007       if (attr->result)
2008         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2009       /* We deliberately don't preserve the "entry" flag.  */
2010
2011       if (attr->data)
2012         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2013       if (attr->in_namelist)
2014         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2015       if (attr->in_common)
2016         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2017
2018       if (attr->function)
2019         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2020       if (attr->subroutine)
2021         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2022       if (attr->generic)
2023         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2024       if (attr->abstract)
2025         MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2026
2027       if (attr->sequence)
2028         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2029       if (attr->elemental)
2030         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2031       if (attr->pure)
2032         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2033       if (attr->implicit_pure)
2034         MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2035       if (attr->recursive)
2036         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2037       if (attr->always_explicit)
2038         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2039       if (attr->cray_pointer)
2040         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2041       if (attr->cray_pointee)
2042         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2043       if (attr->is_bind_c)
2044         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2045       if (attr->is_c_interop)
2046         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2047       if (attr->is_iso_c)
2048         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2049       if (attr->alloc_comp)
2050         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2051       if (attr->pointer_comp)
2052         MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2053       if (attr->proc_pointer_comp)
2054         MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2055       if (attr->private_comp)
2056         MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2057       if (attr->coarray_comp)
2058         MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2059       if (attr->lock_comp)
2060         MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2061       if (attr->zero_comp)
2062         MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2063       if (attr->is_class)
2064         MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2065       if (attr->procedure)
2066         MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2067       if (attr->proc_pointer)
2068         MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2069       if (attr->vtype)
2070         MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2071       if (attr->vtab)
2072         MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2073
2074       mio_rparen ();
2075
2076     }
2077   else
2078     {
2079       for (;;)
2080         {
2081           t = parse_atom ();
2082           if (t == ATOM_RPAREN)
2083             break;
2084           if (t != ATOM_NAME)
2085             bad_module ("Expected attribute bit name");
2086
2087           switch ((ab_attribute) find_enum (attr_bits))
2088             {
2089             case AB_ALLOCATABLE:
2090               attr->allocatable = 1;
2091               break;
2092             case AB_ASYNCHRONOUS:
2093               attr->asynchronous = 1;
2094               break;
2095             case AB_DIMENSION:
2096               attr->dimension = 1;
2097               break;
2098             case AB_CODIMENSION:
2099               attr->codimension = 1;
2100               break;
2101             case AB_CONTIGUOUS:
2102               attr->contiguous = 1;
2103               break;
2104             case AB_EXTERNAL:
2105               attr->external = 1;
2106               break;
2107             case AB_INTRINSIC:
2108               attr->intrinsic = 1;
2109               break;
2110             case AB_OPTIONAL:
2111               attr->optional = 1;
2112               break;
2113             case AB_POINTER:
2114               attr->pointer = 1;
2115               break;
2116             case AB_CLASS_POINTER:
2117               attr->class_pointer = 1;
2118               break;
2119             case AB_PROTECTED:
2120               attr->is_protected = 1;
2121               break;
2122             case AB_VALUE:
2123               attr->value = 1;
2124               break;
2125             case AB_VOLATILE:
2126               attr->volatile_ = 1;
2127               break;
2128             case AB_TARGET:
2129               attr->target = 1;
2130               break;
2131             case AB_THREADPRIVATE:
2132               attr->threadprivate = 1;
2133               break;
2134             case AB_DUMMY:
2135               attr->dummy = 1;
2136               break;
2137             case AB_RESULT:
2138               attr->result = 1;
2139               break;
2140             case AB_DATA:
2141               attr->data = 1;
2142               break;
2143             case AB_IN_NAMELIST:
2144               attr->in_namelist = 1;
2145               break;
2146             case AB_IN_COMMON:
2147               attr->in_common = 1;
2148               break;
2149             case AB_FUNCTION:
2150               attr->function = 1;
2151               break;
2152             case AB_SUBROUTINE:
2153               attr->subroutine = 1;
2154               break;
2155             case AB_GENERIC:
2156               attr->generic = 1;
2157               break;
2158             case AB_ABSTRACT:
2159               attr->abstract = 1;
2160               break;
2161             case AB_SEQUENCE:
2162               attr->sequence = 1;
2163               break;
2164             case AB_ELEMENTAL:
2165               attr->elemental = 1;
2166               break;
2167             case AB_PURE:
2168               attr->pure = 1;
2169               break;
2170             case AB_IMPLICIT_PURE:
2171               attr->implicit_pure = 1;
2172               break;
2173             case AB_RECURSIVE:
2174               attr->recursive = 1;
2175               break;
2176             case AB_ALWAYS_EXPLICIT:
2177               attr->always_explicit = 1;
2178               break;
2179             case AB_CRAY_POINTER:
2180               attr->cray_pointer = 1;
2181               break;
2182             case AB_CRAY_POINTEE:
2183               attr->cray_pointee = 1;
2184               break;
2185             case AB_IS_BIND_C:
2186               attr->is_bind_c = 1;
2187               break;
2188             case AB_IS_C_INTEROP:
2189               attr->is_c_interop = 1;
2190               break;
2191             case AB_IS_ISO_C:
2192               attr->is_iso_c = 1;
2193               break;
2194             case AB_ALLOC_COMP:
2195               attr->alloc_comp = 1;
2196               break;
2197             case AB_COARRAY_COMP:
2198               attr->coarray_comp = 1;
2199               break;
2200             case AB_LOCK_COMP:
2201               attr->lock_comp = 1;
2202               break;
2203             case AB_POINTER_COMP:
2204               attr->pointer_comp = 1;
2205               break;
2206             case AB_PROC_POINTER_COMP:
2207               attr->proc_pointer_comp = 1;
2208               break;
2209             case AB_PRIVATE_COMP:
2210               attr->private_comp = 1;
2211               break;
2212             case AB_ZERO_COMP:
2213               attr->zero_comp = 1;
2214               break;
2215             case AB_IS_CLASS:
2216               attr->is_class = 1;
2217               break;
2218             case AB_PROCEDURE:
2219               attr->procedure = 1;
2220               break;
2221             case AB_PROC_POINTER:
2222               attr->proc_pointer = 1;
2223               break;
2224             case AB_VTYPE:
2225               attr->vtype = 1;
2226               break;
2227             case AB_VTAB:
2228               attr->vtab = 1;
2229               break;
2230             }
2231         }
2232     }
2233 }
2234
2235
2236 static const mstring bt_types[] = {
2237     minit ("INTEGER", BT_INTEGER),
2238     minit ("REAL", BT_REAL),
2239     minit ("COMPLEX", BT_COMPLEX),
2240     minit ("LOGICAL", BT_LOGICAL),
2241     minit ("CHARACTER", BT_CHARACTER),
2242     minit ("DERIVED", BT_DERIVED),
2243     minit ("CLASS", BT_CLASS),
2244     minit ("PROCEDURE", BT_PROCEDURE),
2245     minit ("UNKNOWN", BT_UNKNOWN),
2246     minit ("VOID", BT_VOID),
2247     minit (NULL, -1)
2248 };
2249
2250
2251 static void
2252 mio_charlen (gfc_charlen **clp)
2253 {
2254   gfc_charlen *cl;
2255
2256   mio_lparen ();
2257
2258   if (iomode == IO_OUTPUT)
2259     {
2260       cl = *clp;
2261       if (cl != NULL)
2262         mio_expr (&cl->length);
2263     }
2264   else
2265     {
2266       if (peek_atom () != ATOM_RPAREN)
2267         {
2268           cl = gfc_new_charlen (gfc_current_ns, NULL);
2269           mio_expr (&cl->length);
2270           *clp = cl;
2271         }
2272     }
2273
2274   mio_rparen ();
2275 }
2276
2277
2278 /* See if a name is a generated name.  */
2279
2280 static int
2281 check_unique_name (const char *name)
2282 {
2283   return *name == '@';
2284 }
2285
2286
2287 static void
2288 mio_typespec (gfc_typespec *ts)
2289 {
2290   mio_lparen ();
2291
2292   ts->type = MIO_NAME (bt) (ts->type, bt_types);
2293
2294   if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
2295     mio_integer (&ts->kind);
2296   else
2297     mio_symbol_ref (&ts->u.derived);
2298
2299   mio_symbol_ref (&ts->interface);
2300
2301   /* Add info for C interop and is_iso_c.  */
2302   mio_integer (&ts->is_c_interop);
2303   mio_integer (&ts->is_iso_c);
2304
2305   /* If the typespec is for an identifier either from iso_c_binding, or
2306      a constant that was initialized to an identifier from it, use the
2307      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
2308   if (ts->is_iso_c)
2309     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2310   else
2311     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2312
2313   if (ts->type != BT_CHARACTER)
2314     {
2315       /* ts->u.cl is only valid for BT_CHARACTER.  */
2316       mio_lparen ();
2317       mio_rparen ();
2318     }
2319   else
2320     mio_charlen (&ts->u.cl);
2321
2322   /* So as not to disturb the existing API, use an ATOM_NAME to
2323      transmit deferred characteristic for characters (F2003).  */
2324   if (iomode == IO_OUTPUT)
2325     {
2326       if (ts->type == BT_CHARACTER && ts->deferred)
2327         write_atom (ATOM_NAME, "DEFERRED_CL");
2328     }
2329   else if (peek_atom () != ATOM_RPAREN)
2330     {
2331       if (parse_atom () != ATOM_NAME)
2332         bad_module ("Expected string");
2333       ts->deferred = 1;
2334     }
2335
2336   mio_rparen ();
2337 }
2338
2339
2340 static const mstring array_spec_types[] = {
2341     minit ("EXPLICIT", AS_EXPLICIT),
2342     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2343     minit ("DEFERRED", AS_DEFERRED),
2344     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2345     minit (NULL, -1)
2346 };
2347
2348
2349 static void
2350 mio_array_spec (gfc_array_spec **asp)
2351 {
2352   gfc_array_spec *as;
2353   int i;
2354
2355   mio_lparen ();
2356
2357   if (iomode == IO_OUTPUT)
2358     {
2359       if (*asp == NULL)
2360         goto done;
2361       as = *asp;
2362     }
2363   else
2364     {
2365       if (peek_atom () == ATOM_RPAREN)
2366         {
2367           *asp = NULL;
2368           goto done;
2369         }
2370
2371       *asp = as = gfc_get_array_spec ();
2372     }
2373
2374   mio_integer (&as->rank);
2375   mio_integer (&as->corank);
2376   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2377
2378   if (iomode == IO_INPUT && as->corank)
2379     as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2380
2381   for (i = 0; i < as->rank + as->corank; i++)
2382     {
2383       mio_expr (&as->lower[i]);
2384       mio_expr (&as->upper[i]);
2385     }
2386
2387 done:
2388   mio_rparen ();
2389 }
2390
2391
2392 /* Given a pointer to an array reference structure (which lives in a
2393    gfc_ref structure), find the corresponding array specification
2394    structure.  Storing the pointer in the ref structure doesn't quite
2395    work when loading from a module. Generating code for an array
2396    reference also needs more information than just the array spec.  */
2397
2398 static const mstring array_ref_types[] = {
2399     minit ("FULL", AR_FULL),
2400     minit ("ELEMENT", AR_ELEMENT),
2401     minit ("SECTION", AR_SECTION),
2402     minit (NULL, -1)
2403 };
2404
2405
2406 static void
2407 mio_array_ref (gfc_array_ref *ar)
2408 {
2409   int i;
2410
2411   mio_lparen ();
2412   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2413   mio_integer (&ar->dimen);
2414
2415   switch (ar->type)
2416     {
2417     case AR_FULL:
2418       break;
2419
2420     case AR_ELEMENT:
2421       for (i = 0; i < ar->dimen; i++)
2422         mio_expr (&ar->start[i]);
2423
2424       break;
2425
2426     case AR_SECTION:
2427       for (i = 0; i < ar->dimen; i++)
2428         {
2429           mio_expr (&ar->start[i]);
2430           mio_expr (&ar->end[i]);
2431           mio_expr (&ar->stride[i]);
2432         }
2433
2434       break;
2435
2436     case AR_UNKNOWN:
2437       gfc_internal_error ("mio_array_ref(): Unknown array ref");
2438     }
2439
2440   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2441      we can't call mio_integer directly.  Instead loop over each element
2442      and cast it to/from an integer.  */
2443   if (iomode == IO_OUTPUT)
2444     {
2445       for (i = 0; i < ar->dimen; i++)
2446         {
2447           int tmp = (int)ar->dimen_type[i];
2448           write_atom (ATOM_INTEGER, &tmp);
2449         }
2450     }
2451   else
2452     {
2453       for (i = 0; i < ar->dimen; i++)
2454         {
2455           require_atom (ATOM_INTEGER);
2456           ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2457         }
2458     }
2459
2460   if (iomode == IO_INPUT)
2461     {
2462       ar->where = gfc_current_locus;
2463
2464       for (i = 0; i < ar->dimen; i++)
2465         ar->c_where[i] = gfc_current_locus;
2466     }
2467
2468   mio_rparen ();
2469 }
2470
2471
2472 /* Saves or restores a pointer.  The pointer is converted back and
2473    forth from an integer.  We return the pointer_info pointer so that
2474    the caller can take additional action based on the pointer type.  */
2475
2476 static pointer_info *
2477 mio_pointer_ref (void *gp)
2478 {
2479   pointer_info *p;
2480
2481   if (iomode == IO_OUTPUT)
2482     {
2483       p = get_pointer (*((char **) gp));
2484       write_atom (ATOM_INTEGER, &p->integer);
2485     }
2486   else
2487     {
2488       require_atom (ATOM_INTEGER);
2489       p = add_fixup (atom_int, gp);
2490     }
2491
2492   return p;
2493 }
2494
2495
2496 /* Save and load references to components that occur within
2497    expressions.  We have to describe these references by a number and
2498    by name.  The number is necessary for forward references during
2499    reading, and the name is necessary if the symbol already exists in
2500    the namespace and is not loaded again.  */
2501
2502 static void
2503 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2504 {
2505   char name[GFC_MAX_SYMBOL_LEN + 1];
2506   gfc_component *q;
2507   pointer_info *p;
2508
2509   p = mio_pointer_ref (cp);
2510   if (p->type == P_UNKNOWN)
2511     p->type = P_COMPONENT;
2512
2513   if (iomode == IO_OUTPUT)
2514     mio_pool_string (&(*cp)->name);
2515   else
2516     {
2517       mio_internal_string (name);
2518
2519       if (sym && sym->attr.is_class)
2520         sym = sym->components->ts.u.derived;
2521
2522       /* It can happen that a component reference can be read before the
2523          associated derived type symbol has been loaded. Return now and
2524          wait for a later iteration of load_needed.  */
2525       if (sym == NULL)
2526         return;
2527
2528       if (sym->components != NULL && p->u.pointer == NULL)
2529         {
2530           /* Symbol already loaded, so search by name.  */
2531           q = gfc_find_component (sym, name, true, true);
2532
2533           if (q)
2534             associate_integer_pointer (p, q);
2535         }
2536
2537       /* Make sure this symbol will eventually be loaded.  */
2538       p = find_pointer2 (sym);
2539       if (p->u.rsym.state == UNUSED)
2540         p->u.rsym.state = NEEDED;
2541     }
2542 }
2543
2544
2545 static void mio_namespace_ref (gfc_namespace **nsp);
2546 static void mio_formal_arglist (gfc_formal_arglist **formal);
2547 static void mio_typebound_proc (gfc_typebound_proc** proc);
2548
2549 static void
2550 mio_component (gfc_component *c, int vtype)
2551 {
2552   pointer_info *p;
2553   int n;
2554   gfc_formal_arglist *formal;
2555
2556   mio_lparen ();
2557
2558   if (iomode == IO_OUTPUT)
2559     {
2560       p = get_pointer (c);
2561       mio_integer (&p->integer);
2562     }
2563   else
2564     {
2565       mio_integer (&n);
2566       p = get_integer (n);
2567       associate_integer_pointer (p, c);
2568     }
2569
2570   if (p->type == P_UNKNOWN)
2571     p->type = P_COMPONENT;
2572
2573   mio_pool_string (&c->name);
2574   mio_typespec (&c->ts);
2575   mio_array_spec (&c->as);
2576
2577   mio_symbol_attribute (&c->attr);
2578   if (c->ts.type == BT_CLASS)
2579     c->attr.class_ok = 1;
2580   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2581
2582   if (!vtype)
2583     mio_expr (&c->initializer);
2584
2585   if (c->attr.proc_pointer)
2586     {
2587       if (iomode == IO_OUTPUT)
2588         {
2589           formal = c->formal;
2590           while (formal && !formal->sym)
2591             formal = formal->next;
2592
2593           if (formal)
2594             mio_namespace_ref (&formal->sym->ns);
2595           else
2596             mio_namespace_ref (&c->formal_ns);
2597         }
2598       else
2599         {
2600           mio_namespace_ref (&c->formal_ns);
2601           /* TODO: if (c->formal_ns)
2602             {
2603               c->formal_ns->proc_name = c;
2604               c->refs++;
2605             }*/
2606         }
2607
2608       mio_formal_arglist (&c->formal);
2609
2610       mio_typebound_proc (&c->tb);
2611     }
2612
2613   mio_rparen ();
2614 }
2615
2616
2617 static void
2618 mio_component_list (gfc_component **cp, int vtype)
2619 {
2620   gfc_component *c, *tail;
2621
2622   mio_lparen ();
2623
2624   if (iomode == IO_OUTPUT)
2625     {
2626       for (c = *cp; c; c = c->next)
2627         mio_component (c, vtype);
2628     }
2629   else
2630     {
2631       *cp = NULL;
2632       tail = NULL;
2633
2634       for (;;)
2635         {
2636           if (peek_atom () == ATOM_RPAREN)
2637             break;
2638
2639           c = gfc_get_component ();
2640           mio_component (c, vtype);
2641
2642           if (tail == NULL)
2643             *cp = c;
2644           else
2645             tail->next = c;
2646
2647           tail = c;
2648         }
2649     }
2650
2651   mio_rparen ();
2652 }
2653
2654
2655 static void
2656 mio_actual_arg (gfc_actual_arglist *a)
2657 {
2658   mio_lparen ();
2659   mio_pool_string (&a->name);
2660   mio_expr (&a->expr);
2661   mio_rparen ();
2662 }
2663
2664
2665 static void
2666 mio_actual_arglist (gfc_actual_arglist **ap)
2667 {
2668   gfc_actual_arglist *a, *tail;
2669
2670   mio_lparen ();
2671
2672   if (iomode == IO_OUTPUT)
2673     {
2674       for (a = *ap; a; a = a->next)
2675         mio_actual_arg (a);
2676
2677     }
2678   else
2679     {
2680       tail = NULL;
2681
2682       for (;;)
2683         {
2684           if (peek_atom () != ATOM_LPAREN)
2685             break;
2686
2687           a = gfc_get_actual_arglist ();
2688
2689           if (tail == NULL)
2690             *ap = a;
2691           else
2692             tail->next = a;
2693
2694           tail = a;
2695           mio_actual_arg (a);
2696         }
2697     }
2698
2699   mio_rparen ();
2700 }
2701
2702
2703 /* Read and write formal argument lists.  */
2704
2705 static void
2706 mio_formal_arglist (gfc_formal_arglist **formal)
2707 {
2708   gfc_formal_arglist *f, *tail;
2709
2710   mio_lparen ();
2711
2712   if (iomode == IO_OUTPUT)
2713     {
2714       for (f = *formal; f; f = f->next)
2715         mio_symbol_ref (&f->sym);
2716     }
2717   else
2718     {
2719       *formal = tail = NULL;
2720
2721       while (peek_atom () != ATOM_RPAREN)
2722         {
2723           f = gfc_get_formal_arglist ();
2724           mio_symbol_ref (&f->sym);
2725
2726           if (*formal == NULL)
2727             *formal = f;
2728           else
2729             tail->next = f;
2730
2731           tail = f;
2732         }
2733     }
2734
2735   mio_rparen ();
2736 }
2737
2738
2739 /* Save or restore a reference to a symbol node.  */
2740
2741 pointer_info *
2742 mio_symbol_ref (gfc_symbol **symp)
2743 {
2744   pointer_info *p;
2745
2746   p = mio_pointer_ref (symp);
2747   if (p->type == P_UNKNOWN)
2748     p->type = P_SYMBOL;
2749
2750   if (iomode == IO_OUTPUT)
2751     {
2752       if (p->u.wsym.state == UNREFERENCED)
2753         p->u.wsym.state = NEEDS_WRITE;
2754     }
2755   else
2756     {
2757       if (p->u.rsym.state == UNUSED)
2758         p->u.rsym.state = NEEDED;
2759     }
2760   return p;
2761 }
2762
2763
2764 /* Save or restore a reference to a symtree node.  */
2765
2766 static void
2767 mio_symtree_ref (gfc_symtree **stp)
2768 {
2769   pointer_info *p;
2770   fixup_t *f;
2771
2772   if (iomode == IO_OUTPUT)
2773     mio_symbol_ref (&(*stp)->n.sym);
2774   else
2775     {
2776       require_atom (ATOM_INTEGER);
2777       p = get_integer (atom_int);
2778
2779       /* An unused equivalence member; make a symbol and a symtree
2780          for it.  */
2781       if (in_load_equiv && p->u.rsym.symtree == NULL)
2782         {
2783           /* Since this is not used, it must have a unique name.  */
2784           p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2785
2786           /* Make the symbol.  */
2787           if (p->u.rsym.sym == NULL)
2788             {
2789               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2790                                               gfc_current_ns);
2791               p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2792             }
2793
2794           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2795           p->u.rsym.symtree->n.sym->refs++;
2796           p->u.rsym.referenced = 1;
2797
2798           /* If the symbol is PRIVATE and in COMMON, load_commons will
2799              generate a fixup symbol, which must be associated.  */
2800           if (p->fixup)
2801             resolve_fixups (p->fixup, p->u.rsym.sym);
2802           p->fixup = NULL;
2803         }
2804
2805       if (p->type == P_UNKNOWN)
2806         p->type = P_SYMBOL;
2807
2808       if (p->u.rsym.state == UNUSED)
2809         p->u.rsym.state = NEEDED;
2810
2811       if (p->u.rsym.symtree != NULL)
2812         {
2813           *stp = p->u.rsym.symtree;
2814         }
2815       else
2816         {
2817           f = XCNEW (fixup_t);
2818
2819           f->next = p->u.rsym.stfixup;
2820           p->u.rsym.stfixup = f;
2821
2822           f->pointer = (void **) stp;
2823         }
2824     }
2825 }
2826
2827
2828 static void
2829 mio_iterator (gfc_iterator **ip)
2830 {
2831   gfc_iterator *iter;
2832
2833   mio_lparen ();
2834
2835   if (iomode == IO_OUTPUT)
2836     {
2837       if (*ip == NULL)
2838         goto done;
2839     }
2840   else
2841     {
2842       if (peek_atom () == ATOM_RPAREN)
2843         {
2844           *ip = NULL;
2845           goto done;
2846         }
2847
2848       *ip = gfc_get_iterator ();
2849     }
2850
2851   iter = *ip;
2852
2853   mio_expr (&iter->var);
2854   mio_expr (&iter->start);
2855   mio_expr (&iter->end);
2856   mio_expr (&iter->step);
2857
2858 done:
2859   mio_rparen ();
2860 }
2861
2862
2863 static void
2864 mio_constructor (gfc_constructor_base *cp)
2865 {
2866   gfc_constructor *c;
2867
2868   mio_lparen ();
2869
2870   if (iomode == IO_OUTPUT)
2871     {
2872       for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
2873         {
2874           mio_lparen ();
2875           mio_expr (&c->expr);
2876           mio_iterator (&c->iterator);
2877           mio_rparen ();
2878         }
2879     }
2880   else
2881     {
2882       while (peek_atom () != ATOM_RPAREN)
2883         {
2884           c = gfc_constructor_append_expr (cp, NULL, NULL);
2885
2886           mio_lparen ();
2887           mio_expr (&c->expr);
2888           mio_iterator (&c->iterator);
2889           mio_rparen ();
2890         }
2891     }
2892
2893   mio_rparen ();
2894 }
2895
2896
2897 static const mstring ref_types[] = {
2898     minit ("ARRAY", REF_ARRAY),
2899     minit ("COMPONENT", REF_COMPONENT),
2900     minit ("SUBSTRING", REF_SUBSTRING),
2901     minit (NULL, -1)
2902 };
2903
2904
2905 static void
2906 mio_ref (gfc_ref **rp)
2907 {
2908   gfc_ref *r;
2909
2910   mio_lparen ();
2911
2912   r = *rp;
2913   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2914
2915   switch (r->type)
2916     {
2917     case REF_ARRAY:
2918       mio_array_ref (&r->u.ar);
2919       break;
2920
2921     case REF_COMPONENT:
2922       mio_symbol_ref (&r->u.c.sym);
2923       mio_component_ref (&r->u.c.component, r->u.c.sym);
2924       break;
2925
2926     case REF_SUBSTRING:
2927       mio_expr (&r->u.ss.start);
2928       mio_expr (&r->u.ss.end);
2929       mio_charlen (&r->u.ss.length);
2930       break;
2931     }
2932
2933   mio_rparen ();
2934 }
2935
2936
2937 static void
2938 mio_ref_list (gfc_ref **rp)
2939 {
2940   gfc_ref *ref, *head, *tail;
2941
2942   mio_lparen ();
2943
2944   if (iomode == IO_OUTPUT)
2945     {
2946       for (ref = *rp; ref; ref = ref->next)
2947         mio_ref (&ref);
2948     }
2949   else
2950     {
2951       head = tail = NULL;
2952
2953       while (peek_atom () != ATOM_RPAREN)
2954         {
2955           if (head == NULL)
2956             head = tail = gfc_get_ref ();
2957           else
2958             {
2959               tail->next = gfc_get_ref ();
2960               tail = tail->next;
2961             }
2962
2963           mio_ref (&tail);
2964         }
2965
2966       *rp = head;
2967     }
2968
2969   mio_rparen ();
2970 }
2971
2972
2973 /* Read and write an integer value.  */
2974
2975 static void
2976 mio_gmp_integer (mpz_t *integer)
2977 {
2978   char *p;
2979
2980   if (iomode == IO_INPUT)
2981     {
2982       if (parse_atom () != ATOM_STRING)
2983         bad_module ("Expected integer string");
2984
2985       mpz_init (*integer);
2986       if (mpz_set_str (*integer, atom_string, 10))
2987         bad_module ("Error converting integer");
2988
2989       free (atom_string);
2990     }
2991   else
2992     {
2993       p = mpz_get_str (NULL, 10, *integer);
2994       write_atom (ATOM_STRING, p);
2995       free (p);
2996     }
2997 }
2998
2999
3000 static void
3001 mio_gmp_real (mpfr_t *real)
3002 {
3003   mp_exp_t exponent;
3004   char *p;
3005
3006   if (iomode == IO_INPUT)
3007     {
3008       if (parse_atom () != ATOM_STRING)
3009         bad_module ("Expected real string");
3010
3011       mpfr_init (*real);
3012       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3013       free (atom_string);
3014     }
3015   else
3016     {
3017       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3018
3019       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3020         {
3021           write_atom (ATOM_STRING, p);
3022           free (p);
3023           return;
3024         }
3025
3026       atom_string = XCNEWVEC (char, strlen (p) + 20);
3027
3028       sprintf (atom_string, "0.%s@%ld", p, exponent);
3029
3030       /* Fix negative numbers.  */
3031       if (atom_string[2] == '-')
3032         {
3033           atom_string[0] = '-';
3034           atom_string[1] = '0';
3035           atom_string[2] = '.';
3036         }
3037
3038       write_atom (ATOM_STRING, atom_string);
3039
3040       free (atom_string);
3041       free (p);
3042     }
3043 }
3044
3045
3046 /* Save and restore the shape of an array constructor.  */
3047
3048 static void
3049 mio_shape (mpz_t **pshape, int rank)
3050 {
3051   mpz_t *shape;
3052   atom_type t;
3053   int n;
3054
3055   /* A NULL shape is represented by ().  */
3056   mio_lparen ();
3057
3058   if (iomode == IO_OUTPUT)
3059     {
3060       shape = *pshape;
3061       if (!shape)
3062         {
3063           mio_rparen ();
3064           return;
3065         }
3066     }
3067   else
3068     {
3069       t = peek_atom ();
3070       if (t == ATOM_RPAREN)
3071         {
3072           *pshape = NULL;
3073           mio_rparen ();
3074           return;
3075         }
3076
3077       shape = gfc_get_shape (rank);
3078       *pshape = shape;
3079     }
3080
3081   for (n = 0; n < rank; n++)
3082     mio_gmp_integer (&shape[n]);
3083
3084   mio_rparen ();
3085 }
3086
3087
3088 static const mstring expr_types[] = {
3089     minit ("OP", EXPR_OP),
3090     minit ("FUNCTION", EXPR_FUNCTION),
3091     minit ("CONSTANT", EXPR_CONSTANT),
3092     minit ("VARIABLE", EXPR_VARIABLE),
3093     minit ("SUBSTRING", EXPR_SUBSTRING),
3094     minit ("STRUCTURE", EXPR_STRUCTURE),
3095     minit ("ARRAY", EXPR_ARRAY),
3096     minit ("NULL", EXPR_NULL),
3097     minit ("COMPCALL", EXPR_COMPCALL),
3098     minit (NULL, -1)
3099 };
3100
3101 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3102    generic operators, not in expressions.  INTRINSIC_USER is also
3103    replaced by the correct function name by the time we see it.  */
3104
3105 static const mstring intrinsics[] =
3106 {
3107     minit ("UPLUS", INTRINSIC_UPLUS),
3108     minit ("UMINUS", INTRINSIC_UMINUS),
3109     minit ("PLUS", INTRINSIC_PLUS),
3110     minit ("MINUS", INTRINSIC_MINUS),
3111     minit ("TIMES", INTRINSIC_TIMES),
3112     minit ("DIVIDE", INTRINSIC_DIVIDE),
3113     minit ("POWER", INTRINSIC_POWER),
3114     minit ("CONCAT", INTRINSIC_CONCAT),
3115     minit ("AND", INTRINSIC_AND),
3116     minit ("OR", INTRINSIC_OR),
3117     minit ("EQV", INTRINSIC_EQV),
3118     minit ("NEQV", INTRINSIC_NEQV),
3119     minit ("EQ_SIGN", INTRINSIC_EQ),
3120     minit ("EQ", INTRINSIC_EQ_OS),
3121     minit ("NE_SIGN", INTRINSIC_NE),
3122     minit ("NE", INTRINSIC_NE_OS),
3123     minit ("GT_SIGN", INTRINSIC_GT),
3124     minit ("GT", INTRINSIC_GT_OS),
3125     minit ("GE_SIGN", INTRINSIC_GE),
3126     minit ("GE", INTRINSIC_GE_OS),
3127     minit ("LT_SIGN", INTRINSIC_LT),
3128     minit ("LT", INTRINSIC_LT_OS),
3129     minit ("LE_SIGN", INTRINSIC_LE),
3130     minit ("LE", INTRINSIC_LE_OS),
3131     minit ("NOT", INTRINSIC_NOT),
3132     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3133     minit (NULL, -1)
3134 };
3135
3136
3137 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
3138
3139 static void
3140 fix_mio_expr (gfc_expr *e)
3141 {
3142   gfc_symtree *ns_st = NULL;
3143   const char *fname;
3144
3145   if (iomode != IO_OUTPUT)
3146     return;
3147
3148   if (e->symtree)
3149     {
3150       /* If this is a symtree for a symbol that came from a contained module
3151          namespace, it has a unique name and we should look in the current
3152          namespace to see if the required, non-contained symbol is available
3153          yet. If so, the latter should be written.  */
3154       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3155         {
3156           const char *name = e->symtree->n.sym->name;
3157           if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
3158             name = dt_upper_string (name);
3159           ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3160         }
3161
3162       /* On the other hand, if the existing symbol is the module name or the
3163          new symbol is a dummy argument, do not do the promotion.  */
3164       if (ns_st && ns_st->n.sym
3165           && ns_st->n.sym->attr.flavor != FL_MODULE
3166           && !e->symtree->n.sym->attr.dummy)
3167         e->symtree = ns_st;
3168     }
3169   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
3170     {
3171       gfc_symbol *sym;
3172
3173       /* In some circumstances, a function used in an initialization
3174          expression, in one use associated module, can fail to be
3175          coupled to its symtree when used in a specification
3176          expression in another module.  */
3177       fname = e->value.function.esym ? e->value.function.esym->name
3178                                      : e->value.function.isym->name;
3179       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3180
3181       if (e->symtree)
3182         return;
3183
3184       /* This is probably a reference to a private procedure from another
3185          module.  To prevent a segfault, make a generic with no specific
3186          instances.  If this module is used, without the required
3187          specific coming from somewhere, the appropriate error message
3188          is issued.  */
3189       gfc_get_symbol (fname, gfc_current_ns, &sym);
3190       sym->attr.flavor = FL_PROCEDURE;
3191       sym->attr.generic = 1;
3192       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3193       gfc_commit_symbol (sym);
3194     }
3195 }
3196
3197
3198 /* Read and write expressions.  The form "()" is allowed to indicate a
3199    NULL expression.  */
3200
3201 static void
3202 mio_expr (gfc_expr **ep)
3203 {
3204   gfc_expr *e;
3205   atom_type t;
3206   int flag;
3207
3208   mio_lparen ();
3209
3210   if (iomode == IO_OUTPUT)
3211     {
3212       if (*ep == NULL)
3213         {
3214           mio_rparen ();
3215           return;
3216         }
3217
3218       e = *ep;
3219       MIO_NAME (expr_t) (e->expr_type, expr_types);
3220     }
3221   else
3222     {
3223       t = parse_atom ();
3224       if (t == ATOM_RPAREN)
3225         {
3226           *ep = NULL;
3227           return;
3228         }
3229
3230       if (t != ATOM_NAME)
3231         bad_module ("Expected expression type");
3232
3233       e = *ep = gfc_get_expr ();
3234       e->where = gfc_current_locus;
3235       e->expr_type = (expr_t) find_enum (expr_types);
3236     }
3237
3238   mio_typespec (&e->ts);
3239   mio_integer (&e->rank);
3240
3241   fix_mio_expr (e);
3242
3243   switch (e->expr_type)
3244     {
3245     case EXPR_OP:
3246       e->value.op.op
3247         = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3248
3249       switch (e->value.op.op)
3250         {
3251         case INTRINSIC_UPLUS:
3252         case INTRINSIC_UMINUS:
3253         case INTRINSIC_NOT:
3254         case INTRINSIC_PARENTHESES:
3255           mio_expr (&e->value.op.op1);
3256           break;
3257
3258         case INTRINSIC_PLUS:
3259         case INTRINSIC_MINUS:
3260         case INTRINSIC_TIMES:
3261         case INTRINSIC_DIVIDE:
3262         case INTRINSIC_POWER:
3263         case INTRINSIC_CONCAT:
3264         case INTRINSIC_AND:
3265         case INTRINSIC_OR:
3266         case INTRINSIC_EQV:
3267         case INTRINSIC_NEQV:
3268         case INTRINSIC_EQ:
3269         case INTRINSIC_EQ_OS:
3270         case INTRINSIC_NE:
3271         case INTRINSIC_NE_OS:
3272         case INTRINSIC_GT:
3273         case INTRINSIC_GT_OS:
3274         case INTRINSIC_GE:
3275         case INTRINSIC_GE_OS:
3276         case INTRINSIC_LT:
3277         case INTRINSIC_LT_OS:
3278         case INTRINSIC_LE:
3279         case INTRINSIC_LE_OS:
3280           mio_expr (&e->value.op.op1);
3281           mio_expr (&e->value.op.op2);
3282           break;
3283
3284         default:
3285           bad_module ("Bad operator");
3286         }
3287
3288       break;
3289
3290     case EXPR_FUNCTION:
3291       mio_symtree_ref (&e->symtree);
3292       mio_actual_arglist (&e->value.function.actual);
3293
3294       if (iomode == IO_OUTPUT)
3295         {
3296           e->value.function.name
3297             = mio_allocated_string (e->value.function.name);
3298           flag = e->value.function.esym != NULL;
3299           mio_integer (&flag);
3300           if (flag)
3301             mio_symbol_ref (&e->value.function.esym);
3302           else
3303             write_atom (ATOM_STRING, e->value.function.isym->name);
3304         }
3305       else
3306         {
3307           require_atom (ATOM_STRING);
3308           e->value.function.name = gfc_get_string (atom_string);
3309           free (atom_string);
3310
3311           mio_integer (&flag);
3312           if (flag)
3313             mio_symbol_ref (&e->value.function.esym);
3314           else
3315             {
3316               require_atom (ATOM_STRING);
3317               e->value.function.isym = gfc_find_function (atom_string);
3318               free (atom_string);
3319             }
3320         }
3321
3322       break;
3323
3324     case EXPR_VARIABLE:
3325       mio_symtree_ref (&e->symtree);
3326       mio_ref_list (&e->ref);
3327       break;
3328
3329     case EXPR_SUBSTRING:
3330       e->value.character.string
3331         = CONST_CAST (gfc_char_t *,
3332                       mio_allocated_wide_string (e->value.character.string,
3333                                                  e->value.character.length));
3334       mio_ref_list (&e->ref);
3335       break;
3336
3337     case EXPR_STRUCTURE:
3338     case EXPR_ARRAY:
3339       mio_constructor (&e->value.constructor);
3340       mio_shape (&e->shape, e->rank);
3341       break;
3342
3343     case EXPR_CONSTANT:
3344       switch (e->ts.type)
3345         {
3346         case BT_INTEGER:
3347           mio_gmp_integer (&e->value.integer);
3348           break;
3349
3350         case BT_REAL:
3351           gfc_set_model_kind (e->ts.kind);
3352           mio_gmp_real (&e->value.real);
3353           break;
3354
3355         case BT_COMPLEX:
3356           gfc_set_model_kind (e->ts.kind);
3357           mio_gmp_real (&mpc_realref (e->value.complex));
3358           mio_gmp_real (&mpc_imagref (e->value.complex));
3359           break;
3360
3361         case BT_LOGICAL:
3362           mio_integer (&e->value.logical);
3363           break;
3364
3365         case BT_CHARACTER:
3366           mio_integer (&e->value.character.length);
3367           e->value.character.string
3368             = CONST_CAST (gfc_char_t *,
3369                           mio_allocated_wide_string (e->value.character.string,
3370                                                      e->value.character.length));
3371           break;
3372
3373         default:
3374           bad_module ("Bad type in constant expression");
3375         }
3376
3377       break;
3378
3379     case EXPR_NULL:
3380       break;
3381
3382     case EXPR_COMPCALL:
3383     case EXPR_PPC:
3384       gcc_unreachable ();
3385       break;
3386     }
3387
3388   mio_rparen ();
3389 }
3390
3391
3392 /* Read and write namelists.  */
3393
3394 static void
3395 mio_namelist (gfc_symbol *sym)
3396 {
3397   gfc_namelist *n, *m;
3398   const char *check_name;
3399
3400   mio_lparen ();
3401
3402   if (iomode == IO_OUTPUT)
3403     {
3404       for (n = sym->namelist; n; n = n->next)
3405         mio_symbol_ref (&n->sym);
3406     }
3407   else
3408     {
3409       /* This departure from the standard is flagged as an error.
3410          It does, in fact, work correctly. TODO: Allow it
3411          conditionally?  */
3412       if (sym->attr.flavor == FL_NAMELIST)
3413         {
3414           check_name = find_use_name (sym->name, false);
3415           if (check_name && strcmp (check_name, sym->name) != 0)
3416             gfc_error ("Namelist %s cannot be renamed by USE "
3417                        "association to %s", sym->name, check_name);
3418         }
3419
3420       m = NULL;
3421       while (peek_atom () != ATOM_RPAREN)
3422         {
3423           n = gfc_get_namelist ();
3424           mio_symbol_ref (&n->sym);
3425
3426           if (sym->namelist == NULL)
3427             sym->namelist = n;
3428           else
3429             m->next = n;
3430
3431           m = n;
3432         }
3433       sym->namelist_tail = m;
3434     }
3435
3436   mio_rparen ();
3437 }
3438
3439
3440 /* Save/restore lists of gfc_interface structures.  When loading an
3441    interface, we are really appending to the existing list of
3442    interfaces.  Checking for duplicate and ambiguous interfaces has to
3443    be done later when all symbols have been loaded.  */
3444
3445 pointer_info *
3446 mio_interface_rest (gfc_interface **ip)
3447 {
3448   gfc_interface *tail, *p;
3449   pointer_info *pi = NULL;
3450
3451   if (iomode == IO_OUTPUT)
3452     {
3453       if (ip != NULL)
3454         for (p = *ip; p; p = p->next)
3455           mio_symbol_ref (&p->sym);
3456     }
3457   else
3458     {
3459       if (*ip == NULL)
3460         tail = NULL;
3461       else
3462         {
3463           tail = *ip;
3464           while (tail->next)
3465             tail = tail->next;
3466         }
3467
3468       for (;;)
3469         {
3470           if (peek_atom () == ATOM_RPAREN)
3471             break;
3472
3473           p = gfc_get_interface ();
3474           p->where = gfc_current_locus;
3475           pi = mio_symbol_ref (&p->sym);
3476
3477           if (tail == NULL)
3478             *ip = p;
3479           else
3480             tail->next = p;
3481
3482           tail = p;
3483         }
3484     }
3485
3486   mio_rparen ();
3487   return pi;
3488 }
3489
3490
3491 /* Save/restore a nameless operator interface.  */
3492
3493 static void
3494 mio_interface (gfc_interface **ip)
3495 {
3496   mio_lparen ();
3497   mio_interface_rest (ip);
3498 }
3499
3500
3501 /* Save/restore a named operator interface.  */
3502
3503 static void
3504 mio_symbol_interface (const char **name, const char **module,
3505                       gfc_interface **ip)
3506 {
3507   mio_lparen ();
3508   mio_pool_string (name);
3509   mio_pool_string (module);
3510   mio_interface_rest (ip);
3511 }
3512
3513
3514 static void
3515 mio_namespace_ref (gfc_namespace **nsp)
3516 {
3517   gfc_namespace *ns;
3518   pointer_info *p;
3519
3520   p = mio_pointer_ref (nsp);
3521
3522   if (p->type == P_UNKNOWN)
3523     p->type = P_NAMESPACE;
3524
3525   if (iomode == IO_INPUT && p->integer != 0)
3526     {
3527       ns = (gfc_namespace *) p->u.pointer;
3528       if (ns == NULL)
3529         {
3530           ns = gfc_get_namespace (NULL, 0);
3531           associate_integer_pointer (p, ns);
3532         }
3533       else
3534         ns->refs++;
3535     }
3536 }
3537
3538
3539 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
3540
3541 static gfc_namespace* current_f2k_derived;
3542
3543 static void
3544 mio_typebound_proc (gfc_typebound_proc** proc)
3545 {
3546   int flag;
3547   int overriding_flag;
3548
3549   if (iomode == IO_INPUT)
3550     {
3551       *proc = gfc_get_typebound_proc (NULL);
3552       (*proc)->where = gfc_current_locus;
3553     }
3554   gcc_assert (*proc);
3555
3556   mio_lparen ();
3557
3558   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3559
3560   /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
3561   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3562   overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3563   overriding_flag = mio_name (overriding_flag, binding_overriding);
3564   (*proc)->deferred = ((overriding_flag & 2) != 0);
3565   (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3566   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3567
3568   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3569   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3570   (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3571
3572   mio_pool_string (&((*proc)->pass_arg));
3573
3574   flag = (int) (*proc)->pass_arg_num;
3575   mio_integer (&flag);
3576   (*proc)->pass_arg_num = (unsigned) flag;
3577
3578   if ((*proc)->is_generic)
3579     {
3580       gfc_tbp_generic* g;
3581       int iop;
3582
3583       mio_lparen ();
3584
3585       if (iomode == IO_OUTPUT)
3586         for (g = (*proc)->u.generic; g; g = g->next)
3587           {
3588             iop = (int) g->is_operator;
3589             mio_integer (&iop);
3590             mio_allocated_string (g->specific_st->name);
3591           }
3592       else
3593         {
3594           (*proc)->u.generic = NULL;
3595           while (peek_atom () != ATOM_RPAREN)
3596             {
3597               gfc_symtree** sym_root;
3598
3599               g = gfc_get_tbp_generic ();
3600               g->specific = NULL;
3601
3602               mio_integer (&iop);
3603               g->is_operator = (bool) iop;
3604
3605               require_atom (ATOM_STRING);
3606               sym_root = &current_f2k_derived->tb_sym_root;
3607               g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3608               free (atom_string);
3609
3610               g->next = (*proc)->u.generic;
3611               (*proc)->u.generic = g;
3612             }
3613         }
3614
3615       mio_rparen ();
3616     }
3617   else if (!(*proc)->ppc)
3618     mio_symtree_ref (&(*proc)->u.specific);
3619
3620   mio_rparen ();
3621 }
3622
3623 /* Walker-callback function for this purpose.  */
3624 static void
3625 mio_typebound_symtree (gfc_symtree* st)
3626 {
3627   if (iomode == IO_OUTPUT && !st->n.tb)
3628     return;
3629
3630   if (iomode == IO_OUTPUT)
3631     {
3632       mio_lparen ();
3633       mio_allocated_string (st->name);
3634     }
3635   /* For IO_INPUT, the above is done in mio_f2k_derived.  */
3636
3637   mio_typebound_proc (&st->n.tb);
3638   mio_rparen ();
3639 }
3640
3641 /* IO a full symtree (in all depth).  */
3642 static void
3643 mio_full_typebound_tree (gfc_symtree** root)
3644 {
3645   mio_lparen ();
3646
3647   if (iomode == IO_OUTPUT)
3648     gfc_traverse_symtree (*root, &mio_typebound_symtree);
3649   else
3650     {
3651       while (peek_atom () == ATOM_LPAREN)
3652         {
3653           gfc_symtree* st;
3654
3655           mio_lparen ();
3656
3657           require_atom (ATOM_STRING);
3658           st = gfc_get_tbp_symtree (root, atom_string);
3659           free (atom_string);
3660
3661           mio_typebound_symtree (st);
3662         }
3663     }
3664
3665   mio_rparen ();
3666 }
3667
3668 static void
3669 mio_finalizer (gfc_finalizer **f)
3670 {
3671   if (iomode == IO_OUTPUT)
3672     {
3673       gcc_assert (*f);
3674       gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
3675       mio_symtree_ref (&(*f)->proc_tree);
3676     }
3677   else
3678     {
3679       *f = gfc_get_finalizer ();
3680       (*f)->where = gfc_current_locus; /* Value should not matter.  */
3681       (*f)->next = NULL;
3682
3683       mio_symtree_ref (&(*f)->proc_tree);
3684       (*f)->proc_sym = NULL;
3685     }
3686 }
3687
3688 static void
3689 mio_f2k_derived (gfc_namespace *f2k)
3690 {
3691   current_f2k_derived = f2k;
3692
3693   /* Handle the list of finalizer procedures.  */
3694   mio_lparen ();
3695   if (iomode == IO_OUTPUT)
3696     {
3697       gfc_finalizer *f;
3698       for (f = f2k->finalizers; f; f = f->next)
3699         mio_finalizer (&f);
3700     }
3701   else
3702     {
3703       f2k->finalizers = NULL;
3704       while (peek_atom () != ATOM_RPAREN)
3705         {
3706           gfc_finalizer *cur = NULL;
3707           mio_finalizer (&cur);
3708           cur->next = f2k->finalizers;
3709           f2k->finalizers = cur;
3710         }
3711     }
3712   mio_rparen ();
3713
3714   /* Handle type-bound procedures.  */
3715   mio_full_typebound_tree (&f2k->tb_sym_root);
3716
3717   /* Type-bound user operators.  */
3718   mio_full_typebound_tree (&f2k->tb_uop_root);
3719
3720   /* Type-bound intrinsic operators.  */
3721   mio_lparen ();
3722   if (iomode == IO_OUTPUT)
3723     {
3724       int op;
3725       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
3726         {
3727           gfc_intrinsic_op realop;
3728
3729           if (op == INTRINSIC_USER || !f2k->tb_op[op])
3730             continue;
3731
3732           mio_lparen ();
3733           realop = (gfc_intrinsic_op) op;
3734           mio_intrinsic_op (&realop);
3735           mio_typebound_proc (&f2k->tb_op[op]);
3736           mio_rparen ();
3737         }
3738     }
3739   else
3740     while (peek_atom () != ATOM_RPAREN)
3741       {
3742         gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
3743
3744         mio_lparen ();
3745         mio_intrinsic_op (&op);
3746         mio_typebound_proc (&f2k->tb_op[op]);
3747         mio_rparen ();
3748       }
3749   mio_rparen ();
3750 }
3751
3752 static void
3753 mio_full_f2k_derived (gfc_symbol *sym)