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