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 /* It is not quite enough to check for ambiguity in the symbols by
3948    the loaded symbol and the new symbol not being identical.  */
3949 static bool
3950 check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
3951 {
3952   gfc_symbol *rsym;
3953   module_locus locus;
3954   symbol_attribute attr;
3955
3956   rsym = info->u.rsym.sym;
3957   if (st_sym == rsym)
3958     return false;
3959
3960   /* Identical derived types are not ambiguous and will be rolled up
3961      later.  */
3962   if (st_sym->attr.flavor == FL_DERIVED
3963         && rsym->attr.flavor == FL_DERIVED
3964         && gfc_compare_derived_types (st_sym, rsym))
3965     return false;
3966
3967   /* If the existing symbol is generic from a different module and
3968      the new symbol is generic there can be no ambiguity.  */
3969   if (st_sym->attr.generic
3970         && st_sym->module
3971         && strcmp (st_sym->module, module_name))
3972     {
3973       /* The new symbol's attributes have not yet been read.  Since
3974          we need attr.generic, read it directly.  */
3975       get_module_locus (&locus);
3976       set_module_locus (&info->u.rsym.where);
3977       mio_lparen ();
3978       attr.generic = 0;
3979       mio_symbol_attribute (&attr);
3980       set_module_locus (&locus);
3981       if (attr.generic)
3982         return false;
3983     }
3984
3985   return true;
3986 }
3987
3988
3989 /* Read a module file.  */
3990
3991 static void
3992 read_module (void)
3993 {
3994   module_locus operator_interfaces, user_operators;
3995   const char *p;
3996   char name[GFC_MAX_SYMBOL_LEN + 1];
3997   gfc_intrinsic_op i;
3998   int ambiguous, j, nuse, symbol;
3999   pointer_info *info, *q;
4000   gfc_use_rename *u;
4001   gfc_symtree *st;
4002   gfc_symbol *sym;
4003
4004   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
4005   skip_list ();
4006
4007   get_module_locus (&user_operators);
4008   skip_list ();
4009   skip_list ();
4010
4011   /* Skip commons and equivalences for now.  */
4012   skip_list ();
4013   skip_list ();
4014
4015   mio_lparen ();
4016
4017   /* Create the fixup nodes for all the symbols.  */
4018
4019   while (peek_atom () != ATOM_RPAREN)
4020     {
4021       require_atom (ATOM_INTEGER);
4022       info = get_integer (atom_int);
4023
4024       info->type = P_SYMBOL;
4025       info->u.rsym.state = UNUSED;
4026
4027       mio_internal_string (info->u.rsym.true_name);
4028       mio_internal_string (info->u.rsym.module);
4029       mio_internal_string (info->u.rsym.binding_label);
4030
4031
4032       require_atom (ATOM_INTEGER);
4033       info->u.rsym.ns = atom_int;
4034
4035       get_module_locus (&info->u.rsym.where);
4036       skip_list ();
4037
4038       /* See if the symbol has already been loaded by a previous module.
4039          If so, we reference the existing symbol and prevent it from
4040          being loaded again.  This should not happen if the symbol being
4041          read is an index for an assumed shape dummy array (ns != 1).  */
4042
4043       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4044
4045       if (sym == NULL
4046           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4047         continue;
4048
4049       info->u.rsym.state = USED;
4050       info->u.rsym.sym = sym;
4051
4052       /* Some symbols do not have a namespace (eg. formal arguments),
4053          so the automatic "unique symtree" mechanism must be suppressed
4054          by marking them as referenced.  */
4055       q = get_integer (info->u.rsym.ns);
4056       if (q->u.pointer == NULL)
4057         {
4058           info->u.rsym.referenced = 1;
4059           continue;
4060         }
4061
4062       /* If possible recycle the symtree that references the symbol.
4063          If a symtree is not found and the module does not import one,
4064          a unique-name symtree is found by read_cleanup.  */
4065       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
4066       if (st != NULL)
4067         {
4068           info->u.rsym.symtree = st;
4069           info->u.rsym.referenced = 1;
4070         }
4071     }
4072
4073   mio_rparen ();
4074
4075   /* Parse the symtree lists.  This lets us mark which symbols need to
4076      be loaded.  Renaming is also done at this point by replacing the
4077      symtree name.  */
4078
4079   mio_lparen ();
4080
4081   while (peek_atom () != ATOM_RPAREN)
4082     {
4083       mio_internal_string (name);
4084       mio_integer (&ambiguous);
4085       mio_integer (&symbol);
4086
4087       info = get_integer (symbol);
4088
4089       /* See how many use names there are.  If none, go through the start
4090          of the loop at least once.  */
4091       nuse = number_use_names (name, false);
4092       info->u.rsym.renamed = nuse ? 1 : 0;
4093
4094       if (nuse == 0)
4095         nuse = 1;
4096
4097       for (j = 1; j <= nuse; j++)
4098         {
4099           /* Get the jth local name for this symbol.  */
4100           p = find_use_name_n (name, &j, false);
4101
4102           if (p == NULL && strcmp (name, module_name) == 0)
4103             p = name;
4104
4105           /* Skip symtree nodes not in an ONLY clause, unless there
4106              is an existing symtree loaded from another USE statement.  */
4107           if (p == NULL)
4108             {
4109               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4110               if (st != NULL)
4111                 info->u.rsym.symtree = st;
4112               continue;
4113             }
4114
4115           /* If a symbol of the same name and module exists already,
4116              this symbol, which is not in an ONLY clause, must not be
4117              added to the namespace(11.3.2).  Note that find_symbol
4118              only returns the first occurrence that it finds.  */
4119           if (!only_flag && !info->u.rsym.renamed
4120                 && strcmp (name, module_name) != 0
4121                 && find_symbol (gfc_current_ns->sym_root, name,
4122                                 module_name, 0))
4123             continue;
4124
4125           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4126
4127           if (st != NULL)
4128             {
4129               /* Check for ambiguous symbols.  */
4130               if (check_for_ambiguous (st->n.sym, info))
4131                 st->ambiguous = 1;
4132               info->u.rsym.symtree = st;
4133             }
4134           else
4135             {
4136               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4137
4138               /* Delete the symtree if the symbol has been added by a USE
4139                  statement without an ONLY(11.3.2).  Remember that the rsym
4140                  will be the same as the symbol found in the symtree, for
4141                  this case.  */
4142               if (st && (only_flag || info->u.rsym.renamed)
4143                      && !st->n.sym->attr.use_only
4144                      && !st->n.sym->attr.use_rename
4145                      && info->u.rsym.sym == st->n.sym)
4146                 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
4147
4148               /* Create a symtree node in the current namespace for this
4149                  symbol.  */
4150               st = check_unique_name (p)
4151                    ? gfc_get_unique_symtree (gfc_current_ns)
4152                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4153               st->ambiguous = ambiguous;
4154
4155               sym = info->u.rsym.sym;
4156
4157               /* Create a symbol node if it doesn't already exist.  */
4158               if (sym == NULL)
4159                 {
4160                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4161                                                      gfc_current_ns);
4162                   sym = info->u.rsym.sym;
4163                   sym->module = gfc_get_string (info->u.rsym.module);
4164
4165                   /* TODO: hmm, can we test this?  Do we know it will be
4166                      initialized to zeros?  */
4167                   if (info->u.rsym.binding_label[0] != '\0')
4168                     strcpy (sym->binding_label, info->u.rsym.binding_label);
4169                 }
4170
4171               st->n.sym = sym;
4172               st->n.sym->refs++;
4173
4174               if (strcmp (name, p) != 0)
4175                 sym->attr.use_rename = 1;
4176
4177               /* We need to set the only_flag here so that symbols from the
4178                  same USE...ONLY but earlier are not deleted from the tree in
4179                  the gfc_delete_symtree above.  */
4180               sym->attr.use_only = only_flag;
4181
4182               /* Store the symtree pointing to this symbol.  */
4183               info->u.rsym.symtree = st;
4184
4185               if (info->u.rsym.state == UNUSED)
4186                 info->u.rsym.state = NEEDED;
4187               info->u.rsym.referenced = 1;
4188             }
4189         }
4190     }
4191
4192   mio_rparen ();
4193
4194   /* Load intrinsic operator interfaces.  */
4195   set_module_locus (&operator_interfaces);
4196   mio_lparen ();
4197
4198   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4199     {
4200       if (i == INTRINSIC_USER)
4201         continue;
4202
4203       if (only_flag)
4204         {
4205           u = find_use_operator (i);
4206
4207           if (u == NULL)
4208             {
4209               skip_list ();
4210               continue;
4211             }
4212
4213           u->found = 1;
4214         }
4215
4216       mio_interface (&gfc_current_ns->op[i]);
4217     }
4218
4219   mio_rparen ();
4220
4221   /* Load generic and user operator interfaces.  These must follow the
4222      loading of symtree because otherwise symbols can be marked as
4223      ambiguous.  */
4224
4225   set_module_locus (&user_operators);
4226
4227   load_operator_interfaces ();
4228   load_generic_interfaces ();
4229
4230   load_commons ();
4231   load_equiv ();
4232
4233   /* At this point, we read those symbols that are needed but haven't
4234      been loaded yet.  If one symbol requires another, the other gets
4235      marked as NEEDED if its previous state was UNUSED.  */
4236
4237   while (load_needed (pi_root));
4238
4239   /* Make sure all elements of the rename-list were found in the module.  */
4240
4241   for (u = gfc_rename_list; u; u = u->next)
4242     {
4243       if (u->found)
4244         continue;
4245
4246       if (u->op == INTRINSIC_NONE)
4247         {
4248           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4249                      u->use_name, &u->where, module_name);
4250           continue;
4251         }
4252
4253       if (u->op == INTRINSIC_USER)
4254         {
4255           gfc_error ("User operator '%s' referenced at %L not found "
4256                      "in module '%s'", u->use_name, &u->where, module_name);
4257           continue;
4258         }
4259
4260       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4261                  "in module '%s'", gfc_op2string (u->op), &u->where,
4262                  module_name);
4263     }
4264
4265   gfc_check_interfaces (gfc_current_ns);
4266
4267   /* Clean up symbol nodes that were never loaded, create references
4268      to hidden symbols.  */
4269
4270   read_cleanup (pi_root);
4271 }
4272
4273
4274 /* Given an access type that is specific to an entity and the default
4275    access, return nonzero if the entity is publicly accessible.  If the
4276    element is declared as PUBLIC, then it is public; if declared
4277    PRIVATE, then private, and otherwise it is public unless the default
4278    access in this context has been declared PRIVATE.  */
4279
4280 bool
4281 gfc_check_access (gfc_access specific_access, gfc_access default_access)
4282 {
4283   if (specific_access == ACCESS_PUBLIC)
4284     return TRUE;
4285   if (specific_access == ACCESS_PRIVATE)
4286     return FALSE;
4287
4288   if (gfc_option.flag_module_private)
4289     return default_access == ACCESS_PUBLIC;
4290   else
4291     return default_access != ACCESS_PRIVATE;
4292 }
4293
4294
4295 /* A structure to remember which commons we've already written.  */
4296
4297 struct written_common
4298 {
4299   BBT_HEADER(written_common);
4300   const char *name, *label;
4301 };
4302
4303 static struct written_common *written_commons = NULL;
4304
4305 /* Comparison function used for balancing the binary tree.  */
4306
4307 static int
4308 compare_written_commons (void *a1, void *b1)
4309 {
4310   const char *aname = ((struct written_common *) a1)->name;
4311   const char *alabel = ((struct written_common *) a1)->label;
4312   const char *bname = ((struct written_common *) b1)->name;
4313   const char *blabel = ((struct written_common *) b1)->label;
4314   int c = strcmp (aname, bname);
4315
4316   return (c != 0 ? c : strcmp (alabel, blabel));
4317 }
4318
4319 /* Free a list of written commons.  */
4320
4321 static void
4322 free_written_common (struct written_common *w)
4323 {
4324   if (!w)
4325     return;
4326
4327   if (w->left)
4328     free_written_common (w->left);
4329   if (w->right)
4330     free_written_common (w->right);
4331
4332   gfc_free (w);
4333 }
4334
4335 /* Write a common block to the module -- recursive helper function.  */
4336
4337 static void
4338 write_common_0 (gfc_symtree *st)
4339 {
4340   gfc_common_head *p;
4341   const char * name;
4342   int flags;
4343   const char *label;
4344   struct written_common *w;
4345   bool write_me = true;
4346
4347   if (st == NULL)
4348     return;
4349
4350   write_common_0 (st->left);
4351
4352   /* We will write out the binding label, or the name if no label given.  */
4353   name = st->n.common->name;
4354   p = st->n.common;
4355   label = p->is_bind_c ? p->binding_label : p->name;
4356
4357   /* Check if we've already output this common.  */
4358   w = written_commons;
4359   while (w)
4360     {
4361       int c = strcmp (name, w->name);
4362       c = (c != 0 ? c : strcmp (label, w->label));
4363       if (c == 0)
4364         write_me = false;
4365
4366       w = (c < 0) ? w->left : w->right;
4367     }
4368
4369   if (write_me)
4370     {
4371       /* Write the common to the module.  */
4372       mio_lparen ();
4373       mio_pool_string (&name);
4374
4375       mio_symbol_ref (&p->head);
4376       flags = p->saved ? 1 : 0;
4377       if (p->threadprivate)
4378         flags |= 2;
4379       mio_integer (&flags);
4380
4381       /* Write out whether the common block is bind(c) or not.  */
4382       mio_integer (&(p->is_bind_c));
4383
4384       mio_pool_string (&label);
4385       mio_rparen ();
4386
4387       /* Record that we have written this common.  */
4388       w = XCNEW (struct written_common);
4389       w->name = p->name;
4390       w->label = label;
4391       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4392     }
4393
4394   write_common_0 (st->right);
4395 }
4396
4397
4398 /* Write a common, by initializing the list of written commons, calling
4399    the recursive function write_common_0() and cleaning up afterwards.  */
4400
4401 static void
4402 write_common (gfc_symtree *st)
4403 {
4404   written_commons = NULL;
4405   write_common_0 (st);
4406   free_written_common (written_commons);
4407   written_commons = NULL;
4408 }
4409
4410
4411 /* Write the blank common block to the module.  */
4412
4413 static void
4414 write_blank_common (void)
4415 {
4416   const char * name = BLANK_COMMON_NAME;
4417   int saved;
4418   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4419      this, but it hasn't been checked.  Just making it so for now.  */
4420   int is_bind_c = 0;
4421
4422   if (gfc_current_ns->blank_common.head == NULL)
4423     return;
4424
4425   mio_lparen ();
4426
4427   mio_pool_string (&name);
4428
4429   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4430   saved = gfc_current_ns->blank_common.saved;
4431   mio_integer (&saved);
4432
4433   /* Write out whether the common block is bind(c) or not.  */
4434   mio_integer (&is_bind_c);
4435
4436   /* Write out the binding label, which is BLANK_COMMON_NAME, though
4437      it doesn't matter because the label isn't used.  */
4438   mio_pool_string (&name);
4439
4440   mio_rparen ();
4441 }
4442
4443
4444 /* Write equivalences to the module.  */
4445
4446 static void
4447 write_equiv (void)
4448 {
4449   gfc_equiv *eq, *e;
4450   int num;
4451
4452   num = 0;
4453   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4454     {
4455       mio_lparen ();
4456
4457       for (e = eq; e; e = e->eq)
4458         {
4459           if (e->module == NULL)
4460             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4461           mio_allocated_string (e->module);
4462           mio_expr (&e->expr);
4463         }
4464
4465       num++;
4466       mio_rparen ();
4467     }
4468 }
4469
4470
4471 /* Write a symbol to the module.  */
4472
4473 static void
4474 write_symbol (int n, gfc_symbol *sym)
4475 {
4476   const char *label;
4477
4478   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4479     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4480
4481   mio_integer (&n);
4482   mio_pool_string (&sym->name);
4483
4484   mio_pool_string (&sym->module);
4485   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4486     {
4487       label = sym->binding_label;
4488       mio_pool_string (&label);
4489     }
4490   else
4491     mio_pool_string (&sym->name);
4492
4493   mio_pointer_ref (&sym->ns);
4494
4495   mio_symbol (sym);
4496   write_char ('\n');
4497 }
4498
4499
4500 /* Recursive traversal function to write the initial set of symbols to
4501    the module.  We check to see if the symbol should be written
4502    according to the access specification.  */
4503
4504 static void
4505 write_symbol0 (gfc_symtree *st)
4506 {
4507   gfc_symbol *sym;
4508   pointer_info *p;
4509   bool dont_write = false;
4510
4511   if (st == NULL)
4512     return;
4513
4514   write_symbol0 (st->left);
4515
4516   sym = st->n.sym;
4517   if (sym->module == NULL)
4518     sym->module = gfc_get_string (module_name);
4519
4520   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4521       && !sym->attr.subroutine && !sym->attr.function)
4522     dont_write = true;
4523
4524   if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
4525     dont_write = true;
4526
4527   if (!dont_write)
4528     {
4529       p = get_pointer (sym);
4530       if (p->type == P_UNKNOWN)
4531         p->type = P_SYMBOL;
4532
4533       if (p->u.wsym.state != WRITTEN)
4534         {
4535           write_symbol (p->integer, sym);
4536           p->u.wsym.state = WRITTEN;
4537         }
4538     }
4539
4540   write_symbol0 (st->right);
4541 }
4542
4543
4544 /* Recursive traversal function to write the secondary set of symbols
4545    to the module file.  These are symbols that were not public yet are
4546    needed by the public symbols or another dependent symbol.  The act
4547    of writing a symbol can modify the pointer_info tree, so we cease
4548    traversal if we find a symbol to write.  We return nonzero if a
4549    symbol was written and pass that information upwards.  */
4550
4551 static int
4552 write_symbol1 (pointer_info *p)
4553 {
4554   int result;
4555
4556   if (!p)
4557     return 0;
4558
4559   result = write_symbol1 (p->left);
4560
4561   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4562     {
4563       p->u.wsym.state = WRITTEN;
4564       write_symbol (p->integer, p->u.wsym.sym);
4565       result = 1;
4566     }
4567
4568   result |= write_symbol1 (p->right);
4569   return result;
4570 }
4571
4572
4573 /* Write operator interfaces associated with a symbol.  */
4574
4575 static void
4576 write_operator (gfc_user_op *uop)
4577 {
4578   static char nullstring[] = "";
4579   const char *p = nullstring;
4580
4581   if (uop->op == NULL
4582       || !gfc_check_access (uop->access, uop->ns->default_access))
4583     return;
4584
4585   mio_symbol_interface (&uop->name, &p, &uop->op);
4586 }
4587
4588
4589 /* Write generic interfaces from the namespace sym_root.  */
4590
4591 static void
4592 write_generic (gfc_symtree *st)
4593 {
4594   gfc_symbol *sym;
4595
4596   if (st == NULL)
4597     return;
4598
4599   write_generic (st->left);
4600   write_generic (st->right);
4601
4602   sym = st->n.sym;
4603   if (!sym || check_unique_name (st->name))
4604     return;
4605
4606   if (sym->generic == NULL
4607       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
4608     return;
4609
4610   if (sym->module == NULL)
4611     sym->module = gfc_get_string (module_name);
4612
4613   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
4614 }
4615
4616
4617 static void
4618 write_symtree (gfc_symtree *st)
4619 {
4620   gfc_symbol *sym;
4621   pointer_info *p;
4622
4623   sym = st->n.sym;
4624
4625   /* A symbol in an interface body must not be visible in the
4626      module file.  */
4627   if (sym->ns != gfc_current_ns
4628         && sym->ns->proc_name
4629         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
4630     return;
4631
4632   if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4633       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4634           && !sym->attr.subroutine && !sym->attr.function))
4635     return;
4636
4637   if (check_unique_name (st->name))
4638     return;
4639
4640   p = find_pointer (sym);
4641   if (p == NULL)
4642     gfc_internal_error ("write_symtree(): Symbol not written");
4643
4644   mio_pool_string (&st->name);
4645   mio_integer (&st->ambiguous);
4646   mio_integer (&p->integer);
4647 }
4648
4649
4650 static void
4651 write_module (void)
4652 {
4653   gfc_intrinsic_op i;
4654
4655   /* Write the operator interfaces.  */
4656   mio_lparen ();
4657
4658   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4659     {
4660       if (i == INTRINSIC_USER)
4661         continue;
4662
4663       mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4664                                        gfc_current_ns->default_access)
4665                      ? &gfc_current_ns->op[i] : NULL);
4666     }
4667
4668   mio_rparen ();
4669   write_char ('\n');
4670   write_char ('\n');
4671
4672   mio_lparen ();
4673   gfc_traverse_user_op (gfc_current_ns, write_operator);
4674   mio_rparen ();
4675   write_char ('\n');
4676   write_char ('\n');
4677
4678   mio_lparen ();
4679   write_generic (gfc_current_ns->sym_root);
4680   mio_rparen ();
4681   write_char ('\n');
4682   write_char ('\n');
4683
4684   mio_lparen ();
4685   write_blank_common ();
4686   write_common (gfc_current_ns->common_root);
4687   mio_rparen ();
4688   write_char ('\n');
4689   write_char ('\n');
4690
4691   mio_lparen ();
4692   write_equiv ();
4693   mio_rparen ();
4694   write_char ('\n');
4695   write_char ('\n');
4696
4697   /* Write symbol information.  First we traverse all symbols in the
4698      primary namespace, writing those that need to be written.
4699      Sometimes writing one symbol will cause another to need to be
4700      written.  A list of these symbols ends up on the write stack, and
4701      we end by popping the bottom of the stack and writing the symbol
4702      until the stack is empty.  */
4703
4704   mio_lparen ();
4705
4706   write_symbol0 (gfc_current_ns->sym_root);
4707   while (write_symbol1 (pi_root))
4708     /* Nothing.  */;
4709
4710   mio_rparen ();
4711
4712   write_char ('\n');
4713   write_char ('\n');
4714
4715   mio_lparen ();
4716   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4717   mio_rparen ();
4718 }
4719
4720
4721 /* Read a MD5 sum from the header of a module file.  If the file cannot
4722    be opened, or we have any other error, we return -1.  */
4723
4724 static int
4725 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4726 {
4727   FILE *file;
4728   char buf[1024];
4729   int n;
4730
4731   /* Open the file.  */
4732   if ((file = fopen (filename, "r")) == NULL)
4733     return -1;
4734
4735   /* Read two lines.  */
4736   if (fgets (buf, sizeof (buf) - 1, file) == NULL
4737       || fgets (buf, sizeof (buf) - 1, file) == NULL)
4738     {
4739       fclose (file);
4740       return -1;
4741     }
4742
4743   /* Close the file.  */
4744   fclose (file);
4745
4746   /* If the header is not what we expect, or is too short, bail out.  */
4747   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4748     return -1;
4749
4750   /* Now, we have a real MD5, read it into the array.  */
4751   for (n = 0; n < 16; n++)
4752     {
4753       unsigned int x;
4754
4755       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4756        return -1;
4757
4758       md5[n] = x;
4759     }
4760
4761   return 0;
4762 }
4763
4764
4765 /* Given module, dump it to disk.  If there was an error while
4766    processing the module, dump_flag will be set to zero and we delete
4767    the module file, even if it was already there.  */
4768
4769 void
4770 gfc_dump_module (const char *name, int dump_flag)
4771 {
4772   int n;
4773   char *filename, *filename_tmp, *p;
4774   time_t now;
4775   fpos_t md5_pos;
4776   unsigned char md5_new[16], md5_old[16];
4777
4778   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4779   if (gfc_option.module_dir != NULL)
4780     {
4781       n += strlen (gfc_option.module_dir);
4782       filename = (char *) alloca (n);
4783       strcpy (filename, gfc_option.module_dir);
4784       strcat (filename, name);
4785     }
4786   else
4787     {
4788       filename = (char *) alloca (n);
4789       strcpy (filename, name);
4790     }
4791   strcat (filename, MODULE_EXTENSION);
4792
4793   /* Name of the temporary file used to write the module.  */
4794   filename_tmp = (char *) alloca (n + 1);
4795   strcpy (filename_tmp, filename);
4796   strcat (filename_tmp, "0");
4797
4798   /* There was an error while processing the module.  We delete the
4799      module file, even if it was already there.  */
4800   if (!dump_flag)
4801     {
4802       unlink (filename);
4803       return;
4804     }
4805
4806   /* Write the module to the temporary file.  */
4807   module_fp = fopen (filename_tmp, "w");
4808   if (module_fp == NULL)
4809     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4810                      filename_tmp, strerror (errno));
4811
4812   /* Write the header, including space reserved for the MD5 sum.  */
4813   now = time (NULL);
4814   p = ctime (&now);
4815
4816   *strchr (p, '\n') = '\0';
4817
4818   fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4819            gfc_source_file, p);
4820   fgetpos (module_fp, &md5_pos);
4821   fputs ("00000000000000000000000000000000 -- "
4822         "If you edit this, you'll get what you deserve.\n\n", module_fp);
4823
4824   /* Initialize the MD5 context that will be used for output.  */
4825   md5_init_ctx (&ctx);
4826
4827   /* Write the module itself.  */
4828   iomode = IO_OUTPUT;
4829   strcpy (module_name, name);
4830
4831   init_pi_tree ();
4832
4833   write_module ();
4834
4835   free_pi_tree (pi_root);
4836   pi_root = NULL;
4837
4838   write_char ('\n');
4839
4840   /* Write the MD5 sum to the header of the module file.  */
4841   md5_finish_ctx (&ctx, md5_new);
4842   fsetpos (module_fp, &md5_pos);
4843   for (n = 0; n < 16; n++)
4844     fprintf (module_fp, "%02x", md5_new[n]);
4845
4846   if (fclose (module_fp))
4847     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4848                      filename_tmp, strerror (errno));
4849
4850   /* Read the MD5 from the header of the old module file and compare.  */
4851   if (read_md5_from_module_file (filename, md5_old) != 0
4852       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4853     {
4854       /* Module file have changed, replace the old one.  */
4855       unlink (filename);
4856       rename (filename_tmp, filename);
4857     }
4858   else
4859     unlink (filename_tmp);
4860 }
4861
4862
4863 static void
4864 sort_iso_c_rename_list (void)
4865 {
4866   gfc_use_rename *tmp_list = NULL;
4867   gfc_use_rename *curr;
4868   gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4869   int c_kind;
4870   int i;
4871
4872   for (curr = gfc_rename_list; curr; curr = curr->next)
4873     {
4874       c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4875       if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4876         {
4877           gfc_error ("Symbol '%s' referenced at %L does not exist in "
4878                      "intrinsic module ISO_C_BINDING.", curr->use_name,
4879                      &curr->where);
4880         }
4881       else
4882         /* Put it in the list.  */
4883         kinds_used[c_kind] = curr;
4884     }
4885
4886   /* Make a new (sorted) rename list.  */
4887   i = 0;
4888   while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4889     i++;
4890
4891   if (i < ISOCBINDING_NUMBER)
4892     {
4893       tmp_list = kinds_used[i];
4894
4895       i++;
4896       curr = tmp_list;
4897       for (; i < ISOCBINDING_NUMBER; i++)
4898         if (kinds_used[i] != NULL)
4899           {
4900             curr->next = kinds_used[i];
4901             curr = curr->next;
4902             curr->next = NULL;
4903           }
4904     }
4905
4906   gfc_rename_list = tmp_list;
4907 }
4908
4909
4910 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4911    the current namespace for all named constants, pointer types, and
4912    procedures in the module unless the only clause was used or a rename
4913    list was provided.  */
4914
4915 static void
4916 import_iso_c_binding_module (void)
4917 {
4918   gfc_symbol *mod_sym = NULL;
4919   gfc_symtree *mod_symtree = NULL;
4920   const char *iso_c_module_name = "__iso_c_binding";
4921   gfc_use_rename *u;
4922   int i;
4923   char *local_name;
4924
4925   /* Look only in the current namespace.  */
4926   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4927
4928   if (mod_symtree == NULL)
4929     {
4930       /* symtree doesn't already exist in current namespace.  */
4931       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4932
4933       if (mod_symtree != NULL)
4934         mod_sym = mod_symtree->n.sym;
4935       else
4936         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4937                             "create symbol for %s", iso_c_module_name);
4938
4939       mod_sym->attr.flavor = FL_MODULE;
4940       mod_sym->attr.intrinsic = 1;
4941       mod_sym->module = gfc_get_string (iso_c_module_name);
4942       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4943     }
4944
4945   /* Generate the symbols for the named constants representing
4946      the kinds for intrinsic data types.  */
4947   if (only_flag)
4948     {
4949       /* Sort the rename list because there are dependencies between types
4950          and procedures (e.g., c_loc needs c_ptr).  */
4951       sort_iso_c_rename_list ();
4952
4953       for (u = gfc_rename_list; u; u = u->next)
4954         {
4955           i = get_c_kind (u->use_name, c_interop_kinds_table);
4956
4957           if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4958             {
4959               gfc_error ("Symbol '%s' referenced at %L does not exist in "
4960                          "intrinsic module ISO_C_BINDING.", u->use_name,
4961                          &u->where);
4962               continue;
4963             }
4964
4965           generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4966         }
4967     }
4968   else
4969     {
4970       for (i = 0; i < ISOCBINDING_NUMBER; i++)
4971         {
4972           local_name = NULL;
4973           for (u = gfc_rename_list; u; u = u->next)
4974             {
4975               if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4976                 {
4977                   local_name = u->local_name;
4978                   u->found = 1;
4979                   break;
4980                 }
4981             }
4982           generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4983         }
4984
4985       for (u = gfc_rename_list; u; u = u->next)
4986         {
4987           if (u->found)
4988             continue;
4989
4990           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4991                      "module ISO_C_BINDING", u->use_name, &u->where);
4992         }
4993     }
4994 }
4995
4996
4997 /* Add an integer named constant from a given module.  */
4998
4999 static void
5000 create_int_parameter (const char *name, int value, const char *modname,
5001                       intmod_id module, int id)
5002 {
5003   gfc_symtree *tmp_symtree;
5004   gfc_symbol *sym;
5005
5006   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5007   if (tmp_symtree != NULL)
5008     {
5009       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5010         return;
5011       else
5012         gfc_error ("Symbol '%s' already declared", name);
5013     }
5014
5015   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
5016   sym = tmp_symtree->n.sym;
5017
5018   sym->module = gfc_get_string (modname);
5019   sym->attr.flavor = FL_PARAMETER;
5020   sym->ts.type = BT_INTEGER;
5021   sym->ts.kind = gfc_default_integer_kind;
5022   sym->value = gfc_int_expr (value);
5023   sym->attr.use_assoc = 1;
5024   sym->from_intmod = module;
5025   sym->intmod_sym_id = id;
5026 }
5027
5028
5029 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
5030
5031 static void
5032 use_iso_fortran_env_module (void)
5033 {
5034   static char mod[] = "iso_fortran_env";
5035   const char *local_name;
5036   gfc_use_rename *u;
5037   gfc_symbol *mod_sym;
5038   gfc_symtree *mod_symtree;
5039   int i;
5040
5041   intmod_sym symbol[] = {
5042 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5043 #include "iso-fortran-env.def"
5044 #undef NAMED_INTCST
5045     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5046
5047   i = 0;
5048 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5049 #include "iso-fortran-env.def"
5050 #undef NAMED_INTCST
5051
5052   /* Generate the symbol for the module itself.  */
5053   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5054   if (mod_symtree == NULL)
5055     {
5056       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
5057       gcc_assert (mod_symtree);
5058       mod_sym = mod_symtree->n.sym;
5059
5060       mod_sym->attr.flavor = FL_MODULE;
5061       mod_sym->attr.intrinsic = 1;
5062       mod_sym->module = gfc_get_string (mod);
5063       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5064     }
5065   else
5066     if (!mod_symtree->n.sym->attr.intrinsic)
5067       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5068                  "non-intrinsic module name used previously", mod);
5069
5070   /* Generate the symbols for the module integer named constants.  */
5071   if (only_flag)
5072     for (u = gfc_rename_list; u; u = u->next)
5073       {
5074         for (i = 0; symbol[i].name; i++)
5075           if (strcmp (symbol[i].name, u->use_name) == 0)
5076             break;
5077
5078         if (symbol[i].name == NULL)
5079           {
5080             gfc_error ("Symbol '%s' referenced at %L does not exist in "
5081                        "intrinsic module ISO_FORTRAN_ENV", u->use_name,
5082                        &u->where);
5083             continue;
5084           }
5085
5086         if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5087             && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5088           gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5089                            "from intrinsic module ISO_FORTRAN_ENV at %L is "
5090                            "incompatible with option %s", &u->where,
5091                            gfc_option.flag_default_integer
5092                              ? "-fdefault-integer-8" : "-fdefault-real-8");
5093
5094         create_int_parameter (u->local_name[0] ? u->local_name
5095                                                : symbol[i].name,
5096                               symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
5097                               symbol[i].id);
5098       }
5099   else
5100     {
5101       for (i = 0; symbol[i].name; i++)
5102         {
5103           local_name = NULL;
5104           for (u = gfc_rename_list; u; u = u->next)
5105             {
5106               if (strcmp (symbol[i].name, u->use_name) == 0)
5107                 {
5108                   local_name = u->local_name;
5109                   u->found = 1;
5110                   break;
5111                 }
5112             }
5113
5114           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5115               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5116             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5117                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
5118                              "incompatible with option %s",
5119                              gfc_option.flag_default_integer
5120                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
5121
5122           create_int_parameter (local_name ? local_name : symbol[i].name,
5123                                 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
5124                                 symbol[i].id);
5125         }
5126
5127       for (u = gfc_rename_list; u; u = u->next)
5128         {
5129           if (u->found)
5130             continue;
5131
5132           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5133                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
5134         }
5135     }
5136 }
5137
5138
5139 /* Process a USE directive.  */
5140
5141 void
5142 gfc_use_module (void)
5143 {
5144   char *filename;
5145   gfc_state_data *p;
5146   int c, line, start;
5147   gfc_symtree *mod_symtree;
5148   gfc_use_list *use_stmt;
5149
5150   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
5151                               + 1);
5152   strcpy (filename, module_name);
5153   strcat (filename, MODULE_EXTENSION);
5154
5155   /* First, try to find an non-intrinsic module, unless the USE statement
5156      specified that the module is intrinsic.  */
5157   module_fp = NULL;
5158   if (!specified_int)
5159     module_fp = gfc_open_included_file (filename, true, true);
5160
5161   /* Then, see if it's an intrinsic one, unless the USE statement
5162      specified that the module is non-intrinsic.  */
5163   if (module_fp == NULL && !specified_nonint)
5164     {
5165       if (strcmp (module_name, "iso_fortran_env") == 0
5166           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
5167                              "intrinsic module at %C") != FAILURE)
5168        {
5169          use_iso_fortran_env_module ();
5170          return;
5171        }
5172
5173       if (strcmp (module_name, "iso_c_binding") == 0
5174           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
5175                              "ISO_C_BINDING module at %C") != FAILURE)
5176         {
5177           import_iso_c_binding_module();
5178           return;
5179         }
5180
5181       module_fp = gfc_open_intrinsic_module (filename);
5182
5183       if (module_fp == NULL && specified_int)
5184         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5185                          module_name);
5186     }
5187
5188   if (module_fp == NULL)
5189     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5190                      filename, strerror (errno));
5191
5192   /* Check that we haven't already USEd an intrinsic module with the
5193      same name.  */
5194
5195   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
5196   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
5197     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5198                "intrinsic module name used previously", module_name);
5199
5200   iomode = IO_INPUT;
5201   module_line = 1;
5202   module_column = 1;
5203   start = 0;
5204
5205   /* Skip the first two lines of the module, after checking that this is
5206      a gfortran module file.  */
5207   line = 0;
5208   while (line < 2)
5209     {
5210       c = module_char ();
5211       if (c == EOF)
5212         bad_module ("Unexpected end of module");
5213       if (start++ < 2)
5214         parse_name (c);
5215       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
5216           || (start == 2 && strcmp (atom_name, " module") != 0))
5217         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5218                          "file", filename);
5219
5220       if (c == '\n')
5221         line++;
5222     }
5223
5224   /* Make sure we're not reading the same module that we may be building.  */
5225   for (p = gfc_state_stack; p; p = p->previous)
5226     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
5227       gfc_fatal_error ("Can't USE the same module we're building!");
5228
5229   init_pi_tree ();
5230   init_true_name_tree ();
5231
5232   read_module ();
5233
5234   free_true_name (true_name_root);
5235   true_name_root = NULL;
5236
5237   free_pi_tree (pi_root);
5238   pi_root = NULL;
5239
5240   fclose (module_fp);
5241
5242   use_stmt = gfc_get_use_list ();
5243   use_stmt->module_name = gfc_get_string (module_name);
5244   use_stmt->only_flag = only_flag;
5245   use_stmt->rename = gfc_rename_list;
5246   use_stmt->where = use_locus;
5247   gfc_rename_list = NULL;
5248   use_stmt->next = gfc_current_ns->use_stmts;
5249   gfc_current_ns->use_stmts = use_stmt;
5250 }
5251
5252
5253 void
5254 gfc_free_use_stmts (gfc_use_list *use_stmts)
5255 {
5256   gfc_use_list *next;
5257   for (; use_stmts; use_stmts = next)
5258     {
5259       gfc_use_rename *next_rename;
5260
5261       for (; use_stmts->rename; use_stmts->rename = next_rename)
5262         {
5263           next_rename = use_stmts->rename->next;
5264           gfc_free (use_stmts->rename);
5265         }
5266       next = use_stmts->next;
5267       gfc_free (use_stmts);
5268     }
5269 }
5270
5271
5272 void
5273 gfc_module_init_2 (void)
5274 {
5275   last_atom = ATOM_LPAREN;
5276 }
5277
5278
5279 void
5280 gfc_module_done_2 (void)
5281 {
5282   free_rename ();
5283 }