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
   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 2, 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 COPYING.  If not, write to the Free
  21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.  */
  23
  24 /* The syntax of gfortran modules resembles that of lisp lists, ie a
  25    sequence of atoms, which can be left or right parenthesis, names,
  26    integers or strings.  Parenthesis are always matched which allows
  27    us to skip over sections at high speed without having to know
  28    anything about the internal structure of the lists.  A "name" is
  29    usually a fortran 95 identifier, but can also start with '@' in
  30    order to reference a hidden symbol.
  31
  32    The first line of a module is an informational message about what
  33    created the module, the file it came from and when it was created.
  34    The second line is a warning for people not to edit the module.
  35    The rest of the module looks like:
  36
  37    ( ( <Interface info for UPLUS> )
  38      ( <Interface info for UMINUS> )
  39      ...
  40    )
  41    ( ( <name of operator interface> <module of op interface> <i/f1> ... )
  42      ...
  43    )
  44    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
  45      ...
  46    )
  47    ( ( <common name> <symbol> <saved flag>)
  48      ...
  49    )
  50
  51    ( equivalence list )
  52
  53    ( <Symbol Number (in no particular order)>
  54      <True name of symbol>
  55      <Module name of symbol>
  56      ( <symbol information> )
  57      ...
  58    )
  59    ( <Symtree name>
  60      <Ambiguous flag>
  61      <Symbol number>
  62      ...
  63    )
  64
  65    In general, symbols refer to other symbols by their symbol number,
  66    which are zero based.  Symbols are written to the module in no
  67    particular order.  */
  68
  69 #include "config.h"
  70 #include "system.h"
  71 #include "gfortran.h"
  72 #include "arith.h"
  73 #include "match.h"
  74 #include "parse.h" /* FIXME */
  75 #include "md5.h"
  76
  77 #define MODULE_EXTENSION ".mod"
  78
  79
  80 /* Structure that describes a position within a module file.  */
  81
  82 typedef struct
  83 {
  84   int column, line;
  85   fpos_t pos;
  86 }
  87 module_locus;
  88
  89 /* Structure for list of symbols of intrinsic modules.  */
  90 typedef struct
  91 {
  92   int id;
  93   const char *name;
  94   int value;
  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;
 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() gfc_getmem(sizeof(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 operator;
 173   locus where;
 174 }
 175 gfc_use_rename;
 176
 177 #define gfc_get_use_rename() gfc_getmem(sizeof(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 (ie 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 = gp;
 464       *cp = p->u.pointer;
 465     }
 466   else
 467     {
 468       f = gfc_getmem (sizeof (fixup_t));
 469
 470       f->next = p->fixup;
 471       p->fixup = f;
 472
 473       f->pointer = 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;
 506   interface_type type, type2;
 507   gfc_intrinsic_op operator;
 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 = gfc_get_use_rename ();
 585       new->where = gfc_current_locus;
 586       new->found = 0;
 587
 588       if (gfc_rename_list == NULL)
 589         gfc_rename_list = new;
 590       else
 591         tail->next = new;
 592       tail = new;
 593
 594       /* See what kind of interface we're dealing with.  Assume it is
 595          not an operator.  */
 596       new->operator = INTRINSIC_NONE;
 597       if (gfc_match_generic_spec (&type, name, &operator) == 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 (only_flag)
 617             {
 618               if (m != MATCH_YES)
 619                 strcpy (new->use_name, name);
 620               else
 621                 {
 622                   strcpy (new->local_name, name);
 623                   m = gfc_match_generic_spec (&type2, new->use_name, &operator);
 624                   if (type != type2)
 625                     goto syntax;
 626                   if (m == MATCH_NO)
 627                     goto syntax;
 628                   if (m == MATCH_ERROR)
 629                     goto cleanup;
 630                 }
 631             }
 632           else
 633             {
 634               if (m != MATCH_YES)
 635                 goto syntax;
 636               strcpy (new->local_name, name);
 637
 638               m = gfc_match_generic_spec (&type2, new->use_name, &operator);
 639               if (type != type2)
 640                 goto syntax;
 641               if (m == MATCH_NO)
 642                 goto syntax;
 643               if (m == MATCH_ERROR)
 644                 goto cleanup;
 645             }
 646
 647           if (strcmp (new->use_name, module_name) == 0
 648               || strcmp (new->local_name, module_name) == 0)
 649             {
 650               gfc_error ("The name '%s' at %C has already been used as "
 651                          "an external module name.", module_name);
 652               goto cleanup;
 653             }
 654
 655           if (type == INTERFACE_USER_OP)
 656             new->operator = operator;
 657
 658           break;
 659
 660         case INTERFACE_INTRINSIC_OP:
 661           new->operator = operator;
 662           break;
 663         }
 664
 665       if (gfc_match_eos () == MATCH_YES)
 666         break;
 667       if (gfc_match_char (',') != MATCH_YES)
 668         goto syntax;
 669     }
 670
 671   return MATCH_YES;
 672
 673 syntax:
 674   gfc_syntax_error (ST_USE);
 675
 676 cleanup:
 677   free_rename ();
 678   return MATCH_ERROR;
 679  }
 680
 681
 682 /* Given a name and a number, inst, return the inst name
 683    under which to load this symbol. Returns NULL if this
 684    symbol shouldn't be loaded. If inst is zero, returns
 685    the number of instances of this name.  */
 686
 687 static const char *
 688 find_use_name_n (const char *name, int *inst)
 689 {
 690   gfc_use_rename *u;
 691   int i;
 692
 693   i = 0;
 694   for (u = gfc_rename_list; u; u = u->next)
 695     {
 696       if (strcmp (u->use_name, name) != 0)
 697         continue;
 698       if (++i == *inst)
 699         break;
 700     }
 701
 702   if (!*inst)
 703     {
 704       *inst = i;
 705       return NULL;
 706     }
 707
 708   if (u == NULL)
 709     return only_flag ? NULL : name;
 710
 711   u->found = 1;
 712
 713   return (u->local_name[0] != '\0') ? u->local_name : name;
 714 }
 715
 716
 717 /* Given a name, return the name under which to load this symbol.
 718    Returns NULL if this symbol shouldn't be loaded.  */
 719
 720 static const char *
 721 find_use_name (const char *name)
 722 {
 723   int i = 1;
 724   return find_use_name_n (name, &i);
 725 }
 726
 727
 728 /* Given a real name, return the number of use names associated with it.  */
 729
 730 static int
 731 number_use_names (const char *name)
 732 {
 733   int i = 0;
 734   const char *c;
 735   c = find_use_name_n (name, &i);
 736   return i;
 737 }
 738
 739
 740 /* Try to find the operator in the current list.  */
 741
 742 static gfc_use_rename *
 743 find_use_operator (gfc_intrinsic_op operator)
 744 {
 745   gfc_use_rename *u;
 746
 747   for (u = gfc_rename_list; u; u = u->next)
 748     if (u->operator == operator)
 749       return u;
 750
 751   return NULL;
 752 }
 753
 754
 755 /*****************************************************************/
 756
 757 /* The next couple of subroutines maintain a tree used to avoid a
 758    brute-force search for a combination of true name and module name.
 759    While symtree names, the name that a particular symbol is known by
 760    can changed with USE statements, we still have to keep track of the
 761    true names to generate the correct reference, and also avoid
 762    loading the same real symbol twice in a program unit.
 763
 764    When we start reading, the true name tree is built and maintained
 765    as symbols are read.  The tree is searched as we load new symbols
 766    to see if it already exists someplace in the namespace.  */
 767
 768 typedef struct true_name
 769 {
 770   BBT_HEADER (true_name);
 771   gfc_symbol *sym;
 772 }
 773 true_name;
 774
 775 static true_name *true_name_root;
 776
 777
 778 /* Compare two true_name structures.  */
 779
 780 static int
 781 compare_true_names (void *_t1, void *_t2)
 782 {
 783   true_name *t1, *t2;
 784   int c;
 785
 786   t1 = (true_name *) _t1;
 787   t2 = (true_name *) _t2;
 788
 789   c = ((t1->sym->module > t2->sym->module)
 790        - (t1->sym->module < t2->sym->module));
 791   if (c != 0)
 792     return c;
 793
 794   return strcmp (t1->sym->name, t2->sym->name);
 795 }
 796
 797
 798 /* Given a true name, search the true name tree to see if it exists
 799    within the main namespace.  */
 800
 801 static gfc_symbol *
 802 find_true_name (const char *name, const char *module)
 803 {
 804   true_name t, *p;
 805   gfc_symbol sym;
 806   int c;
 807
 808   sym.name = gfc_get_string (name);
 809   if (module != NULL)
 810     sym.module = gfc_get_string (module);
 811   else
 812     sym.module = NULL;
 813   t.sym = &sym;
 814
 815   p = true_name_root;
 816   while (p != NULL)
 817     {
 818       c = compare_true_names ((void *) (&t), (void *) p);
 819       if (c == 0)
 820         return p->sym;
 821
 822       p = (c < 0) ? p->left : p->right;
 823     }
 824
 825   return NULL;
 826 }
 827
 828
 829 /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
 830
 831 static void
 832 add_true_name (gfc_symbol *sym)
 833 {
 834   true_name *t;
 835
 836   t = gfc_getmem (sizeof (true_name));
 837   t->sym = sym;
 838
 839   gfc_insert_bbt (&true_name_root, t, compare_true_names);
 840 }
 841
 842
 843 /* Recursive function to build the initial true name tree by
 844    recursively traversing the current namespace.  */
 845
 846 static void
 847 build_tnt (gfc_symtree *st)
 848 {
 849   if (st == NULL)
 850     return;
 851
 852   build_tnt (st->left);
 853   build_tnt (st->right);
 854
 855   if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
 856     return;
 857
 858   add_true_name (st->n.sym);
 859 }
 860
 861
 862 /* Initialize the true name tree with the current namespace.  */
 863
 864 static void
 865 init_true_name_tree (void)
 866 {
 867   true_name_root = NULL;
 868   build_tnt (gfc_current_ns->sym_root);
 869 }
 870
 871
 872 /* Recursively free a true name tree node.  */
 873
 874 static void
 875 free_true_name (true_name *t)
 876 {
 877   if (t == NULL)
 878     return;
 879   free_true_name (t->left);
 880   free_true_name (t->right);
 881
 882   gfc_free (t);
 883 }
 884
 885
 886 /*****************************************************************/
 887
 888 /* Module reading and writing.  */
 889
 890 typedef enum
 891 {
 892   ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
 893 }
 894 atom_type;
 895
 896 static atom_type last_atom;
 897
 898
 899 /* The name buffer must be at least as long as a symbol name.  Right
 900    now it's not clear how we're going to store numeric constants--
 901    probably as a hexadecimal string, since this will allow the exact
 902    number to be preserved (this can't be done by a decimal
 903    representation).  Worry about that later.  TODO!  */
 904
 905 #define MAX_ATOM_SIZE 100
 906
 907 static int atom_int;
 908 static char *atom_string, atom_name[MAX_ATOM_SIZE];
 909
 910
 911 /* Report problems with a module.  Error reporting is not very
 912    elaborate, since this sorts of errors shouldn't really happen.
 913    This subroutine never returns.  */
 914
 915 static void bad_module (const char *) ATTRIBUTE_NORETURN;
 916
 917 static void
 918 bad_module (const char *msgid)
 919 {
 920   fclose (module_fp);
 921
 922   switch (iomode)
 923     {
 924     case IO_INPUT:
 925       gfc_fatal_error ("Reading module %s at line %d column %d: %s",
 926                        module_name, module_line, module_column, msgid);
 927       break;
 928     case IO_OUTPUT:
 929       gfc_fatal_error ("Writing module %s at line %d column %d: %s",
 930                        module_name, module_line, module_column, msgid);
 931       break;
 932     default:
 933       gfc_fatal_error ("Module %s at line %d column %d: %s",
 934                        module_name, module_line, module_column, msgid);
 935       break;
 936     }
 937 }
 938
 939
 940 /* Set the module's input pointer.  */
 941
 942 static void
 943 set_module_locus (module_locus *m)
 944 {
 945   module_column = m->column;
 946   module_line = m->line;
 947   fsetpos (module_fp, &m->pos);
 948 }
 949
 950
 951 /* Get the module's input pointer so that we can restore it later.  */
 952
 953 static void
 954 get_module_locus (module_locus *m)
 955 {
 956   m->column = module_column;
 957   m->line = module_line;
 958   fgetpos (module_fp, &m->pos);
 959 }
 960
 961
 962 /* Get the next character in the module, updating our reckoning of
 963    where we are.  */
 964
 965 static int
 966 module_char (void)
 967 {
 968   int c;
 969
 970   c = getc (module_fp);
 971
 972   if (c == EOF)
 973     bad_module ("Unexpected EOF");
 974
 975   if (c == '\n')
 976     {
 977       module_line++;
 978       module_column = 0;
 979     }
 980
 981   module_column++;
 982   return c;
 983 }
 984
 985
 986 /* Parse a string constant.  The delimiter is guaranteed to be a
 987    single quote.  */
 988
 989 static void
 990 parse_string (void)
 991 {
 992   module_locus start;
 993   int len, c;
 994   char *p;
 995
 996   get_module_locus (&start);
 997
 998   len = 0;
 999
1000   /* See how long the string is.  */
1001   for ( ; ; )
1002     {
1003       c = module_char ();
1004       if (c == EOF)
1005         bad_module ("Unexpected end of module in string constant");
1006
1007       if (c != '\'')
1008         {
1009           len++;
1010           continue;
1011         }
1012
1013       c = module_char ();
1014       if (c == '\'')
1015         {
1016           len++;
1017           continue;
1018         }
1019
1020       break;
1021     }
1022
1023   set_module_locus (&start);
1024
1025   atom_string = p = gfc_getmem (len + 1);
1026
1027   for (; len > 0; len--)
1028     {
1029       c = module_char ();
1030       if (c == '\'')
1031         module_char ();         /* Guaranteed to be another \'.  */
1032       *p++ = c;
1033     }
1034
1035   module_char ();               /* Terminating \'.  */
1036   *p = '\0';                    /* C-style string for debug purposes.  */
1037 }
1038
1039
1040 /* Parse a small integer.  */
1041
1042 static void
1043 parse_integer (int c)
1044 {
1045   module_locus m;
1046
1047   atom_int = c - '0';
1048
1049   for (;;)
1050     {
1051       get_module_locus (&m);
1052
1053       c = module_char ();
1054       if (!ISDIGIT (c))
1055         break;
1056
1057       atom_int = 10 * atom_int + c - '0';
1058       if (atom_int > 99999999)
1059         bad_module ("Integer overflow");
1060     }
1061
1062   set_module_locus (&m);
1063 }
1064
1065
1066 /* Parse a name.  */
1067
1068 static void
1069 parse_name (int c)
1070 {
1071   module_locus m;
1072   char *p;
1073   int len;
1074
1075   p = atom_name;
1076
1077   *p++ = c;
1078   len = 1;
1079
1080   get_module_locus (&m);
1081
1082   for (;;)
1083     {
1084       c = module_char ();
1085       if (!ISALNUM (c) && c != '_' && c != '-')
1086         break;
1087
1088       *p++ = c;
1089       if (++len > GFC_MAX_SYMBOL_LEN)
1090         bad_module ("Name too long");
1091     }
1092
1093   *p = '\0';
1094
1095   fseek (module_fp, -1, SEEK_CUR);
1096   module_column = m.column + len - 1;
1097
1098   if (c == '\n')
1099     module_line--;
1100 }
1101
1102
1103 /* Read the next atom in the module's input stream.  */
1104
1105 static atom_type
1106 parse_atom (void)
1107 {
1108   int c;
1109
1110   do
1111     {
1112       c = module_char ();
1113     }
1114   while (c == ' ' || c == '\n');
1115
1116   switch (c)
1117     {
1118     case '(':
1119       return ATOM_LPAREN;
1120
1121     case ')':
1122       return ATOM_RPAREN;
1123
1124     case '\'':
1125       parse_string ();
1126       return ATOM_STRING;
1127
1128     case '0':
1129     case '1':
1130     case '2':
1131     case '3':
1132     case '4':
1133     case '5':
1134     case '6':
1135     case '7':
1136     case '8':
1137     case '9':
1138       parse_integer (c);
1139       return ATOM_INTEGER;
1140
1141     case 'a':
1142     case 'b':
1143     case 'c':
1144     case 'd':
1145     case 'e':
1146     case 'f':
1147     case 'g':
1148     case 'h':
1149     case 'i':
1150     case 'j':
1151     case 'k':
1152     case 'l':
1153     case 'm':
1154     case 'n':
1155     case 'o':
1156     case 'p':
1157     case 'q':
1158     case 'r':
1159     case 's':
1160     case 't':
1161     case 'u':
1162     case 'v':
1163     case 'w':
1164     case 'x':
1165     case 'y':
1166     case 'z':
1167     case 'A':
1168     case 'B':
1169     case 'C':
1170     case 'D':
1171     case 'E':
1172     case 'F':
1173     case 'G':
1174     case 'H':
1175     case 'I':
1176     case 'J':
1177     case 'K':
1178     case 'L':
1179     case 'M':
1180     case 'N':
1181     case 'O':
1182     case 'P':
1183     case 'Q':
1184     case 'R':
1185     case 'S':
1186     case 'T':
1187     case 'U':
1188     case 'V':
1189     case 'W':
1190     case 'X':
1191     case 'Y':
1192     case 'Z':
1193       parse_name (c);
1194       return ATOM_NAME;
1195
1196     default:
1197       bad_module ("Bad name");
1198     }
1199
1200   /* Not reached.  */
1201 }
1202
1203
1204 /* Peek at the next atom on the input.  */
1205
1206 static atom_type
1207 peek_atom (void)
1208 {
1209   module_locus m;
1210   atom_type a;
1211
1212   get_module_locus (&m);
1213
1214   a = parse_atom ();
1215   if (a == ATOM_STRING)
1216     gfc_free (atom_string);
1217
1218   set_module_locus (&m);
1219   return a;
1220 }
1221
1222
1223 /* Read the next atom from the input, requiring that it be a
1224    particular kind.  */
1225
1226 static void
1227 require_atom (atom_type type)
1228 {
1229   module_locus m;
1230   atom_type t;
1231   const char *p;
1232
1233   get_module_locus (&m);
1234
1235   t = parse_atom ();
1236   if (t != type)
1237     {
1238       switch (type)
1239         {
1240         case ATOM_NAME:
1241           p = _("Expected name");
1242           break;
1243         case ATOM_LPAREN:
1244           p = _("Expected left parenthesis");
1245           break;
1246         case ATOM_RPAREN:
1247           p = _("Expected right parenthesis");
1248           break;
1249         case ATOM_INTEGER:
1250           p = _("Expected integer");
1251           break;
1252         case ATOM_STRING:
1253           p = _("Expected string");
1254           break;
1255         default:
1256           gfc_internal_error ("require_atom(): bad atom type required");
1257         }
1258
1259       set_module_locus (&m);
1260       bad_module (p);
1261     }
1262 }
1263
1264
1265 /* Given a pointer to an mstring array, require that the current input
1266    be one of the strings in the array.  We return the enum value.  */
1267
1268 static int
1269 find_enum (const mstring *m)
1270 {
1271   int i;
1272
1273   i = gfc_string2code (m, atom_name);
1274   if (i >= 0)
1275     return i;
1276
1277   bad_module ("find_enum(): Enum not found");
1278
1279   /* Not reached.  */
1280 }
1281
1282
1283 /**************** Module output subroutines ***************************/
1284
1285 /* Output a character to a module file.  */
1286
1287 static void
1288 write_char (char out)
1289 {
1290   if (putc (out, module_fp) == EOF)
1291     gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1292
1293   /* Add this to our MD5.  */
1294   md5_process_bytes (&out, sizeof (out), &ctx);
1295
1296   if (out != '\n')
1297     module_column++;
1298   else
1299     {
1300       module_column = 1;
1301       module_line++;
1302     }
1303 }
1304
1305
1306 /* Write an atom to a module.  The line wrapping isn't perfect, but it
1307    should work most of the time.  This isn't that big of a deal, since
1308    the file really isn't meant to be read by people anyway.  */
1309
1310 static void
1311 write_atom (atom_type atom, const void *v)
1312 {
1313   char buffer[20];
1314   int i, len;
1315   const char *p;
1316
1317   switch (atom)
1318     {
1319     case ATOM_STRING:
1320     case ATOM_NAME:
1321       p = v;
1322       break;
1323
1324     case ATOM_LPAREN:
1325       p = "(";
1326       break;
1327
1328     case ATOM_RPAREN:
1329       p = ")";
1330       break;
1331
1332     case ATOM_INTEGER:
1333       i = *((const int *) v);
1334       if (i < 0)
1335         gfc_internal_error ("write_atom(): Writing negative integer");
1336
1337       sprintf (buffer, "%d", i);
1338       p = buffer;
1339       break;
1340
1341     default:
1342       gfc_internal_error ("write_atom(): Trying to write dab atom");
1343
1344     }
1345
1346   if(p == NULL || *p == '\0')
1347      len = 0;
1348   else
1349   len = strlen (p);
1350
1351   if (atom != ATOM_RPAREN)
1352     {
1353       if (module_column + len > 72)
1354         write_char ('\n');
1355       else
1356         {
1357
1358           if (last_atom != ATOM_LPAREN && module_column != 1)
1359             write_char (' ');
1360         }
1361     }
1362
1363   if (atom == ATOM_STRING)
1364     write_char ('\'');
1365
1366   while (p != NULL && *p)
1367     {
1368       if (atom == ATOM_STRING && *p == '\'')
1369         write_char ('\'');
1370       write_char (*p++);
1371     }
1372
1373   if (atom == ATOM_STRING)
1374     write_char ('\'');
1375
1376   last_atom = atom;
1377 }
1378
1379
1380
1381 /***************** Mid-level I/O subroutines *****************/
1382
1383 /* These subroutines let their caller read or write atoms without
1384    caring about which of the two is actually happening.  This lets a
1385    subroutine concentrate on the actual format of the data being
1386    written.  */
1387
1388 static void mio_expr (gfc_expr **);
1389 static void mio_symbol_ref (gfc_symbol **);
1390 static void mio_symtree_ref (gfc_symtree **);
1391
1392 /* Read or write an enumerated value.  On writing, we return the input
1393    value for the convenience of callers.  We avoid using an integer
1394    pointer because enums are sometimes inside bitfields.  */
1395
1396 static int
1397 mio_name (int t, const mstring *m)
1398 {
1399   if (iomode == IO_OUTPUT)
1400     write_atom (ATOM_NAME, gfc_code2string (m, t));
1401   else
1402     {
1403       require_atom (ATOM_NAME);
1404       t = find_enum (m);
1405     }
1406
1407   return t;
1408 }
1409
1410 /* Specialization of mio_name.  */
1411
1412 #define DECL_MIO_NAME(TYPE) \
1413  static inline TYPE \
1414  MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1415  { \
1416    return (TYPE) mio_name ((int) t, m); \
1417  }
1418 #define MIO_NAME(TYPE) mio_name_##TYPE
1419
1420 static void
1421 mio_lparen (void)
1422 {
1423   if (iomode == IO_OUTPUT)
1424     write_atom (ATOM_LPAREN, NULL);
1425   else
1426     require_atom (ATOM_LPAREN);
1427 }
1428
1429
1430 static void
1431 mio_rparen (void)
1432 {
1433   if (iomode == IO_OUTPUT)
1434     write_atom (ATOM_RPAREN, NULL);
1435   else
1436     require_atom (ATOM_RPAREN);
1437 }
1438
1439
1440 static void
1441 mio_integer (int *ip)
1442 {
1443   if (iomode == IO_OUTPUT)
1444     write_atom (ATOM_INTEGER, ip);
1445   else
1446     {
1447       require_atom (ATOM_INTEGER);
1448       *ip = atom_int;
1449     }
1450 }
1451
1452
1453 /* Read or write a character pointer that points to a string on the heap.  */
1454
1455 static const char *
1456 mio_allocated_string (const char *s)
1457 {
1458   if (iomode == IO_OUTPUT)
1459     {
1460       write_atom (ATOM_STRING, s);
1461       return s;
1462     }
1463   else
1464     {
1465       require_atom (ATOM_STRING);
1466       return atom_string;
1467     }
1468 }
1469
1470
1471 /* Read or write a string that is in static memory.  */
1472
1473 static void
1474 mio_pool_string (const char **stringp)
1475 {
1476   /* TODO: one could write the string only once, and refer to it via a
1477      fixup pointer.  */
1478
1479   /* As a special case we have to deal with a NULL string.  This
1480      happens for the 'module' member of 'gfc_symbol's that are not in a
1481      module.  We read / write these as the empty string.  */
1482   if (iomode == IO_OUTPUT)
1483     {
1484       const char *p = *stringp == NULL ? "" : *stringp;
1485       write_atom (ATOM_STRING, p);
1486     }
1487   else
1488     {
1489       require_atom (ATOM_STRING);
1490       *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1491       gfc_free (atom_string);
1492     }
1493 }
1494
1495
1496 /* Read or write a string that is inside of some already-allocated
1497    structure.  */
1498
1499 static void
1500 mio_internal_string (char *string)
1501 {
1502   if (iomode == IO_OUTPUT)
1503     write_atom (ATOM_STRING, string);
1504   else
1505     {
1506       require_atom (ATOM_STRING);
1507       strcpy (string, atom_string);
1508       gfc_free (atom_string);
1509     }
1510 }
1511
1512
1513 typedef enum
1514 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1515   AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1516   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1517   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1518   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1519   AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP,
1520   AB_IS_ISO_C
1521 }
1522 ab_attribute;
1523
1524 static const mstring attr_bits[] =
1525 {
1526     minit ("ALLOCATABLE", AB_ALLOCATABLE),
1527     minit ("DIMENSION", AB_DIMENSION),
1528     minit ("EXTERNAL", AB_EXTERNAL),
1529     minit ("INTRINSIC", AB_INTRINSIC),
1530     minit ("OPTIONAL", AB_OPTIONAL),
1531     minit ("POINTER", AB_POINTER),
1532     minit ("SAVE", AB_SAVE),
1533     minit ("VOLATILE", AB_VOLATILE),
1534     minit ("TARGET", AB_TARGET),
1535     minit ("THREADPRIVATE", AB_THREADPRIVATE),
1536     minit ("DUMMY", AB_DUMMY),
1537     minit ("RESULT", AB_RESULT),
1538     minit ("DATA", AB_DATA),
1539     minit ("IN_NAMELIST", AB_IN_NAMELIST),
1540     minit ("IN_COMMON", AB_IN_COMMON),
1541     minit ("FUNCTION", AB_FUNCTION),
1542     minit ("SUBROUTINE", AB_SUBROUTINE),
1543     minit ("SEQUENCE", AB_SEQUENCE),
1544     minit ("ELEMENTAL", AB_ELEMENTAL),
1545     minit ("PURE", AB_PURE),
1546     minit ("RECURSIVE", AB_RECURSIVE),
1547     minit ("GENERIC", AB_GENERIC),
1548     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1549     minit ("CRAY_POINTER", AB_CRAY_POINTER),
1550     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1551     minit ("IS_BIND_C", AB_IS_BIND_C),
1552     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1553     minit ("IS_ISO_C", AB_IS_ISO_C),
1554     minit ("VALUE", AB_VALUE),
1555     minit ("ALLOC_COMP", AB_ALLOC_COMP),
1556     minit ("PROTECTED", AB_PROTECTED),
1557     minit (NULL, -1)
1558 };
1559
1560
1561 /* Specialization of mio_name.  */
1562 DECL_MIO_NAME (ab_attribute)
1563 DECL_MIO_NAME (ar_type)
1564 DECL_MIO_NAME (array_type)
1565 DECL_MIO_NAME (bt)
1566 DECL_MIO_NAME (expr_t)
1567 DECL_MIO_NAME (gfc_access)
1568 DECL_MIO_NAME (gfc_intrinsic_op)
1569 DECL_MIO_NAME (ifsrc)
1570 DECL_MIO_NAME (procedure_type)
1571 DECL_MIO_NAME (ref_type)
1572 DECL_MIO_NAME (sym_flavor)
1573 DECL_MIO_NAME (sym_intent)
1574 #undef DECL_MIO_NAME
1575
1576 /* Symbol attributes are stored in list with the first three elements
1577    being the enumerated fields, while the remaining elements (if any)
1578    indicate the individual attribute bits.  The access field is not
1579    saved-- it controls what symbols are exported when a module is
1580    written.  */
1581
1582 static void
1583 mio_symbol_attribute (symbol_attribute *attr)
1584 {
1585   atom_type t;
1586
1587   mio_lparen ();
1588
1589   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1590   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1591   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1592   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1593
1594   if (iomode == IO_OUTPUT)
1595     {
1596       if (attr->allocatable)
1597         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1598       if (attr->dimension)
1599         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1600       if (attr->external)
1601         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1602       if (attr->intrinsic)
1603         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1604       if (attr->optional)
1605         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1606       if (attr->pointer)
1607         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1608       if (attr->protected)
1609         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1610       if (attr->save)
1611         MIO_NAME (ab_attribute) (AB_SAVE, attr_bits);
1612       if (attr->value)
1613         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1614       if (attr->volatile_)
1615         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1616       if (attr->target)
1617         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1618       if (attr->threadprivate)
1619         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1620       if (attr->dummy)
1621         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1622       if (attr->result)
1623         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1624       /* We deliberately don't preserve the "entry" flag.  */
1625
1626       if (attr->data)
1627         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1628       if (attr->in_namelist)
1629         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1630       if (attr->in_common)
1631         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1632
1633       if (attr->function)
1634         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1635       if (attr->subroutine)
1636         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1637       if (attr->generic)
1638         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1639
1640       if (attr->sequence)
1641         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1642       if (attr->elemental)
1643         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1644       if (attr->pure)
1645         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1646       if (attr->recursive)
1647         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1648       if (attr->always_explicit)
1649         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1650       if (attr->cray_pointer)
1651         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1652       if (attr->cray_pointee)
1653         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1654       if (attr->is_bind_c)
1655         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1656       if (attr->is_c_interop)
1657         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1658       if (attr->is_iso_c)
1659         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1660       if (attr->alloc_comp)
1661         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1662
1663       mio_rparen ();
1664
1665     }
1666   else
1667     {
1668       for (;;)
1669         {
1670           t = parse_atom ();
1671           if (t == ATOM_RPAREN)
1672             break;
1673           if (t != ATOM_NAME)
1674             bad_module ("Expected attribute bit name");
1675
1676           switch ((ab_attribute) find_enum (attr_bits))
1677             {
1678             case AB_ALLOCATABLE:
1679               attr->allocatable = 1;
1680               break;
1681             case AB_DIMENSION:
1682               attr->dimension = 1;
1683               break;
1684             case AB_EXTERNAL:
1685               attr->external = 1;
1686               break;
1687             case AB_INTRINSIC:
1688               attr->intrinsic = 1;
1689               break;
1690             case AB_OPTIONAL:
1691               attr->optional = 1;
1692               break;
1693             case AB_POINTER:
1694               attr->pointer = 1;
1695               break;
1696             case AB_PROTECTED:
1697               attr->protected = 1;
1698               break;
1699             case AB_SAVE:
1700               attr->save = 1;
1701               break;
1702             case AB_VALUE:
1703               attr->value = 1;
1704               break;
1705             case AB_VOLATILE:
1706               attr->volatile_ = 1;
1707               break;
1708             case AB_TARGET:
1709               attr->target = 1;
1710               break;
1711             case AB_THREADPRIVATE:
1712               attr->threadprivate = 1;
1713               break;
1714             case AB_DUMMY:
1715               attr->dummy = 1;
1716               break;
1717             case AB_RESULT:
1718               attr->result = 1;
1719               break;
1720             case AB_DATA:
1721               attr->data = 1;
1722               break;
1723             case AB_IN_NAMELIST:
1724               attr->in_namelist = 1;
1725               break;
1726             case AB_IN_COMMON:
1727               attr->in_common = 1;
1728               break;
1729             case AB_FUNCTION:
1730               attr->function = 1;
1731               break;
1732             case AB_SUBROUTINE:
1733               attr->subroutine = 1;
1734               break;
1735             case AB_GENERIC:
1736               attr->generic = 1;
1737               break;
1738             case AB_SEQUENCE:
1739               attr->sequence = 1;
1740               break;
1741             case AB_ELEMENTAL:
1742               attr->elemental = 1;
1743               break;
1744             case AB_PURE:
1745               attr->pure = 1;
1746               break;
1747             case AB_RECURSIVE:
1748               attr->recursive = 1;
1749               break;
1750             case AB_ALWAYS_EXPLICIT:
1751               attr->always_explicit = 1;
1752               break;
1753             case AB_CRAY_POINTER:
1754               attr->cray_pointer = 1;
1755               break;
1756             case AB_CRAY_POINTEE:
1757               attr->cray_pointee = 1;
1758               break;
1759             case AB_IS_BIND_C:
1760               attr->is_bind_c = 1;
1761               break;
1762             case AB_IS_C_INTEROP:
1763               attr->is_c_interop = 1;
1764               break;
1765             case AB_IS_ISO_C:
1766               attr->is_iso_c = 1;
1767               break;
1768             case AB_ALLOC_COMP:
1769               attr->alloc_comp = 1;
1770               break;
1771             }
1772         }
1773     }
1774 }
1775
1776
1777 static const mstring bt_types[] = {
1778     minit ("INTEGER", BT_INTEGER),
1779     minit ("REAL", BT_REAL),
1780     minit ("COMPLEX", BT_COMPLEX),
1781     minit ("LOGICAL", BT_LOGICAL),
1782     minit ("CHARACTER", BT_CHARACTER),
1783     minit ("DERIVED", BT_DERIVED),
1784     minit ("PROCEDURE", BT_PROCEDURE),
1785     minit ("UNKNOWN", BT_UNKNOWN),
1786     minit ("VOID", BT_VOID),
1787     minit (NULL, -1)
1788 };
1789
1790
1791 static void
1792 mio_charlen (gfc_charlen **clp)
1793 {
1794   gfc_charlen *cl;
1795
1796   mio_lparen ();
1797
1798   if (iomode == IO_OUTPUT)
1799     {
1800       cl = *clp;
1801       if (cl != NULL)
1802         mio_expr (&cl->length);
1803     }
1804   else
1805     {
1806       if (peek_atom () != ATOM_RPAREN)
1807         {
1808           cl = gfc_get_charlen ();
1809           mio_expr (&cl->length);
1810
1811           *clp = cl;
1812
1813           cl->next = gfc_current_ns->cl_list;
1814           gfc_current_ns->cl_list = cl;
1815         }
1816     }
1817
1818   mio_rparen ();
1819 }
1820
1821
1822 /* Return a symtree node with a name that is guaranteed to be unique
1823    within the namespace and corresponds to an illegal fortran name.  */
1824
1825 static gfc_symtree *
1826 get_unique_symtree (gfc_namespace *ns)
1827 {
1828   char name[GFC_MAX_SYMBOL_LEN + 1];
1829   static int serial = 0;
1830
1831   sprintf (name, "@%d", serial++);
1832   return gfc_new_symtree (&ns->sym_root, name);
1833 }
1834
1835
1836 /* See if a name is a generated name.  */
1837
1838 static int
1839 check_unique_name (const char *name)
1840 {
1841   return *name == '@';
1842 }
1843
1844
1845 static void
1846 mio_typespec (gfc_typespec *ts)
1847 {
1848   mio_lparen ();
1849
1850   ts->type = MIO_NAME (bt) (ts->type, bt_types);
1851
1852   if (ts->type != BT_DERIVED)
1853     mio_integer (&ts->kind);
1854   else
1855     mio_symbol_ref (&ts->derived);
1856
1857   /* Add info for C interop and is_iso_c.  */
1858   mio_integer (&ts->is_c_interop);
1859   mio_integer (&ts->is_iso_c);
1860
1861   /* If the typespec is for an identifier either from iso_c_binding, or
1862      a constant that was initialized to an identifier from it, use the
1863      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
1864   if (ts->is_iso_c)
1865     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
1866   else
1867     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
1868
1869   if (ts->type != BT_CHARACTER)
1870     {
1871       /* ts->cl is only valid for BT_CHARACTER.  */
1872       mio_lparen ();
1873       mio_rparen ();
1874     }
1875   else
1876     mio_charlen (&ts->cl);
1877
1878   mio_rparen ();
1879 }
1880
1881
1882 static const mstring array_spec_types[] = {
1883     minit ("EXPLICIT", AS_EXPLICIT),
1884     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1885     minit ("DEFERRED", AS_DEFERRED),
1886     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1887     minit (NULL, -1)
1888 };
1889
1890
1891 static void
1892 mio_array_spec (gfc_array_spec **asp)
1893 {
1894   gfc_array_spec *as;
1895   int i;
1896
1897   mio_lparen ();
1898
1899   if (iomode == IO_OUTPUT)
1900     {
1901       if (*asp == NULL)
1902         goto done;
1903       as = *asp;
1904     }
1905   else
1906     {
1907       if (peek_atom () == ATOM_RPAREN)
1908         {
1909           *asp = NULL;
1910           goto done;
1911         }
1912
1913       *asp = as = gfc_get_array_spec ();
1914     }
1915
1916   mio_integer (&as->rank);
1917   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
1918
1919   for (i = 0; i < as->rank; i++)
1920     {
1921       mio_expr (&as->lower[i]);
1922       mio_expr (&as->upper[i]);
1923     }
1924
1925 done:
1926   mio_rparen ();
1927 }
1928
1929
1930 /* Given a pointer to an array reference structure (which lives in a
1931    gfc_ref structure), find the corresponding array specification
1932    structure.  Storing the pointer in the ref structure doesn't quite
1933    work when loading from a module. Generating code for an array
1934    reference also needs more information than just the array spec.  */
1935
1936 static const mstring array_ref_types[] = {
1937     minit ("FULL", AR_FULL),
1938     minit ("ELEMENT", AR_ELEMENT),
1939     minit ("SECTION", AR_SECTION),
1940     minit (NULL, -1)
1941 };
1942
1943
1944 static void
1945 mio_array_ref (gfc_array_ref *ar)
1946 {
1947   int i;
1948
1949   mio_lparen ();
1950   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
1951   mio_integer (&ar->dimen);
1952
1953   switch (ar->type)
1954     {
1955     case AR_FULL:
1956       break;
1957
1958     case AR_ELEMENT:
1959       for (i = 0; i < ar->dimen; i++)
1960         mio_expr (&ar->start[i]);
1961
1962       break;
1963
1964     case AR_SECTION:
1965       for (i = 0; i < ar->dimen; i++)
1966         {
1967           mio_expr (&ar->start[i]);
1968           mio_expr (&ar->end[i]);
1969           mio_expr (&ar->stride[i]);
1970         }
1971
1972       break;
1973
1974     case AR_UNKNOWN:
1975       gfc_internal_error ("mio_array_ref(): Unknown array ref");
1976     }
1977
1978   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1979      we can't call mio_integer directly.  Instead loop over each element
1980      and cast it to/from an integer.  */
1981   if (iomode == IO_OUTPUT)
1982     {
1983       for (i = 0; i < ar->dimen; i++)
1984         {
1985           int tmp = (int)ar->dimen_type[i];
1986           write_atom (ATOM_INTEGER, &tmp);
1987         }
1988     }
1989   else
1990     {
1991       for (i = 0; i < ar->dimen; i++)
1992         {
1993           require_atom (ATOM_INTEGER);
1994           ar->dimen_type[i] = atom_int;
1995         }
1996     }
1997
1998   if (iomode == IO_INPUT)
1999     {
2000       ar->where = gfc_current_locus;
2001
2002       for (i = 0; i < ar->dimen; i++)
2003         ar->c_where[i] = gfc_current_locus;
2004     }
2005
2006   mio_rparen ();
2007 }
2008
2009
2010 /* Saves or restores a pointer.  The pointer is converted back and
2011    forth from an integer.  We return the pointer_info pointer so that
2012    the caller can take additional action based on the pointer type.  */
2013
2014 static pointer_info *
2015 mio_pointer_ref (void *gp)
2016 {
2017   pointer_info *p;
2018
2019   if (iomode == IO_OUTPUT)
2020     {
2021       p = get_pointer (*((char **) gp));
2022       write_atom (ATOM_INTEGER, &p->integer);
2023     }
2024   else
2025     {
2026       require_atom (ATOM_INTEGER);
2027       p = add_fixup (atom_int, gp);
2028     }
2029
2030   return p;
2031 }
2032
2033
2034 /* Save and load references to components that occur within
2035    expressions.  We have to describe these references by a number and
2036    by name.  The number is necessary for forward references during
2037    reading, and the name is necessary if the symbol already exists in
2038    the namespace and is not loaded again.  */
2039
2040 static void
2041 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2042 {
2043   char name[GFC_MAX_SYMBOL_LEN + 1];
2044   gfc_component *q;
2045   pointer_info *p;
2046
2047   p = mio_pointer_ref (cp);
2048   if (p->type == P_UNKNOWN)
2049     p->type = P_COMPONENT;
2050
2051   if (iomode == IO_OUTPUT)
2052     mio_pool_string (&(*cp)->name);
2053   else
2054     {
2055       mio_internal_string (name);
2056
2057       /* It can happen that a component reference can be read before the
2058          associated derived type symbol has been loaded. Return now and
2059          wait for a later iteration of load_needed.  */
2060       if (sym == NULL)
2061         return;
2062
2063       if (sym->components != NULL && p->u.pointer == NULL)
2064         {
2065           /* Symbol already loaded, so search by name.  */
2066           for (q = sym->components; q; q = q->next)
2067             if (strcmp (q->name, name) == 0)
2068               break;
2069
2070           if (q == NULL)
2071             gfc_internal_error ("mio_component_ref(): Component not found");
2072
2073           associate_integer_pointer (p, q);
2074         }
2075
2076       /* Make sure this symbol will eventually be loaded.  */
2077       p = find_pointer2 (sym);
2078       if (p->u.rsym.state == UNUSED)
2079         p->u.rsym.state = NEEDED;
2080     }
2081 }
2082
2083
2084 static void
2085 mio_component (gfc_component *c)
2086 {
2087   pointer_info *p;
2088   int n;
2089
2090   mio_lparen ();
2091
2092   if (iomode == IO_OUTPUT)
2093     {
2094       p = get_pointer (c);
2095       mio_integer (&p->integer);
2096     }
2097   else
2098     {
2099       mio_integer (&n);
2100       p = get_integer (n);
2101       associate_integer_pointer (p, c);
2102     }
2103
2104   if (p->type == P_UNKNOWN)
2105     p->type = P_COMPONENT;
2106
2107   mio_pool_string (&c->name);
2108   mio_typespec (&c->ts);
2109   mio_array_spec (&c->as);
2110
2111   mio_integer (&c->dimension);
2112   mio_integer (&c->pointer);
2113   mio_integer (&c->allocatable);
2114   c->access = MIO_NAME (gfc_access) (c->access, access_types);
2115
2116   mio_expr (&c->initializer);
2117   mio_rparen ();
2118 }
2119
2120
2121 static void
2122 mio_component_list (gfc_component **cp)
2123 {
2124   gfc_component *c, *tail;
2125
2126   mio_lparen ();
2127
2128   if (iomode == IO_OUTPUT)
2129     {
2130       for (c = *cp; c; c = c->next)
2131         mio_component (c);
2132     }
2133   else
2134     {
2135       *cp = NULL;
2136       tail = NULL;
2137
2138       for (;;)
2139         {
2140           if (peek_atom () == ATOM_RPAREN)
2141             break;
2142
2143           c = gfc_get_component ();
2144           mio_component (c);
2145
2146           if (tail == NULL)
2147             *cp = c;
2148           else
2149             tail->next = c;
2150
2151           tail = c;
2152         }
2153     }
2154
2155   mio_rparen ();
2156 }
2157
2158
2159 static void
2160 mio_actual_arg (gfc_actual_arglist *a)
2161 {
2162   mio_lparen ();
2163   mio_pool_string (&a->name);
2164   mio_expr (&a->expr);
2165   mio_rparen ();
2166 }
2167
2168
2169 static void
2170 mio_actual_arglist (gfc_actual_arglist **ap)
2171 {
2172   gfc_actual_arglist *a, *tail;
2173
2174   mio_lparen ();
2175
2176   if (iomode == IO_OUTPUT)
2177     {
2178       for (a = *ap; a; a = a->next)
2179         mio_actual_arg (a);
2180
2181     }
2182   else
2183     {
2184       tail = NULL;
2185
2186       for (;;)
2187         {
2188           if (peek_atom () != ATOM_LPAREN)
2189             break;
2190
2191           a = gfc_get_actual_arglist ();
2192
2193           if (tail == NULL)
2194             *ap = a;
2195           else
2196             tail->next = a;
2197
2198           tail = a;
2199           mio_actual_arg (a);
2200         }
2201     }
2202
2203   mio_rparen ();
2204 }
2205
2206
2207 /* Read and write formal argument lists.  */
2208
2209 static void
2210 mio_formal_arglist (gfc_symbol *sym)
2211 {
2212   gfc_formal_arglist *f, *tail;
2213
2214   mio_lparen ();
2215
2216   if (iomode == IO_OUTPUT)
2217     {
2218       for (f = sym->formal; f; f = f->next)
2219         mio_symbol_ref (&f->sym);
2220     }
2221   else
2222     {
2223       sym->formal = tail = NULL;
2224
2225       while (peek_atom () != ATOM_RPAREN)
2226         {
2227           f = gfc_get_formal_arglist ();
2228           mio_symbol_ref (&f->sym);
2229
2230           if (sym->formal == NULL)
2231             sym->formal = f;
2232           else
2233             tail->next = f;
2234
2235           tail = f;
2236         }
2237     }
2238
2239   mio_rparen ();
2240 }
2241
2242
2243 /* Save or restore a reference to a symbol node.  */
2244
2245 void
2246 mio_symbol_ref (gfc_symbol **symp)
2247 {
2248   pointer_info *p;
2249
2250   p = mio_pointer_ref (symp);
2251   if (p->type == P_UNKNOWN)
2252     p->type = P_SYMBOL;
2253
2254   if (iomode == IO_OUTPUT)
2255     {
2256       if (p->u.wsym.state == UNREFERENCED)
2257         p->u.wsym.state = NEEDS_WRITE;
2258     }
2259   else
2260     {
2261       if (p->u.rsym.state == UNUSED)
2262         p->u.rsym.state = NEEDED;
2263     }
2264 }
2265
2266
2267 /* Save or restore a reference to a symtree node.  */
2268
2269 static void
2270 mio_symtree_ref (gfc_symtree **stp)
2271 {
2272   pointer_info *p;
2273   fixup_t *f;
2274
2275   if (iomode == IO_OUTPUT)
2276     mio_symbol_ref (&(*stp)->n.sym);
2277   else
2278     {
2279       require_atom (ATOM_INTEGER);
2280       p = get_integer (atom_int);
2281
2282       /* An unused equivalence member; make a symbol and a symtree
2283          for it.  */
2284       if (in_load_equiv && p->u.rsym.symtree == NULL)
2285         {
2286           /* Since this is not used, it must have a unique name.  */
2287           p->u.rsym.symtree = get_unique_symtree (gfc_current_ns);
2288
2289           /* Make the symbol.  */
2290           if (p->u.rsym.sym == NULL)
2291             {
2292               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2293                                               gfc_current_ns);
2294               p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2295             }
2296
2297           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2298           p->u.rsym.symtree->n.sym->refs++;
2299           p->u.rsym.referenced = 1;
2300         }
2301
2302       if (p->type == P_UNKNOWN)
2303         p->type = P_SYMBOL;
2304
2305       if (p->u.rsym.state == UNUSED)
2306         p->u.rsym.state = NEEDED;
2307
2308       if (p->u.rsym.symtree != NULL)
2309         {
2310           *stp = p->u.rsym.symtree;
2311         }
2312       else
2313         {
2314           f = gfc_getmem (sizeof (fixup_t));
2315
2316           f->next = p->u.rsym.stfixup;
2317           p->u.rsym.stfixup = f;
2318
2319           f->pointer = (void **) stp;
2320         }
2321     }
2322 }
2323
2324
2325 static void
2326 mio_iterator (gfc_iterator **ip)
2327 {
2328   gfc_iterator *iter;
2329
2330   mio_lparen ();
2331
2332   if (iomode == IO_OUTPUT)
2333     {
2334       if (*ip == NULL)
2335         goto done;
2336     }
2337   else
2338     {
2339       if (peek_atom () == ATOM_RPAREN)
2340         {
2341           *ip = NULL;
2342           goto done;
2343         }
2344
2345       *ip = gfc_get_iterator ();
2346     }
2347
2348   iter = *ip;
2349
2350   mio_expr (&iter->var);
2351   mio_expr (&iter->start);
2352   mio_expr (&iter->end);
2353   mio_expr (&iter->step);
2354
2355 done:
2356   mio_rparen ();
2357 }
2358
2359
2360 static void
2361 mio_constructor (gfc_constructor **cp)
2362 {
2363   gfc_constructor *c, *tail;
2364
2365   mio_lparen ();
2366
2367   if (iomode == IO_OUTPUT)
2368     {
2369       for (c = *cp; c; c = c->next)
2370         {
2371           mio_lparen ();
2372           mio_expr (&c->expr);
2373           mio_iterator (&c->iterator);
2374           mio_rparen ();
2375         }
2376     }
2377   else
2378     {
2379       *cp = NULL;
2380       tail = NULL;
2381
2382       while (peek_atom () != ATOM_RPAREN)
2383         {
2384           c = gfc_get_constructor ();
2385
2386           if (tail == NULL)
2387             *cp = c;
2388           else
2389             tail->next = c;
2390
2391           tail = c;
2392
2393           mio_lparen ();
2394           mio_expr (&c->expr);
2395           mio_iterator (&c->iterator);
2396           mio_rparen ();
2397         }
2398     }
2399
2400   mio_rparen ();
2401 }
2402
2403
2404 static const mstring ref_types[] = {
2405     minit ("ARRAY", REF_ARRAY),
2406     minit ("COMPONENT", REF_COMPONENT),
2407     minit ("SUBSTRING", REF_SUBSTRING),
2408     minit (NULL, -1)
2409 };
2410
2411
2412 static void
2413 mio_ref (gfc_ref **rp)
2414 {
2415   gfc_ref *r;
2416
2417   mio_lparen ();
2418
2419   r = *rp;
2420   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2421
2422   switch (r->type)
2423     {
2424     case REF_ARRAY:
2425       mio_array_ref (&r->u.ar);
2426       break;
2427
2428     case REF_COMPONENT:
2429       mio_symbol_ref (&r->u.c.sym);
2430       mio_component_ref (&r->u.c.component, r->u.c.sym);
2431       break;
2432
2433     case REF_SUBSTRING:
2434       mio_expr (&r->u.ss.start);
2435       mio_expr (&r->u.ss.end);
2436       mio_charlen (&r->u.ss.length);
2437       break;
2438     }
2439
2440   mio_rparen ();
2441 }
2442
2443
2444 static void
2445 mio_ref_list (gfc_ref **rp)
2446 {
2447   gfc_ref *ref, *head, *tail;
2448
2449   mio_lparen ();
2450
2451   if (iomode == IO_OUTPUT)
2452     {
2453       for (ref = *rp; ref; ref = ref->next)
2454         mio_ref (&ref);
2455     }
2456   else
2457     {
2458       head = tail = NULL;
2459
2460       while (peek_atom () != ATOM_RPAREN)
2461         {
2462           if (head == NULL)
2463             head = tail = gfc_get_ref ();
2464           else
2465             {
2466               tail->next = gfc_get_ref ();
2467               tail = tail->next;
2468             }
2469
2470           mio_ref (&tail);
2471         }
2472
2473       *rp = head;
2474     }
2475
2476   mio_rparen ();
2477 }
2478
2479
2480 /* Read and write an integer value.  */
2481
2482 static void
2483 mio_gmp_integer (mpz_t *integer)
2484 {
2485   char *p;
2486
2487   if (iomode == IO_INPUT)
2488     {
2489       if (parse_atom () != ATOM_STRING)
2490         bad_module ("Expected integer string");
2491
2492       mpz_init (*integer);
2493       if (mpz_set_str (*integer, atom_string, 10))
2494         bad_module ("Error converting integer");
2495
2496       gfc_free (atom_string);
2497     }
2498   else
2499     {
2500       p = mpz_get_str (NULL, 10, *integer);
2501       write_atom (ATOM_STRING, p);
2502       gfc_free (p);
2503     }
2504 }
2505
2506
2507 static void
2508 mio_gmp_real (mpfr_t *real)
2509 {
2510   mp_exp_t exponent;
2511   char *p;
2512
2513   if (iomode == IO_INPUT)
2514     {
2515       if (parse_atom () != ATOM_STRING)
2516         bad_module ("Expected real string");
2517
2518       mpfr_init (*real);
2519       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2520       gfc_free (atom_string);
2521     }
2522   else
2523     {
2524       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2525       atom_string = gfc_getmem (strlen (p) + 20);
2526
2527       sprintf (atom_string, "0.%s@%ld", p, exponent);
2528
2529       /* Fix negative numbers.  */
2530       if (atom_string[2] == '-')
2531         {
2532           atom_string[0] = '-';
2533           atom_string[1] = '0';
2534           atom_string[2] = '.';
2535         }
2536
2537       write_atom (ATOM_STRING, atom_string);
2538
2539       gfc_free (atom_string);
2540       gfc_free (p);
2541     }
2542 }
2543
2544
2545 /* Save and restore the shape of an array constructor.  */
2546
2547 static void
2548 mio_shape (mpz_t **pshape, int rank)
2549 {
2550   mpz_t *shape;
2551   atom_type t;
2552   int n;
2553
2554   /* A NULL shape is represented by ().  */
2555   mio_lparen ();
2556
2557   if (iomode == IO_OUTPUT)
2558     {
2559       shape = *pshape;
2560       if (!shape)
2561         {
2562           mio_rparen ();
2563           return;
2564         }
2565     }
2566   else
2567     {
2568       t = peek_atom ();
2569       if (t == ATOM_RPAREN)
2570         {
2571           *pshape = NULL;
2572           mio_rparen ();
2573           return;
2574         }
2575
2576       shape = gfc_get_shape (rank);
2577       *pshape = shape;
2578     }
2579
2580   for (n = 0; n < rank; n++)
2581     mio_gmp_integer (&shape[n]);
2582
2583   mio_rparen ();
2584 }
2585
2586
2587 static const mstring expr_types[] = {
2588     minit ("OP", EXPR_OP),
2589     minit ("FUNCTION", EXPR_FUNCTION),
2590     minit ("CONSTANT", EXPR_CONSTANT),
2591     minit ("VARIABLE", EXPR_VARIABLE),
2592     minit ("SUBSTRING", EXPR_SUBSTRING),
2593     minit ("STRUCTURE", EXPR_STRUCTURE),
2594     minit ("ARRAY", EXPR_ARRAY),
2595     minit ("NULL", EXPR_NULL),
2596     minit (NULL, -1)
2597 };
2598
2599 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2600    generic operators, not in expressions.  INTRINSIC_USER is also
2601    replaced by the correct function name by the time we see it.  */
2602
2603 static const mstring intrinsics[] =
2604 {
2605     minit ("UPLUS", INTRINSIC_UPLUS),
2606     minit ("UMINUS", INTRINSIC_UMINUS),
2607     minit ("PLUS", INTRINSIC_PLUS),
2608     minit ("MINUS", INTRINSIC_MINUS),
2609     minit ("TIMES", INTRINSIC_TIMES),
2610     minit ("DIVIDE", INTRINSIC_DIVIDE),
2611     minit ("POWER", INTRINSIC_POWER),
2612     minit ("CONCAT", INTRINSIC_CONCAT),
2613     minit ("AND", INTRINSIC_AND),
2614     minit ("OR", INTRINSIC_OR),
2615     minit ("EQV", INTRINSIC_EQV),
2616     minit ("NEQV", INTRINSIC_NEQV),
2617     minit ("EQ", INTRINSIC_EQ),
2618     minit ("NE", INTRINSIC_NE),
2619     minit ("GT", INTRINSIC_GT),
2620     minit ("GE", INTRINSIC_GE),
2621     minit ("LT", INTRINSIC_LT),
2622     minit ("LE", INTRINSIC_LE),
2623     minit ("NOT", INTRINSIC_NOT),
2624     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2625     minit (NULL, -1)
2626 };
2627
2628
2629 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
2630
2631 static void
2632 fix_mio_expr (gfc_expr *e)
2633 {
2634   gfc_symtree *ns_st = NULL;
2635   const char *fname;
2636
2637   if (iomode != IO_OUTPUT)
2638     return;
2639
2640   if (e->symtree)
2641     {
2642       /* If this is a symtree for a symbol that came from a contained module
2643          namespace, it has a unique name and we should look in the current
2644          namespace to see if the required, non-contained symbol is available
2645          yet. If so, the latter should be written.  */
2646       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2647         ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2648                                   e->symtree->n.sym->name);
2649
2650       /* On the other hand, if the existing symbol is the module name or the
2651          new symbol is a dummy argument, do not do the promotion.  */
2652       if (ns_st && ns_st->n.sym
2653           && ns_st->n.sym->attr.flavor != FL_MODULE
2654           && !e->symtree->n.sym->attr.dummy)
2655         e->symtree = ns_st;
2656     }
2657   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2658     {
2659       /* In some circumstances, a function used in an initialization
2660          expression, in one use associated module, can fail to be
2661          coupled to its symtree when used in a specification
2662          expression in another module.  */
2663       fname = e->value.function.esym ? e->value.function.esym->name
2664                                      : e->value.function.isym->name;
2665       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2666     }
2667 }
2668
2669
2670 /* Read and write expressions.  The form "()" is allowed to indicate a
2671    NULL expression.  */
2672
2673 static void
2674 mio_expr (gfc_expr **ep)
2675 {
2676   gfc_expr *e;
2677   atom_type t;
2678   int flag;
2679
2680   mio_lparen ();
2681
2682   if (iomode == IO_OUTPUT)
2683     {
2684       if (*ep == NULL)
2685         {
2686           mio_rparen ();
2687           return;
2688         }
2689
2690       e = *ep;
2691       MIO_NAME (expr_t) (e->expr_type, expr_types);
2692     }
2693   else
2694     {
2695       t = parse_atom ();
2696       if (t == ATOM_RPAREN)
2697         {
2698           *ep = NULL;
2699           return;
2700         }
2701
2702       if (t != ATOM_NAME)
2703         bad_module ("Expected expression type");
2704
2705       e = *ep = gfc_get_expr ();
2706       e->where = gfc_current_locus;
2707       e->expr_type = (expr_t) find_enum (expr_types);
2708     }
2709
2710   mio_typespec (&e->ts);
2711   mio_integer (&e->rank);
2712
2713   fix_mio_expr (e);
2714
2715   switch (e->expr_type)
2716     {
2717     case EXPR_OP:
2718       e->value.op.operator
2719         = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2720
2721       switch (e->value.op.operator)
2722         {
2723         case INTRINSIC_UPLUS:
2724         case INTRINSIC_UMINUS:
2725         case INTRINSIC_NOT:
2726         case INTRINSIC_PARENTHESES:
2727           mio_expr (&e->value.op.op1);
2728           break;
2729
2730         case INTRINSIC_PLUS:
2731         case INTRINSIC_MINUS:
2732         case INTRINSIC_TIMES:
2733         case INTRINSIC_DIVIDE:
2734         case INTRINSIC_POWER:
2735         case INTRINSIC_CONCAT:
2736         case INTRINSIC_AND:
2737         case INTRINSIC_OR:
2738         case INTRINSIC_EQV:
2739         case INTRINSIC_NEQV:
2740         case INTRINSIC_EQ:
2741         case INTRINSIC_NE:
2742         case INTRINSIC_GT:
2743         case INTRINSIC_GE:
2744         case INTRINSIC_LT:
2745         case INTRINSIC_LE:
2746           mio_expr (&e->value.op.op1);
2747           mio_expr (&e->value.op.op2);
2748           break;
2749
2750         default:
2751           bad_module ("Bad operator");
2752         }
2753
2754       break;
2755
2756     case EXPR_FUNCTION:
2757       mio_symtree_ref (&e->symtree);
2758       mio_actual_arglist (&e->value.function.actual);
2759
2760       if (iomode == IO_OUTPUT)
2761         {
2762           e->value.function.name
2763             = mio_allocated_string (e->value.function.name);
2764           flag = e->value.function.esym != NULL;
2765           mio_integer (&flag);
2766           if (flag)
2767             mio_symbol_ref (&e->value.function.esym);
2768           else
2769             write_atom (ATOM_STRING, e->value.function.isym->name);
2770         }
2771       else
2772         {
2773           require_atom (ATOM_STRING);
2774           e->value.function.name = gfc_get_string (atom_string);
2775           gfc_free (atom_string);
2776
2777           mio_integer (&flag);
2778           if (flag)
2779             mio_symbol_ref (&e->value.function.esym);
2780           else
2781             {
2782               require_atom (ATOM_STRING);
2783               e->value.function.isym = gfc_find_function (atom_string);
2784               gfc_free (atom_string);
2785             }
2786         }
2787
2788       break;
2789
2790     case EXPR_VARIABLE:
2791       mio_symtree_ref (&e->symtree);
2792       mio_ref_list (&e->ref);
2793       break;
2794
2795     case EXPR_SUBSTRING:
2796       e->value.character.string
2797         = (char *) mio_allocated_string (e->value.character.string);
2798       mio_ref_list (&e->ref);
2799       break;
2800
2801     case EXPR_STRUCTURE:
2802     case EXPR_ARRAY:
2803       mio_constructor (&e->value.constructor);
2804       mio_shape (&e->shape, e->rank);
2805       break;
2806
2807     case EXPR_CONSTANT:
2808       switch (e->ts.type)
2809         {
2810         case BT_INTEGER:
2811           mio_gmp_integer (&e->value.integer);
2812           break;
2813
2814         case BT_REAL:
2815           gfc_set_model_kind (e->ts.kind);
2816           mio_gmp_real (&e->value.real);
2817           break;
2818
2819         case BT_COMPLEX:
2820           gfc_set_model_kind (e->ts.kind);
2821           mio_gmp_real (&e->value.complex.r);
2822           mio_gmp_real (&e->value.complex.i);
2823           break;
2824
2825         case BT_LOGICAL:
2826           mio_integer (&e->value.logical);
2827           break;
2828
2829         case BT_CHARACTER:
2830           mio_integer (&e->value.character.length);
2831           e->value.character.string
2832             = (char *) mio_allocated_string (e->value.character.string);
2833           break;
2834
2835         default:
2836           bad_module ("Bad type in constant expression");
2837         }
2838
2839       break;
2840
2841     case EXPR_NULL:
2842       break;
2843     }
2844
2845   mio_rparen ();
2846 }
2847
2848
2849 /* Read and write namelists.  */
2850
2851 static void
2852 mio_namelist (gfc_symbol *sym)
2853 {
2854   gfc_namelist *n, *m;
2855   const char *check_name;
2856
2857   mio_lparen ();
2858
2859   if (iomode == IO_OUTPUT)
2860     {
2861       for (n = sym->namelist; n; n = n->next)
2862         mio_symbol_ref (&n->sym);
2863     }
2864   else
2865     {
2866       /* This departure from the standard is flagged as an error.
2867          It does, in fact, work correctly. TODO: Allow it
2868          conditionally?  */
2869       if (sym->attr.flavor == FL_NAMELIST)
2870         {
2871           check_name = find_use_name (sym->name);
2872           if (check_name && strcmp (check_name, sym->name) != 0)
2873             gfc_error ("Namelist %s cannot be renamed by USE "
2874                        "association to %s", sym->name, check_name);
2875         }
2876
2877       m = NULL;
2878       while (peek_atom () != ATOM_RPAREN)
2879         {
2880           n = gfc_get_namelist ();
2881           mio_symbol_ref (&n->sym);
2882
2883           if (sym->namelist == NULL)
2884             sym->namelist = n;
2885           else
2886             m->next = n;
2887
2888           m = n;
2889         }
2890       sym->namelist_tail = m;
2891     }
2892
2893   mio_rparen ();
2894 }
2895
2896
2897 /* Save/restore lists of gfc_interface stuctures.  When loading an
2898    interface, we are really appending to the existing list of
2899    interfaces.  Checking for duplicate and ambiguous interfaces has to
2900    be done later when all symbols have been loaded.  */
2901
2902 static void
2903 mio_interface_rest (gfc_interface **ip)
2904 {
2905   gfc_interface *tail, *p;
2906
2907   if (iomode == IO_OUTPUT)
2908     {
2909       if (ip != NULL)
2910         for (p = *ip; p; p = p->next)
2911           mio_symbol_ref (&p->sym);
2912     }
2913   else
2914     {
2915       if (*ip == NULL)
2916         tail = NULL;
2917       else
2918         {
2919           tail = *ip;
2920           while (tail->next)
2921             tail = tail->next;
2922         }
2923
2924       for (;;)
2925         {
2926           if (peek_atom () == ATOM_RPAREN)
2927             break;
2928
2929           p = gfc_get_interface ();
2930           p->where = gfc_current_locus;
2931           mio_symbol_ref (&p->sym);
2932
2933           if (tail == NULL)
2934             *ip = p;
2935           else
2936             tail->next = p;
2937
2938           tail = p;
2939         }
2940     }
2941
2942   mio_rparen ();
2943 }
2944
2945
2946 /* Save/restore a nameless operator interface.  */
2947
2948 static void
2949 mio_interface (gfc_interface **ip)
2950 {
2951   mio_lparen ();
2952   mio_interface_rest (ip);
2953 }
2954
2955
2956 /* Save/restore a named operator interface.  */
2957
2958 static void
2959 mio_symbol_interface (const char **name, const char **module,
2960                       gfc_interface **ip)
2961 {
2962   mio_lparen ();
2963   mio_pool_string (name);
2964   mio_pool_string (module);
2965   mio_interface_rest (ip);
2966 }
2967
2968
2969 static void
2970 mio_namespace_ref (gfc_namespace **nsp)
2971 {
2972   gfc_namespace *ns;
2973   pointer_info *p;
2974
2975   p = mio_pointer_ref (nsp);
2976
2977   if (p->type == P_UNKNOWN)
2978     p->type = P_NAMESPACE;
2979
2980   if (iomode == IO_INPUT && p->integer != 0)
2981     {
2982       ns = (gfc_namespace *) p->u.pointer;
2983       if (ns == NULL)
2984         {
2985           ns = gfc_get_namespace (NULL, 0);
2986           associate_integer_pointer (p, ns);
2987         }
2988       else
2989         ns->refs++;
2990     }
2991 }
2992
2993
2994 /* Unlike most other routines, the address of the symbol node is already
2995    fixed on input and the name/module has already been filled in.  */
2996
2997 static void
2998 mio_symbol (gfc_symbol *sym)
2999 {
3000   int intmod = INTMOD_NONE;
3001
3002   gfc_formal_arglist *formal;
3003
3004   mio_lparen ();
3005
3006   mio_symbol_attribute (&sym->attr);
3007   mio_typespec (&sym->ts);
3008
3009   /* Contained procedures don't have formal namespaces.  Instead we output the
3010      procedure namespace.  The will contain the formal arguments.  */
3011   if (iomode == IO_OUTPUT)
3012     {
3013       formal = sym->formal;
3014       while (formal && !formal->sym)
3015         formal = formal->next;
3016
3017       if (formal)
3018         mio_namespace_ref (&formal->sym->ns);
3019       else
3020         mio_namespace_ref (&sym->formal_ns);
3021     }
3022   else
3023     {
3024       mio_namespace_ref (&sym->formal_ns);
3025       if (sym->formal_ns)
3026         {
3027           sym->formal_ns->proc_name = sym;
3028           sym->refs++;
3029         }
3030     }
3031
3032   /* Save/restore common block links.  */
3033   mio_symbol_ref (&sym->common_next);
3034
3035   mio_formal_arglist (sym);
3036
3037   if (sym->attr.flavor == FL_PARAMETER)
3038     mio_expr (&sym->value);
3039
3040   mio_array_spec (&sym->as);
3041
3042   mio_symbol_ref (&sym->result);
3043
3044   if (sym->attr.cray_pointee)
3045     mio_symbol_ref (&sym->cp_pointer);
3046
3047   /* Note that components are always saved, even if they are supposed
3048      to be private.  Component access is checked during searching.  */
3049
3050   mio_component_list (&sym->components);
3051
3052   if (sym->components != NULL)
3053     sym->component_access
3054       = MIO_NAME (gfc_access) (sym->component_access, access_types);
3055
3056   mio_namelist (sym);
3057
3058   /* Add the fields that say whether this is from an intrinsic module,
3059      and if so, what symbol it is within the module.  */
3060 /*   mio_integer (&(sym->from_intmod)); */
3061   if (iomode == IO_OUTPUT)
3062     {
3063       intmod = sym->from_intmod;
3064       mio_integer (&intmod);
3065     }
3066   else
3067     {
3068       mio_integer (&intmod);
3069       sym->from_intmod = intmod;
3070     }
3071
3072   mio_integer (&(sym->intmod_sym_id));
3073
3074   mio_rparen ();
3075 }
3076
3077
3078 /************************* Top level subroutines *************************/
3079
3080 /* Skip a list between balanced left and right parens.  */
3081
3082 static void
3083 skip_list (void)
3084 {
3085   int level;
3086
3087   level = 0;
3088   do
3089     {
3090       switch (parse_atom ())
3091         {
3092         case ATOM_LPAREN:
3093           level++;
3094           break;
3095
3096         case ATOM_RPAREN:
3097           level--;
3098           break;
3099
3100         case ATOM_STRING:
3101           gfc_free (atom_string);
3102           break;
3103
3104         case ATOM_NAME:
3105         case ATOM_INTEGER:
3106           break;
3107         }
3108     }
3109   while (level > 0);
3110 }
3111
3112
3113 /* Load operator interfaces from the module.  Interfaces are unusual
3114    in that they attach themselves to existing symbols.  */
3115
3116 static void
3117 load_operator_interfaces (void)
3118 {
3119   const char *p;
3120   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3121   gfc_user_op *uop;
3122
3123   mio_lparen ();
3124
3125   while (peek_atom () != ATOM_RPAREN)
3126     {
3127       mio_lparen ();
3128
3129       mio_internal_string (name);
3130       mio_internal_string (module);
3131
3132       /* Decide if we need to load this one or not.  */
3133       p = find_use_name (name);
3134       if (p == NULL)
3135         {
3136           while (parse_atom () != ATOM_RPAREN);
3137         }
3138       else
3139         {
3140           uop = gfc_get_uop (p);
3141           mio_interface_rest (&uop->operator);
3142         }
3143     }
3144
3145   mio_rparen ();
3146 }
3147
3148
3149 /* Load interfaces from the module.  Interfaces are unusual in that
3150    they attach themselves to existing symbols.  */
3151
3152 static void
3153 load_generic_interfaces (void)
3154 {
3155   const char *p;
3156   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3157   gfc_symbol *sym;
3158   gfc_interface *generic = NULL;
3159   int n, i;
3160
3161   mio_lparen ();
3162
3163   while (peek_atom () != ATOM_RPAREN)
3164     {
3165       mio_lparen ();
3166
3167       mio_internal_string (name);
3168       mio_internal_string (module);
3169
3170       n = number_use_names (name);
3171       n = n ? n : 1;
3172
3173       for (i = 1; i <= n; i++)
3174         {
3175           /* Decide if we need to load this one or not.  */
3176           p = find_use_name_n (name, &i);
3177
3178           if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3179             {
3180               while (parse_atom () != ATOM_RPAREN);
3181                 continue;
3182             }
3183
3184           if (sym == NULL)
3185             {
3186               gfc_get_symbol (p, NULL, &sym);
3187
3188               sym->attr.flavor = FL_PROCEDURE;
3189               sym->attr.generic = 1;
3190               sym->attr.use_assoc = 1;
3191             }
3192           else
3193             {
3194               /* Unless sym is a generic interface, this reference
3195                  is ambiguous.  */
3196               gfc_symtree *st;
3197               p = p ? p : name;
3198               st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3199               if (!sym->attr.generic
3200                   && sym->module != NULL
3201                   && strcmp(module, sym->module) != 0)
3202                 st->ambiguous = 1;
3203             }
3204           if (i == 1)
3205             {
3206               mio_interface_rest (&sym->generic);
3207               generic = sym->generic;
3208             }
3209           else
3210             {
3211               sym->generic = generic;
3212               sym->attr.generic_copy = 1;
3213             }
3214         }
3215     }
3216
3217   mio_rparen ();
3218 }
3219
3220
3221 /* Load common blocks.  */
3222
3223 static void
3224 load_commons (void)
3225 {
3226   char name[GFC_MAX_SYMBOL_LEN + 1];
3227   gfc_common_head *p;
3228
3229   mio_lparen ();
3230
3231   while (peek_atom () != ATOM_RPAREN)
3232     {
3233       int flags;
3234       mio_lparen ();
3235       mio_internal_string (name);
3236
3237       p = gfc_get_common (name, 1);
3238
3239       mio_symbol_ref (&p->head);
3240       mio_integer (&flags);
3241       if (flags & 1)
3242         p->saved = 1;
3243       if (flags & 2)
3244         p->threadprivate = 1;
3245       p->use_assoc = 1;
3246
3247       /* Get whether this was a bind(c) common or not.  */
3248       mio_integer (&p->is_bind_c);
3249       /* Get the binding label.  */
3250       mio_internal_string (p->binding_label);
3251
3252       mio_rparen ();
3253     }
3254
3255   mio_rparen ();
3256 }
3257
3258
3259 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
3260    so that unused variables are not loaded and so that the expression can
3261    be safely freed.  */
3262
3263 static void
3264 load_equiv (void)
3265 {
3266   gfc_equiv *head, *tail, *end, *eq;
3267   bool unused;
3268
3269   mio_lparen ();
3270   in_load_equiv = true;
3271
3272   end = gfc_current_ns->equiv;
3273   while (end != NULL && end->next != NULL)
3274     end = end->next;
3275
3276   while (peek_atom () != ATOM_RPAREN) {
3277     mio_lparen ();
3278     head = tail = NULL;
3279
3280     while(peek_atom () != ATOM_RPAREN)
3281       {
3282         if (head == NULL)
3283           head = tail = gfc_get_equiv ();
3284         else
3285           {
3286             tail->eq = gfc_get_equiv ();
3287             tail = tail->eq;
3288           }
3289
3290         mio_pool_string (&tail->module);
3291         mio_expr (&tail->expr);
3292       }
3293
3294     /* Unused equivalence members have a unique name.  */
3295     unused = true;
3296     for (eq = head; eq; eq = eq->eq)
3297       {
3298         if (!check_unique_name (eq->expr->symtree->name))
3299           {
3300             unused = false;
3301             break;
3302           }
3303       }
3304
3305     if (unused)
3306       {
3307         for (eq = head; eq; eq = head)
3308           {
3309             head = eq->eq;
3310             gfc_free_expr (eq->expr);
3311             gfc_free (eq);
3312           }
3313       }
3314
3315     if (end == NULL)
3316       gfc_current_ns->equiv = head;
3317     else
3318       end->next = head;
3319
3320     if (head != NULL)
3321       end = head;
3322
3323     mio_rparen ();
3324   }
3325
3326   mio_rparen ();
3327   in_load_equiv = false;
3328 }
3329
3330
3331 /* Recursive function to traverse the pointer_info tree and load a
3332    needed symbol.  We return nonzero if we load a symbol and stop the
3333    traversal, because the act of loading can alter the tree.  */
3334
3335 static int
3336 load_needed (pointer_info *p)
3337 {
3338   gfc_namespace *ns;
3339   pointer_info *q;
3340   gfc_symbol *sym;
3341   int rv;
3342
3343   rv = 0;
3344   if (p == NULL)
3345     return rv;
3346
3347   rv |= load_needed (p->left);
3348   rv |= load_needed (p->right);
3349
3350   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3351     return rv;
3352
3353   p->u.rsym.state = USED;
3354
3355   set_module_locus (&p->u.rsym.where);
3356
3357   sym = p->u.rsym.sym;
3358   if (sym == NULL)
3359     {
3360       q = get_integer (p->u.rsym.ns);
3361
3362       ns = (gfc_namespace *) q->u.pointer;
3363       if (ns == NULL)
3364         {
3365           /* Create an interface namespace if necessary.  These are
3366              the namespaces that hold the formal parameters of module
3367              procedures.  */
3368
3369           ns = gfc_get_namespace (NULL, 0);
3370           associate_integer_pointer (q, ns);
3371         }
3372
3373       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3374       sym->module = gfc_get_string (p->u.rsym.module);
3375
3376       associate_integer_pointer (p, sym);
3377     }
3378
3379   mio_symbol (sym);
3380   sym->attr.use_assoc = 1;
3381   if (only_flag)
3382     sym->attr.use_only = 1;
3383
3384   return 1;
3385 }
3386
3387
3388 /* Recursive function for cleaning up things after a module has been read.  */
3389
3390 static void
3391 read_cleanup (pointer_info *p)
3392 {
3393   gfc_symtree *st;
3394   pointer_info *q;
3395
3396   if (p == NULL)
3397     return;
3398
3399   read_cleanup (p->left);
3400   read_cleanup (p->right);
3401
3402   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3403     {
3404       /* Add hidden symbols to the symtree.  */
3405       q = get_integer (p->u.rsym.ns);
3406       st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
3407
3408       st->n.sym = p->u.rsym.sym;
3409       st->n.sym->refs++;
3410
3411       /* Fixup any symtree references.  */
3412       p->u.rsym.symtree = st;
3413       resolve_fixups (p->u.rsym.stfixup, st);
3414       p->u.rsym.stfixup = NULL;
3415     }
3416
3417   /* Free unused symbols.  */
3418   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3419     gfc_free_symbol (p->u.rsym.sym);
3420 }
3421
3422
3423 /* Given a root symtree node and a symbol, try to find a symtree that
3424    references the symbol that is not a unique name.  */
3425
3426 static gfc_symtree *
3427 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3428 {
3429   gfc_symtree *s = NULL;
3430
3431   if (st == NULL)
3432     return s;
3433
3434   s = find_symtree_for_symbol (st->right, sym);
3435   if (s != NULL)
3436     return s;
3437   s = find_symtree_for_symbol (st->left, sym);
3438   if (s != NULL)
3439     return s;
3440
3441   if (st->n.sym == sym && !check_unique_name (st->name))
3442     return st;
3443
3444   return s;
3445 }
3446
3447
3448 /* Read a module file.  */
3449
3450 static void
3451 read_module (void)
3452 {
3453   module_locus operator_interfaces, user_operators;
3454   const char *p;
3455   char name[GFC_MAX_SYMBOL_LEN + 1];
3456   gfc_intrinsic_op i;
3457   int ambiguous, j, nuse, symbol;
3458   pointer_info *info, *q;
3459   gfc_use_rename *u;
3460   gfc_symtree *st;
3461   gfc_symbol *sym;
3462
3463   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
3464   skip_list ();
3465
3466   get_module_locus (&user_operators);
3467   skip_list ();
3468   skip_list ();
3469
3470   /* Skip commons and equivalences for now.  */
3471   skip_list ();
3472   skip_list ();
3473
3474   mio_lparen ();
3475
3476   /* Create the fixup nodes for all the symbols.  */
3477
3478   while (peek_atom () != ATOM_RPAREN)
3479     {
3480       require_atom (ATOM_INTEGER);
3481       info = get_integer (atom_int);
3482
3483       info->type = P_SYMBOL;
3484       info->u.rsym.state = UNUSED;
3485
3486       mio_internal_string (info->u.rsym.true_name);
3487       mio_internal_string (info->u.rsym.module);
3488       mio_internal_string (info->u.rsym.binding_label);
3489
3490
3491       require_atom (ATOM_INTEGER);
3492       info->u.rsym.ns = atom_int;
3493
3494       get_module_locus (&info->u.rsym.where);
3495       skip_list ();
3496
3497       /* See if the symbol has already been loaded by a previous module.
3498          If so, we reference the existing symbol and prevent it from
3499          being loaded again.  This should not happen if the symbol being
3500          read is an index for an assumed shape dummy array (ns != 1).  */
3501
3502       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3503
3504       if (sym == NULL
3505           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3506         continue;
3507
3508       info->u.rsym.state = USED;
3509       info->u.rsym.sym = sym;
3510
3511       /* Some symbols do not have a namespace (eg. formal arguments),
3512          so the automatic "unique symtree" mechanism must be suppressed
3513          by marking them as referenced.  */
3514       q = get_integer (info->u.rsym.ns);
3515       if (q->u.pointer == NULL)
3516         {
3517           info->u.rsym.referenced = 1;
3518           continue;
3519         }
3520
3521       /* If possible recycle the symtree that references the symbol.
3522          If a symtree is not found and the module does not import one,
3523          a unique-name symtree is found by read_cleanup.  */
3524       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3525       if (st != NULL)
3526         {
3527           info->u.rsym.symtree = st;
3528           info->u.rsym.referenced = 1;
3529         }
3530     }
3531
3532   mio_rparen ();
3533
3534   /* Parse the symtree lists.  This lets us mark which symbols need to
3535      be loaded.  Renaming is also done at this point by replacing the
3536      symtree name.  */
3537
3538   mio_lparen ();
3539
3540   while (peek_atom () != ATOM_RPAREN)
3541     {
3542       mio_internal_string (name);
3543       mio_integer (&ambiguous);
3544       mio_integer (&symbol);
3545
3546       info = get_integer (symbol);
3547
3548       /* See how many use names there are.  If none, go through the start
3549          of the loop at least once.  */
3550       nuse = number_use_names (name);
3551       if (nuse == 0)
3552         nuse = 1;
3553
3554       for (j = 1; j <= nuse; j++)
3555         {
3556           /* Get the jth local name for this symbol.  */
3557           p = find_use_name_n (name, &j);
3558
3559           if (p == NULL && strcmp (name, module_name) == 0)
3560             p = name;
3561
3562           /* Skip symtree nodes not in an ONLY clause, unless there
3563              is an existing symtree loaded from another USE statement.  */
3564           if (p == NULL)
3565             {
3566               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3567               if (st != NULL)
3568                 info->u.rsym.symtree = st;
3569               continue;
3570             }
3571
3572           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3573
3574           if (st != NULL)
3575             {
3576               /* Check for ambiguous symbols.  */
3577               if (st->n.sym != info->u.rsym.sym)
3578                 st->ambiguous = 1;
3579               info->u.rsym.symtree = st;
3580             }
3581           else
3582             {
3583               /* Create a symtree node in the current namespace for this
3584                  symbol.  */
3585               st = check_unique_name (p)
3586                    ? get_unique_symtree (gfc_current_ns)
3587                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3588
3589               st->ambiguous = ambiguous;
3590
3591               sym = info->u.rsym.sym;
3592
3593               /* Create a symbol node if it doesn't already exist.  */
3594               if (sym == NULL)
3595                 {
3596                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3597                                                      gfc_current_ns);
3598                   sym = info->u.rsym.sym;
3599                   sym->module = gfc_get_string (info->u.rsym.module);
3600
3601                   /* TODO: hmm, can we test this?  Do we know it will be
3602                      initialized to zeros?  */
3603                   if (info->u.rsym.binding_label[0] != '\0')
3604                     strcpy (sym->binding_label, info->u.rsym.binding_label);
3605                 }
3606
3607               st->n.sym = sym;
3608               st->n.sym->refs++;
3609
3610               /* Store the symtree pointing to this symbol.  */
3611               info->u.rsym.symtree = st;
3612
3613               if (info->u.rsym.state == UNUSED)
3614                 info->u.rsym.state = NEEDED;
3615               info->u.rsym.referenced = 1;
3616             }
3617         }
3618     }
3619
3620   mio_rparen ();
3621
3622   /* Load intrinsic operator interfaces.  */
3623   set_module_locus (&operator_interfaces);
3624   mio_lparen ();
3625
3626   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3627     {
3628       if (i == INTRINSIC_USER)
3629         continue;
3630
3631       if (only_flag)
3632         {
3633           u = find_use_operator (i);
3634
3635           if (u == NULL)
3636             {
3637               skip_list ();
3638               continue;
3639             }
3640
3641           u->found = 1;
3642         }
3643
3644       mio_interface (&gfc_current_ns->operator[i]);
3645     }
3646
3647   mio_rparen ();
3648
3649   /* Load generic and user operator interfaces.  These must follow the
3650      loading of symtree because otherwise symbols can be marked as
3651      ambiguous.  */
3652
3653   set_module_locus (&user_operators);
3654
3655   load_operator_interfaces ();
3656   load_generic_interfaces ();
3657
3658   load_commons ();
3659   load_equiv ();
3660
3661   /* At this point, we read those symbols that are needed but haven't
3662      been loaded yet.  If one symbol requires another, the other gets
3663      marked as NEEDED if its previous state was UNUSED.  */
3664
3665   while (load_needed (pi_root));
3666
3667   /* Make sure all elements of the rename-list were found in the module.  */
3668
3669   for (u = gfc_rename_list; u; u = u->next)
3670     {
3671       if (u->found)
3672         continue;
3673
3674       if (u->operator == INTRINSIC_NONE)
3675         {
3676           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3677                      u->use_name, &u->where, module_name);
3678           continue;
3679         }
3680
3681       if (u->operator == INTRINSIC_USER)
3682         {
3683           gfc_error ("User operator '%s' referenced at %L not found "
3684                      "in module '%s'", u->use_name, &u->where, module_name);
3685           continue;
3686         }
3687
3688       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3689                  "in module '%s'", gfc_op2string (u->operator), &u->where,
3690                  module_name);
3691     }
3692
3693   gfc_check_interfaces (gfc_current_ns);
3694
3695   /* Clean up symbol nodes that were never loaded, create references
3696      to hidden symbols.  */
3697
3698   read_cleanup (pi_root);
3699 }
3700
3701
3702 /* Given an access type that is specific to an entity and the default
3703    access, return nonzero if the entity is publicly accessible.  If the
3704    element is declared as PUBLIC, then it is public; if declared
3705    PRIVATE, then private, and otherwise it is public unless the default
3706    access in this context has been declared PRIVATE.  */
3707
3708 bool
3709 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3710 {
3711   if (specific_access == ACCESS_PUBLIC)
3712     return TRUE;
3713   if (specific_access == ACCESS_PRIVATE)
3714     return FALSE;
3715
3716   return default_access != ACCESS_PRIVATE;
3717 }
3718
3719
3720 /* Write a common block to the module.  */
3721
3722 static void
3723 write_common (gfc_symtree *st)
3724 {
3725   gfc_common_head *p;
3726   const char * name;
3727   int flags;
3728   const char *label;
3729
3730   if (st == NULL)
3731     return;
3732
3733   write_common (st->left);
3734   write_common (st->right);
3735
3736   mio_lparen ();
3737
3738   /* Write the unmangled name.  */
3739   name = st->n.common->name;
3740
3741   mio_pool_string (&name);
3742
3743   p = st->n.common;
3744   mio_symbol_ref (&p->head);
3745   flags = p->saved ? 1 : 0;
3746   if (p->threadprivate) flags |= 2;
3747   mio_integer (&flags);
3748
3749   /* Write out whether the common block is bind(c) or not.  */
3750   mio_integer (&(p->is_bind_c));
3751
3752   /* Write out the binding label, or the com name if no label given.  */
3753   if (p->is_bind_c)
3754     {
3755       label = p->binding_label;
3756       mio_pool_string (&label);
3757     }
3758   else
3759     {
3760       label = p->name;
3761       mio_pool_string (&label);
3762     }
3763
3764   mio_rparen ();
3765 }
3766
3767
3768 /* Write the blank common block to the module.  */
3769
3770 static void
3771 write_blank_common (void)
3772 {
3773   const char * name = BLANK_COMMON_NAME;
3774   int saved;
3775   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
3776      this, but it hasn't been checked.  Just making it so for now.  */
3777   int is_bind_c = 0;
3778
3779   if (gfc_current_ns->blank_common.head == NULL)
3780     return;
3781
3782   mio_lparen ();
3783
3784   mio_pool_string (&name);
3785
3786   mio_symbol_ref (&gfc_current_ns->blank_common.head);
3787   saved = gfc_current_ns->blank_common.saved;
3788   mio_integer (&saved);
3789
3790   /* Write out whether the common block is bind(c) or not.  */
3791   mio_integer (&is_bind_c);
3792
3793   /* Write out the binding label, which is BLANK_COMMON_NAME, though
3794      it doesn't matter because the label isn't used.  */
3795   mio_pool_string (&name);
3796
3797   mio_rparen ();
3798 }
3799
3800
3801 /* Write equivalences to the module.  */
3802
3803 static void
3804 write_equiv (void)
3805 {
3806   gfc_equiv *eq, *e;
3807   int num;
3808
3809   num = 0;
3810   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
3811     {
3812       mio_lparen ();
3813
3814       for (e = eq; e; e = e->eq)
3815         {
3816           if (e->module == NULL)
3817             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3818           mio_allocated_string (e->module);
3819           mio_expr (&e->expr);
3820         }
3821
3822       num++;
3823       mio_rparen ();
3824     }
3825 }
3826
3827
3828 /* Write a symbol to the module.  */
3829
3830 static void
3831 write_symbol (int n, gfc_symbol *sym)
3832 {
3833    const char *label;
3834
3835   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3836     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3837
3838   mio_integer (&n);
3839   mio_pool_string (&sym->name);
3840
3841   mio_pool_string (&sym->module);
3842   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
3843     {
3844       label = sym->binding_label;
3845       mio_pool_string (&label);
3846     }
3847   else
3848     mio_pool_string (&sym->name);
3849
3850   mio_pointer_ref (&sym->ns);
3851
3852   mio_symbol (sym);
3853   write_char ('\n');
3854 }
3855
3856
3857 /* Recursive traversal function to write the initial set of symbols to
3858    the module.  We check to see if the symbol should be written
3859    according to the access specification.  */
3860
3861 static void
3862 write_symbol0 (gfc_symtree *st)
3863 {
3864   gfc_symbol *sym;
3865   pointer_info *p;
3866
3867   if (st == NULL)
3868     return;
3869
3870   write_symbol0 (st->left);
3871   write_symbol0 (st->right);
3872
3873   sym = st->n.sym;
3874   if (sym->module == NULL)
3875     sym->module = gfc_get_string (module_name);
3876
3877   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3878       && !sym->attr.subroutine && !sym->attr.function)
3879     return;
3880
3881   if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3882     return;
3883
3884   p = get_pointer (sym);
3885   if (p->type == P_UNKNOWN)
3886     p->type = P_SYMBOL;
3887
3888   if (p->u.wsym.state == WRITTEN)
3889     return;
3890
3891   write_symbol (p->integer, sym);
3892   p->u.wsym.state = WRITTEN;
3893 }
3894
3895
3896 /* Recursive traversal function to write the secondary set of symbols
3897    to the module file.  These are symbols that were not public yet are
3898    needed by the public symbols or another dependent symbol.  The act
3899    of writing a symbol can modify the pointer_info tree, so we cease
3900    traversal if we find a symbol to write.  We return nonzero if a
3901    symbol was written and pass that information upwards.  */
3902
3903 static int
3904 write_symbol1 (pointer_info *p)
3905 {
3906
3907   if (p == NULL)
3908     return 0;
3909
3910   if (write_symbol1 (p->left))
3911     return 1;
3912   if (write_symbol1 (p->right))
3913     return 1;
3914
3915   if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3916     return 0;
3917
3918   p->u.wsym.state = WRITTEN;
3919   write_symbol (p->integer, p->u.wsym.sym);
3920
3921   return 1;
3922 }
3923
3924
3925 /* Write operator interfaces associated with a symbol.  */
3926
3927 static void
3928 write_operator (gfc_user_op *uop)
3929 {
3930   static char nullstring[] = "";
3931   const char *p = nullstring;
3932
3933   if (uop->operator == NULL
3934       || !gfc_check_access (uop->access, uop->ns->default_access))
3935     return;
3936
3937   mio_symbol_interface (&uop->name, &p, &uop->operator);
3938 }
3939
3940
3941 /* Write generic interfaces associated with a symbol.  */
3942
3943 static void
3944 write_generic (gfc_symbol *sym)
3945 {
3946   if (sym->generic == NULL
3947       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3948     return;
3949
3950   if (sym->module == NULL)
3951     sym->module = gfc_get_string (module_name);
3952
3953   mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3954 }
3955
3956
3957 static void
3958 write_symtree (gfc_symtree *st)
3959 {
3960   gfc_symbol *sym;
3961   pointer_info *p;
3962
3963   sym = st->n.sym;
3964   if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
3965       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3966           && !sym->attr.subroutine && !sym->attr.function))
3967     return;
3968
3969   if (check_unique_name (st->name))
3970     return;
3971
3972   p = find_pointer (sym);
3973   if (p == NULL)
3974     gfc_internal_error ("write_symtree(): Symbol not written");
3975
3976   mio_pool_string (&st->name);
3977   mio_integer (&st->ambiguous);
3978   mio_integer (&p->integer);
3979 }
3980
3981
3982 static void
3983 write_module (void)
3984 {
3985   gfc_intrinsic_op i;
3986
3987   /* Write the operator interfaces.  */
3988   mio_lparen ();
3989
3990   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3991     {
3992       if (i == INTRINSIC_USER)
3993         continue;
3994
3995       mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
3996                                        gfc_current_ns->default_access)
3997                      ? &gfc_current_ns->operator[i] : NULL);
3998     }
3999
4000   mio_rparen ();
4001   write_char ('\n');
4002   write_char ('\n');
4003
4004   mio_lparen ();
4005   gfc_traverse_user_op (gfc_current_ns, write_operator);
4006   mio_rparen ();
4007   write_char ('\n');
4008   write_char ('\n');
4009
4010   mio_lparen ();
4011   gfc_traverse_ns (gfc_current_ns, write_generic);
4012   mio_rparen ();
4013   write_char ('\n');
4014   write_char ('\n');
4015
4016   mio_lparen ();
4017   write_blank_common ();
4018   write_common (gfc_current_ns->common_root);
4019   mio_rparen ();
4020   write_char ('\n');
4021   write_char ('\n');
4022
4023   mio_lparen ();
4024   write_equiv ();
4025   mio_rparen ();
4026   write_char ('\n');
4027   write_char ('\n');
4028
4029   /* Write symbol information.  First we traverse all symbols in the
4030      primary namespace, writing those that need to be written.
4031      Sometimes writing one symbol will cause another to need to be
4032      written.  A list of these symbols ends up on the write stack, and
4033      we end by popping the bottom of the stack and writing the symbol
4034      until the stack is empty.  */
4035
4036   mio_lparen ();
4037
4038   write_symbol0 (gfc_current_ns->sym_root);
4039   while (write_symbol1 (pi_root));
4040
4041   mio_rparen ();
4042
4043   write_char ('\n');
4044   write_char ('\n');
4045
4046   mio_lparen ();
4047   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4048   mio_rparen ();
4049 }
4050
4051
4052 /* Read a MD5 sum from the header of a module file.  If the file cannot
4053    be opened, or we have any other error, we return -1.  */
4054
4055 static int
4056 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4057 {
4058   FILE *file;
4059   char buf[1024];
4060   int n;
4061
4062   /* Open the file.  */
4063   if ((file = fopen (filename, "r")) == NULL)
4064     return -1;
4065
4066   /* Read two lines.  */
4067   if (fgets (buf, sizeof (buf) - 1, file) == NULL
4068       || fgets (buf, sizeof (buf) - 1, file) == NULL)
4069     {
4070       fclose (file);
4071       return -1;
4072     }
4073
4074   /* Close the file.  */
4075   fclose (file);
4076
4077   /* If the header is not what we expect, or is too short, bail out.  */
4078   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4079     return -1;
4080
4081   /* Now, we have a real MD5, read it into the array.  */
4082   for (n = 0; n < 16; n++)
4083     {
4084       unsigned int x;
4085
4086       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4087        return -1;
4088
4089       md5[n] = x;
4090     }
4091
4092   return 0;
4093 }
4094
4095
4096 /* Given module, dump it to disk.  If there was an error while
4097    processing the module, dump_flag will be set to zero and we delete
4098    the module file, even if it was already there.  */
4099
4100 void
4101 gfc_dump_module (const char *name, int dump_flag)
4102 {
4103   int n;
4104   char *filename, *filename_tmp, *p;
4105   time_t now;
4106   fpos_t md5_pos;
4107   unsigned char md5_new[16], md5_old[16];
4108
4109   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4110   if (gfc_option.module_dir != NULL)
4111     {
4112       n += strlen (gfc_option.module_dir);
4113       filename = (char *) alloca (n);
4114       strcpy (filename, gfc_option.module_dir);
4115       strcat (filename, name);
4116     }
4117   else
4118     {
4119       filename = (char *) alloca (n);
4120       strcpy (filename, name);
4121     }
4122   strcat (filename, MODULE_EXTENSION);
4123
4124   /* Name of the temporary file used to write the module.  */
4125   filename_tmp = (char *) alloca (n + 1);
4126   strcpy (filename_tmp, filename);
4127   strcat (filename_tmp, "0");
4128
4129   /* There was an error while processing the module.  We delete the
4130      module file, even if it was already there.  */
4131   if (!dump_flag)
4132     {
4133       unlink (filename);
4134       return;
4135     }
4136
4137   /* Write the module to the temporary file.  */
4138   module_fp = fopen (filename_tmp, "w");
4139   if (module_fp == NULL)
4140     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4141                      filename_tmp, strerror (errno));
4142
4143   /* Write the header, including space reserved for the MD5 sum.  */
4144   now = time (NULL);
4145   p = ctime (&now);
4146
4147   *strchr (p, '\n') = '\0';
4148
4149   fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4150            gfc_source_file, p);
4151   fgetpos (module_fp, &md5_pos);
4152   fputs ("00000000000000000000000000000000 -- "
4153         "If you edit this, you'll get what you deserve.\n\n", module_fp);
4154
4155   /* Initialize the MD5 context that will be used for output.  */
4156   md5_init_ctx (&ctx);
4157
4158   /* Write the module itself.  */
4159   iomode = IO_OUTPUT;
4160   strcpy (module_name, name);
4161
4162   init_pi_tree ();
4163
4164   write_module ();
4165
4166   free_pi_tree (pi_root);
4167   pi_root = NULL;
4168
4169   write_char ('\n');
4170
4171   /* Write the MD5 sum to the header of the module file.  */
4172   md5_finish_ctx (&ctx, md5_new);
4173   fsetpos (module_fp, &md5_pos);
4174   for (n = 0; n < 16; n++)
4175     fprintf (module_fp, "%02x", md5_new[n]);
4176
4177   if (fclose (module_fp))
4178     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4179                      filename_tmp, strerror (errno));
4180
4181   /* Read the MD5 from the header of the old module file and compare.  */
4182   if (read_md5_from_module_file (filename, md5_old) != 0
4183       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4184     {
4185       /* Module file have changed, replace the old one.  */
4186       unlink (filename);
4187       rename (filename_tmp, filename);
4188     }
4189   else
4190     unlink (filename_tmp);
4191 }
4192
4193
4194 static void
4195 sort_iso_c_rename_list (void)
4196 {
4197   gfc_use_rename *tmp_list = NULL;
4198   gfc_use_rename *curr;
4199   gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4200   int c_kind;
4201   int i;
4202
4203   for (curr = gfc_rename_list; curr; curr = curr->next)
4204     {
4205       c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4206       if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4207         {
4208           gfc_error ("Symbol '%s' referenced at %L does not exist in "
4209                      "intrinsic module ISO_C_BINDING.", curr->use_name,
4210                      &curr->where);
4211         }
4212       else
4213         /* Put it in the list.  */
4214         kinds_used[c_kind] = curr;
4215     }
4216
4217   /* Make a new (sorted) rename list.  */
4218   i = 0;
4219   while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4220     i++;
4221
4222   if (i < ISOCBINDING_NUMBER)
4223     {
4224       tmp_list = kinds_used[i];
4225
4226       i++;
4227       curr = tmp_list;
4228       for (; i < ISOCBINDING_NUMBER; i++)
4229         if (kinds_used[i] != NULL)
4230           {
4231             curr->next = kinds_used[i];
4232             curr = curr->next;
4233             curr->next = NULL;
4234           }
4235     }
4236
4237   gfc_rename_list = tmp_list;
4238 }
4239
4240
4241 /* Import the instrinsic ISO_C_BINDING module, generating symbols in
4242    the current namespace for all named constants, pointer types, and
4243    procedures in the module unless the only clause was used or a rename
4244    list was provided.  */
4245
4246 static void
4247 import_iso_c_binding_module (void)
4248 {
4249   gfc_symbol *mod_sym = NULL;
4250   gfc_symtree *mod_symtree = NULL;
4251   const char *iso_c_module_name = "__iso_c_binding";
4252   gfc_use_rename *u;
4253   int i;
4254   char *local_name;
4255
4256   /* Look only in the current namespace.  */
4257   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4258
4259   if (mod_symtree == NULL)
4260     {
4261       /* symtree doesn't already exist in current namespace.  */
4262       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4263
4264       if (mod_symtree != NULL)
4265         mod_sym = mod_symtree->n.sym;
4266       else
4267         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4268                             "create symbol for %s", iso_c_module_name);
4269
4270       mod_sym->attr.flavor = FL_MODULE;
4271       mod_sym->attr.intrinsic = 1;
4272       mod_sym->module = gfc_get_string (iso_c_module_name);
4273       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4274     }
4275
4276   /* Generate the symbols for the named constants representing
4277      the kinds for intrinsic data types.  */
4278   if (only_flag)
4279     {
4280       /* Sort the rename list because there are dependencies between types
4281          and procedures (e.g., c_loc needs c_ptr).  */
4282       sort_iso_c_rename_list ();
4283
4284       for (u = gfc_rename_list; u; u = u->next)
4285         {
4286           i = get_c_kind (u->use_name, c_interop_kinds_table);
4287
4288           if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4289             {
4290               gfc_error ("Symbol '%s' referenced at %L does not exist in "
4291                          "intrinsic module ISO_C_BINDING.", u->use_name,
4292                          &u->where);
4293               continue;
4294             }
4295
4296           generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4297         }
4298     }
4299   else
4300     {
4301       for (i = 0; i < ISOCBINDING_NUMBER; i++)
4302         {
4303           local_name = NULL;
4304           for (u = gfc_rename_list; u; u = u->next)
4305             {
4306               if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4307                 {
4308                   local_name = u->local_name;
4309                   u->found = 1;
4310                   break;
4311                 }
4312             }
4313           generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4314         }
4315
4316       for (u = gfc_rename_list; u; u = u->next)
4317         {
4318           if (u->found)
4319             continue;
4320
4321           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4322                      "module ISO_C_BINDING", u->use_name, &u->where);
4323         }
4324     }
4325 }
4326
4327
4328 /* Add an integer named constant from a given module.  */
4329
4330 static void
4331 create_int_parameter (const char *name, int value, const char *modname,
4332                       intmod_id module, int id)
4333 {
4334   gfc_symtree *tmp_symtree;
4335   gfc_symbol *sym;
4336
4337   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4338   if (tmp_symtree != NULL)
4339     {
4340       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4341         return;
4342       else
4343         gfc_error ("Symbol '%s' already declared", name);
4344     }
4345
4346   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4347   sym = tmp_symtree->n.sym;
4348
4349   sym->module = gfc_get_string (modname);
4350   sym->attr.flavor = FL_PARAMETER;
4351   sym->ts.type = BT_INTEGER;
4352   sym->ts.kind = gfc_default_integer_kind;
4353   sym->value = gfc_int_expr (value);
4354   sym->attr.use_assoc = 1;
4355   sym->from_intmod = module;
4356   sym->intmod_sym_id = id;
4357 }
4358
4359
4360 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
4361
4362 static void
4363 use_iso_fortran_env_module (void)
4364 {
4365   static char mod[] = "iso_fortran_env";
4366   const char *local_name;
4367   gfc_use_rename *u;
4368   gfc_symbol *mod_sym;
4369   gfc_symtree *mod_symtree;
4370   int i;
4371
4372   intmod_sym symbol[] = {
4373 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4374 #include "iso-fortran-env.def"
4375 #undef NAMED_INTCST
4376     { ISOFORTRANENV_INVALID, NULL, -1234 } };
4377
4378   i = 0;
4379 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4380 #include "iso-fortran-env.def"
4381 #undef NAMED_INTCST
4382
4383   /* Generate the symbol for the module itself.  */
4384   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4385   if (mod_symtree == NULL)
4386     {
4387       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4388       gcc_assert (mod_symtree);
4389       mod_sym = mod_symtree->n.sym;
4390
4391       mod_sym->attr.flavor = FL_MODULE;
4392       mod_sym->attr.intrinsic = 1;
4393       mod_sym->module = gfc_get_string (mod);
4394       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4395     }
4396   else
4397     if (!mod_symtree->n.sym->attr.intrinsic)
4398       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4399                  "non-intrinsic module name used previously", mod);
4400
4401   /* Generate the symbols for the module integer named constants.  */
4402   if (only_flag)
4403     for (u = gfc_rename_list; u; u = u->next)
4404       {
4405         for (i = 0; symbol[i].name; i++)
4406           if (strcmp (symbol[i].name, u->use_name) == 0)
4407             break;
4408
4409         if (symbol[i].name == NULL)
4410           {
4411             gfc_error ("Symbol '%s' referenced at %L does not exist in "
4412                        "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4413                        &u->where);
4414             continue;
4415           }
4416
4417         if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4418             && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4419           gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4420                            "from intrinsic module ISO_FORTRAN_ENV at %L is "
4421                            "incompatible with option %s", &u->where,
4422                            gfc_option.flag_default_integer
4423                              ? "-fdefault-integer-8" : "-fdefault-real-8");
4424
4425         create_int_parameter (u->local_name[0] ? u->local_name
4426                                                : symbol[i].name,
4427                               symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4428                               symbol[i].id);
4429       }
4430   else
4431     {
4432       for (i = 0; symbol[i].name; i++)
4433         {
4434           local_name = NULL;
4435           for (u = gfc_rename_list; u; u = u->next)
4436             {
4437               if (strcmp (symbol[i].name, u->use_name) == 0)
4438                 {
4439                   local_name = u->local_name;
4440                   u->found = 1;
4441                   break;
4442                 }
4443             }
4444
4445           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4446               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4447             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4448                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
4449                              "incompatible with option %s",
4450                              gfc_option.flag_default_integer
4451                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
4452
4453           create_int_parameter (local_name ? local_name : symbol[i].name,
4454                                 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4455                                 symbol[i].id);
4456         }
4457
4458       for (u = gfc_rename_list; u; u = u->next)
4459         {
4460           if (u->found)
4461             continue;
4462
4463           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4464                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4465         }
4466     }
4467 }
4468
4469
4470 /* Process a USE directive.  */
4471
4472 void
4473 gfc_use_module (void)
4474 {
4475   char *filename;
4476   gfc_state_data *p;
4477   int c, line, start;
4478   gfc_symtree *mod_symtree;
4479
4480   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4481                               + 1);
4482   strcpy (filename, module_name);
4483   strcat (filename, MODULE_EXTENSION);
4484
4485   /* First, try to find an non-intrinsic module, unless the USE statement
4486      specified that the module is intrinsic.  */
4487   module_fp = NULL;
4488   if (!specified_int)
4489     module_fp = gfc_open_included_file (filename, true, true);
4490
4491   /* Then, see if it's an intrinsic one, unless the USE statement
4492      specified that the module is non-intrinsic.  */
4493   if (module_fp == NULL && !specified_nonint)
4494     {
4495       if (strcmp (module_name, "iso_fortran_env") == 0
4496           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4497                              "intrinsic module at %C") != FAILURE)
4498        {
4499          use_iso_fortran_env_module ();
4500          return;
4501        }
4502
4503       if (strcmp (module_name, "iso_c_binding") == 0
4504           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4505                              "ISO_C_BINDING module at %C") != FAILURE)
4506         {
4507           import_iso_c_binding_module();
4508           return;
4509         }
4510
4511       module_fp = gfc_open_intrinsic_module (filename);
4512
4513       if (module_fp == NULL && specified_int)
4514         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4515                          module_name);
4516     }
4517
4518   if (module_fp == NULL)
4519     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4520                      filename, strerror (errno));
4521
4522   /* Check that we haven't already USEd an intrinsic module with the
4523      same name.  */
4524
4525   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4526   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4527     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4528                "intrinsic module name used previously", module_name);
4529
4530   iomode = IO_INPUT;
4531   module_line = 1;
4532   module_column = 1;
4533   start = 0;
4534
4535   /* Skip the first two lines of the module, after checking that this is
4536      a gfortran module file.  */
4537   line = 0;
4538   while (line < 2)
4539     {
4540       c = module_char ();
4541       if (c == EOF)
4542         bad_module ("Unexpected end of module");
4543       if (start++ < 2)
4544         parse_name (c);
4545       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4546           || (start == 2 && strcmp (atom_name, " module") != 0))
4547         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4548                          "file", filename);
4549
4550       if (c == '\n')
4551         line++;
4552     }
4553
4554   /* Make sure we're not reading the same module that we may be building.  */
4555   for (p = gfc_state_stack; p; p = p->previous)
4556     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4557       gfc_fatal_error ("Can't USE the same module we're building!");
4558
4559   init_pi_tree ();
4560   init_true_name_tree ();
4561
4562   read_module ();
4563
4564   free_true_name (true_name_root);
4565   true_name_root = NULL;
4566
4567   free_pi_tree (pi_root);
4568   pi_root = NULL;
4569
4570   fclose (module_fp);
4571 }
4572
4573
4574 void
4575 gfc_module_init_2 (void)
4576 {
4577   last_atom = ATOM_LPAREN;
4578 }
4579
4580
4581 void
4582 gfc_module_done_2 (void)
4583 {
4584   free_rename ();
4585 }