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