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 }
1653 ab_attribute;
1654
1655 static const mstring attr_bits[] =
1656 {
1657     minit ("ALLOCATABLE", AB_ALLOCATABLE),
1658     minit ("DIMENSION", AB_DIMENSION),
1659     minit ("EXTERNAL", AB_EXTERNAL),
1660     minit ("INTRINSIC", AB_INTRINSIC),
1661     minit ("OPTIONAL", AB_OPTIONAL),
1662     minit ("POINTER", AB_POINTER),
1663     minit ("VOLATILE", AB_VOLATILE),
1664     minit ("TARGET", AB_TARGET),
1665     minit ("THREADPRIVATE", AB_THREADPRIVATE),
1666     minit ("DUMMY", AB_DUMMY),
1667     minit ("RESULT", AB_RESULT),
1668     minit ("DATA", AB_DATA),
1669     minit ("IN_NAMELIST", AB_IN_NAMELIST),
1670     minit ("IN_COMMON", AB_IN_COMMON),
1671     minit ("FUNCTION", AB_FUNCTION),
1672     minit ("SUBROUTINE", AB_SUBROUTINE),
1673     minit ("SEQUENCE", AB_SEQUENCE),
1674     minit ("ELEMENTAL", AB_ELEMENTAL),
1675     minit ("PURE", AB_PURE),
1676     minit ("RECURSIVE", AB_RECURSIVE),
1677     minit ("GENERIC", AB_GENERIC),
1678     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1679     minit ("CRAY_POINTER", AB_CRAY_POINTER),
1680     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1681     minit ("IS_BIND_C", AB_IS_BIND_C),
1682     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1683     minit ("IS_ISO_C", AB_IS_ISO_C),
1684     minit ("VALUE", AB_VALUE),
1685     minit ("ALLOC_COMP", AB_ALLOC_COMP),
1686     minit ("POINTER_COMP", AB_POINTER_COMP),
1687     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1688     minit ("ZERO_COMP", AB_ZERO_COMP),
1689     minit ("PROTECTED", AB_PROTECTED),
1690     minit ("ABSTRACT", AB_ABSTRACT),
1691     minit (NULL, -1)
1692 };
1693
1694
1695 /* Specialization of mio_name.  */
1696 DECL_MIO_NAME (ab_attribute)
1697 DECL_MIO_NAME (ar_type)
1698 DECL_MIO_NAME (array_type)
1699 DECL_MIO_NAME (bt)
1700 DECL_MIO_NAME (expr_t)
1701 DECL_MIO_NAME (gfc_access)
1702 DECL_MIO_NAME (gfc_intrinsic_op)
1703 DECL_MIO_NAME (ifsrc)
1704 DECL_MIO_NAME (save_state)
1705 DECL_MIO_NAME (procedure_type)
1706 DECL_MIO_NAME (ref_type)
1707 DECL_MIO_NAME (sym_flavor)
1708 DECL_MIO_NAME (sym_intent)
1709 #undef DECL_MIO_NAME
1710
1711 /* Symbol attributes are stored in list with the first three elements
1712    being the enumerated fields, while the remaining elements (if any)
1713    indicate the individual attribute bits.  The access field is not
1714    saved-- it controls what symbols are exported when a module is
1715    written.  */
1716
1717 static void
1718 mio_symbol_attribute (symbol_attribute *attr)
1719 {
1720   atom_type t;
1721
1722   mio_lparen ();
1723
1724   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1725   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1726   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1727   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1728   attr->save = MIO_NAME (save_state) (attr->save, save_status);
1729
1730   if (iomode == IO_OUTPUT)
1731     {
1732       if (attr->allocatable)
1733         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1734       if (attr->dimension)
1735         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1736       if (attr->external)
1737         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1738       if (attr->intrinsic)
1739         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1740       if (attr->optional)
1741         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1742       if (attr->pointer)
1743         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1744       if (attr->is_protected)
1745         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1746       if (attr->value)
1747         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1748       if (attr->volatile_)
1749         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1750       if (attr->target)
1751         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1752       if (attr->threadprivate)
1753         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1754       if (attr->dummy)
1755         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1756       if (attr->result)
1757         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1758       /* We deliberately don't preserve the "entry" flag.  */
1759
1760       if (attr->data)
1761         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1762       if (attr->in_namelist)
1763         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1764       if (attr->in_common)
1765         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1766
1767       if (attr->function)
1768         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1769       if (attr->subroutine)
1770         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1771       if (attr->generic)
1772         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1773       if (attr->abstract)
1774         MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1775
1776       if (attr->sequence)
1777         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1778       if (attr->elemental)
1779         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1780       if (attr->pure)
1781         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1782       if (attr->recursive)
1783         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1784       if (attr->always_explicit)
1785         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1786       if (attr->cray_pointer)
1787         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1788       if (attr->cray_pointee)
1789         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1790       if (attr->is_bind_c)
1791         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1792       if (attr->is_c_interop)
1793         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1794       if (attr->is_iso_c)
1795         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1796       if (attr->alloc_comp)
1797         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1798       if (attr->pointer_comp)
1799         MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1800       if (attr->private_comp)
1801         MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1802       if (attr->zero_comp)
1803         MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
1804
1805       mio_rparen ();
1806
1807     }
1808   else
1809     {
1810       for (;;)
1811         {
1812           t = parse_atom ();
1813           if (t == ATOM_RPAREN)
1814             break;
1815           if (t != ATOM_NAME)
1816             bad_module ("Expected attribute bit name");
1817
1818           switch ((ab_attribute) find_enum (attr_bits))
1819             {
1820             case AB_ALLOCATABLE:
1821               attr->allocatable = 1;
1822               break;
1823             case AB_DIMENSION:
1824               attr->dimension = 1;
1825               break;
1826             case AB_EXTERNAL:
1827               attr->external = 1;
1828               break;
1829             case AB_INTRINSIC:
1830               attr->intrinsic = 1;
1831               break;
1832             case AB_OPTIONAL:
1833               attr->optional = 1;
1834               break;
1835             case AB_POINTER:
1836               attr->pointer = 1;
1837               break;
1838             case AB_PROTECTED:
1839               attr->is_protected = 1;
1840               break;
1841             case AB_VALUE:
1842               attr->value = 1;
1843               break;
1844             case AB_VOLATILE:
1845               attr->volatile_ = 1;
1846               break;
1847             case AB_TARGET:
1848               attr->target = 1;
1849               break;
1850             case AB_THREADPRIVATE:
1851               attr->threadprivate = 1;
1852               break;
1853             case AB_DUMMY:
1854               attr->dummy = 1;
1855               break;
1856             case AB_RESULT:
1857               attr->result = 1;
1858               break;
1859             case AB_DATA:
1860               attr->data = 1;
1861               break;
1862             case AB_IN_NAMELIST:
1863               attr->in_namelist = 1;
1864               break;
1865             case AB_IN_COMMON:
1866               attr->in_common = 1;
1867               break;
1868             case AB_FUNCTION:
1869               attr->function = 1;
1870               break;
1871             case AB_SUBROUTINE:
1872               attr->subroutine = 1;
1873               break;
1874             case AB_GENERIC:
1875               attr->generic = 1;
1876               break;
1877             case AB_ABSTRACT:
1878               attr->abstract = 1;
1879               break;
1880             case AB_SEQUENCE:
1881               attr->sequence = 1;
1882               break;
1883             case AB_ELEMENTAL:
1884               attr->elemental = 1;
1885               break;
1886             case AB_PURE:
1887               attr->pure = 1;
1888               break;
1889             case AB_RECURSIVE:
1890               attr->recursive = 1;
1891               break;
1892             case AB_ALWAYS_EXPLICIT:
1893               attr->always_explicit = 1;
1894               break;
1895             case AB_CRAY_POINTER:
1896               attr->cray_pointer = 1;
1897               break;
1898             case AB_CRAY_POINTEE:
1899               attr->cray_pointee = 1;
1900               break;
1901             case AB_IS_BIND_C:
1902               attr->is_bind_c = 1;
1903               break;
1904             case AB_IS_C_INTEROP:
1905               attr->is_c_interop = 1;
1906               break;
1907             case AB_IS_ISO_C:
1908               attr->is_iso_c = 1;
1909               break;
1910             case AB_ALLOC_COMP:
1911               attr->alloc_comp = 1;
1912               break;
1913             case AB_POINTER_COMP:
1914               attr->pointer_comp = 1;
1915               break;
1916             case AB_PRIVATE_COMP:
1917               attr->private_comp = 1;
1918               break;
1919             case AB_ZERO_COMP:
1920               attr->zero_comp = 1;
1921               break;
1922             }
1923         }
1924     }
1925 }
1926
1927
1928 static const mstring bt_types[] = {
1929     minit ("INTEGER", BT_INTEGER),
1930     minit ("REAL", BT_REAL),
1931     minit ("COMPLEX", BT_COMPLEX),
1932     minit ("LOGICAL", BT_LOGICAL),
1933     minit ("CHARACTER", BT_CHARACTER),
1934     minit ("DERIVED", BT_DERIVED),
1935     minit ("PROCEDURE", BT_PROCEDURE),
1936     minit ("UNKNOWN", BT_UNKNOWN),
1937     minit ("VOID", BT_VOID),
1938     minit (NULL, -1)
1939 };
1940
1941
1942 static void
1943 mio_charlen (gfc_charlen **clp)
1944 {
1945   gfc_charlen *cl;
1946
1947   mio_lparen ();
1948
1949   if (iomode == IO_OUTPUT)
1950     {
1951       cl = *clp;
1952       if (cl != NULL)
1953         mio_expr (&cl->length);
1954     }
1955   else
1956     {
1957       if (peek_atom () != ATOM_RPAREN)
1958         {
1959           cl = gfc_get_charlen ();
1960           mio_expr (&cl->length);
1961
1962           *clp = cl;
1963
1964           cl->next = gfc_current_ns->cl_list;
1965           gfc_current_ns->cl_list = cl;
1966         }
1967     }
1968
1969   mio_rparen ();
1970 }
1971
1972
1973 /* See if a name is a generated name.  */
1974
1975 static int
1976 check_unique_name (const char *name)
1977 {
1978   return *name == '@';
1979 }
1980
1981
1982 static void
1983 mio_typespec (gfc_typespec *ts)
1984 {
1985   mio_lparen ();
1986
1987   ts->type = MIO_NAME (bt) (ts->type, bt_types);
1988
1989   if (ts->type != BT_DERIVED)
1990     mio_integer (&ts->kind);
1991   else
1992     mio_symbol_ref (&ts->derived);
1993
1994   /* Add info for C interop and is_iso_c.  */
1995   mio_integer (&ts->is_c_interop);
1996   mio_integer (&ts->is_iso_c);
1997
1998   /* If the typespec is for an identifier either from iso_c_binding, or
1999      a constant that was initialized to an identifier from it, use the
2000      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
2001   if (ts->is_iso_c)
2002     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2003   else
2004     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2005
2006   if (ts->type != BT_CHARACTER)
2007     {
2008       /* ts->cl is only valid for BT_CHARACTER.  */
2009       mio_lparen ();
2010       mio_rparen ();
2011     }
2012   else
2013     mio_charlen (&ts->cl);
2014
2015   mio_rparen ();
2016 }
2017
2018
2019 static const mstring array_spec_types[] = {
2020     minit ("EXPLICIT", AS_EXPLICIT),
2021     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2022     minit ("DEFERRED", AS_DEFERRED),
2023     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2024     minit (NULL, -1)
2025 };
2026
2027
2028 static void
2029 mio_array_spec (gfc_array_spec **asp)
2030 {
2031   gfc_array_spec *as;
2032   int i;
2033
2034   mio_lparen ();
2035
2036   if (iomode == IO_OUTPUT)
2037     {
2038       if (*asp == NULL)
2039         goto done;
2040       as = *asp;
2041     }
2042   else
2043     {
2044       if (peek_atom () == ATOM_RPAREN)
2045         {
2046           *asp = NULL;
2047           goto done;
2048         }
2049
2050       *asp = as = gfc_get_array_spec ();
2051     }
2052
2053   mio_integer (&as->rank);
2054   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2055
2056   for (i = 0; i < as->rank; i++)
2057     {
2058       mio_expr (&as->lower[i]);
2059       mio_expr (&as->upper[i]);
2060     }
2061
2062 done:
2063   mio_rparen ();
2064 }
2065
2066
2067 /* Given a pointer to an array reference structure (which lives in a
2068    gfc_ref structure), find the corresponding array specification
2069    structure.  Storing the pointer in the ref structure doesn't quite
2070    work when loading from a module. Generating code for an array
2071    reference also needs more information than just the array spec.  */
2072
2073 static const mstring array_ref_types[] = {
2074     minit ("FULL", AR_FULL),
2075     minit ("ELEMENT", AR_ELEMENT),
2076     minit ("SECTION", AR_SECTION),
2077     minit (NULL, -1)
2078 };
2079
2080
2081 static void
2082 mio_array_ref (gfc_array_ref *ar)
2083 {
2084   int i;
2085
2086   mio_lparen ();
2087   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2088   mio_integer (&ar->dimen);
2089
2090   switch (ar->type)
2091     {
2092     case AR_FULL:
2093       break;
2094
2095     case AR_ELEMENT:
2096       for (i = 0; i < ar->dimen; i++)
2097         mio_expr (&ar->start[i]);
2098
2099       break;
2100
2101     case AR_SECTION:
2102       for (i = 0; i < ar->dimen; i++)
2103         {
2104           mio_expr (&ar->start[i]);
2105           mio_expr (&ar->end[i]);
2106           mio_expr (&ar->stride[i]);
2107         }
2108
2109       break;
2110
2111     case AR_UNKNOWN:
2112       gfc_internal_error ("mio_array_ref(): Unknown array ref");
2113     }
2114
2115   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2116      we can't call mio_integer directly.  Instead loop over each element
2117      and cast it to/from an integer.  */
2118   if (iomode == IO_OUTPUT)
2119     {
2120       for (i = 0; i < ar->dimen; i++)
2121         {
2122           int tmp = (int)ar->dimen_type[i];
2123           write_atom (ATOM_INTEGER, &tmp);
2124         }
2125     }
2126   else
2127     {
2128       for (i = 0; i < ar->dimen; i++)
2129         {
2130           require_atom (ATOM_INTEGER);
2131           ar->dimen_type[i] = atom_int;
2132         }
2133     }
2134
2135   if (iomode == IO_INPUT)
2136     {
2137       ar->where = gfc_current_locus;
2138
2139       for (i = 0; i < ar->dimen; i++)
2140         ar->c_where[i] = gfc_current_locus;
2141     }
2142
2143   mio_rparen ();
2144 }
2145
2146
2147 /* Saves or restores a pointer.  The pointer is converted back and
2148    forth from an integer.  We return the pointer_info pointer so that
2149    the caller can take additional action based on the pointer type.  */
2150
2151 static pointer_info *
2152 mio_pointer_ref (void *gp)
2153 {
2154   pointer_info *p;
2155
2156   if (iomode == IO_OUTPUT)
2157     {
2158       p = get_pointer (*((char **) gp));
2159       write_atom (ATOM_INTEGER, &p->integer);
2160     }
2161   else
2162     {
2163       require_atom (ATOM_INTEGER);
2164       p = add_fixup (atom_int, gp);
2165     }
2166
2167   return p;
2168 }
2169
2170
2171 /* Save and load references to components that occur within
2172    expressions.  We have to describe these references by a number and
2173    by name.  The number is necessary for forward references during
2174    reading, and the name is necessary if the symbol already exists in
2175    the namespace and is not loaded again.  */
2176
2177 static void
2178 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2179 {
2180   char name[GFC_MAX_SYMBOL_LEN + 1];
2181   gfc_component *q;
2182   pointer_info *p;
2183
2184   p = mio_pointer_ref (cp);
2185   if (p->type == P_UNKNOWN)
2186     p->type = P_COMPONENT;
2187
2188   if (iomode == IO_OUTPUT)
2189     mio_pool_string (&(*cp)->name);
2190   else
2191     {
2192       mio_internal_string (name);
2193
2194       /* It can happen that a component reference can be read before the
2195          associated derived type symbol has been loaded. Return now and
2196          wait for a later iteration of load_needed.  */
2197       if (sym == NULL)
2198         return;
2199
2200       if (sym->components != NULL && p->u.pointer == NULL)
2201         {
2202           /* Symbol already loaded, so search by name.  */
2203           for (q = sym->components; q; q = q->next)
2204             if (strcmp (q->name, name) == 0)
2205               break;
2206
2207           if (q == NULL)
2208             gfc_internal_error ("mio_component_ref(): Component not found");
2209
2210           associate_integer_pointer (p, q);
2211         }
2212
2213       /* Make sure this symbol will eventually be loaded.  */
2214       p = find_pointer2 (sym);
2215       if (p->u.rsym.state == UNUSED)
2216         p->u.rsym.state = NEEDED;
2217     }
2218 }
2219
2220
2221 static void
2222 mio_component (gfc_component *c)
2223 {
2224   pointer_info *p;
2225   int n;
2226
2227   mio_lparen ();
2228
2229   if (iomode == IO_OUTPUT)
2230     {
2231       p = get_pointer (c);
2232       mio_integer (&p->integer);
2233     }
2234   else
2235     {
2236       mio_integer (&n);
2237       p = get_integer (n);
2238       associate_integer_pointer (p, c);
2239     }
2240
2241   if (p->type == P_UNKNOWN)
2242     p->type = P_COMPONENT;
2243
2244   mio_pool_string (&c->name);
2245   mio_typespec (&c->ts);
2246   mio_array_spec (&c->as);
2247
2248   mio_integer (&c->dimension);
2249   mio_integer (&c->pointer);
2250   mio_integer (&c->allocatable);
2251   c->access = MIO_NAME (gfc_access) (c->access, access_types);
2252
2253   mio_expr (&c->initializer);
2254   mio_rparen ();
2255 }
2256
2257
2258 static void
2259 mio_component_list (gfc_component **cp)
2260 {
2261   gfc_component *c, *tail;
2262
2263   mio_lparen ();
2264
2265   if (iomode == IO_OUTPUT)
2266     {
2267       for (c = *cp; c; c = c->next)
2268         mio_component (c);
2269     }
2270   else
2271     {
2272       *cp = NULL;
2273       tail = NULL;
2274
2275       for (;;)
2276         {
2277           if (peek_atom () == ATOM_RPAREN)
2278             break;
2279
2280           c = gfc_get_component ();
2281           mio_component (c);
2282
2283           if (tail == NULL)
2284             *cp = c;
2285           else
2286             tail->next = c;
2287
2288           tail = c;
2289         }
2290     }
2291
2292   mio_rparen ();
2293 }
2294
2295
2296 static void
2297 mio_actual_arg (gfc_actual_arglist *a)
2298 {
2299   mio_lparen ();
2300   mio_pool_string (&a->name);
2301   mio_expr (&a->expr);
2302   mio_rparen ();
2303 }
2304
2305
2306 static void
2307 mio_actual_arglist (gfc_actual_arglist **ap)
2308 {
2309   gfc_actual_arglist *a, *tail;
2310
2311   mio_lparen ();
2312
2313   if (iomode == IO_OUTPUT)
2314     {
2315       for (a = *ap; a; a = a->next)
2316         mio_actual_arg (a);
2317
2318     }
2319   else
2320     {
2321       tail = NULL;
2322
2323       for (;;)
2324         {
2325           if (peek_atom () != ATOM_LPAREN)
2326             break;
2327
2328           a = gfc_get_actual_arglist ();
2329
2330           if (tail == NULL)
2331             *ap = a;
2332           else
2333             tail->next = a;
2334
2335           tail = a;
2336           mio_actual_arg (a);
2337         }
2338     }
2339
2340   mio_rparen ();
2341 }
2342
2343
2344 /* Read and write formal argument lists.  */
2345
2346 static void
2347 mio_formal_arglist (gfc_symbol *sym)
2348 {
2349   gfc_formal_arglist *f, *tail;
2350
2351   mio_lparen ();
2352
2353   if (iomode == IO_OUTPUT)
2354     {
2355       for (f = sym->formal; f; f = f->next)
2356         mio_symbol_ref (&f->sym);
2357     }
2358   else
2359     {
2360       sym->formal = tail = NULL;
2361
2362       while (peek_atom () != ATOM_RPAREN)
2363         {
2364           f = gfc_get_formal_arglist ();
2365           mio_symbol_ref (&f->sym);
2366
2367           if (sym->formal == NULL)
2368             sym->formal = f;
2369           else
2370             tail->next = f;
2371
2372           tail = f;
2373         }
2374     }
2375
2376   mio_rparen ();
2377 }
2378
2379
2380 /* Save or restore a reference to a symbol node.  */
2381
2382 pointer_info *
2383 mio_symbol_ref (gfc_symbol **symp)
2384 {
2385   pointer_info *p;
2386
2387   p = mio_pointer_ref (symp);
2388   if (p->type == P_UNKNOWN)
2389     p->type = P_SYMBOL;
2390
2391   if (iomode == IO_OUTPUT)
2392     {
2393       if (p->u.wsym.state == UNREFERENCED)
2394         p->u.wsym.state = NEEDS_WRITE;
2395     }
2396   else
2397     {
2398       if (p->u.rsym.state == UNUSED)
2399         p->u.rsym.state = NEEDED;
2400     }
2401   return p;
2402 }
2403
2404
2405 /* Save or restore a reference to a symtree node.  */
2406
2407 static void
2408 mio_symtree_ref (gfc_symtree **stp)
2409 {
2410   pointer_info *p;
2411   fixup_t *f;
2412
2413   if (iomode == IO_OUTPUT)
2414     mio_symbol_ref (&(*stp)->n.sym);
2415   else
2416     {
2417       require_atom (ATOM_INTEGER);
2418       p = get_integer (atom_int);
2419
2420       /* An unused equivalence member; make a symbol and a symtree
2421          for it.  */
2422       if (in_load_equiv && p->u.rsym.symtree == NULL)
2423         {
2424           /* Since this is not used, it must have a unique name.  */
2425           p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2426
2427           /* Make the symbol.  */
2428           if (p->u.rsym.sym == NULL)
2429             {
2430               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2431                                               gfc_current_ns);
2432               p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2433             }
2434
2435           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2436           p->u.rsym.symtree->n.sym->refs++;
2437           p->u.rsym.referenced = 1;
2438
2439           /* If the symbol is PRIVATE and in COMMON, load_commons will
2440              generate a fixup symbol, which must be associated.  */
2441           if (p->fixup)
2442             resolve_fixups (p->fixup, p->u.rsym.sym);
2443           p->fixup = NULL;
2444         }
2445
2446       if (p->type == P_UNKNOWN)
2447         p->type = P_SYMBOL;
2448
2449       if (p->u.rsym.state == UNUSED)
2450         p->u.rsym.state = NEEDED;
2451
2452       if (p->u.rsym.symtree != NULL)
2453         {
2454           *stp = p->u.rsym.symtree;
2455         }
2456       else
2457         {
2458           f = XCNEW (fixup_t);
2459
2460           f->next = p->u.rsym.stfixup;
2461           p->u.rsym.stfixup = f;
2462
2463           f->pointer = (void **) stp;
2464         }
2465     }
2466 }
2467
2468
2469 static void
2470 mio_iterator (gfc_iterator **ip)
2471 {
2472   gfc_iterator *iter;
2473
2474   mio_lparen ();
2475
2476   if (iomode == IO_OUTPUT)
2477     {
2478       if (*ip == NULL)
2479         goto done;
2480     }
2481   else
2482     {
2483       if (peek_atom () == ATOM_RPAREN)
2484         {
2485           *ip = NULL;
2486           goto done;
2487         }
2488
2489       *ip = gfc_get_iterator ();
2490     }
2491
2492   iter = *ip;
2493
2494   mio_expr (&iter->var);
2495   mio_expr (&iter->start);
2496   mio_expr (&iter->end);
2497   mio_expr (&iter->step);
2498
2499 done:
2500   mio_rparen ();
2501 }
2502
2503
2504 static void
2505 mio_constructor (gfc_constructor **cp)
2506 {
2507   gfc_constructor *c, *tail;
2508
2509   mio_lparen ();
2510
2511   if (iomode == IO_OUTPUT)
2512     {
2513       for (c = *cp; c; c = c->next)
2514         {
2515           mio_lparen ();
2516           mio_expr (&c->expr);
2517           mio_iterator (&c->iterator);
2518           mio_rparen ();
2519         }
2520     }
2521   else
2522     {
2523       *cp = NULL;
2524       tail = NULL;
2525
2526       while (peek_atom () != ATOM_RPAREN)
2527         {
2528           c = gfc_get_constructor ();
2529
2530           if (tail == NULL)
2531             *cp = c;
2532           else
2533             tail->next = c;
2534
2535           tail = c;
2536
2537           mio_lparen ();
2538           mio_expr (&c->expr);
2539           mio_iterator (&c->iterator);
2540           mio_rparen ();
2541         }
2542     }
2543
2544   mio_rparen ();
2545 }
2546
2547
2548 static const mstring ref_types[] = {
2549     minit ("ARRAY", REF_ARRAY),
2550     minit ("COMPONENT", REF_COMPONENT),
2551     minit ("SUBSTRING", REF_SUBSTRING),
2552     minit (NULL, -1)
2553 };
2554
2555
2556 static void
2557 mio_ref (gfc_ref **rp)
2558 {
2559   gfc_ref *r;
2560
2561   mio_lparen ();
2562
2563   r = *rp;
2564   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2565
2566   switch (r->type)
2567     {
2568     case REF_ARRAY:
2569       mio_array_ref (&r->u.ar);
2570       break;
2571
2572     case REF_COMPONENT:
2573       mio_symbol_ref (&r->u.c.sym);
2574       mio_component_ref (&r->u.c.component, r->u.c.sym);
2575       break;
2576
2577     case REF_SUBSTRING:
2578       mio_expr (&r->u.ss.start);
2579       mio_expr (&r->u.ss.end);
2580       mio_charlen (&r->u.ss.length);
2581       break;
2582     }
2583
2584   mio_rparen ();
2585 }
2586
2587
2588 static void
2589 mio_ref_list (gfc_ref **rp)
2590 {
2591   gfc_ref *ref, *head, *tail;
2592
2593   mio_lparen ();
2594
2595   if (iomode == IO_OUTPUT)
2596     {
2597       for (ref = *rp; ref; ref = ref->next)
2598         mio_ref (&ref);
2599     }
2600   else
2601     {
2602       head = tail = NULL;
2603
2604       while (peek_atom () != ATOM_RPAREN)
2605         {
2606           if (head == NULL)
2607             head = tail = gfc_get_ref ();
2608           else
2609             {
2610               tail->next = gfc_get_ref ();
2611               tail = tail->next;
2612             }
2613
2614           mio_ref (&tail);
2615         }
2616
2617       *rp = head;
2618     }
2619
2620   mio_rparen ();
2621 }
2622
2623
2624 /* Read and write an integer value.  */
2625
2626 static void
2627 mio_gmp_integer (mpz_t *integer)
2628 {
2629   char *p;
2630
2631   if (iomode == IO_INPUT)
2632     {
2633       if (parse_atom () != ATOM_STRING)
2634         bad_module ("Expected integer string");
2635
2636       mpz_init (*integer);
2637       if (mpz_set_str (*integer, atom_string, 10))
2638         bad_module ("Error converting integer");
2639
2640       gfc_free (atom_string);
2641     }
2642   else
2643     {
2644       p = mpz_get_str (NULL, 10, *integer);
2645       write_atom (ATOM_STRING, p);
2646       gfc_free (p);
2647     }
2648 }
2649
2650
2651 static void
2652 mio_gmp_real (mpfr_t *real)
2653 {
2654   mp_exp_t exponent;
2655   char *p;
2656
2657   if (iomode == IO_INPUT)
2658     {
2659       if (parse_atom () != ATOM_STRING)
2660         bad_module ("Expected real string");
2661
2662       mpfr_init (*real);
2663       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2664       gfc_free (atom_string);
2665     }
2666   else
2667     {
2668       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2669
2670       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
2671         {
2672           write_atom (ATOM_STRING, p);
2673           gfc_free (p);
2674           return;
2675         }
2676
2677       atom_string = XCNEWVEC (char, strlen (p) + 20);
2678
2679       sprintf (atom_string, "0.%s@%ld", p, exponent);
2680
2681       /* Fix negative numbers.  */
2682       if (atom_string[2] == '-')
2683         {
2684           atom_string[0] = '-';
2685           atom_string[1] = '0';
2686           atom_string[2] = '.';
2687         }
2688
2689       write_atom (ATOM_STRING, atom_string);
2690
2691       gfc_free (atom_string);
2692       gfc_free (p);
2693     }
2694 }
2695
2696
2697 /* Save and restore the shape of an array constructor.  */
2698
2699 static void
2700 mio_shape (mpz_t **pshape, int rank)
2701 {
2702   mpz_t *shape;
2703   atom_type t;
2704   int n;
2705
2706   /* A NULL shape is represented by ().  */
2707   mio_lparen ();
2708
2709   if (iomode == IO_OUTPUT)
2710     {
2711       shape = *pshape;
2712       if (!shape)
2713         {
2714           mio_rparen ();
2715           return;
2716         }
2717     }
2718   else
2719     {
2720       t = peek_atom ();
2721       if (t == ATOM_RPAREN)
2722         {
2723           *pshape = NULL;
2724           mio_rparen ();
2725           return;
2726         }
2727
2728       shape = gfc_get_shape (rank);
2729       *pshape = shape;
2730     }
2731
2732   for (n = 0; n < rank; n++)
2733     mio_gmp_integer (&shape[n]);
2734
2735   mio_rparen ();
2736 }
2737
2738
2739 static const mstring expr_types[] = {
2740     minit ("OP", EXPR_OP),
2741     minit ("FUNCTION", EXPR_FUNCTION),
2742     minit ("CONSTANT", EXPR_CONSTANT),
2743     minit ("VARIABLE", EXPR_VARIABLE),
2744     minit ("SUBSTRING", EXPR_SUBSTRING),
2745     minit ("STRUCTURE", EXPR_STRUCTURE),
2746     minit ("ARRAY", EXPR_ARRAY),
2747     minit ("NULL", EXPR_NULL),
2748     minit (NULL, -1)
2749 };
2750
2751 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2752    generic operators, not in expressions.  INTRINSIC_USER is also
2753    replaced by the correct function name by the time we see it.  */
2754
2755 static const mstring intrinsics[] =
2756 {
2757     minit ("UPLUS", INTRINSIC_UPLUS),
2758     minit ("UMINUS", INTRINSIC_UMINUS),
2759     minit ("PLUS", INTRINSIC_PLUS),
2760     minit ("MINUS", INTRINSIC_MINUS),
2761     minit ("TIMES", INTRINSIC_TIMES),
2762     minit ("DIVIDE", INTRINSIC_DIVIDE),
2763     minit ("POWER", INTRINSIC_POWER),
2764     minit ("CONCAT", INTRINSIC_CONCAT),
2765     minit ("AND", INTRINSIC_AND),
2766     minit ("OR", INTRINSIC_OR),
2767     minit ("EQV", INTRINSIC_EQV),
2768     minit ("NEQV", INTRINSIC_NEQV),
2769     minit ("EQ_SIGN", INTRINSIC_EQ),
2770     minit ("EQ", INTRINSIC_EQ_OS),
2771     minit ("NE_SIGN", INTRINSIC_NE),
2772     minit ("NE", INTRINSIC_NE_OS),
2773     minit ("GT_SIGN", INTRINSIC_GT),
2774     minit ("GT", INTRINSIC_GT_OS),
2775     minit ("GE_SIGN", INTRINSIC_GE),
2776     minit ("GE", INTRINSIC_GE_OS),
2777     minit ("LT_SIGN", INTRINSIC_LT),
2778     minit ("LT", INTRINSIC_LT_OS),
2779     minit ("LE_SIGN", INTRINSIC_LE),
2780     minit ("LE", INTRINSIC_LE_OS),
2781     minit ("NOT", INTRINSIC_NOT),
2782     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2783     minit (NULL, -1)
2784 };
2785
2786
2787 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
2788
2789 static void
2790 fix_mio_expr (gfc_expr *e)
2791 {
2792   gfc_symtree *ns_st = NULL;
2793   const char *fname;
2794
2795   if (iomode != IO_OUTPUT)
2796     return;
2797
2798   if (e->symtree)
2799     {
2800       /* If this is a symtree for a symbol that came from a contained module
2801          namespace, it has a unique name and we should look in the current
2802          namespace to see if the required, non-contained symbol is available
2803          yet. If so, the latter should be written.  */
2804       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2805         ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2806                                   e->symtree->n.sym->name);
2807
2808       /* On the other hand, if the existing symbol is the module name or the
2809          new symbol is a dummy argument, do not do the promotion.  */
2810       if (ns_st && ns_st->n.sym
2811           && ns_st->n.sym->attr.flavor != FL_MODULE
2812           && !e->symtree->n.sym->attr.dummy)
2813         e->symtree = ns_st;
2814     }
2815   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2816     {
2817       /* In some circumstances, a function used in an initialization
2818          expression, in one use associated module, can fail to be
2819          coupled to its symtree when used in a specification
2820          expression in another module.  */
2821       fname = e->value.function.esym ? e->value.function.esym->name
2822                                      : e->value.function.isym->name;
2823       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2824     }
2825 }
2826
2827
2828 /* Read and write expressions.  The form "()" is allowed to indicate a
2829    NULL expression.  */
2830
2831 static void
2832 mio_expr (gfc_expr **ep)
2833 {
2834   gfc_expr *e;
2835   atom_type t;
2836   int flag;
2837
2838   mio_lparen ();
2839
2840   if (iomode == IO_OUTPUT)
2841     {
2842       if (*ep == NULL)
2843         {
2844           mio_rparen ();
2845           return;
2846         }
2847
2848       e = *ep;
2849       MIO_NAME (expr_t) (e->expr_type, expr_types);
2850     }
2851   else
2852     {
2853       t = parse_atom ();
2854       if (t == ATOM_RPAREN)
2855         {
2856           *ep = NULL;
2857           return;
2858         }
2859
2860       if (t != ATOM_NAME)
2861         bad_module ("Expected expression type");
2862
2863       e = *ep = gfc_get_expr ();
2864       e->where = gfc_current_locus;
2865       e->expr_type = (expr_t) find_enum (expr_types);
2866     }
2867
2868   mio_typespec (&e->ts);
2869   mio_integer (&e->rank);
2870
2871   fix_mio_expr (e);
2872
2873   switch (e->expr_type)
2874     {
2875     case EXPR_OP:
2876       e->value.op.op
2877         = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
2878
2879       switch (e->value.op.op)
2880         {
2881         case INTRINSIC_UPLUS:
2882         case INTRINSIC_UMINUS:
2883         case INTRINSIC_NOT:
2884         case INTRINSIC_PARENTHESES:
2885           mio_expr (&e->value.op.op1);
2886           break;
2887
2888         case INTRINSIC_PLUS:
2889         case INTRINSIC_MINUS:
2890         case INTRINSIC_TIMES:
2891         case INTRINSIC_DIVIDE:
2892         case INTRINSIC_POWER:
2893         case INTRINSIC_CONCAT:
2894         case INTRINSIC_AND:
2895         case INTRINSIC_OR:
2896         case INTRINSIC_EQV:
2897         case INTRINSIC_NEQV:
2898         case INTRINSIC_EQ:
2899         case INTRINSIC_EQ_OS:
2900         case INTRINSIC_NE:
2901         case INTRINSIC_NE_OS:
2902         case INTRINSIC_GT:
2903         case INTRINSIC_GT_OS:
2904         case INTRINSIC_GE:
2905         case INTRINSIC_GE_OS:
2906         case INTRINSIC_LT:
2907         case INTRINSIC_LT_OS:
2908         case INTRINSIC_LE:
2909         case INTRINSIC_LE_OS:
2910           mio_expr (&e->value.op.op1);
2911           mio_expr (&e->value.op.op2);
2912           break;
2913
2914         default:
2915           bad_module ("Bad operator");
2916         }
2917
2918       break;
2919
2920     case EXPR_FUNCTION:
2921       mio_symtree_ref (&e->symtree);
2922       mio_actual_arglist (&e->value.function.actual);
2923
2924       if (iomode == IO_OUTPUT)
2925         {
2926           e->value.function.name
2927             = mio_allocated_string (e->value.function.name);
2928           flag = e->value.function.esym != NULL;
2929           mio_integer (&flag);
2930           if (flag)
2931             mio_symbol_ref (&e->value.function.esym);
2932           else
2933             write_atom (ATOM_STRING, e->value.function.isym->name);
2934         }
2935       else
2936         {
2937           require_atom (ATOM_STRING);
2938           e->value.function.name = gfc_get_string (atom_string);
2939           gfc_free (atom_string);
2940
2941           mio_integer (&flag);
2942           if (flag)
2943             mio_symbol_ref (&e->value.function.esym);
2944           else
2945             {
2946               require_atom (ATOM_STRING);
2947               e->value.function.isym = gfc_find_function (atom_string);
2948               gfc_free (atom_string);
2949             }
2950         }
2951
2952       break;
2953
2954     case EXPR_VARIABLE:
2955       mio_symtree_ref (&e->symtree);
2956       mio_ref_list (&e->ref);
2957       break;
2958
2959     case EXPR_SUBSTRING:
2960       e->value.character.string
2961         = CONST_CAST (gfc_char_t *,
2962                       mio_allocated_wide_string (e->value.character.string,
2963                                                  e->value.character.length));
2964       mio_ref_list (&e->ref);
2965       break;
2966
2967     case EXPR_STRUCTURE:
2968     case EXPR_ARRAY:
2969       mio_constructor (&e->value.constructor);
2970       mio_shape (&e->shape, e->rank);
2971       break;
2972
2973     case EXPR_CONSTANT:
2974       switch (e->ts.type)
2975         {
2976         case BT_INTEGER:
2977           mio_gmp_integer (&e->value.integer);
2978           break;
2979
2980         case BT_REAL:
2981           gfc_set_model_kind (e->ts.kind);
2982           mio_gmp_real (&e->value.real);
2983           break;
2984
2985         case BT_COMPLEX:
2986           gfc_set_model_kind (e->ts.kind);
2987           mio_gmp_real (&e->value.complex.r);
2988           mio_gmp_real (&e->value.complex.i);
2989           break;
2990
2991         case BT_LOGICAL:
2992           mio_integer (&e->value.logical);
2993           break;
2994
2995         case BT_CHARACTER:
2996           mio_integer (&e->value.character.length);
2997           e->value.character.string
2998             = CONST_CAST (gfc_char_t *,
2999                           mio_allocated_wide_string (e->value.character.string,
3000                                                      e->value.character.length));
3001           break;
3002
3003         default:
3004           bad_module ("Bad type in constant expression");
3005         }
3006
3007       break;
3008
3009     case EXPR_NULL:
3010       break;
3011     }
3012
3013   mio_rparen ();
3014 }
3015
3016
3017 /* Read and write namelists.  */
3018
3019 static void
3020 mio_namelist (gfc_symbol *sym)
3021 {
3022   gfc_namelist *n, *m;
3023   const char *check_name;
3024
3025   mio_lparen ();
3026
3027   if (iomode == IO_OUTPUT)
3028     {
3029       for (n = sym->namelist; n; n = n->next)
3030         mio_symbol_ref (&n->sym);
3031     }
3032   else
3033     {
3034       /* This departure from the standard is flagged as an error.
3035          It does, in fact, work correctly. TODO: Allow it
3036          conditionally?  */
3037       if (sym->attr.flavor == FL_NAMELIST)
3038         {
3039           check_name = find_use_name (sym->name, false);
3040           if (check_name && strcmp (check_name, sym->name) != 0)
3041             gfc_error ("Namelist %s cannot be renamed by USE "
3042                        "association to %s", sym->name, check_name);
3043         }
3044
3045       m = NULL;
3046       while (peek_atom () != ATOM_RPAREN)
3047         {
3048           n = gfc_get_namelist ();
3049           mio_symbol_ref (&n->sym);
3050
3051           if (sym->namelist == NULL)
3052             sym->namelist = n;
3053           else
3054             m->next = n;
3055
3056           m = n;
3057         }
3058       sym->namelist_tail = m;
3059     }
3060
3061   mio_rparen ();
3062 }
3063
3064
3065 /* Save/restore lists of gfc_interface structures.  When loading an
3066    interface, we are really appending to the existing list of
3067    interfaces.  Checking for duplicate and ambiguous interfaces has to
3068    be done later when all symbols have been loaded.  */
3069
3070 pointer_info *
3071 mio_interface_rest (gfc_interface **ip)
3072 {
3073   gfc_interface *tail, *p;
3074   pointer_info *pi = NULL;
3075
3076   if (iomode == IO_OUTPUT)
3077     {
3078       if (ip != NULL)
3079         for (p = *ip; p; p = p->next)
3080           mio_symbol_ref (&p->sym);
3081     }
3082   else
3083     {
3084       if (*ip == NULL)
3085         tail = NULL;
3086       else
3087         {
3088           tail = *ip;
3089           while (tail->next)
3090             tail = tail->next;
3091         }
3092
3093       for (;;)
3094         {
3095           if (peek_atom () == ATOM_RPAREN)
3096             break;
3097
3098           p = gfc_get_interface ();
3099           p->where = gfc_current_locus;
3100           pi = mio_symbol_ref (&p->sym);
3101
3102           if (tail == NULL)
3103             *ip = p;
3104           else
3105             tail->next = p;
3106
3107           tail = p;
3108         }
3109     }
3110
3111   mio_rparen ();
3112   return pi;
3113 }
3114
3115
3116 /* Save/restore a nameless operator interface.  */
3117
3118 static void
3119 mio_interface (gfc_interface **ip)
3120 {
3121   mio_lparen ();
3122   mio_interface_rest (ip);
3123 }
3124
3125
3126 /* Save/restore a named operator interface.  */
3127
3128 static void
3129 mio_symbol_interface (const char **name, const char **module,
3130                       gfc_interface **ip)
3131 {
3132   mio_lparen ();
3133   mio_pool_string (name);
3134   mio_pool_string (module);
3135   mio_interface_rest (ip);
3136 }
3137
3138
3139 static void
3140 mio_namespace_ref (gfc_namespace **nsp)
3141 {
3142   gfc_namespace *ns;
3143   pointer_info *p;
3144
3145   p = mio_pointer_ref (nsp);
3146
3147   if (p->type == P_UNKNOWN)
3148     p->type = P_NAMESPACE;
3149
3150   if (iomode == IO_INPUT && p->integer != 0)
3151     {
3152       ns = (gfc_namespace *) p->u.pointer;
3153       if (ns == NULL)
3154         {
3155           ns = gfc_get_namespace (NULL, 0);
3156           associate_integer_pointer (p, ns);
3157         }
3158       else
3159         ns->refs++;
3160     }
3161 }
3162
3163
3164 /* Unlike most other routines, the address of the symbol node is already
3165    fixed on input and the name/module has already been filled in.  */
3166
3167 static void
3168 mio_symbol (gfc_symbol *sym)
3169 {
3170   int intmod = INTMOD_NONE;
3171
3172   gfc_formal_arglist *formal;
3173
3174   mio_lparen ();
3175
3176   mio_symbol_attribute (&sym->attr);
3177   mio_typespec (&sym->ts);
3178
3179   /* Contained procedures don't have formal namespaces.  Instead we output the
3180      procedure namespace.  The will contain the formal arguments.  */
3181   if (iomode == IO_OUTPUT)
3182     {
3183       formal = sym->formal;
3184       while (formal && !formal->sym)
3185         formal = formal->next;
3186
3187       if (formal)
3188         mio_namespace_ref (&formal->sym->ns);
3189       else
3190         mio_namespace_ref (&sym->formal_ns);
3191     }
3192   else
3193     {
3194       mio_namespace_ref (&sym->formal_ns);
3195       if (sym->formal_ns)
3196         {
3197           sym->formal_ns->proc_name = sym;
3198           sym->refs++;
3199         }
3200     }
3201
3202   /* Save/restore common block links.  */
3203   mio_symbol_ref (&sym->common_next);
3204
3205   mio_formal_arglist (sym);
3206
3207   if (sym->attr.flavor == FL_PARAMETER)
3208     mio_expr (&sym->value);
3209
3210   mio_array_spec (&sym->as);
3211
3212   mio_symbol_ref (&sym->result);
3213
3214   if (sym->attr.cray_pointee)
3215     mio_symbol_ref (&sym->cp_pointer);
3216
3217   /* Note that components are always saved, even if they are supposed
3218      to be private.  Component access is checked during searching.  */
3219
3220   mio_component_list (&sym->components);
3221
3222   if (sym->components != NULL)
3223     sym->component_access
3224       = MIO_NAME (gfc_access) (sym->component_access, access_types);
3225
3226   mio_namelist (sym);
3227
3228   /* Add the fields that say whether this is from an intrinsic module,
3229      and if so, what symbol it is within the module.  */
3230 /*   mio_integer (&(sym->from_intmod)); */
3231   if (iomode == IO_OUTPUT)
3232     {
3233       intmod = sym->from_intmod;
3234       mio_integer (&intmod);
3235     }
3236   else
3237     {
3238       mio_integer (&intmod);
3239       sym->from_intmod = intmod;
3240     }
3241
3242   mio_integer (&(sym->intmod_sym_id));
3243
3244   mio_rparen ();
3245 }
3246
3247
3248 /************************* Top level subroutines *************************/
3249
3250 /* Given a root symtree node and a symbol, try to find a symtree that
3251    references the symbol that is not a unique name.  */
3252
3253 static gfc_symtree *
3254 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3255 {
3256   gfc_symtree *s = NULL;
3257
3258   if (st == NULL)
3259     return s;
3260
3261   s = find_symtree_for_symbol (st->right, sym);
3262   if (s != NULL)
3263     return s;
3264   s = find_symtree_for_symbol (st->left, sym);
3265   if (s != NULL)
3266     return s;
3267
3268   if (st->n.sym == sym && !check_unique_name (st->name))
3269     return st;
3270
3271   return s;
3272 }
3273
3274
3275 /* A recursive function to look for a specific symbol by name and by
3276    module.  Whilst several symtrees might point to one symbol, its
3277    is sufficient for the purposes here than one exist.  Note that
3278    generic interfaces are distinguished as are symbols that have been
3279    renamed in another module.  */
3280 static gfc_symtree *
3281 find_symbol (gfc_symtree *st, const char *name,
3282              const char *module, int generic)
3283 {
3284   int c;
3285   gfc_symtree *retval, *s;
3286
3287   if (st == NULL || st->n.sym == NULL)
3288     return NULL;
3289
3290   c = strcmp (name, st->n.sym->name);
3291   if (c == 0 && st->n.sym->module
3292              && strcmp (module, st->n.sym->module) == 0
3293              && !check_unique_name (st->name))
3294     {
3295       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3296
3297       /* Detect symbols that are renamed by use association in another
3298          module by the absence of a symtree and null attr.use_rename,
3299          since the latter is not transmitted in the module file.  */
3300       if (((!generic && !st->n.sym->attr.generic)
3301                 || (generic && st->n.sym->attr.generic))
3302             && !(s == NULL && !st->n.sym->attr.use_rename))
3303         return st;
3304     }
3305
3306   retval = find_symbol (st->left, name, module, generic);
3307
3308   if (retval == NULL)
3309     retval = find_symbol (st->right, name, module, generic);
3310
3311   return retval;
3312 }
3313
3314
3315 /* Skip a list between balanced left and right parens.  */
3316
3317 static void
3318 skip_list (void)
3319 {
3320   int level;
3321
3322   level = 0;
3323   do
3324     {
3325       switch (parse_atom ())
3326         {
3327         case ATOM_LPAREN:
3328           level++;
3329           break;
3330
3331         case ATOM_RPAREN:
3332           level--;
3333           break;
3334
3335         case ATOM_STRING:
3336           gfc_free (atom_string);
3337           break;
3338
3339         case ATOM_NAME:
3340         case ATOM_INTEGER:
3341           break;
3342         }
3343     }
3344   while (level > 0);
3345 }
3346
3347
3348 /* Load operator interfaces from the module.  Interfaces are unusual
3349    in that they attach themselves to existing symbols.  */
3350
3351 static void
3352 load_operator_interfaces (void)
3353 {
3354   const char *p;
3355   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3356   gfc_user_op *uop;
3357   pointer_info *pi = NULL;
3358   int n, i;
3359
3360   mio_lparen ();
3361
3362   while (peek_atom () != ATOM_RPAREN)
3363     {
3364       mio_lparen ();
3365
3366       mio_internal_string (name);
3367       mio_internal_string (module);
3368
3369       n = number_use_names (name, true);
3370       n = n ? n : 1;
3371
3372       for (i = 1; i <= n; i++)
3373         {
3374           /* Decide if we need to load this one or not.  */
3375           p = find_use_name_n (name, &i, true);
3376
3377           if (p == NULL)
3378             {
3379               while (parse_atom () != ATOM_RPAREN);
3380               continue;
3381             }
3382
3383           if (i == 1)
3384             {
3385               uop = gfc_get_uop (p);
3386               pi = mio_interface_rest (&uop->op);
3387             }
3388           else
3389             {
3390               if (gfc_find_uop (p, NULL))
3391                 continue;
3392               uop = gfc_get_uop (p);
3393               uop->op = gfc_get_interface ();
3394               uop->op->where = gfc_current_locus;
3395               add_fixup (pi->integer, &uop->op->sym);
3396             }
3397         }
3398     }
3399
3400   mio_rparen ();
3401 }
3402
3403
3404 /* Load interfaces from the module.  Interfaces are unusual in that
3405    they attach themselves to existing symbols.  */
3406
3407 static void
3408 load_generic_interfaces (void)
3409 {
3410   const char *p;
3411   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3412   gfc_symbol *sym;
3413   gfc_interface *generic = NULL;
3414   int n, i, renamed;
3415
3416   mio_lparen ();
3417
3418   while (peek_atom () != ATOM_RPAREN)
3419     {
3420       mio_lparen ();
3421
3422       mio_internal_string (name);
3423       mio_internal_string (module);
3424
3425       n = number_use_names (name, false);
3426       renamed = n ? 1 : 0;
3427       n = n ? n : 1;
3428
3429       for (i = 1; i <= n; i++)
3430         {
3431           gfc_symtree *st;
3432           /* Decide if we need to load this one or not.  */
3433           p = find_use_name_n (name, &i, false);
3434
3435           st = find_symbol (gfc_current_ns->sym_root,
3436                             name, module_name, 1);
3437
3438           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3439             {
3440               /* Skip the specific names for these cases.  */
3441               while (i == 1 && parse_atom () != ATOM_RPAREN);
3442
3443               continue;
3444             }
3445
3446           /* If the symbol exists already and is being USEd without being
3447              in an ONLY clause, do not load a new symtree(11.3.2).  */
3448           if (!only_flag && st)
3449             sym = st->n.sym;
3450
3451           if (!sym)
3452             {
3453               /* Make the symbol inaccessible if it has been added by a USE
3454                  statement without an ONLY(11.3.2).  */
3455               if (st && only_flag
3456                      && !st->n.sym->attr.use_only
3457                      && !st->n.sym->attr.use_rename
3458                      && strcmp (st->n.sym->module, module_name) == 0)
3459                 {
3460                   sym = st->n.sym;
3461                   gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3462                   st = gfc_get_unique_symtree (gfc_current_ns);
3463                   st->n.sym = sym;
3464                   sym = NULL;
3465                 }
3466               else if (st)
3467                 {
3468                   sym = st->n.sym;
3469                   if (strcmp (st->name, p) != 0)
3470                     {
3471                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
3472                       st->n.sym = sym;
3473                       sym->refs++;
3474                     }
3475                 }
3476
3477               /* Since we haven't found a valid generic interface, we had
3478                  better make one.  */
3479               if (!sym)
3480                 {
3481                   gfc_get_symbol (p, NULL, &sym);
3482                   sym->name = gfc_get_string (name);
3483                   sym->module = gfc_get_string (module_name);
3484                   sym->attr.flavor = FL_PROCEDURE;
3485                   sym->attr.generic = 1;
3486                   sym->attr.use_assoc = 1;
3487                 }
3488             }
3489           else
3490             {
3491               /* Unless sym is a generic interface, this reference
3492                  is ambiguous.  */
3493               if (st == NULL)
3494                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3495
3496               sym = st->n.sym;
3497
3498               if (st && !sym->attr.generic
3499                      && sym->module
3500                      && strcmp(module, sym->module))
3501                 st->ambiguous = 1;
3502             }
3503
3504           sym->attr.use_only = only_flag;
3505           sym->attr.use_rename = renamed;
3506
3507           if (i == 1)
3508             {
3509               mio_interface_rest (&sym->generic);
3510               generic = sym->generic;
3511             }
3512           else if (!sym->generic)
3513             {
3514               sym->generic = generic;
3515               sym->attr.generic_copy = 1;
3516             }
3517         }
3518     }
3519
3520   mio_rparen ();
3521 }
3522
3523
3524 /* Load common blocks.  */
3525
3526 static void
3527 load_commons (void)
3528 {
3529   char name[GFC_MAX_SYMBOL_LEN + 1];
3530   gfc_common_head *p;
3531
3532   mio_lparen ();
3533
3534   while (peek_atom () != ATOM_RPAREN)
3535     {
3536       int flags;
3537       mio_lparen ();
3538       mio_internal_string (name);
3539
3540       p = gfc_get_common (name, 1);
3541
3542       mio_symbol_ref (&p->head);
3543       mio_integer (&flags);
3544       if (flags & 1)
3545         p->saved = 1;
3546       if (flags & 2)
3547         p->threadprivate = 1;
3548       p->use_assoc = 1;
3549
3550       /* Get whether this was a bind(c) common or not.  */
3551       mio_integer (&p->is_bind_c);
3552       /* Get the binding label.  */
3553       mio_internal_string (p->binding_label);
3554
3555       mio_rparen ();
3556     }
3557
3558   mio_rparen ();
3559 }
3560
3561
3562 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
3563    so that unused variables are not loaded and so that the expression can
3564    be safely freed.  */
3565
3566 static void
3567 load_equiv (void)
3568 {
3569   gfc_equiv *head, *tail, *end, *eq;
3570   bool unused;
3571
3572   mio_lparen ();
3573   in_load_equiv = true;
3574
3575   end = gfc_current_ns->equiv;
3576   while (end != NULL && end->next != NULL)
3577     end = end->next;
3578
3579   while (peek_atom () != ATOM_RPAREN) {
3580     mio_lparen ();
3581     head = tail = NULL;
3582
3583     while(peek_atom () != ATOM_RPAREN)
3584       {
3585         if (head == NULL)
3586           head = tail = gfc_get_equiv ();
3587         else
3588           {
3589             tail->eq = gfc_get_equiv ();
3590             tail = tail->eq;
3591           }
3592
3593         mio_pool_string (&tail->module);
3594         mio_expr (&tail->expr);
3595       }
3596
3597     /* Unused equivalence members have a unique name.  */
3598     unused = true;
3599     for (eq = head; eq; eq = eq->eq)
3600       {
3601         if (!check_unique_name (eq->expr->symtree->name))
3602           {
3603             unused = false;
3604             break;
3605           }
3606       }
3607
3608     if (unused)
3609       {
3610         for (eq = head; eq; eq = head)
3611           {
3612             head = eq->eq;
3613             gfc_free_expr (eq->expr);
3614             gfc_free (eq);
3615           }
3616       }
3617
3618     if (end == NULL)
3619       gfc_current_ns->equiv = head;
3620     else
3621       end->next = head;
3622
3623     if (head != NULL)
3624       end = head;
3625
3626     mio_rparen ();
3627   }
3628
3629   mio_rparen ();
3630   in_load_equiv = false;
3631 }
3632
3633
3634 /* Recursive function to traverse the pointer_info tree and load a
3635    needed symbol.  We return nonzero if we load a symbol and stop the
3636    traversal, because the act of loading can alter the tree.  */
3637
3638 static int
3639 load_needed (pointer_info *p)
3640 {
3641   gfc_namespace *ns;
3642   pointer_info *q;
3643   gfc_symbol *sym;
3644   int rv;
3645
3646   rv = 0;
3647   if (p == NULL)
3648     return rv;
3649
3650   rv |= load_needed (p->left);
3651   rv |= load_needed (p->right);
3652
3653   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3654     return rv;
3655
3656   p->u.rsym.state = USED;
3657
3658   set_module_locus (&p->u.rsym.where);
3659
3660   sym = p->u.rsym.sym;
3661   if (sym == NULL)
3662     {
3663       q = get_integer (p->u.rsym.ns);
3664
3665       ns = (gfc_namespace *) q->u.pointer;
3666       if (ns == NULL)
3667         {
3668           /* Create an interface namespace if necessary.  These are
3669              the namespaces that hold the formal parameters of module
3670              procedures.  */
3671
3672           ns = gfc_get_namespace (NULL, 0);
3673           associate_integer_pointer (q, ns);
3674         }
3675
3676       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
3677          doesn't go pear-shaped if the symbol is used.  */
3678       if (!ns->proc_name)
3679         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
3680                                  1, &ns->proc_name);
3681
3682       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3683       sym->module = gfc_get_string (p->u.rsym.module);
3684       strcpy (sym->binding_label, p->u.rsym.binding_label);
3685
3686       associate_integer_pointer (p, sym);
3687     }
3688
3689   mio_symbol (sym);
3690   sym->attr.use_assoc = 1;
3691   if (only_flag)
3692     sym->attr.use_only = 1;
3693   if (p->u.rsym.renamed)
3694     sym->attr.use_rename = 1;
3695
3696   return 1;
3697 }
3698
3699
3700 /* Recursive function for cleaning up things after a module has been read.  */
3701
3702 static void
3703 read_cleanup (pointer_info *p)
3704 {
3705   gfc_symtree *st;
3706   pointer_info *q;
3707
3708   if (p == NULL)
3709     return;
3710
3711   read_cleanup (p->left);
3712   read_cleanup (p->right);
3713
3714   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3715     {
3716       /* Add hidden symbols to the symtree.  */
3717       q = get_integer (p->u.rsym.ns);
3718       st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
3719
3720       st->n.sym = p->u.rsym.sym;
3721       st->n.sym->refs++;
3722
3723       /* Fixup any symtree references.  */
3724       p->u.rsym.symtree = st;
3725       resolve_fixups (p->u.rsym.stfixup, st);
3726       p->u.rsym.stfixup = NULL;
3727     }
3728
3729   /* Free unused symbols.  */
3730   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3731     gfc_free_symbol (p->u.rsym.sym);
3732 }
3733
3734
3735 /* Read a module file.  */
3736
3737 static void
3738 read_module (void)
3739 {
3740   module_locus operator_interfaces, user_operators;
3741   const char *p;
3742   char name[GFC_MAX_SYMBOL_LEN + 1];
3743   gfc_intrinsic_op i;
3744   int ambiguous, j, nuse, symbol;
3745   pointer_info *info, *q;
3746   gfc_use_rename *u;
3747   gfc_symtree *st;
3748   gfc_symbol *sym;
3749
3750   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
3751   skip_list ();
3752
3753   get_module_locus (&user_operators);
3754   skip_list ();
3755   skip_list ();
3756
3757   /* Skip commons and equivalences for now.  */
3758   skip_list ();
3759   skip_list ();
3760
3761   mio_lparen ();
3762
3763   /* Create the fixup nodes for all the symbols.  */
3764
3765   while (peek_atom () != ATOM_RPAREN)
3766     {
3767       require_atom (ATOM_INTEGER);
3768       info = get_integer (atom_int);
3769
3770       info->type = P_SYMBOL;
3771       info->u.rsym.state = UNUSED;
3772
3773       mio_internal_string (info->u.rsym.true_name);
3774       mio_internal_string (info->u.rsym.module);
3775       mio_internal_string (info->u.rsym.binding_label);
3776
3777
3778       require_atom (ATOM_INTEGER);
3779       info->u.rsym.ns = atom_int;
3780
3781       get_module_locus (&info->u.rsym.where);
3782       skip_list ();
3783
3784       /* See if the symbol has already been loaded by a previous module.
3785          If so, we reference the existing symbol and prevent it from
3786          being loaded again.  This should not happen if the symbol being
3787          read is an index for an assumed shape dummy array (ns != 1).  */
3788
3789       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3790
3791       if (sym == NULL
3792           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3793         continue;
3794
3795       info->u.rsym.state = USED;
3796       info->u.rsym.sym = sym;
3797
3798       /* Some symbols do not have a namespace (eg. formal arguments),
3799          so the automatic "unique symtree" mechanism must be suppressed
3800          by marking them as referenced.  */
3801       q = get_integer (info->u.rsym.ns);
3802       if (q->u.pointer == NULL)
3803         {
3804           info->u.rsym.referenced = 1;
3805           continue;
3806         }
3807
3808       /* If possible recycle the symtree that references the symbol.
3809          If a symtree is not found and the module does not import one,
3810          a unique-name symtree is found by read_cleanup.  */
3811       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3812       if (st != NULL)
3813         {
3814           info->u.rsym.symtree = st;
3815           info->u.rsym.referenced = 1;
3816         }
3817     }
3818
3819   mio_rparen ();
3820
3821   /* Parse the symtree lists.  This lets us mark which symbols need to
3822      be loaded.  Renaming is also done at this point by replacing the
3823      symtree name.  */
3824
3825   mio_lparen ();
3826
3827   while (peek_atom () != ATOM_RPAREN)
3828     {
3829       mio_internal_string (name);
3830       mio_integer (&ambiguous);
3831       mio_integer (&symbol);
3832
3833       info = get_integer (symbol);
3834
3835       /* See how many use names there are.  If none, go through the start
3836          of the loop at least once.  */
3837       nuse = number_use_names (name, false);
3838       info->u.rsym.renamed = nuse ? 1 : 0;
3839
3840       if (nuse == 0)
3841         nuse = 1;
3842
3843       for (j = 1; j <= nuse; j++)
3844         {
3845           /* Get the jth local name for this symbol.  */
3846           p = find_use_name_n (name, &j, false);
3847
3848           if (p == NULL && strcmp (name, module_name) == 0)
3849             p = name;
3850
3851           /* Skip symtree nodes not in an ONLY clause, unless there
3852              is an existing symtree loaded from another USE statement.  */
3853           if (p == NULL)
3854             {
3855               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3856               if (st != NULL)
3857                 info->u.rsym.symtree = st;
3858               continue;
3859             }
3860
3861           /* If a symbol of the same name and module exists already,
3862              this symbol, which is not in an ONLY clause, must not be
3863              added to the namespace(11.3.2).  Note that find_symbol
3864              only returns the first occurrence that it finds.  */
3865           if (!only_flag && !info->u.rsym.renamed
3866                 && strcmp (name, module_name) != 0
3867                 && find_symbol (gfc_current_ns->sym_root, name,
3868                                 module_name, 0))
3869             continue;
3870
3871           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3872
3873           if (st != NULL)
3874             {
3875               /* Check for ambiguous symbols.  */
3876               if (st->n.sym != info->u.rsym.sym)
3877                 st->ambiguous = 1;
3878               info->u.rsym.symtree = st;
3879             }
3880           else
3881             {
3882               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3883
3884               /* Delete the symtree if the symbol has been added by a USE
3885                  statement without an ONLY(11.3.2). Remember that the rsym
3886                  will be the same as the symbol found in the symtree, for
3887                  this case.*/
3888               if (st && (only_flag || info->u.rsym.renamed)
3889                      && !st->n.sym->attr.use_only
3890                      && !st->n.sym->attr.use_rename
3891                      && info->u.rsym.sym == st->n.sym)
3892                 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3893
3894               /* Create a symtree node in the current namespace for this
3895                  symbol.  */
3896               st = check_unique_name (p)
3897                    ? gfc_get_unique_symtree (gfc_current_ns)
3898                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3899               st->ambiguous = ambiguous;
3900
3901               sym = info->u.rsym.sym;
3902
3903               /* Create a symbol node if it doesn't already exist.  */
3904               if (sym == NULL)
3905                 {
3906                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3907                                                      gfc_current_ns);
3908                   sym = info->u.rsym.sym;
3909                   sym->module = gfc_get_string (info->u.rsym.module);
3910
3911                   /* TODO: hmm, can we test this?  Do we know it will be
3912                      initialized to zeros?  */
3913                   if (info->u.rsym.binding_label[0] != '\0')
3914                     strcpy (sym->binding_label, info->u.rsym.binding_label);
3915                 }
3916
3917               st->n.sym = sym;
3918               st->n.sym->refs++;
3919
3920               if (strcmp (name, p) != 0)
3921                 sym->attr.use_rename = 1;
3922
3923               /* Store the symtree pointing to this symbol.  */
3924               info->u.rsym.symtree = st;
3925
3926               if (info->u.rsym.state == UNUSED)
3927                 info->u.rsym.state = NEEDED;
3928               info->u.rsym.referenced = 1;
3929             }
3930         }
3931     }
3932
3933   mio_rparen ();
3934
3935   /* Load intrinsic operator interfaces.  */
3936   set_module_locus (&operator_interfaces);
3937   mio_lparen ();
3938
3939   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3940     {
3941       if (i == INTRINSIC_USER)
3942         continue;
3943
3944       if (only_flag)
3945         {
3946           u = find_use_operator (i);
3947
3948           if (u == NULL)
3949             {
3950               skip_list ();
3951               continue;
3952             }
3953
3954           u->found = 1;
3955         }
3956
3957       mio_interface (&gfc_current_ns->op[i]);
3958     }
3959
3960   mio_rparen ();
3961
3962   /* Load generic and user operator interfaces.  These must follow the
3963      loading of symtree because otherwise symbols can be marked as
3964      ambiguous.  */
3965
3966   set_module_locus (&user_operators);
3967
3968   load_operator_interfaces ();
3969   load_generic_interfaces ();
3970
3971   load_commons ();
3972   load_equiv ();
3973
3974   /* At this point, we read those symbols that are needed but haven't
3975      been loaded yet.  If one symbol requires another, the other gets
3976      marked as NEEDED if its previous state was UNUSED.  */
3977
3978   while (load_needed (pi_root));
3979
3980   /* Make sure all elements of the rename-list were found in the module.  */
3981
3982   for (u = gfc_rename_list; u; u = u->next)
3983     {
3984       if (u->found)
3985         continue;
3986
3987       if (u->op == INTRINSIC_NONE)
3988         {
3989           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3990                      u->use_name, &u->where, module_name);
3991           continue;
3992         }
3993
3994       if (u->op == INTRINSIC_USER)
3995         {
3996           gfc_error ("User operator '%s' referenced at %L not found "
3997                      "in module '%s'", u->use_name, &u->where, module_name);
3998           continue;
3999         }
4000
4001       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4002                  "in module '%s'", gfc_op2string (u->op), &u->where,
4003                  module_name);
4004     }
4005
4006   gfc_check_interfaces (gfc_current_ns);
4007
4008   /* Clean up symbol nodes that were never loaded, create references
4009      to hidden symbols.  */
4010
4011   read_cleanup (pi_root);
4012 }
4013
4014
4015 /* Given an access type that is specific to an entity and the default
4016    access, return nonzero if the entity is publicly accessible.  If the
4017    element is declared as PUBLIC, then it is public; if declared
4018    PRIVATE, then private, and otherwise it is public unless the default
4019    access in this context has been declared PRIVATE.  */
4020
4021 bool
4022 gfc_check_access (gfc_access specific_access, gfc_access default_access)
4023 {
4024   if (specific_access == ACCESS_PUBLIC)
4025     return TRUE;
4026   if (specific_access == ACCESS_PRIVATE)
4027     return FALSE;
4028
4029   if (gfc_option.flag_module_private)
4030     return default_access == ACCESS_PUBLIC;
4031   else
4032     return default_access != ACCESS_PRIVATE;
4033 }
4034
4035
4036 /* A structure to remember which commons we've already written.  */
4037
4038 struct written_common
4039 {
4040   BBT_HEADER(written_common);
4041   const char *name, *label;
4042 };
4043
4044 static struct written_common *written_commons = NULL;
4045
4046 /* Comparison function used for balancing the binary tree.  */
4047
4048 static int
4049 compare_written_commons (void *a1, void *b1)
4050 {
4051   const char *aname = ((struct written_common *) a1)->name;
4052   const char *alabel = ((struct written_common *) a1)->label;
4053   const char *bname = ((struct written_common *) b1)->name;
4054   const char *blabel = ((struct written_common *) b1)->label;
4055   int c = strcmp (aname, bname);
4056
4057   return (c != 0 ? c : strcmp (alabel, blabel));
4058 }
4059
4060 /* Free a list of written commons.  */
4061
4062 static void
4063 free_written_common (struct written_common *w)
4064 {
4065   if (!w)
4066     return;
4067
4068   if (w->left)
4069     free_written_common (w->left);
4070   if (w->right)
4071     free_written_common (w->right);
4072
4073   gfc_free (w);
4074 }
4075
4076 /* Write a common block to the module -- recursive helper function.  */
4077
4078 static void
4079 write_common_0 (gfc_symtree *st)
4080 {
4081   gfc_common_head *p;
4082   const char * name;
4083   int flags;
4084   const char *label;
4085   struct written_common *w;
4086   bool write_me = true;
4087
4088   if (st == NULL)
4089     return;
4090
4091   write_common_0 (st->left);
4092
4093   /* We will write out the binding label, or the name if no label given.  */
4094   name = st->n.common->name;
4095   p = st->n.common;
4096   label = p->is_bind_c ? p->binding_label : p->name;
4097
4098   /* Check if we've already output this common.  */
4099   w = written_commons;
4100   while (w)
4101     {
4102       int c = strcmp (name, w->name);
4103       c = (c != 0 ? c : strcmp (label, w->label));
4104       if (c == 0)
4105         write_me = false;
4106
4107       w = (c < 0) ? w->left : w->right;
4108     }
4109
4110   if (write_me)
4111     {
4112       /* Write the common to the module.  */
4113       mio_lparen ();
4114       mio_pool_string (&name);
4115
4116       mio_symbol_ref (&p->head);
4117       flags = p->saved ? 1 : 0;
4118       if (p->threadprivate)
4119         flags |= 2;
4120       mio_integer (&flags);
4121
4122       /* Write out whether the common block is bind(c) or not.  */
4123       mio_integer (&(p->is_bind_c));
4124
4125       mio_pool_string (&label);
4126       mio_rparen ();
4127
4128       /* Record that we have written this common.  */
4129       w = XCNEW (struct written_common);
4130       w->name = p->name;
4131       w->label = label;
4132       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4133     }
4134
4135   write_common_0 (st->right);
4136 }
4137
4138
4139 /* Write a common, by initializing the list of written commons, calling
4140    the recursive function write_common_0() and cleaning up afterwards.  */
4141
4142 static void
4143 write_common (gfc_symtree *st)
4144 {
4145   written_commons = NULL;
4146   write_common_0 (st);
4147   free_written_common (written_commons);
4148   written_commons = NULL;
4149 }
4150
4151
4152 /* Write the blank common block to the module.  */
4153
4154 static void
4155 write_blank_common (void)
4156 {
4157   const char * name = BLANK_COMMON_NAME;
4158   int saved;
4159   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4160      this, but it hasn't been checked.  Just making it so for now.  */
4161   int is_bind_c = 0;
4162
4163   if (gfc_current_ns->blank_common.head == NULL)
4164     return;
4165
4166   mio_lparen ();
4167
4168   mio_pool_string (&name);
4169
4170   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4171   saved = gfc_current_ns->blank_common.saved;
4172   mio_integer (&saved);
4173
4174   /* Write out whether the common block is bind(c) or not.  */
4175   mio_integer (&is_bind_c);
4176
4177   /* Write out the binding label, which is BLANK_COMMON_NAME, though
4178      it doesn't matter because the label isn't used.  */
4179   mio_pool_string (&name);
4180
4181   mio_rparen ();
4182 }
4183
4184
4185 /* Write equivalences to the module.  */
4186
4187 static void
4188 write_equiv (void)
4189 {
4190   gfc_equiv *eq, *e;
4191   int num;
4192
4193   num = 0;
4194   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4195     {
4196       mio_lparen ();
4197
4198       for (e = eq; e; e = e->eq)
4199         {
4200           if (e->module == NULL)
4201             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4202           mio_allocated_string (e->module);
4203           mio_expr (&e->expr);
4204         }
4205
4206       num++;
4207       mio_rparen ();
4208     }
4209 }
4210
4211
4212 /* Write a symbol to the module.  */
4213
4214 static void
4215 write_symbol (int n, gfc_symbol *sym)
4216 {
4217   const char *label;
4218
4219   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4220     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4221
4222   mio_integer (&n);
4223   mio_pool_string (&sym->name);
4224
4225   mio_pool_string (&sym->module);
4226   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4227     {
4228       label = sym->binding_label;
4229       mio_pool_string (&label);
4230     }
4231   else
4232     mio_pool_string (&sym->name);
4233
4234   mio_pointer_ref (&sym->ns);
4235
4236   mio_symbol (sym);
4237   write_char ('\n');
4238 }
4239
4240
4241 /* Recursive traversal function to write the initial set of symbols to
4242    the module.  We check to see if the symbol should be written
4243    according to the access specification.  */
4244
4245 static void
4246 write_symbol0 (gfc_symtree *st)
4247 {
4248   gfc_symbol *sym;
4249   pointer_info *p;
4250   bool dont_write = false;
4251
4252   if (st == NULL)
4253     return;
4254
4255   write_symbol0 (st->left);
4256
4257   sym = st->n.sym;
4258   if (sym->module == NULL)
4259     sym->module = gfc_get_string (module_name);
4260
4261   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4262       && !sym->attr.subroutine && !sym->attr.function)
4263     dont_write = true;
4264
4265   if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
4266     dont_write = true;
4267
4268   if (!dont_write)
4269     {
4270       p = get_pointer (sym);
4271       if (p->type == P_UNKNOWN)
4272         p->type = P_SYMBOL;
4273
4274       if (p->u.wsym.state != WRITTEN)
4275         {
4276           write_symbol (p->integer, sym);
4277           p->u.wsym.state = WRITTEN;
4278         }
4279     }
4280
4281   write_symbol0 (st->right);
4282 }
4283
4284
4285 /* Recursive traversal function to write the secondary set of symbols
4286    to the module file.  These are symbols that were not public yet are
4287    needed by the public symbols or another dependent symbol.  The act
4288    of writing a symbol can modify the pointer_info tree, so we cease
4289    traversal if we find a symbol to write.  We return nonzero if a
4290    symbol was written and pass that information upwards.  */
4291
4292 static int
4293 write_symbol1 (pointer_info *p)
4294 {
4295   int result;
4296
4297   if (!p)
4298     return 0;
4299
4300   result = write_symbol1 (p->left);
4301
4302   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4303     {
4304       p->u.wsym.state = WRITTEN;
4305       write_symbol (p->integer, p->u.wsym.sym);
4306       result = 1;
4307     }
4308
4309   result |= write_symbol1 (p->right);
4310   return result;
4311 }
4312
4313
4314 /* Write operator interfaces associated with a symbol.  */
4315
4316 static void
4317 write_operator (gfc_user_op *uop)
4318 {
4319   static char nullstring[] = "";
4320   const char *p = nullstring;
4321
4322   if (uop->op == NULL
4323       || !gfc_check_access (uop->access, uop->ns->default_access))
4324     return;
4325
4326   mio_symbol_interface (&uop->name, &p, &uop->op);
4327 }
4328
4329
4330 /* Write generic interfaces from the namespace sym_root.  */
4331
4332 static void
4333 write_generic (gfc_symtree *st)
4334 {
4335   gfc_symbol *sym;
4336
4337   if (st == NULL)
4338     return;
4339
4340   write_generic (st->left);
4341   write_generic (st->right);
4342
4343   sym = st->n.sym;
4344   if (!sym || check_unique_name (st->name))
4345     return;
4346
4347   if (sym->generic == NULL
4348       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
4349     return;
4350
4351   if (sym->module == NULL)
4352     sym->module = gfc_get_string (module_name);
4353
4354   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
4355 }
4356
4357
4358 static void
4359 write_symtree (gfc_symtree *st)
4360 {
4361   gfc_symbol *sym;
4362   pointer_info *p;
4363
4364   sym = st->n.sym;
4365   if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4366       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4367           && !sym->attr.subroutine && !sym->attr.function))
4368     return;
4369
4370   if (check_unique_name (st->name))
4371     return;
4372
4373   p = find_pointer (sym);
4374   if (p == NULL)
4375     gfc_internal_error ("write_symtree(): Symbol not written");
4376
4377   mio_pool_string (&st->name);
4378   mio_integer (&st->ambiguous);
4379   mio_integer (&p->integer);
4380 }
4381
4382
4383 static void
4384 write_module (void)
4385 {
4386   gfc_intrinsic_op i;
4387
4388   /* Write the operator interfaces.  */
4389   mio_lparen ();
4390
4391   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4392     {
4393       if (i == INTRINSIC_USER)
4394         continue;
4395
4396       mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4397                                        gfc_current_ns->default_access)
4398                      ? &gfc_current_ns->op[i] : NULL);
4399     }
4400
4401   mio_rparen ();
4402   write_char ('\n');
4403   write_char ('\n');
4404
4405   mio_lparen ();
4406   gfc_traverse_user_op (gfc_current_ns, write_operator);
4407   mio_rparen ();
4408   write_char ('\n');
4409   write_char ('\n');
4410
4411   mio_lparen ();
4412   write_generic (gfc_current_ns->sym_root);
4413   mio_rparen ();
4414   write_char ('\n');
4415   write_char ('\n');
4416
4417   mio_lparen ();
4418   write_blank_common ();
4419   write_common (gfc_current_ns->common_root);
4420   mio_rparen ();
4421   write_char ('\n');
4422   write_char ('\n');
4423
4424   mio_lparen ();
4425   write_equiv ();
4426   mio_rparen ();
4427   write_char ('\n');
4428   write_char ('\n');
4429
4430   /* Write symbol information.  First we traverse all symbols in the
4431      primary namespace, writing those that need to be written.
4432      Sometimes writing one symbol will cause another to need to be
4433      written.  A list of these symbols ends up on the write stack, and
4434      we end by popping the bottom of the stack and writing the symbol
4435      until the stack is empty.  */
4436
4437   mio_lparen ();
4438
4439   write_symbol0 (gfc_current_ns->sym_root);
4440   while (write_symbol1 (pi_root))
4441     /* Nothing.  */;
4442
4443   mio_rparen ();
4444
4445   write_char ('\n');
4446   write_char ('\n');
4447
4448   mio_lparen ();
4449   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4450   mio_rparen ();
4451 }
4452
4453
4454 /* Read a MD5 sum from the header of a module file.  If the file cannot
4455    be opened, or we have any other error, we return -1.  */
4456
4457 static int
4458 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4459 {
4460   FILE *file;
4461   char buf[1024];
4462   int n;
4463
4464   /* Open the file.  */
4465   if ((file = fopen (filename, "r")) == NULL)
4466     return -1;
4467
4468   /* Read two lines.  */
4469   if (fgets (buf, sizeof (buf) - 1, file) == NULL
4470       || fgets (buf, sizeof (buf) - 1, file) == NULL)
4471     {
4472       fclose (file);
4473       return -1;
4474     }
4475
4476   /* Close the file.  */
4477   fclose (file);
4478
4479   /* If the header is not what we expect, or is too short, bail out.  */
4480   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4481     return -1;
4482
4483   /* Now, we have a real MD5, read it into the array.  */
4484   for (n = 0; n < 16; n++)
4485     {
4486       unsigned int x;
4487
4488       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4489        return -1;
4490
4491       md5[n] = x;
4492     }
4493
4494   return 0;
4495 }
4496
4497
4498 /* Given module, dump it to disk.  If there was an error while
4499    processing the module, dump_flag will be set to zero and we delete
4500    the module file, even if it was already there.  */
4501
4502 void
4503 gfc_dump_module (const char *name, int dump_flag)
4504 {
4505   int n;
4506   char *filename, *filename_tmp, *p;
4507   time_t now;
4508   fpos_t md5_pos;
4509   unsigned char md5_new[16], md5_old[16];
4510
4511   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4512   if (gfc_option.module_dir != NULL)
4513     {
4514       n += strlen (gfc_option.module_dir);
4515       filename = (char *) alloca (n);
4516       strcpy (filename, gfc_option.module_dir);
4517       strcat (filename, name);
4518     }
4519   else
4520     {
4521       filename = (char *) alloca (n);
4522       strcpy (filename, name);
4523     }
4524   strcat (filename, MODULE_EXTENSION);
4525
4526   /* Name of the temporary file used to write the module.  */
4527   filename_tmp = (char *) alloca (n + 1);
4528   strcpy (filename_tmp, filename);
4529   strcat (filename_tmp, "0");
4530
4531   /* There was an error while processing the module.  We delete the
4532      module file, even if it was already there.  */
4533   if (!dump_flag)
4534     {
4535       unlink (filename);
4536       return;
4537     }
4538
4539   /* Write the module to the temporary file.  */
4540   module_fp = fopen (filename_tmp, "w");
4541   if (module_fp == NULL)
4542     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4543                      filename_tmp, strerror (errno));
4544
4545   /* Write the header, including space reserved for the MD5 sum.  */
4546   now = time (NULL);
4547   p = ctime (&now);
4548
4549   *strchr (p, '\n') = '\0';
4550
4551   fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4552            gfc_source_file, p);
4553   fgetpos (module_fp, &md5_pos);
4554   fputs ("00000000000000000000000000000000 -- "
4555         "If you edit this, you'll get what you deserve.\n\n", module_fp);
4556
4557   /* Initialize the MD5 context that will be used for output.  */
4558   md5_init_ctx (&ctx);
4559
4560   /* Write the module itself.  */
4561   iomode = IO_OUTPUT;
4562   strcpy (module_name, name);
4563
4564   init_pi_tree ();
4565
4566   write_module ();
4567
4568   free_pi_tree (pi_root);
4569   pi_root = NULL;
4570
4571   write_char ('\n');
4572
4573   /* Write the MD5 sum to the header of the module file.  */
4574   md5_finish_ctx (&ctx, md5_new);
4575   fsetpos (module_fp, &md5_pos);
4576   for (n = 0; n < 16; n++)
4577     fprintf (module_fp, "%02x", md5_new[n]);
4578
4579   if (fclose (module_fp))
4580     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4581                      filename_tmp, strerror (errno));
4582
4583   /* Read the MD5 from the header of the old module file and compare.  */
4584   if (read_md5_from_module_file (filename, md5_old) != 0
4585       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4586     {
4587       /* Module file have changed, replace the old one.  */
4588       unlink (filename);
4589       rename (filename_tmp, filename);
4590     }
4591   else
4592     unlink (filename_tmp);
4593 }
4594
4595
4596 static void
4597 sort_iso_c_rename_list (void)
4598 {
4599   gfc_use_rename *tmp_list = NULL;
4600   gfc_use_rename *curr;
4601   gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4602   int c_kind;
4603   int i;
4604
4605   for (curr = gfc_rename_list; curr; curr = curr->next)
4606     {
4607       c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4608       if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4609         {
4610           gfc_error ("Symbol '%s' referenced at %L does not exist in "
4611                      "intrinsic module ISO_C_BINDING.", curr->use_name,
4612                      &curr->where);
4613         }
4614       else
4615         /* Put it in the list.  */
4616         kinds_used[c_kind] = curr;
4617     }
4618
4619   /* Make a new (sorted) rename list.  */
4620   i = 0;
4621   while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4622     i++;
4623
4624   if (i < ISOCBINDING_NUMBER)
4625     {
4626       tmp_list = kinds_used[i];
4627
4628       i++;
4629       curr = tmp_list;
4630       for (; i < ISOCBINDING_NUMBER; i++)
4631         if (kinds_used[i] != NULL)
4632           {
4633             curr->next = kinds_used[i];
4634             curr = curr->next;
4635             curr->next = NULL;
4636           }
4637     }
4638
4639   gfc_rename_list = tmp_list;
4640 }
4641
4642
4643 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4644    the current namespace for all named constants, pointer types, and
4645    procedures in the module unless the only clause was used or a rename
4646    list was provided.  */
4647
4648 static void
4649 import_iso_c_binding_module (void)
4650 {
4651   gfc_symbol *mod_sym = NULL;
4652   gfc_symtree *mod_symtree = NULL;
4653   const char *iso_c_module_name = "__iso_c_binding";
4654   gfc_use_rename *u;
4655   int i;
4656   char *local_name;
4657
4658   /* Look only in the current namespace.  */
4659   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4660
4661   if (mod_symtree == NULL)
4662     {
4663       /* symtree doesn't already exist in current namespace.  */
4664       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4665
4666       if (mod_symtree != NULL)
4667         mod_sym = mod_symtree->n.sym;
4668       else
4669         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4670                             "create symbol for %s", iso_c_module_name);
4671
4672       mod_sym->attr.flavor = FL_MODULE;
4673       mod_sym->attr.intrinsic = 1;
4674       mod_sym->module = gfc_get_string (iso_c_module_name);
4675       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4676     }
4677
4678   /* Generate the symbols for the named constants representing
4679      the kinds for intrinsic data types.  */
4680   if (only_flag)
4681     {
4682       /* Sort the rename list because there are dependencies between types
4683          and procedures (e.g., c_loc needs c_ptr).  */
4684       sort_iso_c_rename_list ();
4685
4686       for (u = gfc_rename_list; u; u = u->next)
4687         {
4688           i = get_c_kind (u->use_name, c_interop_kinds_table);
4689
4690           if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4691             {
4692               gfc_error ("Symbol '%s' referenced at %L does not exist in "
4693                          "intrinsic module ISO_C_BINDING.", u->use_name,
4694                          &u->where);
4695               continue;
4696             }
4697
4698           generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4699         }
4700     }
4701   else
4702     {
4703       for (i = 0; i < ISOCBINDING_NUMBER; i++)
4704         {
4705           local_name = NULL;
4706           for (u = gfc_rename_list; u; u = u->next)
4707             {
4708               if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4709                 {
4710                   local_name = u->local_name;
4711                   u->found = 1;
4712                   break;
4713                 }
4714             }
4715           generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4716         }
4717
4718       for (u = gfc_rename_list; u; u = u->next)
4719         {
4720           if (u->found)
4721             continue;
4722
4723           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4724                      "module ISO_C_BINDING", u->use_name, &u->where);
4725         }
4726     }
4727 }
4728
4729
4730 /* Add an integer named constant from a given module.  */
4731
4732 static void
4733 create_int_parameter (const char *name, int value, const char *modname,
4734                       intmod_id module, int id)
4735 {
4736   gfc_symtree *tmp_symtree;
4737   gfc_symbol *sym;
4738
4739   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4740   if (tmp_symtree != NULL)
4741     {
4742       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4743         return;
4744       else
4745         gfc_error ("Symbol '%s' already declared", name);
4746     }
4747
4748   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4749   sym = tmp_symtree->n.sym;
4750
4751   sym->module = gfc_get_string (modname);
4752   sym->attr.flavor = FL_PARAMETER;
4753   sym->ts.type = BT_INTEGER;
4754   sym->ts.kind = gfc_default_integer_kind;
4755   sym->value = gfc_int_expr (value);
4756   sym->attr.use_assoc = 1;
4757   sym->from_intmod = module;
4758   sym->intmod_sym_id = id;
4759 }
4760
4761
4762 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
4763
4764 static void
4765 use_iso_fortran_env_module (void)
4766 {
4767   static char mod[] = "iso_fortran_env";
4768   const char *local_name;
4769   gfc_use_rename *u;
4770   gfc_symbol *mod_sym;
4771   gfc_symtree *mod_symtree;
4772   int i;
4773
4774   intmod_sym symbol[] = {
4775 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
4776 #include "iso-fortran-env.def"
4777 #undef NAMED_INTCST
4778     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
4779
4780   i = 0;
4781 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
4782 #include "iso-fortran-env.def"
4783 #undef NAMED_INTCST
4784
4785   /* Generate the symbol for the module itself.  */
4786   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4787   if (mod_symtree == NULL)
4788     {
4789       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4790       gcc_assert (mod_symtree);
4791       mod_sym = mod_symtree->n.sym;
4792
4793       mod_sym->attr.flavor = FL_MODULE;
4794       mod_sym->attr.intrinsic = 1;
4795       mod_sym->module = gfc_get_string (mod);
4796       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4797     }
4798   else
4799     if (!mod_symtree->n.sym->attr.intrinsic)
4800       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4801                  "non-intrinsic module name used previously", mod);
4802
4803   /* Generate the symbols for the module integer named constants.  */
4804   if (only_flag)
4805     for (u = gfc_rename_list; u; u = u->next)
4806       {
4807         for (i = 0; symbol[i].name; i++)
4808           if (strcmp (symbol[i].name, u->use_name) == 0)
4809             break;
4810
4811         if (symbol[i].name == NULL)
4812           {
4813             gfc_error ("Symbol '%s' referenced at %L does not exist in "
4814                        "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4815                        &u->where);
4816             continue;
4817           }
4818
4819         if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4820             && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4821           gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4822                            "from intrinsic module ISO_FORTRAN_ENV at %L is "
4823                            "incompatible with option %s", &u->where,
4824                            gfc_option.flag_default_integer
4825                              ? "-fdefault-integer-8" : "-fdefault-real-8");
4826
4827         create_int_parameter (u->local_name[0] ? u->local_name
4828                                                : symbol[i].name,
4829                               symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4830                               symbol[i].id);
4831       }
4832   else
4833     {
4834       for (i = 0; symbol[i].name; i++)
4835         {
4836           local_name = NULL;
4837           for (u = gfc_rename_list; u; u = u->next)
4838             {
4839               if (strcmp (symbol[i].name, u->use_name) == 0)
4840                 {
4841                   local_name = u->local_name;
4842                   u->found = 1;
4843                   break;
4844                 }
4845             }
4846
4847           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4848               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4849             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4850                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
4851                              "incompatible with option %s",
4852                              gfc_option.flag_default_integer
4853                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
4854
4855           create_int_parameter (local_name ? local_name : symbol[i].name,
4856                                 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4857                                 symbol[i].id);
4858         }
4859
4860       for (u = gfc_rename_list; u; u = u->next)
4861         {
4862           if (u->found)
4863             continue;
4864
4865           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4866                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4867         }
4868     }
4869 }
4870
4871
4872 /* Process a USE directive.  */
4873
4874 void
4875 gfc_use_module (void)
4876 {
4877   char *filename;
4878   gfc_state_data *p;
4879   int c, line, start;
4880   gfc_symtree *mod_symtree;
4881
4882   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4883                               + 1);
4884   strcpy (filename, module_name);
4885   strcat (filename, MODULE_EXTENSION);
4886
4887   /* First, try to find an non-intrinsic module, unless the USE statement
4888      specified that the module is intrinsic.  */
4889   module_fp = NULL;
4890   if (!specified_int)
4891     module_fp = gfc_open_included_file (filename, true, true);
4892
4893   /* Then, see if it's an intrinsic one, unless the USE statement
4894      specified that the module is non-intrinsic.  */
4895   if (module_fp == NULL && !specified_nonint)
4896     {
4897       if (strcmp (module_name, "iso_fortran_env") == 0
4898           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4899                              "intrinsic module at %C") != FAILURE)
4900        {
4901          use_iso_fortran_env_module ();
4902          return;
4903        }
4904
4905       if (strcmp (module_name, "iso_c_binding") == 0
4906           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4907                              "ISO_C_BINDING module at %C") != FAILURE)
4908         {
4909           import_iso_c_binding_module();
4910           return;
4911         }
4912
4913       module_fp = gfc_open_intrinsic_module (filename);
4914
4915       if (module_fp == NULL && specified_int)
4916         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4917                          module_name);
4918     }
4919
4920   if (module_fp == NULL)
4921     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4922                      filename, strerror (errno));
4923
4924   /* Check that we haven't already USEd an intrinsic module with the
4925      same name.  */
4926
4927   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4928   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4929     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4930                "intrinsic module name used previously", module_name);
4931
4932   iomode = IO_INPUT;
4933   module_line = 1;
4934   module_column = 1;
4935   start = 0;
4936
4937   /* Skip the first two lines of the module, after checking that this is
4938      a gfortran module file.  */
4939   line = 0;
4940   while (line < 2)
4941     {
4942       c = module_char ();
4943       if (c == EOF)
4944         bad_module ("Unexpected end of module");
4945       if (start++ < 2)
4946         parse_name (c);
4947       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4948           || (start == 2 && strcmp (atom_name, " module") != 0))
4949         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4950                          "file", filename);
4951
4952       if (c == '\n')
4953         line++;
4954     }
4955
4956   /* Make sure we're not reading the same module that we may be building.  */
4957   for (p = gfc_state_stack; p; p = p->previous)
4958     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4959       gfc_fatal_error ("Can't USE the same module we're building!");
4960
4961   init_pi_tree ();
4962   init_true_name_tree ();
4963
4964   read_module ();
4965
4966   free_true_name (true_name_root);
4967   true_name_root = NULL;
4968
4969   free_pi_tree (pi_root);
4970   pi_root = NULL;
4971
4972   fclose (module_fp);
4973 }
4974
4975
4976 void
4977 gfc_module_init_2 (void)
4978 {
4979   last_atom = ATOM_LPAREN;
4980 }
4981
4982
4983 void
4984 gfc_module_done_2 (void)
4985 {
4986   free_rename ();
4987 }