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