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