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