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