gcc/fortran/module.c

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