gcc/fortran/module.c

   1 /* Handle modules, which amounts to loading and saving symbols and
   2    their attendant structures.
   3    Copyright (C) 2000-2014 Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
  23    sequence of atoms, which can be left or right parenthesis, names,
  24    integers or strings.  Parenthesis are always matched which allows
  25    us to skip over sections at high speed without having to know
  26    anything about the internal structure of the lists.  A "name" is
  27    usually a fortran 95 identifier, but can also start with '@' in
  28    order to reference a hidden symbol.
  29
  30    The first line of a module is an informational message about what
  31    created the module, the file it came from and when it was created.
  32    The second line is a warning for people not to edit the module.
  33    The rest of the module looks like:
  34
  35    ( ( <Interface info for UPLUS> )
  36      ( <Interface info for UMINUS> )
  37      ...
  38    )
  39    ( ( <name of operator interface> <module of op interface> <i/f1> ... )
  40      ...
  41    )
  42    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
  43      ...
  44    )
  45    ( ( <common name> <symbol> <saved flag>)
  46      ...
  47    )
  48
  49    ( equivalence list )
  50
  51    ( <Symbol Number (in no particular order)>
  52      <True name of symbol>
  53      <Module name of symbol>
  54      ( <symbol information> )
  55      ...
  56    )
  57    ( <Symtree name>
  58      <Ambiguous flag>
  59      <Symbol number>
  60      ...
  61    )
  62
  63    In general, symbols refer to other symbols by their symbol number,
  64    which are zero based.  Symbols are written to the module in no
  65    particular order.  */
  66
  67 #include "config.h"
  68 #include "system.h"
  69 #include "coretypes.h"
  70 #include "gfortran.h"
  71 #include "arith.h"
  72 #include "match.h"
  73 #include "parse.h" /* FIXME */
  74 #include "constructor.h"
  75 #include "cpp.h"
  76 #include "tree.h"
  77 #include "stringpool.h"
  78 #include "scanner.h"
  79 #include <zlib.h>
  80
  81 #define MODULE_EXTENSION ".mod"
  82
  83 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
  84    recognized.  */
  85 #define MOD_VERSION "13"
  86
  87
  88 /* Structure that describes a position within a module file.  */
  89
  90 typedef struct
  91 {
  92   int column, line;
  93   long pos;
  94 }
  95 module_locus;
  96
  97 /* Structure for list of symbols of intrinsic modules.  */
  98 typedef struct
  99 {
 100   int id;
 101   const char *name;
 102   int value;
 103   int standard;
 104 }
 105 intmod_sym;
 106
 107
 108 typedef enum
 109 {
 110   P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
 111 }
 112 pointer_t;
 113
 114 /* The fixup structure lists pointers to pointers that have to
 115    be updated when a pointer value becomes known.  */
 116
 117 typedef struct fixup_t
 118 {
 119   void **pointer;
 120   struct fixup_t *next;
 121 }
 122 fixup_t;
 123
 124
 125 /* Structure for holding extra info needed for pointers being read.  */
 126
 127 enum gfc_rsym_state
 128 {
 129   UNUSED,
 130   NEEDED,
 131   USED
 132 };
 133
 134 enum gfc_wsym_state
 135 {
 136   UNREFERENCED = 0,
 137   NEEDS_WRITE,
 138   WRITTEN
 139 };
 140
 141 typedef struct pointer_info
 142 {
 143   BBT_HEADER (pointer_info);
 144   int integer;
 145   pointer_t type;
 146
 147   /* The first component of each member of the union is the pointer
 148      being stored.  */
 149
 150   fixup_t *fixup;
 151
 152   union
 153   {
 154     void *pointer;      /* Member for doing pointer searches.  */
 155
 156     struct
 157     {
 158       gfc_symbol *sym;
 159       char *true_name, *module, *binding_label;
 160       fixup_t *stfixup;
 161       gfc_symtree *symtree;
 162       enum gfc_rsym_state state;
 163       int ns, referenced, renamed;
 164       module_locus where;
 165     }
 166     rsym;
 167
 168     struct
 169     {
 170       gfc_symbol *sym;
 171       enum gfc_wsym_state state;
 172     }
 173     wsym;
 174   }
 175   u;
 176
 177 }
 178 pointer_info;
 179
 180 #define gfc_get_pointer_info() XCNEW (pointer_info)
 181
 182
 183 /* Local variables */
 184
 185 /* The gzFile for the module we're reading or writing.  */
 186 static gzFile module_fp;
 187
 188
 189 /* The name of the module we're reading (USE'ing) or writing.  */
 190 static const char *module_name;
 191 static gfc_use_list *module_list;
 192
 193 /* If we're reading an intrinsic module, this is its ID.  */
 194 static intmod_id current_intmod;
 195
 196 /* Content of module.  */
 197 static char* module_content;
 198
 199 static long module_pos;
 200 static int module_line, module_column, only_flag;
 201 static int prev_module_line, prev_module_column;
 202
 203 static enum
 204 { IO_INPUT, IO_OUTPUT }
 205 iomode;
 206
 207 static gfc_use_rename *gfc_rename_list;
 208 static pointer_info *pi_root;
 209 static int symbol_number;       /* Counter for assigning symbol numbers */
 210
 211 /* Tells mio_expr_ref to make symbols for unused equivalence members.  */
 212 static bool in_load_equiv;
 213
 214
 215
 216 /*****************************************************************/
 217
 218 /* Pointer/integer conversion.  Pointers between structures are stored
 219    as integers in the module file.  The next couple of subroutines
 220    handle this translation for reading and writing.  */
 221
 222 /* Recursively free the tree of pointer structures.  */
 223
 224 static void
 225 free_pi_tree (pointer_info *p)
 226 {
 227   if (p == NULL)
 228     return;
 229
 230   if (p->fixup != NULL)
 231     gfc_internal_error ("free_pi_tree(): Unresolved fixup");
 232
 233   free_pi_tree (p->left);
 234   free_pi_tree (p->right);
 235
 236   if (iomode == IO_INPUT)
 237     {
 238       XDELETEVEC (p->u.rsym.true_name);
 239       XDELETEVEC (p->u.rsym.module);
 240       XDELETEVEC (p->u.rsym.binding_label);
 241     }
 242
 243   free (p);
 244 }
 245
 246
 247 /* Compare pointers when searching by pointer.  Used when writing a
 248    module.  */
 249
 250 static int
 251 compare_pointers (void *_sn1, void *_sn2)
 252 {
 253   pointer_info *sn1, *sn2;
 254
 255   sn1 = (pointer_info *) _sn1;
 256   sn2 = (pointer_info *) _sn2;
 257
 258   if (sn1->u.pointer < sn2->u.pointer)
 259     return -1;
 260   if (sn1->u.pointer > sn2->u.pointer)
 261     return 1;
 262
 263   return 0;
 264 }
 265
 266
 267 /* Compare integers when searching by integer.  Used when reading a
 268    module.  */
 269
 270 static int
 271 compare_integers (void *_sn1, void *_sn2)
 272 {
 273   pointer_info *sn1, *sn2;
 274
 275   sn1 = (pointer_info *) _sn1;
 276   sn2 = (pointer_info *) _sn2;
 277
 278   if (sn1->integer < sn2->integer)
 279     return -1;
 280   if (sn1->integer > sn2->integer)
 281     return 1;
 282
 283   return 0;
 284 }
 285
 286
 287 /* Initialize the pointer_info tree.  */
 288
 289 static void
 290 init_pi_tree (void)
 291 {
 292   compare_fn compare;
 293   pointer_info *p;
 294
 295   pi_root = NULL;
 296   compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
 297
 298   /* Pointer 0 is the NULL pointer.  */
 299   p = gfc_get_pointer_info ();
 300   p->u.pointer = NULL;
 301   p->integer = 0;
 302   p->type = P_OTHER;
 303
 304   gfc_insert_bbt (&pi_root, p, compare);
 305
 306   /* Pointer 1 is the current namespace.  */
 307   p = gfc_get_pointer_info ();
 308   p->u.pointer = gfc_current_ns;
 309   p->integer = 1;
 310   p->type = P_NAMESPACE;
 311
 312   gfc_insert_bbt (&pi_root, p, compare);
 313
 314   symbol_number = 2;
 315 }
 316
 317
 318 /* During module writing, call here with a pointer to something,
 319    returning the pointer_info node.  */
 320
 321 static pointer_info *
 322 find_pointer (void *gp)
 323 {
 324   pointer_info *p;
 325
 326   p = pi_root;
 327   while (p != NULL)
 328     {
 329       if (p->u.pointer == gp)
 330         break;
 331       p = (gp < p->u.pointer) ? p->left : p->right;
 332     }
 333
 334   return p;
 335 }
 336
 337
 338 /* Given a pointer while writing, returns the pointer_info tree node,
 339    creating it if it doesn't exist.  */
 340
 341 static pointer_info *
 342 get_pointer (void *gp)
 343 {
 344   pointer_info *p;
 345
 346   p = find_pointer (gp);
 347   if (p != NULL)
 348     return p;
 349
 350   /* Pointer doesn't have an integer.  Give it one.  */
 351   p = gfc_get_pointer_info ();
 352
 353   p->u.pointer = gp;
 354   p->integer = symbol_number++;
 355
 356   gfc_insert_bbt (&pi_root, p, compare_pointers);
 357
 358   return p;
 359 }
 360
 361
 362 /* Given an integer during reading, find it in the pointer_info tree,
 363    creating the node if not found.  */
 364
 365 static pointer_info *
 366 get_integer (int integer)
 367 {
 368   pointer_info *p, t;
 369   int c;
 370
 371   t.integer = integer;
 372
 373   p = pi_root;
 374   while (p != NULL)
 375     {
 376       c = compare_integers (&t, p);
 377       if (c == 0)
 378         break;
 379
 380       p = (c < 0) ? p->left : p->right;
 381     }
 382
 383   if (p != NULL)
 384     return p;
 385
 386   p = gfc_get_pointer_info ();
 387   p->integer = integer;
 388   p->u.pointer = NULL;
 389
 390   gfc_insert_bbt (&pi_root, p, compare_integers);
 391
 392   return p;
 393 }
 394
 395
 396 /* Resolve any fixups using a known pointer.  */
 397
 398 static void
 399 resolve_fixups (fixup_t *f, void *gp)
 400 {
 401   fixup_t *next;
 402
 403   for (; f; f = next)
 404     {
 405       next = f->next;
 406       *(f->pointer) = gp;
 407       free (f);
 408     }
 409 }
 410
 411
 412 /* Convert a string such that it starts with a lower-case character. Used
 413    to convert the symtree name of a derived-type to the symbol name or to
 414    the name of the associated generic function.  */
 415
 416 static const char *
 417 dt_lower_string (const char *name)
 418 {
 419   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
 420     return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
 421                            &name[1]);
 422   return gfc_get_string (name);
 423 }
 424
 425
 426 /* Convert a string such that it starts with an upper-case character. Used to
 427    return the symtree-name for a derived type; the symbol name itself and the
 428    symtree/symbol name of the associated generic function start with a lower-
 429    case character.  */
 430
 431 static const char *
 432 dt_upper_string (const char *name)
 433 {
 434   if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
 435     return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
 436                            &name[1]);
 437   return gfc_get_string (name);
 438 }
 439
 440 /* Call here during module reading when we know what pointer to
 441    associate with an integer.  Any fixups that exist are resolved at
 442    this time.  */
 443
 444 static void
 445 associate_integer_pointer (pointer_info *p, void *gp)
 446 {
 447   if (p->u.pointer != NULL)
 448     gfc_internal_error ("associate_integer_pointer(): Already associated");
 449
 450   p->u.pointer = gp;
 451
 452   resolve_fixups (p->fixup, gp);
 453
 454   p->fixup = NULL;
 455 }
 456
 457
 458 /* During module reading, given an integer and a pointer to a pointer,
 459    either store the pointer from an already-known value or create a
 460    fixup structure in order to store things later.  Returns zero if
 461    the reference has been actually stored, or nonzero if the reference
 462    must be fixed later (i.e., associate_integer_pointer must be called
 463    sometime later.  Returns the pointer_info structure.  */
 464
 465 static pointer_info *
 466 add_fixup (int integer, void *gp)
 467 {
 468   pointer_info *p;
 469   fixup_t *f;
 470   char **cp;
 471
 472   p = get_integer (integer);
 473
 474   if (p->integer == 0 || p->u.pointer != NULL)
 475     {
 476       cp = (char **) gp;
 477       *cp = (char *) p->u.pointer;
 478     }
 479   else
 480     {
 481       f = XCNEW (fixup_t);
 482
 483       f->next = p->fixup;
 484       p->fixup = f;
 485
 486       f->pointer = (void **) gp;
 487     }
 488
 489   return p;
 490 }
 491
 492
 493 /*****************************************************************/
 494
 495 /* Parser related subroutines */
 496
 497 /* Free the rename list left behind by a USE statement.  */
 498
 499 static void
 500 free_rename (gfc_use_rename *list)
 501 {
 502   gfc_use_rename *next;
 503
 504   for (; list; list = next)
 505     {
 506       next = list->next;
 507       free (list);
 508     }
 509 }
 510
 511
 512 /* Match a USE statement.  */
 513
 514 match
 515 gfc_match_use (void)
 516 {
 517   char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
 518   gfc_use_rename *tail = NULL, *new_use;
 519   interface_type type, type2;
 520   gfc_intrinsic_op op;
 521   match m;
 522   gfc_use_list *use_list;
 523
 524   use_list = gfc_get_use_list ();
 525
 526   if (gfc_match (" , ") == MATCH_YES)
 527     {
 528       if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
 529         {
 530           if (!gfc_notify_std (GFC_STD_F2003, "module "
 531                                "nature in USE statement at %C"))
 532             goto cleanup;
 533
 534           if (strcmp (module_nature, "intrinsic") == 0)
 535             use_list->intrinsic = true;
 536           else
 537             {
 538               if (strcmp (module_nature, "non_intrinsic") == 0)
 539                 use_list->non_intrinsic = true;
 540               else
 541                 {
 542                   gfc_error ("Module nature in USE statement at %C shall "
 543                              "be either INTRINSIC or NON_INTRINSIC");
 544                   goto cleanup;
 545                 }
 546             }
 547         }
 548       else
 549         {
 550           /* Help output a better error message than "Unclassifiable
 551              statement".  */
 552           gfc_match (" %n", module_nature);
 553           if (strcmp (module_nature, "intrinsic") == 0
 554               || strcmp (module_nature, "non_intrinsic") == 0)
 555             gfc_error ("\"::\" was expected after module nature at %C "
 556                        "but was not found");
 557           free (use_list);
 558           return m;
 559         }
 560     }
 561   else
 562     {
 563       m = gfc_match (" ::");
 564       if (m == MATCH_YES &&
 565           !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
 566         goto cleanup;
 567
 568       if (m != MATCH_YES)
 569         {
 570           m = gfc_match ("% ");
 571           if (m != MATCH_YES)
 572             {
 573               free (use_list);
 574               return m;
 575             }
 576         }
 577     }
 578
 579   use_list->where = gfc_current_locus;
 580
 581   m = gfc_match_name (name);
 582   if (m != MATCH_YES)
 583     {
 584       free (use_list);
 585       return m;
 586     }
 587
 588   use_list->module_name = gfc_get_string (name);
 589
 590   if (gfc_match_eos () == MATCH_YES)
 591     goto done;
 592
 593   if (gfc_match_char (',') != MATCH_YES)
 594     goto syntax;
 595
 596   if (gfc_match (" only :") == MATCH_YES)
 597     use_list->only_flag = true;
 598
 599   if (gfc_match_eos () == MATCH_YES)
 600     goto done;
 601
 602   for (;;)
 603     {
 604       /* Get a new rename struct and add it to the rename list.  */
 605       new_use = gfc_get_use_rename ();
 606       new_use->where = gfc_current_locus;
 607       new_use->found = 0;
 608
 609       if (use_list->rename == NULL)
 610         use_list->rename = new_use;
 611       else
 612         tail->next = new_use;
 613       tail = new_use;
 614
 615       /* See what kind of interface we're dealing with.  Assume it is
 616          not an operator.  */
 617       new_use->op = INTRINSIC_NONE;
 618       if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
 619         goto cleanup;
 620
 621       switch (type)
 622         {
 623         case INTERFACE_NAMELESS:
 624           gfc_error ("Missing generic specification in USE statement at %C");
 625           goto cleanup;
 626
 627         case INTERFACE_USER_OP:
 628         case INTERFACE_GENERIC:
 629           m = gfc_match (" =>");
 630
 631           if (type == INTERFACE_USER_OP && m == MATCH_YES
 632               && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
 633                                   "operators in USE statements at %C")))
 634             goto cleanup;
 635
 636           if (type == INTERFACE_USER_OP)
 637             new_use->op = INTRINSIC_USER;
 638
 639           if (use_list->only_flag)
 640             {
 641               if (m != MATCH_YES)
 642                 strcpy (new_use->use_name, name);
 643               else
 644                 {
 645                   strcpy (new_use->local_name, name);
 646                   m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
 647                   if (type != type2)
 648                     goto syntax;
 649                   if (m == MATCH_NO)
 650                     goto syntax;
 651                   if (m == MATCH_ERROR)
 652                     goto cleanup;
 653                 }
 654             }
 655           else
 656             {
 657               if (m != MATCH_YES)
 658                 goto syntax;
 659               strcpy (new_use->local_name, name);
 660
 661               m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
 662               if (type != type2)
 663                 goto syntax;
 664               if (m == MATCH_NO)
 665                 goto syntax;
 666               if (m == MATCH_ERROR)
 667                 goto cleanup;
 668             }
 669
 670           if (strcmp (new_use->use_name, use_list->module_name) == 0
 671               || strcmp (new_use->local_name, use_list->module_name) == 0)
 672             {
 673               gfc_error ("The name '%s' at %C has already been used as "
 674                          "an external module name.", use_list->module_name);
 675               goto cleanup;
 676             }
 677           break;
 678
 679         case INTERFACE_INTRINSIC_OP:
 680           new_use->op = op;
 681           break;
 682
 683         default:
 684           gcc_unreachable ();
 685         }
 686
 687       if (gfc_match_eos () == MATCH_YES)
 688         break;
 689       if (gfc_match_char (',') != MATCH_YES)
 690         goto syntax;
 691     }
 692
 693 done:
 694   if (module_list)
 695     {
 696       gfc_use_list *last = module_list;
 697       while (last->next)
 698         last = last->next;
 699       last->next = use_list;
 700     }
 701   else
 702     module_list = use_list;
 703
 704   return MATCH_YES;
 705
 706 syntax:
 707   gfc_syntax_error (ST_USE);
 708
 709 cleanup:
 710   free_rename (use_list->rename);
 711   free (use_list);
 712   return MATCH_ERROR;
 713 }
 714
 715
 716 /* Given a name and a number, inst, return the inst name
 717    under which to load this symbol. Returns NULL if this
 718    symbol shouldn't be loaded. If inst is zero, returns
 719    the number of instances of this name. If interface is
 720    true, a user-defined operator is sought, otherwise only
 721    non-operators are sought.  */
 722
 723 static const char *
 724 find_use_name_n (const char *name, int *inst, bool interface)
 725 {
 726   gfc_use_rename *u;
 727   const char *low_name = NULL;
 728   int i;
 729
 730   /* For derived types.  */
 731   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
 732     low_name = dt_lower_string (name);
 733
 734   i = 0;
 735   for (u = gfc_rename_list; u; u = u->next)
 736     {
 737       if ((!low_name && strcmp (u->use_name, name) != 0)
 738           || (low_name && strcmp (u->use_name, low_name) != 0)
 739           || (u->op == INTRINSIC_USER && !interface)
 740           || (u->op != INTRINSIC_USER &&  interface))
 741         continue;
 742       if (++i == *inst)
 743         break;
 744     }
 745
 746   if (!*inst)
 747     {
 748       *inst = i;
 749       return NULL;
 750     }
 751
 752   if (u == NULL)
 753     return only_flag ? NULL : name;
 754
 755   u->found = 1;
 756
 757   if (low_name)
 758     {
 759       if (u->local_name[0] == '\0')
 760         return name;
 761       return dt_upper_string (u->local_name);
 762     }
 763
 764   return (u->local_name[0] != '\0') ? u->local_name : name;
 765 }
 766
 767
 768 /* Given a name, return the name under which to load this symbol.
 769    Returns NULL if this symbol shouldn't be loaded.  */
 770
 771 static const char *
 772 find_use_name (const char *name, bool interface)
 773 {
 774   int i = 1;
 775   return find_use_name_n (name, &i, interface);
 776 }
 777
 778
 779 /* Given a real name, return the number of use names associated with it.  */
 780
 781 static int
 782 number_use_names (const char *name, bool interface)
 783 {
 784   int i = 0;
 785   find_use_name_n (name, &i, interface);
 786   return i;
 787 }
 788
 789
 790 /* Try to find the operator in the current list.  */
 791
 792 static gfc_use_rename *
 793 find_use_operator (gfc_intrinsic_op op)
 794 {
 795   gfc_use_rename *u;
 796
 797   for (u = gfc_rename_list; u; u = u->next)
 798     if (u->op == op)
 799       return u;
 800
 801   return NULL;
 802 }
 803
 804
 805 /*****************************************************************/
 806
 807 /* The next couple of subroutines maintain a tree used to avoid a
 808    brute-force search for a combination of true name and module name.
 809    While symtree names, the name that a particular symbol is known by
 810    can changed with USE statements, we still have to keep track of the
 811    true names to generate the correct reference, and also avoid
 812    loading the same real symbol twice in a program unit.
 813
 814    When we start reading, the true name tree is built and maintained
 815    as symbols are read.  The tree is searched as we load new symbols
 816    to see if it already exists someplace in the namespace.  */
 817
 818 typedef struct true_name
 819 {
 820   BBT_HEADER (true_name);
 821   const char *name;
 822   gfc_symbol *sym;
 823 }
 824 true_name;
 825
 826 static true_name *true_name_root;
 827
 828
 829 /* Compare two true_name structures.  */
 830
 831 static int
 832 compare_true_names (void *_t1, void *_t2)
 833 {
 834   true_name *t1, *t2;
 835   int c;
 836
 837   t1 = (true_name *) _t1;
 838   t2 = (true_name *) _t2;
 839
 840   c = ((t1->sym->module > t2->sym->module)
 841        - (t1->sym->module < t2->sym->module));
 842   if (c != 0)
 843     return c;
 844
 845   return strcmp (t1->name, t2->name);
 846 }
 847
 848
 849 /* Given a true name, search the true name tree to see if it exists
 850    within the main namespace.  */
 851
 852 static gfc_symbol *
 853 find_true_name (const char *name, const char *module)
 854 {
 855   true_name t, *p;
 856   gfc_symbol sym;
 857   int c;
 858
 859   t.name = gfc_get_string (name);
 860   if (module != NULL)
 861     sym.module = gfc_get_string (module);
 862   else
 863     sym.module = NULL;
 864   t.sym = &sym;
 865
 866   p = true_name_root;
 867   while (p != NULL)
 868     {
 869       c = compare_true_names ((void *) (&t), (void *) p);
 870       if (c == 0)
 871         return p->sym;
 872
 873       p = (c < 0) ? p->left : p->right;
 874     }
 875
 876   return NULL;
 877 }
 878
 879
 880 /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
 881
 882 static void
 883 add_true_name (gfc_symbol *sym)
 884 {
 885   true_name *t;
 886
 887   t = XCNEW (true_name);
 888   t->sym = sym;
 889   if (sym->attr.flavor == FL_DERIVED)
 890     t->name = dt_upper_string (sym->name);
 891   else
 892     t->name = sym->name;
 893
 894   gfc_insert_bbt (&true_name_root, t, compare_true_names);
 895 }
 896
 897
 898 /* Recursive function to build the initial true name tree by
 899    recursively traversing the current namespace.  */
 900
 901 static void
 902 build_tnt (gfc_symtree *st)
 903 {
 904   const char *name;
 905   if (st == NULL)
 906     return;
 907
 908   build_tnt (st->left);
 909   build_tnt (st->right);
 910
 911   if (st->n.sym->attr.flavor == FL_DERIVED)
 912     name = dt_upper_string (st->n.sym->name);
 913   else
 914     name = st->n.sym->name;
 915
 916   if (find_true_name (name, st->n.sym->module) != NULL)
 917     return;
 918
 919   add_true_name (st->n.sym);
 920 }
 921
 922
 923 /* Initialize the true name tree with the current namespace.  */
 924
 925 static void
 926 init_true_name_tree (void)
 927 {
 928   true_name_root = NULL;
 929   build_tnt (gfc_current_ns->sym_root);
 930 }
 931
 932
 933 /* Recursively free a true name tree node.  */
 934
 935 static void
 936 free_true_name (true_name *t)
 937 {
 938   if (t == NULL)
 939     return;
 940   free_true_name (t->left);
 941   free_true_name (t->right);
 942
 943   free (t);
 944 }
 945
 946
 947 /*****************************************************************/
 948
 949 /* Module reading and writing.  */
 950
 951 /* The following are versions similar to the ones in scanner.c, but
 952    for dealing with compressed module files.  */
 953
 954 static gzFile
 955 gzopen_included_file_1 (const char *name, gfc_directorylist *list,
 956                      bool module, bool system)
 957 {
 958   char *fullname;
 959   gfc_directorylist *p;
 960   gzFile f;
 961
 962   for (p = list; p; p = p->next)
 963     {
 964       if (module && !p->use_for_modules)
 965        continue;
 966
 967       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
 968       strcpy (fullname, p->path);
 969       strcat (fullname, name);
 970
 971       f = gzopen (fullname, "r");
 972       if (f != NULL)
 973        {
 974          if (gfc_cpp_makedep ())
 975            gfc_cpp_add_dep (fullname, system);
 976
 977          return f;
 978        }
 979     }
 980
 981   return NULL;
 982 }
 983
 984 static gzFile
 985 gzopen_included_file (const char *name, bool include_cwd, bool module)
 986 {
 987   gzFile f = NULL;
 988
 989   if (IS_ABSOLUTE_PATH (name) || include_cwd)
 990     {
 991       f = gzopen (name, "r");
 992       if (f && gfc_cpp_makedep ())
 993        gfc_cpp_add_dep (name, false);
 994     }
 995
 996   if (!f)
 997     f = gzopen_included_file_1 (name, include_dirs, module, false);
 998
 999   return f;
1000 }
1001
1002 static gzFile
1003 gzopen_intrinsic_module (const char* name)
1004 {
1005   gzFile f = NULL;
1006
1007   if (IS_ABSOLUTE_PATH (name))
1008     {
1009       f = gzopen (name, "r");
1010       if (f && gfc_cpp_makedep ())
1011         gfc_cpp_add_dep (name, true);
1012     }
1013
1014   if (!f)
1015     f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);
1016
1017   return f;
1018 }
1019
1020
1021 typedef enum
1022 {
1023   ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
1024 }
1025 atom_type;
1026
1027 static atom_type last_atom;
1028
1029
1030 /* The name buffer must be at least as long as a symbol name.  Right
1031    now it's not clear how we're going to store numeric constants--
1032    probably as a hexadecimal string, since this will allow the exact
1033    number to be preserved (this can't be done by a decimal
1034    representation).  Worry about that later.  TODO!  */
1035
1036 #define MAX_ATOM_SIZE 100
1037
1038 static int atom_int;
1039 static char *atom_string, atom_name[MAX_ATOM_SIZE];
1040
1041
1042 /* Report problems with a module.  Error reporting is not very
1043    elaborate, since this sorts of errors shouldn't really happen.
1044    This subroutine never returns.  */
1045
1046 static void bad_module (const char *) ATTRIBUTE_NORETURN;
1047
1048 static void
1049 bad_module (const char *msgid)
1050 {
1051   XDELETEVEC (module_content);
1052   module_content = NULL;
1053
1054   switch (iomode)
1055     {
1056     case IO_INPUT:
1057       gfc_fatal_error ("Reading module %s at line %d column %d: %s",
1058                        module_name, module_line, module_column, msgid);
1059       break;
1060     case IO_OUTPUT:
1061       gfc_fatal_error ("Writing module %s at line %d column %d: %s",
1062                        module_name, module_line, module_column, msgid);
1063       break;
1064     default:
1065       gfc_fatal_error ("Module %s at line %d column %d: %s",
1066                        module_name, module_line, module_column, msgid);
1067       break;
1068     }
1069 }
1070
1071
1072 /* Set the module's input pointer.  */
1073
1074 static void
1075 set_module_locus (module_locus *m)
1076 {
1077   module_column = m->column;
1078   module_line = m->line;
1079   module_pos = m->pos;
1080 }
1081
1082
1083 /* Get the module's input pointer so that we can restore it later.  */
1084
1085 static void
1086 get_module_locus (module_locus *m)
1087 {
1088   m->column = module_column;
1089   m->line = module_line;
1090   m->pos = module_pos;
1091 }
1092
1093
1094 /* Get the next character in the module, updating our reckoning of
1095    where we are.  */
1096
1097 static int
1098 module_char (void)
1099 {
1100   const char c = module_content[module_pos++];
1101   if (c == '\0')
1102     bad_module ("Unexpected EOF");
1103
1104   prev_module_line = module_line;
1105   prev_module_column = module_column;
1106
1107   if (c == '\n')
1108     {
1109       module_line++;
1110       module_column = 0;
1111     }
1112
1113   module_column++;
1114   return c;
1115 }
1116
1117 /* Unget a character while remembering the line and column.  Works for
1118    a single character only.  */
1119
1120 static void
1121 module_unget_char (void)
1122 {
1123   module_line = prev_module_line;
1124   module_column = prev_module_column;
1125   module_pos--;
1126 }
1127
1128 /* Parse a string constant.  The delimiter is guaranteed to be a
1129    single quote.  */
1130
1131 static void
1132 parse_string (void)
1133 {
1134   int c;
1135   size_t cursz = 30;
1136   size_t len = 0;
1137
1138   atom_string = XNEWVEC (char, cursz);
1139
1140   for ( ; ; )
1141     {
1142       c = module_char ();
1143
1144       if (c == '\'')
1145         {
1146           int c2 = module_char ();
1147           if (c2 != '\'')
1148             {
1149               module_unget_char ();
1150               break;
1151             }
1152         }
1153
1154       if (len >= cursz)
1155         {
1156           cursz *= 2;
1157           atom_string = XRESIZEVEC (char, atom_string, cursz);
1158         }
1159       atom_string[len] = c;
1160       len++;
1161     }
1162
1163   atom_string = XRESIZEVEC (char, atom_string, len + 1);
1164   atom_string[len] = '\0';      /* C-style string for debug purposes.  */
1165 }
1166
1167
1168 /* Parse a small integer.  */
1169
1170 static void
1171 parse_integer (int c)
1172 {
1173   atom_int = c - '0';
1174
1175   for (;;)
1176     {
1177       c = module_char ();
1178       if (!ISDIGIT (c))
1179         {
1180           module_unget_char ();
1181           break;
1182         }
1183
1184       atom_int = 10 * atom_int + c - '0';
1185       if (atom_int > 99999999)
1186         bad_module ("Integer overflow");
1187     }
1188
1189 }
1190
1191
1192 /* Parse a name.  */
1193
1194 static void
1195 parse_name (int c)
1196 {
1197   char *p;
1198   int len;
1199
1200   p = atom_name;
1201
1202   *p++ = c;
1203   len = 1;
1204
1205   for (;;)
1206     {
1207       c = module_char ();
1208       if (!ISALNUM (c) && c != '_' && c != '-')
1209         {
1210           module_unget_char ();
1211           break;
1212         }
1213
1214       *p++ = c;
1215       if (++len > GFC_MAX_SYMBOL_LEN)
1216         bad_module ("Name too long");
1217     }
1218
1219   *p = '\0';
1220
1221 }
1222
1223
1224 /* Read the next atom in the module's input stream.  */
1225
1226 static atom_type
1227 parse_atom (void)
1228 {
1229   int c;
1230
1231   do
1232     {
1233       c = module_char ();
1234     }
1235   while (c == ' ' || c == '\r' || c == '\n');
1236
1237   switch (c)
1238     {
1239     case '(':
1240       return ATOM_LPAREN;
1241
1242     case ')':
1243       return ATOM_RPAREN;
1244
1245     case '\'':
1246       parse_string ();
1247       return ATOM_STRING;
1248
1249     case '0':
1250     case '1':
1251     case '2':
1252     case '3':
1253     case '4':
1254     case '5':
1255     case '6':
1256     case '7':
1257     case '8':
1258     case '9':
1259       parse_integer (c);
1260       return ATOM_INTEGER;
1261
1262     case 'a':
1263     case 'b':
1264     case 'c':
1265     case 'd':
1266     case 'e':
1267     case 'f':
1268     case 'g':
1269     case 'h':
1270     case 'i':
1271     case 'j':
1272     case 'k':
1273     case 'l':
1274     case 'm':
1275     case 'n':
1276     case 'o':
1277     case 'p':
1278     case 'q':
1279     case 'r':
1280     case 's':
1281     case 't':
1282     case 'u':
1283     case 'v':
1284     case 'w':
1285     case 'x':
1286     case 'y':
1287     case 'z':
1288     case 'A':
1289     case 'B':
1290     case 'C':
1291     case 'D':
1292     case 'E':
1293     case 'F':
1294     case 'G':
1295     case 'H':
1296     case 'I':
1297     case 'J':
1298     case 'K':
1299     case 'L':
1300     case 'M':
1301     case 'N':
1302     case 'O':
1303     case 'P':
1304     case 'Q':
1305     case 'R':
1306     case 'S':
1307     case 'T':
1308     case 'U':
1309     case 'V':
1310     case 'W':
1311     case 'X':
1312     case 'Y':
1313     case 'Z':
1314       parse_name (c);
1315       return ATOM_NAME;
1316
1317     default:
1318       bad_module ("Bad name");
1319     }
1320
1321   /* Not reached.  */
1322 }
1323
1324
1325 /* Peek at the next atom on the input.  */
1326
1327 static atom_type
1328 peek_atom (void)
1329 {
1330   int c;
1331
1332   do
1333     {
1334       c = module_char ();
1335     }
1336   while (c == ' ' || c == '\r' || c == '\n');
1337
1338   switch (c)
1339     {
1340     case '(':
1341       module_unget_char ();
1342       return ATOM_LPAREN;
1343
1344     case ')':
1345       module_unget_char ();
1346       return ATOM_RPAREN;
1347
1348     case '\'':
1349       module_unget_char ();
1350       return ATOM_STRING;
1351
1352     case '0':
1353     case '1':
1354     case '2':
1355     case '3':
1356     case '4':
1357     case '5':
1358     case '6':
1359     case '7':
1360     case '8':
1361     case '9':
1362       module_unget_char ();
1363       return ATOM_INTEGER;
1364
1365     case 'a':
1366     case 'b':
1367     case 'c':
1368     case 'd':
1369     case 'e':
1370     case 'f':
1371     case 'g':
1372     case 'h':
1373     case 'i':
1374     case 'j':
1375     case 'k':
1376     case 'l':
1377     case 'm':
1378     case 'n':
1379     case 'o':
1380     case 'p':
1381     case 'q':
1382     case 'r':
1383     case 's':
1384     case 't':
1385     case 'u':
1386     case 'v':
1387     case 'w':
1388     case 'x':
1389     case 'y':
1390     case 'z':
1391     case 'A':
1392     case 'B':
1393     case 'C':
1394     case 'D':
1395     case 'E':
1396     case 'F':
1397     case 'G':
1398     case 'H':
1399     case 'I':
1400     case 'J':
1401     case 'K':
1402     case 'L':
1403     case 'M':
1404     case 'N':
1405     case 'O':
1406     case 'P':
1407     case 'Q':
1408     case 'R':
1409     case 'S':
1410     case 'T':
1411     case 'U':
1412     case 'V':
1413     case 'W':
1414     case 'X':
1415     case 'Y':
1416     case 'Z':
1417       module_unget_char ();
1418       return ATOM_NAME;
1419
1420     default:
1421       bad_module ("Bad name");
1422     }
1423 }
1424
1425
1426 /* Read the next atom from the input, requiring that it be a
1427    particular kind.  */
1428
1429 static void
1430 require_atom (atom_type type)
1431 {
1432   atom_type t;
1433   const char *p;
1434   int column, line;
1435
1436   column = module_column;
1437   line = module_line;
1438
1439   t = parse_atom ();
1440   if (t != type)
1441     {
1442       switch (type)
1443         {
1444         case ATOM_NAME:
1445           p = _("Expected name");
1446           break;
1447         case ATOM_LPAREN:
1448           p = _("Expected left parenthesis");
1449           break;
1450         case ATOM_RPAREN:
1451           p = _("Expected right parenthesis");
1452           break;
1453         case ATOM_INTEGER:
1454           p = _("Expected integer");
1455           break;
1456         case ATOM_STRING:
1457           p = _("Expected string");
1458           break;
1459         default:
1460           gfc_internal_error ("require_atom(): bad atom type required");
1461         }
1462
1463       module_column = column;
1464       module_line = line;
1465       bad_module (p);
1466     }
1467 }
1468
1469
1470 /* Given a pointer to an mstring array, require that the current input
1471    be one of the strings in the array.  We return the enum value.  */
1472
1473 static int
1474 find_enum (const mstring *m)
1475 {
1476   int i;
1477
1478   i = gfc_string2code (m, atom_name);
1479   if (i >= 0)
1480     return i;
1481
1482   bad_module ("find_enum(): Enum not found");
1483
1484   /* Not reached.  */
1485 }
1486
1487
1488 /* Read a string. The caller is responsible for freeing.  */
1489
1490 static char*
1491 read_string (void)
1492 {
1493   char* p;
1494   require_atom (ATOM_STRING);
1495   p = atom_string;
1496   atom_string = NULL;
1497   return p;
1498 }
1499
1500
1501 /**************** Module output subroutines ***************************/
1502
1503 /* Output a character to a module file.  */
1504
1505 static void
1506 write_char (char out)
1507 {
1508   if (gzputc (module_fp, out) == EOF)
1509     gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1510
1511   if (out != '\n')
1512     module_column++;
1513   else
1514     {
1515       module_column = 1;
1516       module_line++;
1517     }
1518 }
1519
1520
1521 /* Write an atom to a module.  The line wrapping isn't perfect, but it
1522    should work most of the time.  This isn't that big of a deal, since
1523    the file really isn't meant to be read by people anyway.  */
1524
1525 static void
1526 write_atom (atom_type atom, const void *v)
1527 {
1528   char buffer[20];
1529   int i, len;
1530   const char *p;
1531
1532   switch (atom)
1533     {
1534     case ATOM_STRING:
1535     case ATOM_NAME:
1536       p = (const char *) v;
1537       break;
1538
1539     case ATOM_LPAREN:
1540       p = "(";
1541       break;
1542
1543     case ATOM_RPAREN:
1544       p = ")";
1545       break;
1546
1547     case ATOM_INTEGER:
1548       i = *((const int *) v);
1549       if (i < 0)
1550         gfc_internal_error ("write_atom(): Writing negative integer");
1551
1552       sprintf (buffer, "%d", i);
1553       p = buffer;
1554       break;
1555
1556     default:
1557       gfc_internal_error ("write_atom(): Trying to write dab atom");
1558
1559     }
1560
1561   if(p == NULL || *p == '\0')
1562      len = 0;
1563   else
1564   len = strlen (p);
1565
1566   if (atom != ATOM_RPAREN)
1567     {
1568       if (module_column + len > 72)
1569         write_char ('\n');
1570       else
1571         {
1572
1573           if (last_atom != ATOM_LPAREN && module_column != 1)
1574             write_char (' ');
1575         }
1576     }
1577
1578   if (atom == ATOM_STRING)
1579     write_char ('\'');
1580
1581   while (p != NULL && *p)
1582     {
1583       if (atom == ATOM_STRING && *p == '\'')
1584         write_char ('\'');
1585       write_char (*p++);
1586     }
1587
1588   if (atom == ATOM_STRING)
1589     write_char ('\'');
1590
1591   last_atom = atom;
1592 }
1593
1594
1595
1596 /***************** Mid-level I/O subroutines *****************/
1597
1598 /* These subroutines let their caller read or write atoms without
1599    caring about which of the two is actually happening.  This lets a
1600    subroutine concentrate on the actual format of the data being
1601    written.  */
1602
1603 static void mio_expr (gfc_expr **);
1604 pointer_info *mio_symbol_ref (gfc_symbol **);
1605 pointer_info *mio_interface_rest (gfc_interface **);
1606 static void mio_symtree_ref (gfc_symtree **);
1607
1608 /* Read or write an enumerated value.  On writing, we return the input
1609    value for the convenience of callers.  We avoid using an integer
1610    pointer because enums are sometimes inside bitfields.  */
1611
1612 static int
1613 mio_name (int t, const mstring *m)
1614 {
1615   if (iomode == IO_OUTPUT)
1616     write_atom (ATOM_NAME, gfc_code2string (m, t));
1617   else
1618     {
1619       require_atom (ATOM_NAME);
1620       t = find_enum (m);
1621     }
1622
1623   return t;
1624 }
1625
1626 /* Specialization of mio_name.  */
1627
1628 #define DECL_MIO_NAME(TYPE) \
1629  static inline TYPE \
1630  MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1631  { \
1632    return (TYPE) mio_name ((int) t, m); \
1633  }
1634 #define MIO_NAME(TYPE) mio_name_##TYPE
1635
1636 static void
1637 mio_lparen (void)
1638 {
1639   if (iomode == IO_OUTPUT)
1640     write_atom (ATOM_LPAREN, NULL);
1641   else
1642     require_atom (ATOM_LPAREN);
1643 }
1644
1645
1646 static void
1647 mio_rparen (void)
1648 {
1649   if (iomode == IO_OUTPUT)
1650     write_atom (ATOM_RPAREN, NULL);
1651   else
1652     require_atom (ATOM_RPAREN);
1653 }
1654
1655
1656 static void
1657 mio_integer (int *ip)
1658 {
1659   if (iomode == IO_OUTPUT)
1660     write_atom (ATOM_INTEGER, ip);
1661   else
1662     {
1663       require_atom (ATOM_INTEGER);
1664       *ip = atom_int;
1665     }
1666 }
1667
1668
1669 /* Read or write a gfc_intrinsic_op value.  */
1670
1671 static void
1672 mio_intrinsic_op (gfc_intrinsic_op* op)
1673 {
1674   /* FIXME: Would be nicer to do this via the operators symbolic name.  */
1675   if (iomode == IO_OUTPUT)
1676     {
1677       int converted = (int) *op;
1678       write_atom (ATOM_INTEGER, &converted);
1679     }
1680   else
1681     {
1682       require_atom (ATOM_INTEGER);
1683       *op = (gfc_intrinsic_op) atom_int;
1684     }
1685 }
1686
1687
1688 /* Read or write a character pointer that points to a string on the heap.  */
1689
1690 static const char *
1691 mio_allocated_string (const char *s)
1692 {
1693   if (iomode == IO_OUTPUT)
1694     {
1695       write_atom (ATOM_STRING, s);
1696       return s;
1697     }
1698   else
1699     {
1700       require_atom (ATOM_STRING);
1701       return atom_string;
1702     }
1703 }
1704
1705
1706 /* Functions for quoting and unquoting strings.  */
1707
1708 static char *
1709 quote_string (const gfc_char_t *s, const size_t slength)
1710 {
1711   const gfc_char_t *p;
1712   char *res, *q;
1713   size_t len = 0, i;
1714
1715   /* Calculate the length we'll need: a backslash takes two ("\\"),
1716      non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
1717   for (p = s, i = 0; i < slength; p++, i++)
1718     {
1719       if (*p == '\\')
1720         len += 2;
1721       else if (!gfc_wide_is_printable (*p))
1722         len += 10;
1723       else
1724         len++;
1725     }
1726
1727   q = res = XCNEWVEC (char, len + 1);
1728   for (p = s, i = 0; i < slength; p++, i++)
1729     {
1730       if (*p == '\\')
1731         *q++ = '\\', *q++ = '\\';
1732       else if (!gfc_wide_is_printable (*p))
1733         {
1734           sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1735                    (unsigned HOST_WIDE_INT) *p);
1736           q += 10;
1737         }
1738       else
1739         *q++ = (unsigned char) *p;
1740     }
1741
1742   res[len] = '\0';
1743   return res;
1744 }
1745
1746 static gfc_char_t *
1747 unquote_string (const char *s)
1748 {
1749   size_t len, i;
1750   const char *p;
1751   gfc_char_t *res;
1752
1753   for (p = s, len = 0; *p; p++, len++)
1754     {
1755       if (*p != '\\')
1756         continue;
1757
1758       if (p[1] == '\\')
1759         p++;
1760       else if (p[1] == 'U')
1761         p += 9; /* That is a "\U????????".  */
1762       else
1763         gfc_internal_error ("unquote_string(): got bad string");
1764     }
1765
1766   res = gfc_get_wide_string (len + 1);
1767   for (i = 0, p = s; i < len; i++, p++)
1768     {
1769       gcc_assert (*p);
1770
1771       if (*p != '\\')
1772         res[i] = (unsigned char) *p;
1773       else if (p[1] == '\\')
1774         {
1775           res[i] = (unsigned char) '\\';
1776           p++;
1777         }
1778       else
1779         {
1780           /* We read the 8-digits hexadecimal constant that follows.  */
1781           int j;
1782           unsigned n;
1783           gfc_char_t c = 0;
1784
1785           gcc_assert (p[1] == 'U');
1786           for (j = 0; j < 8; j++)
1787             {
1788               c = c << 4;
1789               gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1790               c += n;
1791             }
1792
1793           res[i] = c;
1794           p += 9;
1795         }
1796     }
1797
1798   res[len] = '\0';
1799   return res;
1800 }
1801
1802
1803 /* Read or write a character pointer that points to a wide string on the
1804    heap, performing quoting/unquoting of nonprintable characters using the
1805    form \U???????? (where each ? is a hexadecimal digit).
1806    Length is the length of the string, only known and used in output mode.  */
1807
1808 static const gfc_char_t *
1809 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1810 {
1811   if (iomode == IO_OUTPUT)
1812     {
1813       char *quoted = quote_string (s, length);
1814       write_atom (ATOM_STRING, quoted);
1815       free (quoted);
1816       return s;
1817     }
1818   else
1819     {
1820       gfc_char_t *unquoted;
1821
1822       require_atom (ATOM_STRING);
1823       unquoted = unquote_string (atom_string);
1824       free (atom_string);
1825       return unquoted;
1826     }
1827 }
1828
1829
1830 /* Read or write a string that is in static memory.  */
1831
1832 static void
1833 mio_pool_string (const char **stringp)
1834 {
1835   /* TODO: one could write the string only once, and refer to it via a
1836      fixup pointer.  */
1837
1838   /* As a special case we have to deal with a NULL string.  This
1839      happens for the 'module' member of 'gfc_symbol's that are not in a
1840      module.  We read / write these as the empty string.  */
1841   if (iomode == IO_OUTPUT)
1842     {
1843       const char *p = *stringp == NULL ? "" : *stringp;
1844       write_atom (ATOM_STRING, p);
1845     }
1846   else
1847     {
1848       require_atom (ATOM_STRING);
1849       *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1850       free (atom_string);
1851     }
1852 }
1853
1854
1855 /* Read or write a string that is inside of some already-allocated
1856    structure.  */
1857
1858 static void
1859 mio_internal_string (char *string)
1860 {
1861   if (iomode == IO_OUTPUT)
1862     write_atom (ATOM_STRING, string);
1863   else
1864     {
1865       require_atom (ATOM_STRING);
1866       strcpy (string, atom_string);
1867       free (atom_string);
1868     }
1869 }
1870
1871
1872 typedef enum
1873 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1874   AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1875   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1876   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1877   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
1878   AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
1879   AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
1880   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1881   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1882   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
1883   AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET
1884 }
1885 ab_attribute;
1886
1887 static const mstring attr_bits[] =
1888 {
1889     minit ("ALLOCATABLE", AB_ALLOCATABLE),
1890     minit ("ARTIFICIAL", AB_ARTIFICIAL),
1891     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
1892     minit ("DIMENSION", AB_DIMENSION),
1893     minit ("CODIMENSION", AB_CODIMENSION),
1894     minit ("CONTIGUOUS", AB_CONTIGUOUS),
1895     minit ("EXTERNAL", AB_EXTERNAL),
1896     minit ("INTRINSIC", AB_INTRINSIC),
1897     minit ("OPTIONAL", AB_OPTIONAL),
1898     minit ("POINTER", AB_POINTER),
1899     minit ("VOLATILE", AB_VOLATILE),
1900     minit ("TARGET", AB_TARGET),
1901     minit ("THREADPRIVATE", AB_THREADPRIVATE),
1902     minit ("DUMMY", AB_DUMMY),
1903     minit ("RESULT", AB_RESULT),
1904     minit ("DATA", AB_DATA),
1905     minit ("IN_NAMELIST", AB_IN_NAMELIST),
1906     minit ("IN_COMMON", AB_IN_COMMON),
1907     minit ("FUNCTION", AB_FUNCTION),
1908     minit ("SUBROUTINE", AB_SUBROUTINE),
1909     minit ("SEQUENCE", AB_SEQUENCE),
1910     minit ("ELEMENTAL", AB_ELEMENTAL),
1911     minit ("PURE", AB_PURE),
1912     minit ("RECURSIVE", AB_RECURSIVE),
1913     minit ("GENERIC", AB_GENERIC),
1914     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1915     minit ("CRAY_POINTER", AB_CRAY_POINTER),
1916     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1917     minit ("IS_BIND_C", AB_IS_BIND_C),
1918     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1919     minit ("IS_ISO_C", AB_IS_ISO_C),
1920     minit ("VALUE", AB_VALUE),
1921     minit ("ALLOC_COMP", AB_ALLOC_COMP),
1922     minit ("COARRAY_COMP", AB_COARRAY_COMP),
1923     minit ("LOCK_COMP", AB_LOCK_COMP),
1924     minit ("POINTER_COMP", AB_POINTER_COMP),
1925     minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
1926     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1927     minit ("ZERO_COMP", AB_ZERO_COMP),
1928     minit ("PROTECTED", AB_PROTECTED),
1929     minit ("ABSTRACT", AB_ABSTRACT),
1930     minit ("IS_CLASS", AB_IS_CLASS),
1931     minit ("PROCEDURE", AB_PROCEDURE),
1932     minit ("PROC_POINTER", AB_PROC_POINTER),
1933     minit ("VTYPE", AB_VTYPE),
1934     minit ("VTAB", AB_VTAB),
1935     minit ("CLASS_POINTER", AB_CLASS_POINTER),
1936     minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
1937     minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
1938     minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
1939     minit (NULL, -1)
1940 };
1941
1942 /* For binding attributes.  */
1943 static const mstring binding_passing[] =
1944 {
1945     minit ("PASS", 0),
1946     minit ("NOPASS", 1),
1947     minit (NULL, -1)
1948 };
1949 static const mstring binding_overriding[] =
1950 {
1951     minit ("OVERRIDABLE", 0),
1952     minit ("NON_OVERRIDABLE", 1),
1953     minit ("DEFERRED", 2),
1954     minit (NULL, -1)
1955 };
1956 static const mstring binding_generic[] =
1957 {
1958     minit ("SPECIFIC", 0),
1959     minit ("GENERIC", 1),
1960     minit (NULL, -1)
1961 };
1962 static const mstring binding_ppc[] =
1963 {
1964     minit ("NO_PPC", 0),
1965     minit ("PPC", 1),
1966     minit (NULL, -1)
1967 };
1968
1969 /* Specialization of mio_name.  */
1970 DECL_MIO_NAME (ab_attribute)
1971 DECL_MIO_NAME (ar_type)
1972 DECL_MIO_NAME (array_type)
1973 DECL_MIO_NAME (bt)
1974 DECL_MIO_NAME (expr_t)
1975 DECL_MIO_NAME (gfc_access)
1976 DECL_MIO_NAME (gfc_intrinsic_op)
1977 DECL_MIO_NAME (ifsrc)
1978 DECL_MIO_NAME (save_state)
1979 DECL_MIO_NAME (procedure_type)
1980 DECL_MIO_NAME (ref_type)
1981 DECL_MIO_NAME (sym_flavor)
1982 DECL_MIO_NAME (sym_intent)
1983 #undef DECL_MIO_NAME
1984
1985 /* Symbol attributes are stored in list with the first three elements
1986    being the enumerated fields, while the remaining elements (if any)
1987    indicate the individual attribute bits.  The access field is not
1988    saved-- it controls what symbols are exported when a module is
1989    written.  */
1990
1991 static void
1992 mio_symbol_attribute (symbol_attribute *attr)
1993 {
1994   atom_type t;
1995   unsigned ext_attr,extension_level;
1996
1997   mio_lparen ();
1998
1999   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
2000   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
2001   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
2002   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
2003   attr->save = MIO_NAME (save_state) (attr->save, save_status);
2004
2005   ext_attr = attr->ext_attr;
2006   mio_integer ((int *) &ext_attr);
2007   attr->ext_attr = ext_attr;
2008
2009   extension_level = attr->extension;
2010   mio_integer ((int *) &extension_level);
2011   attr->extension = extension_level;
2012
2013   if (iomode == IO_OUTPUT)
2014     {
2015       if (attr->allocatable)
2016         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
2017       if (attr->artificial)
2018         MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
2019       if (attr->asynchronous)
2020         MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
2021       if (attr->dimension)
2022         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
2023       if (attr->codimension)
2024         MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
2025       if (attr->contiguous)
2026         MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
2027       if (attr->external)
2028         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
2029       if (attr->intrinsic)
2030         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
2031       if (attr->optional)
2032         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
2033       if (attr->pointer)
2034         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
2035       if (attr->class_pointer)
2036         MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
2037       if (attr->is_protected)
2038         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
2039       if (attr->value)
2040         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
2041       if (attr->volatile_)
2042         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2043       if (attr->target)
2044         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2045       if (attr->threadprivate)
2046         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2047       if (attr->dummy)
2048         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2049       if (attr->result)
2050         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2051       /* We deliberately don't preserve the "entry" flag.  */
2052
2053       if (attr->data)
2054         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2055       if (attr->in_namelist)
2056         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2057       if (attr->in_common)
2058         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2059
2060       if (attr->function)
2061         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2062       if (attr->subroutine)
2063         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2064       if (attr->generic)
2065         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2066       if (attr->abstract)
2067         MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2068
2069       if (attr->sequence)
2070         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2071       if (attr->elemental)
2072         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2073       if (attr->pure)
2074         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2075       if (attr->implicit_pure)
2076         MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2077       if (attr->unlimited_polymorphic)
2078         MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2079       if (attr->recursive)
2080         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2081       if (attr->always_explicit)
2082         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2083       if (attr->cray_pointer)
2084         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2085       if (attr->cray_pointee)
2086         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2087       if (attr->is_bind_c)
2088         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2089       if (attr->is_c_interop)
2090         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2091       if (attr->is_iso_c)
2092         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2093       if (attr->alloc_comp)
2094         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2095       if (attr->pointer_comp)
2096         MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2097       if (attr->proc_pointer_comp)
2098         MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2099       if (attr->private_comp)
2100         MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2101       if (attr->coarray_comp)
2102         MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2103       if (attr->lock_comp)
2104         MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2105       if (attr->zero_comp)
2106         MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2107       if (attr->is_class)
2108         MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2109       if (attr->procedure)
2110         MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2111       if (attr->proc_pointer)
2112         MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2113       if (attr->vtype)
2114         MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2115       if (attr->vtab)
2116         MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2117       if (attr->omp_declare_target)
2118         MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
2119
2120       mio_rparen ();
2121
2122     }
2123   else
2124     {
2125       for (;;)
2126         {
2127           t = parse_atom ();
2128           if (t == ATOM_RPAREN)
2129             break;
2130           if (t != ATOM_NAME)
2131             bad_module ("Expected attribute bit name");
2132
2133           switch ((ab_attribute) find_enum (attr_bits))
2134             {
2135             case AB_ALLOCATABLE:
2136               attr->allocatable = 1;
2137               break;
2138             case AB_ARTIFICIAL:
2139               attr->artificial = 1;
2140               break;
2141             case AB_ASYNCHRONOUS:
2142               attr->asynchronous = 1;
2143               break;
2144             case AB_DIMENSION:
2145               attr->dimension = 1;
2146               break;
2147             case AB_CODIMENSION:
2148               attr->codimension = 1;
2149               break;
2150             case AB_CONTIGUOUS:
2151               attr->contiguous = 1;
2152               break;
2153             case AB_EXTERNAL:
2154               attr->external = 1;
2155               break;
2156             case AB_INTRINSIC:
2157               attr->intrinsic = 1;
2158               break;
2159             case AB_OPTIONAL:
2160               attr->optional = 1;
2161               break;
2162             case AB_POINTER:
2163               attr->pointer = 1;
2164               break;
2165             case AB_CLASS_POINTER:
2166               attr->class_pointer = 1;
2167               break;
2168             case AB_PROTECTED:
2169               attr->is_protected = 1;
2170               break;
2171             case AB_VALUE:
2172               attr->value = 1;
2173               break;
2174             case AB_VOLATILE:
2175               attr->volatile_ = 1;
2176               break;
2177             case AB_TARGET:
2178               attr->target = 1;
2179               break;
2180             case AB_THREADPRIVATE:
2181               attr->threadprivate = 1;
2182               break;
2183             case AB_DUMMY:
2184               attr->dummy = 1;
2185               break;
2186             case AB_RESULT:
2187               attr->result = 1;
2188               break;
2189             case AB_DATA:
2190               attr->data = 1;
2191               break;
2192             case AB_IN_NAMELIST:
2193               attr->in_namelist = 1;
2194               break;
2195             case AB_IN_COMMON:
2196               attr->in_common = 1;
2197               break;
2198             case AB_FUNCTION:
2199               attr->function = 1;
2200               break;
2201             case AB_SUBROUTINE:
2202               attr->subroutine = 1;
2203               break;
2204             case AB_GENERIC:
2205               attr->generic = 1;
2206               break;
2207             case AB_ABSTRACT:
2208               attr->abstract = 1;
2209               break;
2210             case AB_SEQUENCE:
2211               attr->sequence = 1;
2212               break;
2213             case AB_ELEMENTAL:
2214               attr->elemental = 1;
2215               break;
2216             case AB_PURE:
2217               attr->pure = 1;
2218               break;
2219             case AB_IMPLICIT_PURE:
2220               attr->implicit_pure = 1;
2221               break;
2222             case AB_UNLIMITED_POLY:
2223               attr->unlimited_polymorphic = 1;
2224               break;
2225             case AB_RECURSIVE:
2226               attr->recursive = 1;
2227               break;
2228             case AB_ALWAYS_EXPLICIT:
2229               attr->always_explicit = 1;
2230               break;
2231             case AB_CRAY_POINTER:
2232               attr->cray_pointer = 1;
2233               break;
2234             case AB_CRAY_POINTEE:
2235               attr->cray_pointee = 1;
2236               break;
2237             case AB_IS_BIND_C:
2238               attr->is_bind_c = 1;
2239               break;
2240             case AB_IS_C_INTEROP:
2241               attr->is_c_interop = 1;
2242               break;
2243             case AB_IS_ISO_C:
2244               attr->is_iso_c = 1;
2245               break;
2246             case AB_ALLOC_COMP:
2247               attr->alloc_comp = 1;
2248               break;
2249             case AB_COARRAY_COMP:
2250               attr->coarray_comp = 1;
2251               break;
2252             case AB_LOCK_COMP:
2253               attr->lock_comp = 1;
2254               break;
2255             case AB_POINTER_COMP:
2256               attr->pointer_comp = 1;
2257               break;
2258             case AB_PROC_POINTER_COMP:
2259               attr->proc_pointer_comp = 1;
2260               break;
2261             case AB_PRIVATE_COMP:
2262               attr->private_comp = 1;
2263               break;
2264             case AB_ZERO_COMP:
2265               attr->zero_comp = 1;
2266               break;
2267             case AB_IS_CLASS:
2268               attr->is_class = 1;
2269               break;
2270             case AB_PROCEDURE:
2271               attr->procedure = 1;
2272               break;
2273             case AB_PROC_POINTER:
2274               attr->proc_pointer = 1;
2275               break;
2276             case AB_VTYPE:
2277               attr->vtype = 1;
2278               break;
2279             case AB_VTAB:
2280               attr->vtab = 1;
2281               break;
2282             case AB_OMP_DECLARE_TARGET:
2283               attr->omp_declare_target = 1;
2284               break;
2285             }
2286         }
2287     }
2288 }
2289
2290
2291 static const mstring bt_types[] = {
2292     minit ("INTEGER", BT_INTEGER),
2293     minit ("REAL", BT_REAL),
2294     minit ("COMPLEX", BT_COMPLEX),
2295     minit ("LOGICAL", BT_LOGICAL),
2296     minit ("CHARACTER", BT_CHARACTER),
2297     minit ("DERIVED", BT_DERIVED),
2298     minit ("CLASS", BT_CLASS),
2299     minit ("PROCEDURE", BT_PROCEDURE),
2300     minit ("UNKNOWN", BT_UNKNOWN),
2301     minit ("VOID", BT_VOID),
2302     minit ("ASSUMED", BT_ASSUMED),
2303     minit (NULL, -1)
2304 };
2305
2306
2307 static void
2308 mio_charlen (gfc_charlen **clp)
2309 {
2310   gfc_charlen *cl;
2311
2312   mio_lparen ();
2313
2314   if (iomode == IO_OUTPUT)
2315     {
2316       cl = *clp;
2317       if (cl != NULL)
2318         mio_expr (&cl->length);
2319     }
2320   else
2321     {
2322       if (peek_atom () != ATOM_RPAREN)
2323         {
2324           cl = gfc_new_charlen (gfc_current_ns, NULL);
2325           mio_expr (&cl->length);
2326           *clp = cl;
2327         }
2328     }
2329
2330   mio_rparen ();
2331 }
2332
2333
2334 /* See if a name is a generated name.  */
2335
2336 static int
2337 check_unique_name (const char *name)
2338 {
2339   return *name == '@';
2340 }
2341
2342
2343 static void
2344 mio_typespec (gfc_typespec *ts)
2345 {
2346   mio_lparen ();
2347
2348   ts->type = MIO_NAME (bt) (ts->type, bt_types);
2349
2350   if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
2351     mio_integer (&ts->kind);
2352   else
2353     mio_symbol_ref (&ts->u.derived);
2354
2355   mio_symbol_ref (&ts->interface);
2356
2357   /* Add info for C interop and is_iso_c.  */
2358   mio_integer (&ts->is_c_interop);
2359   mio_integer (&ts->is_iso_c);
2360
2361   /* If the typespec is for an identifier either from iso_c_binding, or
2362      a constant that was initialized to an identifier from it, use the
2363      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
2364   if (ts->is_iso_c)
2365     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2366   else
2367     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2368
2369   if (ts->type != BT_CHARACTER)
2370     {
2371       /* ts->u.cl is only valid for BT_CHARACTER.  */
2372       mio_lparen ();
2373       mio_rparen ();
2374     }
2375   else
2376     mio_charlen (&ts->u.cl);
2377
2378   /* So as not to disturb the existing API, use an ATOM_NAME to
2379      transmit deferred characteristic for characters (F2003).  */
2380   if (iomode == IO_OUTPUT)
2381     {
2382       if (ts->type == BT_CHARACTER && ts->deferred)
2383         write_atom (ATOM_NAME, "DEFERRED_CL");
2384     }
2385   else if (peek_atom () != ATOM_RPAREN)
2386     {
2387       if (parse_atom () != ATOM_NAME)
2388         bad_module ("Expected string");
2389       ts->deferred = 1;
2390     }
2391
2392   mio_rparen ();
2393 }
2394
2395
2396 static const mstring array_spec_types[] = {
2397     minit ("EXPLICIT", AS_EXPLICIT),
2398     minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2399     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2400     minit ("DEFERRED", AS_DEFERRED),
2401     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2402     minit (NULL, -1)
2403 };
2404
2405
2406 static void
2407 mio_array_spec (gfc_array_spec **asp)
2408 {
2409   gfc_array_spec *as;
2410   int i;
2411
2412   mio_lparen ();
2413
2414   if (iomode == IO_OUTPUT)
2415     {
2416       int rank;
2417
2418       if (*asp == NULL)
2419         goto done;
2420       as = *asp;
2421
2422       /* mio_integer expects nonnegative values.  */
2423       rank = as->rank > 0 ? as->rank : 0;
2424       mio_integer (&rank);
2425     }
2426   else
2427     {
2428       if (peek_atom () == ATOM_RPAREN)
2429         {
2430           *asp = NULL;
2431           goto done;
2432         }
2433
2434       *asp = as = gfc_get_array_spec ();
2435       mio_integer (&as->rank);
2436     }
2437
2438   mio_integer (&as->corank);
2439   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2440
2441   if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2442     as->rank = -1;
2443   if (iomode == IO_INPUT && as->corank)
2444     as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2445
2446   if (as->rank + as->corank > 0)
2447     for (i = 0; i < as->rank + as->corank; i++)
2448       {
2449         mio_expr (&as->lower[i]);
2450         mio_expr (&as->upper[i]);
2451       }
2452
2453 done:
2454   mio_rparen ();
2455 }
2456
2457
2458 /* Given a pointer to an array reference structure (which lives in a
2459    gfc_ref structure), find the corresponding array specification
2460    structure.  Storing the pointer in the ref structure doesn't quite
2461    work when loading from a module. Generating code for an array
2462    reference also needs more information than just the array spec.  */
2463
2464 static const mstring array_ref_types[] = {
2465     minit ("FULL", AR_FULL),
2466     minit ("ELEMENT", AR_ELEMENT),
2467     minit ("SECTION", AR_SECTION),
2468     minit (NULL, -1)
2469 };
2470
2471
2472 static void
2473 mio_array_ref (gfc_array_ref *ar)
2474 {
2475   int i;
2476
2477   mio_lparen ();
2478   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2479   mio_integer (&ar->dimen);
2480
2481   switch (ar->type)
2482     {
2483     case AR_FULL:
2484       break;
2485
2486     case AR_ELEMENT:
2487       for (i = 0; i < ar->dimen; i++)
2488         mio_expr (&ar->start[i]);
2489
2490       break;
2491
2492     case AR_SECTION:
2493       for (i = 0; i < ar->dimen; i++)
2494         {
2495           mio_expr (&ar->start[i]);
2496           mio_expr (&ar->end[i]);
2497           mio_expr (&ar->stride[i]);
2498         }
2499
2500       break;
2501
2502     case AR_UNKNOWN:
2503       gfc_internal_error ("mio_array_ref(): Unknown array ref");
2504     }
2505
2506   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2507      we can't call mio_integer directly.  Instead loop over each element
2508      and cast it to/from an integer.  */
2509   if (iomode == IO_OUTPUT)
2510     {
2511       for (i = 0; i < ar->dimen; i++)
2512         {
2513           int tmp = (int)ar->dimen_type[i];
2514           write_atom (ATOM_INTEGER, &tmp);
2515         }
2516     }
2517   else
2518     {
2519       for (i = 0; i < ar->dimen; i++)
2520         {
2521           require_atom (ATOM_INTEGER);
2522           ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2523         }
2524     }
2525
2526   if (iomode == IO_INPUT)
2527     {
2528       ar->where = gfc_current_locus;
2529
2530       for (i = 0; i < ar->dimen; i++)
2531         ar->c_where[i] = gfc_current_locus;
2532     }
2533
2534   mio_rparen ();
2535 }
2536
2537
2538 /* Saves or restores a pointer.  The pointer is converted back and
2539    forth from an integer.  We return the pointer_info pointer so that
2540    the caller can take additional action based on the pointer type.  */
2541
2542 static pointer_info *
2543 mio_pointer_ref (void *gp)
2544 {
2545   pointer_info *p;
2546
2547   if (iomode == IO_OUTPUT)
2548     {
2549       p = get_pointer (*((char **) gp));
2550       write_atom (ATOM_INTEGER, &p->integer);
2551     }
2552   else
2553     {
2554       require_atom (ATOM_INTEGER);
2555       p = add_fixup (atom_int, gp);
2556     }
2557
2558   return p;
2559 }
2560
2561
2562 /* Save and load references to components that occur within
2563    expressions.  We have to describe these references by a number and
2564    by name.  The number is necessary for forward references during
2565    reading, and the name is necessary if the symbol already exists in
2566    the namespace and is not loaded again.  */
2567
2568 static void
2569 mio_component_ref (gfc_component **cp)
2570 {
2571   pointer_info *p;
2572
2573   p = mio_pointer_ref (cp);
2574   if (p->type == P_UNKNOWN)
2575     p->type = P_COMPONENT;
2576 }
2577
2578
2579 static void mio_namespace_ref (gfc_namespace **nsp);
2580 static void mio_formal_arglist (gfc_formal_arglist **formal);
2581 static void mio_typebound_proc (gfc_typebound_proc** proc);
2582
2583 static void
2584 mio_component (gfc_component *c, int vtype)
2585 {
2586   pointer_info *p;
2587   int n;
2588
2589   mio_lparen ();
2590
2591   if (iomode == IO_OUTPUT)
2592     {
2593       p = get_pointer (c);
2594       mio_integer (&p->integer);
2595     }
2596   else
2597     {
2598       mio_integer (&n);
2599       p = get_integer (n);
2600       associate_integer_pointer (p, c);
2601     }
2602
2603   if (p->type == P_UNKNOWN)
2604     p->type = P_COMPONENT;
2605
2606   mio_pool_string (&c->name);
2607   mio_typespec (&c->ts);
2608   mio_array_spec (&c->as);
2609
2610   mio_symbol_attribute (&c->attr);
2611   if (c->ts.type == BT_CLASS)
2612     c->attr.class_ok = 1;
2613   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2614
2615   if (!vtype || strcmp (c->name, "_final") == 0
2616       || strcmp (c->name, "_hash") == 0)
2617     mio_expr (&c->initializer);
2618
2619   if (c->attr.proc_pointer)
2620     mio_typebound_proc (&c->tb);
2621
2622   mio_rparen ();
2623 }
2624
2625
2626 static void
2627 mio_component_list (gfc_component **cp, int vtype)
2628 {
2629   gfc_component *c, *tail;
2630
2631   mio_lparen ();
2632
2633   if (iomode == IO_OUTPUT)
2634     {
2635       for (c = *cp; c; c = c->next)
2636         mio_component (c, vtype);
2637     }
2638   else
2639     {
2640       *cp = NULL;
2641       tail = NULL;
2642
2643       for (;;)
2644         {
2645           if (peek_atom () == ATOM_RPAREN)
2646             break;
2647
2648           c = gfc_get_component ();
2649           mio_component (c, vtype);
2650
2651           if (tail == NULL)
2652             *cp = c;
2653           else
2654             tail->next = c;
2655
2656           tail = c;
2657         }
2658     }
2659
2660   mio_rparen ();
2661 }
2662
2663
2664 static void
2665 mio_actual_arg (gfc_actual_arglist *a)
2666 {
2667   mio_lparen ();
2668   mio_pool_string (&a->name);
2669   mio_expr (&a->expr);
2670   mio_rparen ();
2671 }
2672
2673
2674 static void
2675 mio_actual_arglist (gfc_actual_arglist **ap)
2676 {
2677   gfc_actual_arglist *a, *tail;
2678
2679   mio_lparen ();
2680
2681   if (iomode == IO_OUTPUT)
2682     {
2683       for (a = *ap; a; a = a->next)
2684         mio_actual_arg (a);
2685
2686     }
2687   else
2688     {
2689       tail = NULL;
2690
2691       for (;;)
2692         {
2693           if (peek_atom () != ATOM_LPAREN)
2694             break;
2695
2696           a = gfc_get_actual_arglist ();
2697
2698           if (tail == NULL)
2699             *ap = a;
2700           else
2701             tail->next = a;
2702
2703           tail = a;
2704           mio_actual_arg (a);
2705         }
2706     }
2707
2708   mio_rparen ();
2709 }
2710
2711
2712 /* Read and write formal argument lists.  */
2713
2714 static void
2715 mio_formal_arglist (gfc_formal_arglist **formal)
2716 {
2717   gfc_formal_arglist *f, *tail;
2718
2719   mio_lparen ();
2720
2721   if (iomode == IO_OUTPUT)
2722     {
2723       for (f = *formal; f; f = f->next)
2724         mio_symbol_ref (&f->sym);
2725     }
2726   else
2727     {
2728       *formal = tail = NULL;
2729
2730       while (peek_atom () != ATOM_RPAREN)
2731         {
2732           f = gfc_get_formal_arglist ();
2733           mio_symbol_ref (&f->sym);
2734
2735           if (*formal == NULL)
2736             *formal = f;
2737           else
2738             tail->next = f;
2739
2740           tail = f;
2741         }
2742     }
2743
2744   mio_rparen ();
2745 }
2746
2747
2748 /* Save or restore a reference to a symbol node.  */
2749
2750 pointer_info *
2751 mio_symbol_ref (gfc_symbol **symp)
2752 {
2753   pointer_info *p;
2754
2755   p = mio_pointer_ref (symp);
2756   if (p->type == P_UNKNOWN)
2757     p->type = P_SYMBOL;
2758
2759   if (iomode == IO_OUTPUT)
2760     {
2761       if (p->u.wsym.state == UNREFERENCED)
2762         p->u.wsym.state = NEEDS_WRITE;
2763     }
2764   else
2765     {
2766       if (p->u.rsym.state == UNUSED)
2767         p->u.rsym.state = NEEDED;
2768     }
2769   return p;
2770 }
2771
2772
2773 /* Save or restore a reference to a symtree node.  */
2774
2775 static void
2776 mio_symtree_ref (gfc_symtree **stp)
2777 {
2778   pointer_info *p;
2779   fixup_t *f;
2780
2781   if (iomode == IO_OUTPUT)
2782     mio_symbol_ref (&(*stp)->n.sym);
2783   else
2784     {
2785       require_atom (ATOM_INTEGER);
2786       p = get_integer (atom_int);
2787
2788       /* An unused equivalence member; make a symbol and a symtree
2789          for it.  */
2790       if (in_load_equiv && p->u.rsym.symtree == NULL)
2791         {
2792           /* Since this is not used, it must have a unique name.  */
2793           p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2794
2795           /* Make the symbol.  */
2796           if (p->u.rsym.sym == NULL)
2797             {
2798               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2799                                               gfc_current_ns);
2800               p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2801             }
2802
2803           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2804           p->u.rsym.symtree->n.sym->refs++;
2805           p->u.rsym.referenced = 1;
2806
2807           /* If the symbol is PRIVATE and in COMMON, load_commons will
2808              generate a fixup symbol, which must be associated.  */
2809           if (p->fixup)
2810             resolve_fixups (p->fixup, p->u.rsym.sym);
2811           p->fixup = NULL;
2812         }
2813
2814       if (p->type == P_UNKNOWN)
2815         p->type = P_SYMBOL;
2816
2817       if (p->u.rsym.state == UNUSED)
2818         p->u.rsym.state = NEEDED;
2819
2820       if (p->u.rsym.symtree != NULL)
2821         {
2822           *stp = p->u.rsym.symtree;
2823         }
2824       else
2825         {
2826           f = XCNEW (fixup_t);
2827
2828           f->next = p->u.rsym.stfixup;
2829           p->u.rsym.stfixup = f;
2830
2831           f->pointer = (void **) stp;
2832         }
2833     }
2834 }
2835
2836
2837 static void
2838 mio_iterator (gfc_iterator **ip)
2839 {
2840   gfc_iterator *iter;
2841
2842   mio_lparen ();
2843
2844   if (iomode == IO_OUTPUT)
2845     {
2846       if (*ip == NULL)
2847         goto done;
2848     }
2849   else
2850     {
2851       if (peek_atom () == ATOM_RPAREN)
2852         {
2853           *ip = NULL;
2854           goto done;
2855         }
2856
2857       *ip = gfc_get_iterator ();
2858     }
2859
2860   iter = *ip;
2861
2862   mio_expr (&iter->var);
2863   mio_expr (&iter->start);
2864   mio_expr (&iter->end);
2865   mio_expr (&iter->step);
2866
2867 done:
2868   mio_rparen ();
2869 }
2870
2871
2872 static void
2873 mio_constructor (gfc_constructor_base *cp)
2874 {
2875   gfc_constructor *c;
2876
2877   mio_lparen ();
2878
2879   if (iomode == IO_OUTPUT)
2880     {
2881       for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
2882         {
2883           mio_lparen ();
2884           mio_expr (&c->expr);
2885           mio_iterator (&c->iterator);
2886           mio_rparen ();
2887         }
2888     }
2889   else
2890     {
2891       while (peek_atom () != ATOM_RPAREN)
2892         {
2893           c = gfc_constructor_append_expr (cp, NULL, NULL);
2894
2895           mio_lparen ();
2896           mio_expr (&c->expr);
2897           mio_iterator (&c->iterator);
2898           mio_rparen ();
2899         }
2900     }
2901
2902   mio_rparen ();
2903 }
2904
2905
2906 static const mstring ref_types[] = {
2907     minit ("ARRAY", REF_ARRAY),
2908     minit ("COMPONENT", REF_COMPONENT),
2909     minit ("SUBSTRING", REF_SUBSTRING),
2910     minit (NULL, -1)
2911 };
2912
2913
2914 static void
2915 mio_ref (gfc_ref **rp)
2916 {
2917   gfc_ref *r;
2918
2919   mio_lparen ();
2920
2921   r = *rp;
2922   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2923
2924   switch (r->type)
2925     {
2926     case REF_ARRAY:
2927       mio_array_ref (&r->u.ar);
2928       break;
2929
2930     case REF_COMPONENT:
2931       mio_symbol_ref (&r->u.c.sym);
2932       mio_component_ref (&r->u.c.component);
2933       break;
2934
2935     case REF_SUBSTRING:
2936       mio_expr (&r->u.ss.start);
2937       mio_expr (&r->u.ss.end);
2938       mio_charlen (&r->u.ss.length);
2939       break;
2940     }
2941
2942   mio_rparen ();
2943 }
2944
2945
2946 static void
2947 mio_ref_list (gfc_ref **rp)
2948 {
2949   gfc_ref *ref, *head, *tail;
2950
2951   mio_lparen ();
2952
2953   if (iomode == IO_OUTPUT)
2954     {
2955       for (ref = *rp; ref; ref = ref->next)
2956         mio_ref (&ref);
2957     }
2958   else
2959     {
2960       head = tail = NULL;
2961
2962       while (peek_atom () != ATOM_RPAREN)
2963         {
2964           if (head == NULL)
2965             head = tail = gfc_get_ref ();
2966           else
2967             {
2968               tail->next = gfc_get_ref ();
2969               tail = tail->next;
2970             }
2971
2972           mio_ref (&tail);
2973         }
2974
2975       *rp = head;
2976     }
2977
2978   mio_rparen ();
2979 }
2980
2981
2982 /* Read and write an integer value.  */
2983
2984 static void
2985 mio_gmp_integer (mpz_t *integer)
2986 {
2987   char *p;
2988
2989   if (iomode == IO_INPUT)
2990     {
2991       if (parse_atom () != ATOM_STRING)
2992         bad_module ("Expected integer string");
2993
2994       mpz_init (*integer);
2995       if (mpz_set_str (*integer, atom_string, 10))
2996         bad_module ("Error converting integer");
2997
2998       free (atom_string);
2999     }
3000   else
3001     {
3002       p = mpz_get_str (NULL, 10, *integer);
3003       write_atom (ATOM_STRING, p);
3004       free (p);
3005     }
3006 }
3007
3008
3009 static void
3010 mio_gmp_real (mpfr_t *real)
3011 {
3012   mp_exp_t exponent;
3013   char *p;
3014
3015   if (iomode == IO_INPUT)
3016     {
3017       if (parse_atom () != ATOM_STRING)
3018         bad_module ("Expected real string");
3019
3020       mpfr_init (*real);
3021       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3022       free (atom_string);
3023     }
3024   else
3025     {
3026       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3027
3028       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3029         {
3030           write_atom (ATOM_STRING, p);
3031           free (p);
3032           return;
3033         }
3034
3035       atom_string = XCNEWVEC (char, strlen (p) + 20);
3036
3037       sprintf (atom_string, "0.%s@%ld", p, exponent);
3038
3039       /* Fix negative numbers.  */
3040       if (atom_string[2] == '-')
3041         {
3042           atom_string[0] = '-';
3043           atom_string[1] = '0';
3044           atom_string[2] = '.';
3045         }
3046
3047       write_atom (ATOM_STRING, atom_string);
3048
3049       free (atom_string);
3050       free (p);
3051     }
3052 }
3053
3054
3055 /* Save and restore the shape of an array constructor.  */
3056
3057 static void
3058 mio_shape (mpz_t **pshape, int rank)
3059 {
3060   mpz_t *shape;
3061   atom_type t;
3062   int n;
3063
3064   /* A NULL shape is represented by ().  */
3065   mio_lparen ();
3066
3067   if (iomode == IO_OUTPUT)
3068     {
3069       shape = *pshape;
3070       if (!shape)
3071         {
3072           mio_rparen ();
3073           return;
3074         }
3075     }
3076   else
3077     {
3078       t = peek_atom ();
3079       if (t == ATOM_RPAREN)
3080         {
3081           *pshape = NULL;
3082           mio_rparen ();
3083           return;
3084         }
3085
3086       shape = gfc_get_shape (rank);
3087       *pshape = shape;
3088     }
3089
3090   for (n = 0; n < rank; n++)
3091     mio_gmp_integer (&shape[n]);
3092
3093   mio_rparen ();
3094 }
3095
3096
3097 static const mstring expr_types[] = {
3098     minit ("OP", EXPR_OP),
3099     minit ("FUNCTION", EXPR_FUNCTION),
3100     minit ("CONSTANT", EXPR_CONSTANT),
3101     minit ("VARIABLE", EXPR_VARIABLE),
3102     minit ("SUBSTRING", EXPR_SUBSTRING),
3103     minit ("STRUCTURE", EXPR_STRUCTURE),
3104     minit ("ARRAY", EXPR_ARRAY),
3105     minit ("NULL", EXPR_NULL),
3106     minit ("COMPCALL", EXPR_COMPCALL),
3107     minit (NULL, -1)
3108 };
3109
3110 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3111    generic operators, not in expressions.  INTRINSIC_USER is also
3112    replaced by the correct function name by the time we see it.  */
3113
3114 static const mstring intrinsics[] =
3115 {
3116     minit ("UPLUS", INTRINSIC_UPLUS),
3117     minit ("UMINUS", INTRINSIC_UMINUS),
3118     minit ("PLUS", INTRINSIC_PLUS),
3119     minit ("MINUS", INTRINSIC_MINUS),
3120     minit ("TIMES", INTRINSIC_TIMES),
3121     minit ("DIVIDE", INTRINSIC_DIVIDE),
3122     minit ("POWER", INTRINSIC_POWER),
3123     minit ("CONCAT", INTRINSIC_CONCAT),
3124     minit ("AND", INTRINSIC_AND),
3125     minit ("OR", INTRINSIC_OR),
3126     minit ("EQV", INTRINSIC_EQV),
3127     minit ("NEQV", INTRINSIC_NEQV),
3128     minit ("EQ_SIGN", INTRINSIC_EQ),
3129     minit ("EQ", INTRINSIC_EQ_OS),
3130     minit ("NE_SIGN", INTRINSIC_NE),
3131     minit ("NE", INTRINSIC_NE_OS),
3132     minit ("GT_SIGN", INTRINSIC_GT),
3133     minit ("GT", INTRINSIC_GT_OS),
3134     minit ("GE_SIGN", INTRINSIC_GE),
3135     minit ("GE", INTRINSIC_GE_OS),
3136     minit ("LT_SIGN", INTRINSIC_LT),
3137     minit ("LT", INTRINSIC_LT_OS),
3138     minit ("LE_SIGN", INTRINSIC_LE),
3139     minit ("LE", INTRINSIC_LE_OS),
3140     minit ("NOT", INTRINSIC_NOT),
3141     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3142     minit ("USER", INTRINSIC_USER),
3143     minit (NULL, -1)
3144 };
3145
3146
3147 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
3148
3149 static void
3150 fix_mio_expr (gfc_expr *e)
3151 {
3152   gfc_symtree *ns_st = NULL;
3153   const char *fname;
3154
3155   if (iomode != IO_OUTPUT)
3156     return;
3157
3158   if (e->symtree)
3159     {
3160       /* If this is a symtree for a symbol that came from a contained module
3161          namespace, it has a unique name and we should look in the current
3162          namespace to see if the required, non-contained symbol is available
3163          yet. If so, the latter should be written.  */
3164       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3165         {
3166           const char *name = e->symtree->n.sym->name;
3167           if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
3168             name = dt_upper_string (name);
3169           ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3170         }
3171
3172       /* On the other hand, if the existing symbol is the module name or the
3173          new symbol is a dummy argument, do not do the promotion.  */
3174       if (ns_st && ns_st->n.sym
3175           && ns_st->n.sym->attr.flavor != FL_MODULE
3176           && !e->symtree->n.sym->attr.dummy)
3177         e->symtree = ns_st;
3178     }
3179   else if (e->expr_type == EXPR_FUNCTION
3180            && (e->value.function.name || e->value.function.isym))
3181     {
3182       gfc_symbol *sym;
3183
3184       /* In some circumstances, a function used in an initialization
3185          expression, in one use associated module, can fail to be
3186          coupled to its symtree when used in a specification
3187          expression in another module.  */
3188       fname = e->value.function.esym ? e->value.function.esym->name
3189                                      : e->value.function.isym->name;
3190       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3191
3192       if (e->symtree)
3193         return;
3194
3195       /* This is probably a reference to a private procedure from another
3196          module.  To prevent a segfault, make a generic with no specific
3197          instances.  If this module is used, without the required
3198          specific coming from somewhere, the appropriate error message
3199          is issued.  */
3200       gfc_get_symbol (fname, gfc_current_ns, &sym);
3201       sym->attr.flavor = FL_PROCEDURE;
3202       sym->attr.generic = 1;
3203       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3204       gfc_commit_symbol (sym);
3205     }
3206 }
3207
3208
3209 /* Read and write expressions.  The form "()" is allowed to indicate a
3210    NULL expression.  */
3211
3212 static void
3213 mio_expr (gfc_expr **ep)
3214 {
3215   gfc_expr *e;
3216   atom_type t;
3217   int flag;
3218
3219   mio_lparen ();
3220
3221   if (iomode == IO_OUTPUT)
3222     {
3223       if (*ep == NULL)
3224         {
3225           mio_rparen ();
3226           return;
3227         }
3228
3229       e = *ep;
3230       MIO_NAME (expr_t) (e->expr_type, expr_types);
3231     }
3232   else
3233     {
3234       t = parse_atom ();
3235       if (t == ATOM_RPAREN)
3236         {
3237           *ep = NULL;
3238           return;
3239         }
3240
3241       if (t != ATOM_NAME)
3242         bad_module ("Expected expression type");
3243
3244       e = *ep = gfc_get_expr ();
3245       e->where = gfc_current_locus;
3246       e->expr_type = (expr_t) find_enum (expr_types);
3247     }
3248
3249   mio_typespec (&e->ts);
3250   mio_integer (&e->rank);
3251
3252   fix_mio_expr (e);
3253
3254   switch (e->expr_type)
3255     {
3256     case EXPR_OP:
3257       e->value.op.op
3258         = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3259
3260       switch (e->value.op.op)
3261         {
3262         case INTRINSIC_UPLUS:
3263         case INTRINSIC_UMINUS:
3264         case INTRINSIC_NOT:
3265         case INTRINSIC_PARENTHESES:
3266           mio_expr (&e->value.op.op1);
3267           break;
3268
3269         case INTRINSIC_PLUS:
3270         case INTRINSIC_MINUS:
3271         case INTRINSIC_TIMES:
3272         case INTRINSIC_DIVIDE:
3273         case INTRINSIC_POWER:
3274         case INTRINSIC_CONCAT:
3275         case INTRINSIC_AND:
3276         case INTRINSIC_OR:
3277         case INTRINSIC_EQV:
3278         case INTRINSIC_NEQV:
3279         case INTRINSIC_EQ:
3280         case INTRINSIC_EQ_OS:
3281         case INTRINSIC_NE:
3282         case INTRINSIC_NE_OS:
3283         case INTRINSIC_GT:
3284         case INTRINSIC_GT_OS:
3285         case INTRINSIC_GE:
3286         case INTRINSIC_GE_OS:
3287         case INTRINSIC_LT:
3288         case INTRINSIC_LT_OS:
3289         case INTRINSIC_LE:
3290         case INTRINSIC_LE_OS:
3291           mio_expr (&e->value.op.op1);
3292           mio_expr (&e->value.op.op2);
3293           break;
3294
3295         case INTRINSIC_USER:
3296           /* INTRINSIC_USER should not appear in resolved expressions,
3297              though for UDRs we need to stream unresolved ones.  */
3298           if (iomode == IO_OUTPUT)
3299             write_atom (ATOM_STRING, e->value.op.uop->name);
3300           else
3301             {
3302               char *name = read_string ();
3303               const char *uop_name = find_use_name (name, true);
3304               if (uop_name == NULL)
3305                 {
3306                   size_t len = strlen (name);
3307                   char *name2 = XCNEWVEC (char, len + 2);
3308                   memcpy (name2, name, len);
3309                   name2[len] = ' ';
3310                   name2[len + 1] = '\0';
3311                   free (name);
3312                   uop_name = name = name2;
3313                 }
3314               e->value.op.uop = gfc_get_uop (uop_name);
3315               free (name);
3316             }
3317           mio_expr (&e->value.op.op1);
3318           mio_expr (&e->value.op.op2);
3319           break;
3320
3321         default:
3322           bad_module ("Bad operator");
3323         }
3324
3325       break;
3326
3327     case EXPR_FUNCTION:
3328       mio_symtree_ref (&e->symtree);
3329       mio_actual_arglist (&e->value.function.actual);
3330
3331       if (iomode == IO_OUTPUT)
3332         {
3333           e->value.function.name
3334             = mio_allocated_string (e->value.function.name);
3335           if (e->value.function.esym)
3336             flag = 1;
3337           else if (e->ref)
3338             flag = 2;
3339           else if (e->value.function.isym == NULL)
3340             flag = 3;
3341           else
3342             flag = 0;
3343           mio_integer (&flag);
3344           switch (flag)
3345             {
3346             case 1:
3347               mio_symbol_ref (&e->value.function.esym);
3348               break;
3349             case 2:
3350               mio_ref_list (&e->ref);
3351               break;
3352             case 3:
3353               break;
3354             default:
3355               write_atom (ATOM_STRING, e->value.function.isym->name);
3356             }
3357         }
3358       else
3359         {
3360           require_atom (ATOM_STRING);
3361           if (atom_string[0] == '\0')
3362             e->value.function.name = NULL;
3363           else
3364             e->value.function.name = gfc_get_string (atom_string);
3365           free (atom_string);
3366
3367           mio_integer (&flag);
3368           switch (flag)
3369             {
3370             case 1:
3371               mio_symbol_ref (&e->value.function.esym);
3372               break;
3373             case 2:
3374               mio_ref_list (&e->ref);
3375               break;
3376             case 3:
3377               break;
3378             default:
3379               require_atom (ATOM_STRING);
3380               e->value.function.isym = gfc_find_function (atom_string);
3381               free (atom_string);
3382             }
3383         }
3384
3385       break;
3386
3387     case EXPR_VARIABLE:
3388       mio_symtree_ref (&e->symtree);
3389       mio_ref_list (&e->ref);
3390       break;
3391
3392     case EXPR_SUBSTRING:
3393       e->value.character.string
3394         = CONST_CAST (gfc_char_t *,
3395                       mio_allocated_wide_string (e->value.character.string,
3396                                                  e->value.character.length));
3397       mio_ref_list (&e->ref);
3398       break;
3399
3400     case EXPR_STRUCTURE:
3401     case EXPR_ARRAY:
3402       mio_constructor (&e->value.constructor);
3403       mio_shape (&e->shape, e->rank);
3404       break;
3405
3406     case EXPR_CONSTANT:
3407       switch (e->ts.type)
3408         {
3409         case BT_INTEGER:
3410           mio_gmp_integer (&e->value.integer);
3411           break;
3412
3413         case BT_REAL:
3414           gfc_set_model_kind (e->ts.kind);
3415           mio_gmp_real (&e->value.real);
3416           break;
3417
3418         case BT_COMPLEX:
3419           gfc_set_model_kind (e->ts.kind);
3420           mio_gmp_real (&mpc_realref (e->value.complex));
3421           mio_gmp_real (&mpc_imagref (e->value.complex));
3422           break;
3423
3424         case BT_LOGICAL:
3425           mio_integer (&e->value.logical);
3426           break;
3427
3428         case BT_CHARACTER:
3429           mio_integer (&e->value.character.length);
3430           e->value.character.string
3431             = CONST_CAST (gfc_char_t *,
3432                           mio_allocated_wide_string (e->value.character.string,
3433                                                      e->value.character.length));
3434           break;
3435
3436         default:
3437           bad_module ("Bad type in constant expression");
3438         }
3439
3440       break;
3441
3442     case EXPR_NULL:
3443       break;
3444
3445     case EXPR_COMPCALL:
3446     case EXPR_PPC:
3447       gcc_unreachable ();
3448       break;
3449     }
3450
3451   mio_rparen ();
3452 }
3453
3454
3455 /* Read and write namelists.  */
3456
3457 static void
3458 mio_namelist (gfc_symbol *sym)
3459 {
3460   gfc_namelist *n, *m;
3461   const char *check_name;
3462
3463   mio_lparen ();
3464
3465   if (iomode == IO_OUTPUT)
3466     {
3467       for (n = sym->namelist; n; n = n->next)
3468         mio_symbol_ref (&n->sym);
3469     }
3470   else
3471     {
3472       /* This departure from the standard is flagged as an error.
3473          It does, in fact, work correctly. TODO: Allow it
3474          conditionally?  */
3475       if (sym->attr.flavor == FL_NAMELIST)
3476         {
3477           check_name = find_use_name (sym->name, false);
3478           if (check_name && strcmp (check_name, sym->name) != 0)
3479             gfc_error ("Namelist %s cannot be renamed by USE "
3480                        "association to %s", sym->name, check_name);
3481         }
3482
3483       m = NULL;
3484       while (peek_atom () != ATOM_RPAREN)
3485         {
3486           n = gfc_get_namelist ();
3487           mio_symbol_ref (&n->sym);
3488
3489           if (sym->namelist == NULL)
3490             sym->namelist = n;
3491           else
3492             m->next = n;
3493
3494           m = n;
3495         }
3496       sym->namelist_tail = m;
3497     }
3498
3499   mio_rparen ();
3500 }
3501
3502
3503 /* Save/restore lists of gfc_interface structures.  When loading an
3504    interface, we are really appending to the existing list of
3505    interfaces.  Checking for duplicate and ambiguous interfaces has to
3506    be done later when all symbols have been loaded.  */
3507
3508 pointer_info *
3509 mio_interface_rest (gfc_interface **ip)
3510 {
3511   gfc_interface *tail, *p;
3512   pointer_info *pi = NULL;
3513
3514   if (iomode == IO_OUTPUT)
3515     {
3516       if (ip != NULL)
3517         for (p = *ip; p; p = p->next)
3518           mio_symbol_ref (&p->sym);
3519     }
3520   else
3521     {
3522       if (*ip == NULL)
3523         tail = NULL;
3524       else
3525         {
3526           tail = *ip;
3527           while (tail->next)
3528             tail = tail->next;
3529         }
3530
3531       for (;;)
3532         {
3533           if (peek_atom () == ATOM_RPAREN)
3534             break;
3535
3536           p = gfc_get_interface ();
3537           p->where = gfc_current_locus;
3538           pi = mio_symbol_ref (&p->sym);
3539
3540           if (tail == NULL)
3541             *ip = p;
3542           else
3543             tail->next = p;
3544
3545           tail = p;
3546         }
3547     }
3548
3549   mio_rparen ();
3550   return pi;
3551 }
3552
3553
3554 /* Save/restore a nameless operator interface.  */
3555
3556 static void
3557 mio_interface (gfc_interface **ip)
3558 {
3559   mio_lparen ();
3560   mio_interface_rest (ip);
3561 }
3562
3563
3564 /* Save/restore a named operator interface.  */
3565
3566 static void
3567 mio_symbol_interface (const char **name, const char **module,
3568                       gfc_interface **ip)
3569 {
3570   mio_lparen ();
3571   mio_pool_string (name);
3572   mio_pool_string (module);
3573   mio_interface_rest (ip);
3574 }
3575
3576
3577 static void
3578 mio_namespace_ref (gfc_namespace **nsp)
3579 {
3580   gfc_namespace *ns;
3581   pointer_info *p;
3582
3583   p = mio_pointer_ref (nsp);
3584
3585   if (p->type == P_UNKNOWN)
3586     p->type = P_NAMESPACE;
3587
3588   if (iomode == IO_INPUT && p->integer != 0)
3589     {
3590       ns = (gfc_namespace *) p->u.pointer;
3591       if (ns == NULL)
3592         {
3593           ns = gfc_get_namespace (NULL, 0);
3594           associate_integer_pointer (p, ns);
3595         }
3596       else
3597         ns->refs++;
3598     }
3599 }
3600
3601
3602 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
3603
3604 static gfc_namespace* current_f2k_derived;
3605
3606 static void
3607 mio_typebound_proc (gfc_typebound_proc** proc)
3608 {
3609   int flag;
3610   int overriding_flag;
3611
3612   if (iomode == IO_INPUT)
3613     {
3614       *proc = gfc_get_typebound_proc (NULL);
3615       (*proc)->where = gfc_current_locus;
3616     }
3617   gcc_assert (*proc);
3618
3619   mio_lparen ();
3620
3621   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3622
3623   /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
3624   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3625   overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3626   overriding_flag = mio_name (overriding_flag, binding_overriding);
3627   (*proc)->deferred = ((overriding_flag & 2) != 0);
3628   (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3629   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3630
3631   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3632   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3633   (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3634
3635   mio_pool_string (&((*proc)->pass_arg));
3636
3637   flag = (int) (*proc)->pass_arg_num;
3638   mio_integer (&flag);
3639   (*proc)->pass_arg_num = (unsigned) flag;
3640
3641   if ((*proc)->is_generic)
3642     {
3643       gfc_tbp_generic* g;
3644       int iop;
3645
3646       mio_lparen ();
3647
3648       if (iomode == IO_OUTPUT)
3649         for (g = (*proc)->u.generic; g; g = g->next)
3650           {
3651             iop = (int) g->is_operator;
3652             mio_integer (&iop);
3653             mio_allocated_string (g->specific_st->name);
3654           }
3655       else
3656         {
3657           (*proc)->u.generic = NULL;
3658           while (peek_atom () != ATOM_RPAREN)
3659             {
3660               gfc_symtree** sym_root;
3661
3662               g = gfc_get_tbp_generic ();
3663               g->specific = NULL;
3664
3665               mio_integer (&iop);
3666               g->is_operator = (bool) iop;
3667
3668               require_atom (ATOM_STRING);
3669               sym_root = &current_f2k_derived->tb_sym_root;
3670               g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3671               free (atom_string);
3672
3673               g->next = (*proc)->u.generic;
3674               (*proc)->u.generic = g;
3675             }
3676         }
3677
3678       mio_rparen ();
3679     }
3680   else if (!(*proc)->ppc)
3681     mio_symtree_ref (&(*proc)->u.specific);
3682
3683   mio_rparen ();
3684 }
3685
3686 /* Walker-callback function for this purpose.  */
3687 static void
3688 mio_typebound_symtree (gfc_symtree* st)
3689 {
3690   if (iomode == IO_OUTPUT && !st->n.tb)
3691     return;
3692
3693   if (iomode == IO_OUTPUT)
3694     {
3695       mio_lparen ();
3696       mio_allocated_string (st->name);
3697     }
3698   /* For IO_INPUT, the above is done in mio_f2k_derived.  */
3699
3700   mio_typebound_proc (&st->n.tb);
3701   mio_rparen ();
3702 }
3703
3704 /* IO a full symtree (in all depth).  */
3705 static void
3706 mio_full_typebound_tree (gfc_symtree** root)
3707 {
3708   mio_lparen ();
3709
3710   if (iomode == IO_OUTPUT)
3711     gfc_traverse_symtree (*root, &mio_typebound_symtree);
3712   else
3713     {
3714       while (peek_atom () == ATOM_LPAREN)
3715         {
3716           gfc_symtree* st;
3717
3718           mio_lparen ();
3719
3720           require_atom (ATOM_STRING);
3721           st = gfc_get_tbp_symtree (root, atom_string);
3722           free (atom_string);
3723
3724           mio_typebound_symtree (st);
3725         }
3726     }
3727
3728   mio_rparen ();
3729 }
3730
3731 static void
3732 mio_finalizer (gfc_finalizer **f)
3733 {
3734   if (iomode == IO_OUTPUT)
3735     {
3736       gcc_assert (*f);
3737       gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
3738       mio_symtree_ref (&(*f)->proc_tree);
3739     }
3740   else
3741     {
3742       *f = gfc_get_finalizer ();
3743       (*f)->where = gfc_current_locus; /* Value should not matter.  */
3744       (*f)->next = NULL;
3745
3746       mio_symtree_ref (&(*f)->proc_tree);
3747       (*f)->proc_sym = NULL;
3748     }
3749 }
3750
3751 static void
3752 mio_f2k_derived (gfc_namespace *f2k)
3753 {
3754   current_f2k_derived = f2k;
3755
3756   /* Handle the list of finalizer procedures.  */
3757   mio_lparen ();
3758   if (iomode == IO_OUTPUT)
3759     {
3760       gfc_finalizer *f;
3761       for (f = f2k->finalizers; f; f = f->next)
3762         mio_finalizer (&f);
3763     }
3764   else
3765     {
3766       f2k->finalizers = NULL;
3767       while (peek_atom () != ATOM_RPAREN)
3768         {
3769           gfc_finalizer *cur = NULL;
3770           mio_finalizer (&cur);
3771           cur->next = f2k->finalizers;
3772           f2k->finalizers = cur;
3773         }
3774     }
3775   mio_rparen ();
3776
3777   /* Handle type-bound procedures.  */
3778   mio_full_typebound_tree (&f2k->tb_sym_root);
3779
3780   /* Type-bound user operators.  */
3781   mio_full_typebound_tree (&f2k->tb_uop_root);
3782
3783   /* Type-bound intrinsic operators.  */
3784   mio_lparen ();
3785   if (iomode == IO_OUTPUT)
3786     {
3787       int op;
3788       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
3789         {
3790           gfc_intrinsic_op realop;
3791
3792           if (op == INTRINSIC_USER || !f2k->tb_op[op])
3793             continue;
3794
3795           mio_lparen ();
3796           realop = (gfc_intrinsic_op) op;
3797           mio_intrinsic_op (&realop);
3798           mio_typebound_proc (&f2k->tb_op[op]);
3799           mio_rparen ();
3800         }
3801     }
3802   else
3803     while (peek_atom () != ATOM_RPAREN)
3804       {
3805         gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
3806
3807         mio_lparen ();
3808         mio_intrinsic_op (&op);
3809         mio_typebound_proc (&f2k->tb_op[op]);
3810         mio_rparen ();
3811       }
3812   mio_rparen ();
3813 }
3814
3815 static void
3816 mio_full_f2k_derived (gfc_symbol *sym)
3817 {
3818   mio_lparen ();
3819
3820   if (iomode == IO_OUTPUT)
3821     {
3822       if (sym->f2k_derived)
3823         mio_f2k_derived (sym->f2k_derived);
3824     }
3825   else
3826     {
3827       if (peek_atom () != ATOM_RPAREN)
3828         {
3829           sym->f2k_derived = gfc_get_namespace (NULL, 0);
3830           mio_f2k_derived (sym->f2k_derived);
3831         }
3832       else
3833         gcc_assert (!sym->f2k_derived);
3834     }
3835
3836   mio_rparen ();
3837 }
3838
3839 static const mstring omp_declare_simd_clauses[] =
3840 {
3841     minit ("INBRANCH", 0),
3842     minit ("NOTINBRANCH", 1),
3843     minit ("SIMDLEN", 2),
3844     minit ("UNIFORM", 3),
3845     minit ("LINEAR", 4),
3846     minit ("ALIGNED", 5),
3847     minit (NULL, -1)
3848 };
3849
3850 /* Handle !$omp declare simd.  */
3851
3852 static void
3853 mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
3854 {
3855   if (iomode == IO_OUTPUT)
3856     {
3857       if (*odsp == NULL)
3858         return;
3859     }
3860   else if (peek_atom () != ATOM_LPAREN)
3861     return;
3862
3863   gfc_omp_declare_simd *ods = *odsp;
3864
3865   mio_lparen ();
3866   if (iomode == IO_OUTPUT)
3867     {
3868       write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
3869       if (ods->clauses)
3870         {
3871           gfc_omp_namelist *n;
3872
3873           if (ods->clauses->inbranch)
3874             mio_name (0, omp_declare_simd_clauses);
3875           if (ods->clauses->notinbranch)
3876             mio_name (1, omp_declare_simd_clauses);
3877           if (ods->clauses->simdlen_expr)
3878             {
3879               mio_name (2, omp_declare_simd_clauses);
3880               mio_expr (&ods->clauses->simdlen_expr);
3881             }
3882           for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
3883             {
3884               mio_name (3, omp_declare_simd_clauses);
3885               mio_symbol_ref (&n->sym);
3886             }
3887           for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
3888             {
3889               mio_name (4, omp_declare_simd_clauses);
3890               mio_symbol_ref (&n->sym);
3891               mio_expr (&n->expr);
3892             }
3893           for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
3894             {
3895               mio_name (5, omp_declare_simd_clauses);
3896               mio_symbol_ref (&n->sym);
3897               mio_expr (&n->expr);
3898             }
3899         }
3900     }
3901   else
3902     {
3903       gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
3904
3905       require_atom (ATOM_NAME);
3906       *odsp = ods = gfc_get_omp_declare_simd ();
3907       ods->where = gfc_current_locus;
3908       ods->proc_name = ns->proc_name;
3909       if (peek_atom () == ATOM_NAME)
3910         {
3911           ods->clauses = gfc_get_omp_clauses ();
3912           ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
3913           ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
3914           ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
3915         }
3916       while (peek_atom () == ATOM_NAME)
3917         {
3918           gfc_omp_namelist *n;
3919           int t = mio_name (0, omp_declare_simd_clauses);
3920
3921           switch (t)
3922             {
3923             case 0: ods->clauses->inbranch = true; break;
3924             case 1: ods->clauses->notinbranch = true; break;
3925             case 2: mio_expr (&ods->clauses->simdlen_expr); break;
3926             case 3:
3927             case 4:
3928             case 5:
3929               *ptrs[t - 3] = n = gfc_get_omp_namelist ();
3930               ptrs[t - 3] = &n->next;
3931               mio_symbol_ref (&n->sym);
3932               if (t != 3)
3933                 mio_expr (&n->expr);
3934               break;
3935             }
3936         }
3937     }
3938
3939   mio_omp_declare_simd (ns, &ods->next);
3940
3941   mio_rparen ();
3942 }
3943
3944
3945 static const mstring omp_declare_reduction_stmt[] =
3946 {
3947     minit ("ASSIGN", 0),
3948     minit ("CALL", 1),
3949     minit (NULL, -1)
3950 };
3951
3952
3953 static void
3954 mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
3955                   gfc_namespace *ns, bool is_initializer)
3956 {
3957   if (iomode == IO_OUTPUT)
3958     {
3959       if ((*sym1)->module == NULL)
3960         {
3961           (*sym1)->module = module_name;
3962           (*sym2)->module = module_name;
3963         }
3964       mio_symbol_ref (sym1);
3965       mio_symbol_ref (sym2);
3966       if (ns->code->op == EXEC_ASSIGN)
3967         {
3968           mio_name (0, omp_declare_reduction_stmt);
3969           mio_expr (&ns->code->expr1);
3970           mio_expr (&ns->code->expr2);
3971         }
3972       else
3973         {
3974           int flag;
3975           mio_name (1, omp_declare_reduction_stmt);
3976           mio_symtree_ref (&ns->code->symtree);
3977           mio_actual_arglist (&ns->code->ext.actual);
3978
3979           flag = ns->code->resolved_isym != NULL;
3980           mio_integer (&flag);
3981           if (flag)
3982             write_atom (ATOM_STRING, ns->code->resolved_isym->name);
3983           else
3984             mio_symbol_ref (&ns->code->resolved_sym);
3985         }
3986     }
3987   else
3988     {
3989       pointer_info *p1 = mio_symbol_ref (sym1);
3990       pointer_info *p2 = mio_symbol_ref (sym2);
3991       gfc_symbol *sym;
3992       gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
3993       gcc_assert (p1->u.rsym.sym == NULL);
3994       /* Add hidden symbols to the symtree.  */
3995       pointer_info *q = get_integer (p1->u.rsym.ns);
3996       q->u.pointer = (void *) ns;
3997       sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
3998       sym->ts = udr->ts;
3999       sym->module = gfc_get_string (p1->u.rsym.module);
4000       associate_integer_pointer (p1, sym);
4001       sym->attr.omp_udr_artificial_var = 1;
4002       gcc_assert (p2->u.rsym.sym == NULL);
4003       sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
4004       sym->ts = udr->ts;
4005       sym->module = gfc_get_string (p2->u.rsym.module);
4006       associate_integer_pointer (p2, sym);
4007       sym->attr.omp_udr_artificial_var = 1;
4008       if (mio_name (0, omp_declare_reduction_stmt) == 0)
4009         {
4010           ns->code = gfc_get_code (EXEC_ASSIGN);
4011           mio_expr (&ns->code->expr1);
4012           mio_expr (&ns->code->expr2);
4013         }
4014       else
4015         {
4016           int flag;
4017           ns->code = gfc_get_code (EXEC_CALL);
4018           mio_symtree_ref (&ns->code->symtree);
4019           mio_actual_arglist (&ns->code->ext.actual);
4020
4021           mio_integer (&flag);
4022           if (flag)
4023             {
4024               require_atom (ATOM_STRING);
4025               ns->code->resolved_isym = gfc_find_subroutine (atom_string);
4026               free (atom_string);
4027             }
4028           else
4029             mio_symbol_ref (&ns->code->resolved_sym);
4030         }
4031       ns->code->loc = gfc_current_locus;
4032       ns->omp_udr_ns = 1;
4033     }
4034 }
4035
4036
4037 /* Unlike most other routines, the address of the symbol node is already
4038    fixed on input and the name/module has already been filled in.
4039    If you update the symbol format here, don't forget to update read_module
4040    as well (look for "seek to the symbol's component list").   */
4041
4042 static void
4043 mio_symbol (gfc_symbol *sym)
4044 {
4045   int intmod = INTMOD_NONE;
4046
4047   mio_lparen ();
4048
4049   mio_symbol_attribute (&sym->attr);
4050
4051   /* Note that components are always saved, even if they are supposed
4052      to be private.  Component access is checked during searching.  */
4053   mio_component_list (&sym->components, sym->attr.vtype);
4054   if (sym->components != NULL)
4055     sym->component_access
4056       = MIO_NAME (gfc_access) (sym->component_access, access_types);
4057
4058   mio_typespec (&sym->ts);
4059   if (sym->ts.type == BT_CLASS)
4060     sym->attr.class_ok = 1;
4061
4062   if (iomode == IO_OUTPUT)
4063     mio_namespace_ref (&sym->formal_ns);
4064   else
4065     {
4066       mio_namespace_ref (&sym->formal_ns);
4067       if (sym->formal_ns)
4068         sym->formal_ns->proc_name = sym;
4069     }
4070
4071   /* Save/restore common block links.  */
4072   mio_symbol_ref (&sym->common_next);
4073
4074   mio_formal_arglist (&sym->formal);
4075
4076   if (sym->attr.flavor == FL_PARAMETER)
4077     mio_expr (&sym->value);
4078
4079   mio_array_spec (&sym->as);
4080
4081   mio_symbol_ref (&sym->result);
4082
4083   if (sym->attr.cray_pointee)
4084     mio_symbol_ref (&sym->cp_pointer);
4085
4086   /* Load/save the f2k_derived namespace of a derived-type symbol.  */
4087   mio_full_f2k_derived (sym);
4088
4089   mio_namelist (sym);
4090
4091   /* Add the fields that say whether this is from an intrinsic module,
4092      and if so, what symbol it is within the module.  */
4093 /*   mio_integer (&(sym->from_intmod)); */
4094   if (iomode == IO_OUTPUT)
4095     {
4096       intmod = sym->from_intmod;
4097       mio_integer (&intmod);
4098     }
4099   else
4100     {
4101       mio_integer (&intmod);
4102       if (current_intmod)
4103         sym->from_intmod = current_intmod;
4104       else
4105         sym->from_intmod = (intmod_id) intmod;
4106     }
4107
4108   mio_integer (&(sym->intmod_sym_id));
4109
4110   if (sym->attr.flavor == FL_DERIVED)
4111     mio_integer (&(sym->hash_value));
4112
4113   if (sym->formal_ns
4114       && sym->formal_ns->proc_name == sym
4115       && sym->formal_ns->entries == NULL)
4116     mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
4117
4118   mio_rparen ();
4119 }
4120
4121
4122 /************************* Top level subroutines *************************/
4123
4124 /* Given a root symtree node and a symbol, try to find a symtree that
4125    references the symbol that is not a unique name.  */
4126
4127 static gfc_symtree *
4128 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
4129 {
4130   gfc_symtree *s = NULL;
4131
4132   if (st == NULL)
4133     return s;
4134
4135   s = find_symtree_for_symbol (st->right, sym);
4136   if (s != NULL)
4137     return s;
4138   s = find_symtree_for_symbol (st->left, sym);
4139   if (s != NULL)
4140     return s;
4141
4142   if (st->n.sym == sym && !check_unique_name (st->name))
4143     return st;
4144
4145   return s;
4146 }
4147
4148
4149 /* A recursive function to look for a specific symbol by name and by
4150    module.  Whilst several symtrees might point to one symbol, its
4151    is sufficient for the purposes here than one exist.  Note that
4152    generic interfaces are distinguished as are symbols that have been
4153    renamed in another module.  */
4154 static gfc_symtree *
4155 find_symbol (gfc_symtree *st, const char *name,
4156              const char *module, int generic)
4157 {
4158   int c;
4159   gfc_symtree *retval, *s;
4160
4161   if (st == NULL || st->n.sym == NULL)
4162     return NULL;
4163
4164   c = strcmp (name, st->n.sym->name);
4165   if (c == 0 && st->n.sym->module
4166              && strcmp (module, st->n.sym->module) == 0
4167              && !check_unique_name (st->name))
4168     {
4169       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
4170
4171       /* Detect symbols that are renamed by use association in another
4172          module by the absence of a symtree and null attr.use_rename,
4173          since the latter is not transmitted in the module file.  */
4174       if (((!generic && !st->n.sym->attr.generic)
4175                 || (generic && st->n.sym->attr.generic))
4176             && !(s == NULL && !st->n.sym->attr.use_rename))
4177         return st;
4178     }
4179
4180   retval = find_symbol (st->left, name, module, generic);
4181
4182   if (retval == NULL)
4183     retval = find_symbol (st->right, name, module, generic);
4184
4185   return retval;
4186 }
4187
4188
4189 /* Skip a list between balanced left and right parens.
4190    By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4191    have been already parsed by hand, and the remaining of the content is to be
4192    skipped here.  The default value is 0 (balanced parens).  */
4193
4194 static void
4195 skip_list (int nest_level = 0)
4196 {
4197   int level;
4198
4199   level = nest_level;
4200   do
4201     {
4202       switch (parse_atom ())
4203         {
4204         case ATOM_LPAREN:
4205           level++;
4206           break;
4207
4208         case ATOM_RPAREN:
4209           level--;
4210           break;
4211
4212         case ATOM_STRING:
4213           free (atom_string);
4214           break;
4215
4216         case ATOM_NAME:
4217         case ATOM_INTEGER:
4218           break;
4219         }
4220     }
4221   while (level > 0);
4222 }
4223
4224
4225 /* Load operator interfaces from the module.  Interfaces are unusual
4226    in that they attach themselves to existing symbols.  */
4227
4228 static void
4229 load_operator_interfaces (void)
4230 {
4231   const char *p;
4232   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
4233   gfc_user_op *uop;
4234   pointer_info *pi = NULL;
4235   int n, i;
4236
4237   mio_lparen ();
4238
4239   while (peek_atom () != ATOM_RPAREN)
4240     {
4241       mio_lparen ();
4242
4243       mio_internal_string (name);
4244       mio_internal_string (module);
4245
4246       n = number_use_names (name, true);
4247       n = n ? n : 1;
4248
4249       for (i = 1; i <= n; i++)
4250         {
4251           /* Decide if we need to load this one or not.  */
4252           p = find_use_name_n (name, &i, true);
4253
4254           if (p == NULL)
4255             {
4256               while (parse_atom () != ATOM_RPAREN);
4257               continue;
4258             }
4259
4260           if (i == 1)
4261             {
4262               uop = gfc_get_uop (p);
4263               pi = mio_interface_rest (&uop->op);
4264             }
4265           else
4266             {
4267               if (gfc_find_uop (p, NULL))
4268                 continue;
4269               uop = gfc_get_uop (p);
4270               uop->op = gfc_get_interface ();
4271               uop->op->where = gfc_current_locus;
4272               add_fixup (pi->integer, &uop->op->sym);
4273             }
4274         }
4275     }
4276
4277   mio_rparen ();
4278 }
4279
4280
4281 /* Load interfaces from the module.  Interfaces are unusual in that
4282    they attach themselves to existing symbols.  */
4283
4284 static void
4285 load_generic_interfaces (void)
4286 {
4287   const char *p;
4288   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
4289   gfc_symbol *sym;
4290   gfc_interface *generic = NULL, *gen = NULL;
4291   int n, i, renamed;
4292   bool ambiguous_set = false;
4293
4294   mio_lparen ();
4295
4296   while (peek_atom () != ATOM_RPAREN)
4297     {
4298       mio_lparen ();
4299
4300       mio_internal_string (name);
4301       mio_internal_string (module);
4302
4303       n = number_use_names (name, false);
4304       renamed = n ? 1 : 0;
4305       n = n ? n : 1;
4306
4307       for (i = 1; i <= n; i++)
4308         {
4309           gfc_symtree *st;
4310           /* Decide if we need to load this one or not.  */
4311           p = find_use_name_n (name, &i, false);
4312
4313           st = find_symbol (gfc_current_ns->sym_root,
4314                             name, module_name, 1);
4315
4316           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
4317             {
4318               /* Skip the specific names for these cases.  */
4319               while (i == 1 && parse_atom () != ATOM_RPAREN);
4320
4321               continue;
4322             }
4323
4324           /* If the symbol exists already and is being USEd without being
4325              in an ONLY clause, do not load a new symtree(11.3.2).  */
4326           if (!only_flag && st)
4327             sym = st->n.sym;
4328
4329           if (!sym)
4330             {
4331               if (st)
4332                 {
4333                   sym = st->n.sym;
4334                   if (strcmp (st->name, p) != 0)
4335                     {
4336                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4337                       st->n.sym = sym;
4338                       sym->refs++;
4339                     }
4340                 }
4341
4342               /* Since we haven't found a valid generic interface, we had
4343                  better make one.  */
4344               if (!sym)
4345                 {
4346                   gfc_get_symbol (p, NULL, &sym);
4347                   sym->name = gfc_get_string (name);
4348                   sym->module = module_name;
4349                   sym->attr.flavor = FL_PROCEDURE;
4350                   sym->attr.generic = 1;
4351                   sym->attr.use_assoc = 1;
4352                 }
4353             }
4354           else
4355             {
4356               /* Unless sym is a generic interface, this reference
4357                  is ambiguous.  */
4358               if (st == NULL)
4359                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4360
4361               sym = st->n.sym;
4362
4363               if (st && !sym->attr.generic
4364                      && !st->ambiguous
4365                      && sym->module
4366                      && strcmp (module, sym->module))
4367                 {
4368                   ambiguous_set = true;
4369                   st->ambiguous = 1;
4370                 }
4371             }
4372
4373           sym->attr.use_only = only_flag;
4374           sym->attr.use_rename = renamed;
4375
4376           if (i == 1)
4377             {
4378               mio_interface_rest (&sym->generic);
4379               generic = sym->generic;
4380             }
4381           else if (!sym->generic)
4382             {
4383               sym->generic = generic;
4384               sym->attr.generic_copy = 1;
4385             }
4386
4387           /* If a procedure that is not generic has generic interfaces
4388              that include itself, it is generic! We need to take care
4389              to retain symbols ambiguous that were already so.  */
4390           if (sym->attr.use_assoc
4391                 && !sym->attr.generic
4392                 && sym->attr.flavor == FL_PROCEDURE)
4393             {
4394               for (gen = generic; gen; gen = gen->next)
4395                 {
4396                   if (gen->sym == sym)
4397                     {
4398                       sym->attr.generic = 1;
4399                       if (ambiguous_set)
4400                         st->ambiguous = 0;
4401                       break;
4402                     }
4403                 }
4404             }
4405
4406         }
4407     }
4408
4409   mio_rparen ();
4410 }
4411
4412
4413 /* Load common blocks.  */
4414
4415 static void
4416 load_commons (void)
4417 {
4418   char name[GFC_MAX_SYMBOL_LEN + 1];
4419   gfc_common_head *p;
4420
4421   mio_lparen ();
4422
4423   while (peek_atom () != ATOM_RPAREN)
4424     {
4425       int flags;
4426       char* label;
4427       mio_lparen ();
4428       mio_internal_string (name);
4429
4430       p = gfc_get_common (name, 1);
4431
4432       mio_symbol_ref (&p->head);
4433       mio_integer (&flags);
4434       if (flags & 1)
4435         p->saved = 1;
4436       if (flags & 2)
4437         p->threadprivate = 1;
4438       p->use_assoc = 1;
4439
4440       /* Get whether this was a bind(c) common or not.  */
4441       mio_integer (&p->is_bind_c);
4442       /* Get the binding label.  */
4443       label = read_string ();
4444       if (strlen (label))
4445         p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4446       XDELETEVEC (label);
4447
4448       mio_rparen ();
4449     }
4450
4451   mio_rparen ();
4452 }
4453
4454
4455 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
4456    so that unused variables are not loaded and so that the expression can
4457    be safely freed.  */
4458
4459 static void
4460 load_equiv (void)
4461 {
4462   gfc_equiv *head, *tail, *end, *eq;
4463   bool unused;
4464
4465   mio_lparen ();
4466   in_load_equiv = true;
4467
4468   end = gfc_current_ns->equiv;
4469   while (end != NULL && end->next != NULL)
4470     end = end->next;
4471
4472   while (peek_atom () != ATOM_RPAREN) {
4473     mio_lparen ();
4474     head = tail = NULL;
4475
4476     while(peek_atom () != ATOM_RPAREN)
4477       {
4478         if (head == NULL)
4479           head = tail = gfc_get_equiv ();
4480         else
4481           {
4482             tail->eq = gfc_get_equiv ();
4483             tail = tail->eq;
4484           }
4485
4486         mio_pool_string (&tail->module);
4487         mio_expr (&tail->expr);
4488       }
4489
4490     /* Unused equivalence members have a unique name.  In addition, it
4491        must be checked that the symbols are from the same module.  */
4492     unused = true;
4493     for (eq = head; eq; eq = eq->eq)
4494       {
4495         if (eq->expr->symtree->n.sym->module
4496               && head->expr->symtree->n.sym->module
4497               && strcmp (head->expr->symtree->n.sym->module,
4498                          eq->expr->symtree->n.sym->module) == 0
4499               && !check_unique_name (eq->expr->symtree->name))
4500           {
4501             unused = false;
4502             break;
4503           }
4504       }
4505
4506     if (unused)
4507       {
4508         for (eq = head; eq; eq = head)
4509           {
4510             head = eq->eq;
4511             gfc_free_expr (eq->expr);
4512             free (eq);
4513           }
4514       }
4515
4516     if (end == NULL)
4517       gfc_current_ns->equiv = head;
4518     else
4519       end->next = head;
4520
4521     if (head != NULL)
4522       end = head;
4523
4524     mio_rparen ();
4525   }
4526
4527   mio_rparen ();
4528   in_load_equiv = false;
4529 }
4530
4531
4532 /* This function loads the sym_root of f2k_derived with the extensions to
4533    the derived type.  */
4534 static void
4535 load_derived_extensions (void)
4536 {
4537   int symbol, j;
4538   gfc_symbol *derived;
4539   gfc_symbol *dt;
4540   gfc_symtree *st;
4541   pointer_info *info;
4542   char name[GFC_MAX_SYMBOL_LEN + 1];
4543   char module[GFC_MAX_SYMBOL_LEN + 1];
4544   const char *p;
4545
4546   mio_lparen ();
4547   while (peek_atom () != ATOM_RPAREN)
4548     {
4549       mio_lparen ();
4550       mio_integer (&symbol);
4551       info = get_integer (symbol);
4552       derived = info->u.rsym.sym;
4553
4554       /* This one is not being loaded.  */
4555       if (!info || !derived)
4556         {
4557           while (peek_atom () != ATOM_RPAREN)
4558             skip_list ();
4559           continue;
4560         }
4561
4562       gcc_assert (derived->attr.flavor == FL_DERIVED);
4563       if (derived->f2k_derived == NULL)
4564         derived->f2k_derived = gfc_get_namespace (NULL, 0);
4565
4566       while (peek_atom () != ATOM_RPAREN)
4567         {
4568           mio_lparen ();
4569           mio_internal_string (name);
4570           mio_internal_string (module);
4571
4572           /* Only use one use name to find the symbol.  */
4573           j = 1;
4574           p = find_use_name_n (name, &j, false);
4575           if (p)
4576             {
4577               st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4578               dt = st->n.sym;
4579               st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4580               if (st == NULL)
4581                 {
4582                   /* Only use the real name in f2k_derived to ensure a single
4583                     symtree.  */
4584                   st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
4585                   st->n.sym = dt;
4586                   st->n.sym->refs++;
4587                 }
4588             }
4589           mio_rparen ();
4590         }
4591       mio_rparen ();
4592     }
4593   mio_rparen ();
4594 }
4595
4596
4597 /* This function loads OpenMP user defined reductions.  */
4598 static void
4599 load_omp_udrs (void)
4600 {
4601   mio_lparen ();
4602   while (peek_atom () != ATOM_RPAREN)
4603     {
4604       const char *name, *newname;
4605       char *altname;
4606       gfc_typespec ts;
4607       gfc_symtree *st;
4608       gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
4609
4610       mio_lparen ();
4611       mio_pool_string (&name);
4612       mio_typespec (&ts);
4613       if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
4614         {
4615           const char *p = name + sizeof ("operator ") - 1;
4616           if (strcmp (p, "+") == 0)
4617             rop = OMP_REDUCTION_PLUS;
4618           else if (strcmp (p, "*") == 0)
4619             rop = OMP_REDUCTION_TIMES;
4620           else if (strcmp (p, "-") == 0)
4621             rop = OMP_REDUCTION_MINUS;
4622           else if (strcmp (p, ".and.") == 0)
4623             rop = OMP_REDUCTION_AND;
4624           else if (strcmp (p, ".or.") == 0)
4625             rop = OMP_REDUCTION_OR;
4626           else if (strcmp (p, ".eqv.") == 0)
4627             rop = OMP_REDUCTION_EQV;
4628           else if (strcmp (p, ".neqv.") == 0)
4629             rop = OMP_REDUCTION_NEQV;
4630         }
4631       altname = NULL;
4632       if (rop == OMP_REDUCTION_USER && name[0] == '.')
4633         {
4634           size_t len = strlen (name + 1);
4635           altname = XALLOCAVEC (char, len);
4636           gcc_assert (name[len] == '.');
4637           memcpy (altname, name + 1, len - 1);
4638           altname[len - 1] = '\0';
4639         }
4640       newname = name;
4641       if (rop == OMP_REDUCTION_USER)
4642         newname = find_use_name (altname ? altname : name, !!altname);
4643       else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
4644         newname = NULL;
4645       if (newname == NULL)
4646         {
4647           skip_list (1);
4648           continue;
4649         }
4650       if (altname && newname != altname)
4651         {
4652           size_t len = strlen (newname);
4653           altname = XALLOCAVEC (char, len + 3);
4654           altname[0] = '.';
4655           memcpy (altname + 1, newname, len);
4656           altname[len + 1] = '.';
4657           altname[len + 2] = '\0';
4658           name = gfc_get_string (altname);
4659         }
4660       st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
4661       gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
4662       if (udr)
4663         {
4664           require_atom (ATOM_INTEGER);
4665           pointer_info *p = get_integer (atom_int);
4666           if (strcmp (p->u.rsym.module, udr->omp_out->module))
4667             {
4668               gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4669                          "module %s at %L",
4670                          p->u.rsym.module, &gfc_current_locus);
4671               gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4672                          "%s at %L",
4673                          udr->omp_out->module, &udr->where);
4674             }
4675           skip_list (1);
4676           continue;
4677         }
4678       udr = gfc_get_omp_udr ();
4679       udr->name = name;
4680       udr->rop = rop;
4681       udr->ts = ts;
4682       udr->where = gfc_current_locus;
4683       udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
4684       udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
4685       mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
4686                         false);
4687       if (peek_atom () != ATOM_RPAREN)
4688         {
4689           udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
4690           udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
4691           mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
4692                             udr->initializer_ns, true);
4693         }
4694       if (st)
4695         {
4696           udr->next = st->n.omp_udr;
4697           st->n.omp_udr = udr;
4698         }
4699       else
4700         {
4701           st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
4702           st->n.omp_udr = udr;
4703         }
4704       mio_rparen ();
4705     }
4706   mio_rparen ();
4707 }
4708
4709
4710 /* Recursive function to traverse the pointer_info tree and load a
4711    needed symbol.  We return nonzero if we load a symbol and stop the
4712    traversal, because the act of loading can alter the tree.  */
4713
4714 static int
4715 load_needed (pointer_info *p)
4716 {
4717   gfc_namespace *ns;
4718   pointer_info *q;
4719   gfc_symbol *sym;
4720   int rv;
4721
4722   rv = 0;
4723   if (p == NULL)
4724     return rv;
4725
4726   rv |= load_needed (p->left);
4727   rv |= load_needed (p->right);
4728
4729   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4730     return rv;
4731
4732   p->u.rsym.state = USED;
4733
4734   set_module_locus (&p->u.rsym.where);
4735
4736   sym = p->u.rsym.sym;
4737   if (sym == NULL)
4738     {
4739       q = get_integer (p->u.rsym.ns);
4740
4741       ns = (gfc_namespace *) q->u.pointer;
4742       if (ns == NULL)
4743         {
4744           /* Create an interface namespace if necessary.  These are
4745              the namespaces that hold the formal parameters of module
4746              procedures.  */
4747
4748           ns = gfc_get_namespace (NULL, 0);
4749           associate_integer_pointer (q, ns);
4750         }
4751
4752       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4753          doesn't go pear-shaped if the symbol is used.  */
4754       if (!ns->proc_name)
4755         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4756                                  1, &ns->proc_name);
4757
4758       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4759       sym->name = dt_lower_string (p->u.rsym.true_name);
4760       sym->module = gfc_get_string (p->u.rsym.module);
4761       if (p->u.rsym.binding_label)
4762         sym->binding_label = IDENTIFIER_POINTER (get_identifier
4763                                                  (p->u.rsym.binding_label));
4764
4765       associate_integer_pointer (p, sym);
4766     }
4767
4768   mio_symbol (sym);
4769   sym->attr.use_assoc = 1;
4770
4771   /* Mark as only or rename for later diagnosis for explicitly imported
4772      but not used warnings; don't mark internal symbols such as __vtab,
4773      __def_init etc. Only mark them if they have been explicitly loaded.  */
4774
4775   if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
4776     {
4777       gfc_use_rename *u;
4778
4779       /* Search the use/rename list for the variable; if the variable is
4780          found, mark it.  */
4781       for (u = gfc_rename_list; u; u = u->next)
4782         {
4783           if (strcmp (u->use_name, sym->name) == 0)
4784             {
4785               sym->attr.use_only = 1;
4786               break;
4787             }
4788         }
4789     }
4790
4791   if (p->u.rsym.renamed)
4792     sym->attr.use_rename = 1;
4793
4794   return 1;
4795 }
4796
4797
4798 /* Recursive function for cleaning up things after a module has been read.  */
4799
4800 static void
4801 read_cleanup (pointer_info *p)
4802 {
4803   gfc_symtree *st;
4804   pointer_info *q;
4805
4806   if (p == NULL)
4807     return;
4808
4809   read_cleanup (p->left);
4810   read_cleanup (p->right);
4811
4812   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4813     {
4814       gfc_namespace *ns;
4815       /* Add hidden symbols to the symtree.  */
4816       q = get_integer (p->u.rsym.ns);
4817       ns = (gfc_namespace *) q->u.pointer;
4818
4819       if (!p->u.rsym.sym->attr.vtype
4820             && !p->u.rsym.sym->attr.vtab)
4821         st = gfc_get_unique_symtree (ns);
4822       else
4823         {
4824           /* There is no reason to use 'unique_symtrees' for vtabs or
4825              vtypes - their name is fine for a symtree and reduces the
4826              namespace pollution.  */
4827           st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
4828           if (!st)
4829             st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
4830         }
4831
4832       st->n.sym = p->u.rsym.sym;
4833       st->n.sym->refs++;
4834
4835       /* Fixup any symtree references.  */
4836       p->u.rsym.symtree = st;
4837       resolve_fixups (p->u.rsym.stfixup, st);
4838       p->u.rsym.stfixup = NULL;
4839     }
4840
4841   /* Free unused symbols.  */
4842   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
4843     gfc_free_symbol (p->u.rsym.sym);
4844 }
4845
4846
4847 /* It is not quite enough to check for ambiguity in the symbols by
4848    the loaded symbol and the new symbol not being identical.  */
4849 static bool
4850 check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
4851 {
4852   gfc_symbol *rsym;
4853   module_locus locus;
4854   symbol_attribute attr;
4855
4856   if (gfc_current_ns->proc_name && st_sym->name == gfc_current_ns->proc_name->name)
4857     {
4858       gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4859                  "current program unit", st_sym->name, module_name);
4860       return true;
4861     }
4862
4863   rsym = info->u.rsym.sym;
4864   if (st_sym == rsym)
4865     return false;
4866
4867   if (st_sym->attr.vtab || st_sym->attr.vtype)
4868     return false;
4869
4870   /* If the existing symbol is generic from a different module and
4871      the new symbol is generic there can be no ambiguity.  */
4872   if (st_sym->attr.generic
4873         && st_sym->module
4874         && st_sym->module != module_name)
4875     {
4876       /* The new symbol's attributes have not yet been read.  Since
4877          we need attr.generic, read it directly.  */
4878       get_module_locus (&locus);
4879       set_module_locus (&info->u.rsym.where);
4880       mio_lparen ();
4881       attr.generic = 0;
4882       mio_symbol_attribute (&attr);
4883       set_module_locus (&locus);
4884       if (attr.generic)
4885         return false;
4886     }
4887
4888   return true;
4889 }
4890
4891
4892 /* Read a module file.  */
4893
4894 static void
4895 read_module (void)
4896 {
4897   module_locus operator_interfaces, user_operators, extensions, omp_udrs;
4898   const char *p;
4899   char name[GFC_MAX_SYMBOL_LEN + 1];
4900   int i;
4901   int ambiguous, j, nuse, symbol;
4902   pointer_info *info, *q;
4903   gfc_use_rename *u = NULL;
4904   gfc_symtree *st;
4905   gfc_symbol *sym;
4906
4907   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
4908   skip_list ();
4909
4910   get_module_locus (&user_operators);
4911   skip_list ();
4912   skip_list ();
4913
4914   /* Skip commons, equivalences and derived type extensions for now.  */
4915   skip_list ();
4916   skip_list ();
4917
4918   get_module_locus (&extensions);
4919   skip_list ();
4920
4921   /* Skip OpenMP UDRs.  */
4922   get_module_locus (&omp_udrs);
4923   skip_list ();
4924
4925   mio_lparen ();
4926
4927   /* Create the fixup nodes for all the symbols.  */
4928
4929   while (peek_atom () != ATOM_RPAREN)
4930     {
4931       char* bind_label;
4932       require_atom (ATOM_INTEGER);
4933       info = get_integer (atom_int);
4934
4935       info->type = P_SYMBOL;
4936       info->u.rsym.state = UNUSED;
4937
4938       info->u.rsym.true_name = read_string ();
4939       info->u.rsym.module = read_string ();
4940       bind_label = read_string ();
4941       if (strlen (bind_label))
4942         info->u.rsym.binding_label = bind_label;
4943       else
4944         XDELETEVEC (bind_label);
4945
4946       require_atom (ATOM_INTEGER);
4947       info->u.rsym.ns = atom_int;
4948
4949       get_module_locus (&info->u.rsym.where);
4950
4951       /* See if the symbol has already been loaded by a previous module.
4952          If so, we reference the existing symbol and prevent it from
4953          being loaded again.  This should not happen if the symbol being
4954          read is an index for an assumed shape dummy array (ns != 1).  */
4955
4956       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4957
4958       if (sym == NULL
4959           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4960         {
4961           skip_list ();
4962           continue;
4963         }
4964
4965       info->u.rsym.state = USED;
4966       info->u.rsym.sym = sym;
4967       /* The current symbol has already been loaded, so we can avoid loading
4968          it again.  However, if it is a derived type, some of its components
4969          can be used in expressions in the module.  To avoid the module loading
4970          failing, we need to associate the module's component pointer indexes
4971          with the existing symbol's component pointers.  */
4972       if (sym->attr.flavor == FL_DERIVED)
4973         {
4974           gfc_component *c;
4975
4976           /* First seek to the symbol's component list.  */
4977           mio_lparen (); /* symbol opening.  */
4978           skip_list (); /* skip symbol attribute.  */
4979
4980           mio_lparen (); /* component list opening.  */
4981           for (c = sym->components; c; c = c->next)
4982             {
4983               pointer_info *p;
4984               const char *comp_name;
4985               int n;
4986
4987               mio_lparen (); /* component opening.  */
4988               mio_integer (&n);
4989               p = get_integer (n);
4990               if (p->u.pointer == NULL)
4991                 associate_integer_pointer (p, c);
4992               mio_pool_string (&comp_name);
4993               gcc_assert (comp_name == c->name);
4994               skip_list (1); /* component end.  */
4995             }
4996           mio_rparen (); /* component list closing.  */
4997
4998           skip_list (1); /* symbol end.  */
4999         }
5000       else
5001         skip_list ();
5002
5003       /* Some symbols do not have a namespace (eg. formal arguments),
5004          so the automatic "unique symtree" mechanism must be suppressed
5005          by marking them as referenced.  */
5006       q = get_integer (info->u.rsym.ns);
5007       if (q->u.pointer == NULL)
5008         {
5009           info->u.rsym.referenced = 1;
5010           continue;
5011         }
5012
5013       /* If possible recycle the symtree that references the symbol.
5014          If a symtree is not found and the module does not import one,
5015          a unique-name symtree is found by read_cleanup.  */
5016       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
5017       if (st != NULL)
5018         {
5019           info->u.rsym.symtree = st;
5020           info->u.rsym.referenced = 1;
5021         }
5022     }
5023
5024   mio_rparen ();
5025
5026   /* Parse the symtree lists.  This lets us mark which symbols need to
5027      be loaded.  Renaming is also done at this point by replacing the
5028      symtree name.  */
5029
5030   mio_lparen ();
5031
5032   while (peek_atom () != ATOM_RPAREN)
5033     {
5034       mio_internal_string (name);
5035       mio_integer (&ambiguous);
5036       mio_integer (&symbol);
5037
5038       info = get_integer (symbol);
5039
5040       /* See how many use names there are.  If none, go through the start
5041          of the loop at least once.  */
5042       nuse = number_use_names (name, false);
5043       info->u.rsym.renamed = nuse ? 1 : 0;
5044
5045       if (nuse == 0)
5046         nuse = 1;
5047
5048       for (j = 1; j <= nuse; j++)
5049         {
5050           /* Get the jth local name for this symbol.  */
5051           p = find_use_name_n (name, &j, false);
5052
5053           if (p == NULL && strcmp (name, module_name) == 0)
5054             p = name;
5055
5056           /* Exception: Always import vtabs & vtypes.  */
5057           if (p == NULL && name[0] == '_'
5058               && (strncmp (name, "__vtab_", 5) == 0
5059                   || strncmp (name, "__vtype_", 6) == 0))
5060             p = name;
5061
5062           /* Skip symtree nodes not in an ONLY clause, unless there
5063              is an existing symtree loaded from another USE statement.  */
5064           if (p == NULL)
5065             {
5066               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5067               if (st != NULL
5068                   && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
5069                   && st->n.sym->module != NULL
5070                   && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
5071                 {
5072                   info->u.rsym.symtree = st;
5073                   info->u.rsym.sym = st->n.sym;
5074                 }
5075               continue;
5076             }
5077
5078           /* If a symbol of the same name and module exists already,
5079              this symbol, which is not in an ONLY clause, must not be
5080              added to the namespace(11.3.2).  Note that find_symbol
5081              only returns the first occurrence that it finds.  */
5082           if (!only_flag && !info->u.rsym.renamed
5083                 && strcmp (name, module_name) != 0
5084                 && find_symbol (gfc_current_ns->sym_root, name,
5085                                 module_name, 0))
5086             continue;
5087
5088           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
5089
5090           if (st != NULL)
5091             {
5092               /* Check for ambiguous symbols.  */
5093               if (check_for_ambiguous (st->n.sym, info))
5094                 st->ambiguous = 1;
5095               else
5096                 info->u.rsym.symtree = st;
5097             }
5098           else
5099             {
5100               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5101
5102               /* Create a symtree node in the current namespace for this
5103                  symbol.  */
5104               st = check_unique_name (p)
5105                    ? gfc_get_unique_symtree (gfc_current_ns)
5106                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
5107               st->ambiguous = ambiguous;
5108
5109               sym = info->u.rsym.sym;
5110
5111               /* Create a symbol node if it doesn't already exist.  */
5112               if (sym == NULL)
5113                 {
5114                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
5115                                                      gfc_current_ns);
5116                   info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
5117                   sym = info->u.rsym.sym;
5118                   sym->module = gfc_get_string (info->u.rsym.module);
5119
5120                   if (info->u.rsym.binding_label)
5121                     sym->binding_label =
5122                       IDENTIFIER_POINTER (get_identifier
5123                                           (info->u.rsym.binding_label));
5124                 }
5125
5126               st->n.sym = sym;
5127               st->n.sym->refs++;
5128
5129               if (strcmp (name, p) != 0)
5130                 sym->attr.use_rename = 1;
5131
5132               if (name[0] != '_'
5133                   || (strncmp (name, "__vtab_", 5) != 0
5134                       && strncmp (name, "__vtype_", 6) != 0))
5135                 sym->attr.use_only = only_flag;
5136
5137               /* Store the symtree pointing to this symbol.  */
5138               info->u.rsym.symtree = st;
5139
5140               if (info->u.rsym.state == UNUSED)
5141                 info->u.rsym.state = NEEDED;
5142               info->u.rsym.referenced = 1;
5143             }
5144         }
5145     }
5146
5147   mio_rparen ();
5148
5149   /* Load intrinsic operator interfaces.  */
5150   set_module_locus (&operator_interfaces);
5151   mio_lparen ();
5152
5153   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5154     {
5155       if (i == INTRINSIC_USER)
5156         continue;
5157
5158       if (only_flag)
5159         {
5160           u = find_use_operator ((gfc_intrinsic_op) i);
5161
5162           if (u == NULL)
5163             {
5164               skip_list ();
5165               continue;
5166             }
5167
5168           u->found = 1;
5169         }
5170
5171       mio_interface (&gfc_current_ns->op[i]);
5172       if (u && !gfc_current_ns->op[i])
5173         u->found = 0;
5174     }
5175
5176   mio_rparen ();
5177
5178   /* Load generic and user operator interfaces.  These must follow the
5179      loading of symtree because otherwise symbols can be marked as
5180      ambiguous.  */
5181
5182   set_module_locus (&user_operators);
5183
5184   load_operator_interfaces ();
5185   load_generic_interfaces ();
5186
5187   load_commons ();
5188   load_equiv ();
5189
5190   /* Load OpenMP user defined reductions.  */
5191   set_module_locus (&omp_udrs);
5192   load_omp_udrs ();
5193
5194   /* At this point, we read those symbols that are needed but haven't
5195      been loaded yet.  If one symbol requires another, the other gets
5196      marked as NEEDED if its previous state was UNUSED.  */
5197
5198   while (load_needed (pi_root));
5199
5200   /* Make sure all elements of the rename-list were found in the module.  */
5201
5202   for (u = gfc_rename_list; u; u = u->next)
5203     {
5204       if (u->found)
5205         continue;
5206
5207       if (u->op == INTRINSIC_NONE)
5208         {
5209           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
5210                      u->use_name, &u->where, module_name);
5211           continue;
5212         }
5213
5214       if (u->op == INTRINSIC_USER)
5215         {
5216           gfc_error ("User operator '%s' referenced at %L not found "
5217                      "in module '%s'", u->use_name, &u->where, module_name);
5218           continue;
5219         }
5220
5221       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
5222                  "in module '%s'", gfc_op2string (u->op), &u->where,
5223                  module_name);
5224     }
5225
5226   /* Now we should be in a position to fill f2k_derived with derived type
5227      extensions, since everything has been loaded.  */
5228   set_module_locus (&extensions);
5229   load_derived_extensions ();
5230
5231   /* Clean up symbol nodes that were never loaded, create references
5232      to hidden symbols.  */
5233
5234   read_cleanup (pi_root);
5235 }
5236
5237
5238 /* Given an access type that is specific to an entity and the default
5239    access, return nonzero if the entity is publicly accessible.  If the
5240    element is declared as PUBLIC, then it is public; if declared
5241    PRIVATE, then private, and otherwise it is public unless the default
5242    access in this context has been declared PRIVATE.  */
5243
5244 static bool
5245 check_access (gfc_access specific_access, gfc_access default_access)
5246 {
5247   if (specific_access == ACCESS_PUBLIC)
5248     return TRUE;
5249   if (specific_access == ACCESS_PRIVATE)
5250     return FALSE;
5251
5252   if (gfc_option.flag_module_private)
5253     return default_access == ACCESS_PUBLIC;
5254   else
5255     return default_access != ACCESS_PRIVATE;
5256 }
5257
5258
5259 bool
5260 gfc_check_symbol_access (gfc_symbol *sym)
5261 {
5262   if (sym->attr.vtab || sym->attr.vtype)
5263     return true;
5264   else
5265     return check_access (sym->attr.access, sym->ns->default_access);
5266 }
5267
5268
5269 /* A structure to remember which commons we've already written.  */
5270
5271 struct written_common
5272 {
5273   BBT_HEADER(written_common);
5274   const char *name, *label;
5275 };
5276
5277 static struct written_common *written_commons = NULL;
5278
5279 /* Comparison function used for balancing the binary tree.  */
5280
5281 static int
5282 compare_written_commons (void *a1, void *b1)
5283 {
5284   const char *aname = ((struct written_common *) a1)->name;
5285   const char *alabel = ((struct written_common *) a1)->label;
5286   const char *bname = ((struct written_common *) b1)->name;
5287   const char *blabel = ((struct written_common *) b1)->label;
5288   int c = strcmp (aname, bname);
5289
5290   return (c != 0 ? c : strcmp (alabel, blabel));
5291 }
5292
5293 /* Free a list of written commons.  */
5294
5295 static void
5296 free_written_common (struct written_common *w)
5297 {
5298   if (!w)
5299     return;
5300
5301   if (w->left)
5302     free_written_common (w->left);
5303   if (w->right)
5304     free_written_common (w->right);
5305
5306   free (w);
5307 }
5308
5309 /* Write a common block to the module -- recursive helper function.  */
5310
5311 static void
5312 write_common_0 (gfc_symtree *st, bool this_module)
5313 {
5314   gfc_common_head *p;
5315   const char * name;
5316   int flags;
5317   const char *label;
5318   struct written_common *w;
5319   bool write_me = true;
5320
5321   if (st == NULL)
5322     return;
5323
5324   write_common_0 (st->left, this_module);
5325
5326   /* We will write out the binding label, or "" if no label given.  */
5327   name = st->n.common->name;
5328   p = st->n.common;
5329   label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
5330
5331   /* Check if we've already output this common.  */
5332   w = written_commons;
5333   while (w)
5334     {
5335       int c = strcmp (name, w->name);
5336       c = (c != 0 ? c : strcmp (label, w->label));
5337       if (c == 0)
5338         write_me = false;
5339
5340       w = (c < 0) ? w->left : w->right;
5341     }
5342
5343   if (this_module && p->use_assoc)
5344     write_me = false;
5345
5346   if (write_me)
5347     {
5348       /* Write the common to the module.  */
5349       mio_lparen ();
5350       mio_pool_string (&name);
5351
5352       mio_symbol_ref (&p->head);
5353       flags = p->saved ? 1 : 0;
5354       if (p->threadprivate)
5355         flags |= 2;
5356       mio_integer (&flags);
5357
5358       /* Write out whether the common block is bind(c) or not.  */
5359       mio_integer (&(p->is_bind_c));
5360
5361       mio_pool_string (&label);
5362       mio_rparen ();
5363
5364       /* Record that we have written this common.  */
5365       w = XCNEW (struct written_common);
5366       w->name = p->name;
5367       w->label = label;
5368       gfc_insert_bbt (&written_commons, w, compare_written_commons);
5369     }
5370
5371   write_common_0 (st->right, this_module);
5372 }
5373
5374
5375 /* Write a common, by initializing the list of written commons, calling
5376    the recursive function write_common_0() and cleaning up afterwards.  */
5377
5378 static void
5379 write_common (gfc_symtree *st)
5380 {
5381   written_commons = NULL;
5382   write_common_0 (st, true);
5383   write_common_0 (st, false);
5384   free_written_common (written_commons);
5385   written_commons = NULL;
5386 }
5387
5388
5389 /* Write the blank common block to the module.  */
5390
5391 static void
5392 write_blank_common (void)
5393 {
5394   const char * name = BLANK_COMMON_NAME;
5395   int saved;
5396   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
5397      this, but it hasn't been checked.  Just making it so for now.  */
5398   int is_bind_c = 0;
5399
5400   if (gfc_current_ns->blank_common.head == NULL)
5401     return;
5402
5403   mio_lparen ();
5404
5405   mio_pool_string (&name);
5406
5407   mio_symbol_ref (&gfc_current_ns->blank_common.head);
5408   saved = gfc_current_ns->blank_common.saved;
5409   mio_integer (&saved);
5410
5411   /* Write out whether the common block is bind(c) or not.  */
5412   mio_integer (&is_bind_c);
5413
5414   /* Write out an empty binding label.  */
5415   write_atom (ATOM_STRING, "");
5416
5417   mio_rparen ();
5418 }
5419
5420
5421 /* Write equivalences to the module.  */
5422
5423 static void
5424 write_equiv (void)
5425 {
5426   gfc_equiv *eq, *e;
5427   int num;
5428
5429   num = 0;
5430   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
5431     {
5432       mio_lparen ();
5433
5434       for (e = eq; e; e = e->eq)
5435         {
5436           if (e->module == NULL)
5437             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5438           mio_allocated_string (e->module);
5439           mio_expr (&e->expr);
5440         }
5441
5442       num++;
5443       mio_rparen ();
5444     }
5445 }
5446
5447
5448 /* Write derived type extensions to the module.  */
5449
5450 static void
5451 write_dt_extensions (gfc_symtree *st)
5452 {
5453   if (!gfc_check_symbol_access (st->n.sym))
5454     return;
5455   if (!(st->n.sym->ns && st->n.sym->ns->proc_name
5456         && st->n.sym->ns->proc_name->attr.flavor == FL_MODULE))
5457     return;
5458
5459   mio_lparen ();
5460   mio_pool_string (&st->name);
5461   if (st->n.sym->module != NULL)
5462     mio_pool_string (&st->n.sym->module);
5463   else
5464     {
5465       char name[GFC_MAX_SYMBOL_LEN + 1];
5466       if (iomode == IO_OUTPUT)
5467         strcpy (name, module_name);
5468       mio_internal_string (name);
5469       if (iomode == IO_INPUT)
5470         module_name = gfc_get_string (name);
5471     }
5472   mio_rparen ();
5473 }
5474
5475 static void
5476 write_derived_extensions (gfc_symtree *st)
5477 {
5478   if (!((st->n.sym->attr.flavor == FL_DERIVED)
5479           && (st->n.sym->f2k_derived != NULL)
5480           && (st->n.sym->f2k_derived->sym_root != NULL)))
5481     return;
5482
5483   mio_lparen ();
5484   mio_symbol_ref (&(st->n.sym));
5485   gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
5486                         write_dt_extensions);
5487   mio_rparen ();
5488 }
5489
5490
5491 /* Write a symbol to the module.  */
5492
5493 static void
5494 write_symbol (int n, gfc_symbol *sym)
5495 {
5496   const char *label;
5497
5498   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5499     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
5500
5501   mio_integer (&n);
5502
5503   if (sym->attr.flavor == FL_DERIVED)
5504     {
5505       const char *name;
5506       name = dt_upper_string (sym->name);
5507       mio_pool_string (&name);
5508     }
5509   else
5510     mio_pool_string (&sym->name);
5511
5512   mio_pool_string (&sym->module);
5513   if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5514     {
5515       label = sym->binding_label;
5516       mio_pool_string (&label);
5517     }
5518   else
5519     write_atom (ATOM_STRING, "");
5520
5521   mio_pointer_ref (&sym->ns);
5522
5523   mio_symbol (sym);
5524   write_char ('\n');
5525 }
5526
5527
5528 /* Recursive traversal function to write the initial set of symbols to
5529    the module.  We check to see if the symbol should be written
5530    according to the access specification.  */
5531
5532 static void
5533 write_symbol0 (gfc_symtree *st)
5534 {
5535   gfc_symbol *sym;
5536   pointer_info *p;
5537   bool dont_write = false;
5538
5539   if (st == NULL)
5540     return;
5541
5542   write_symbol0 (st->left);
5543
5544   sym = st->n.sym;
5545   if (sym->module == NULL)
5546     sym->module = module_name;
5547
5548   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5549       && !sym->attr.subroutine && !sym->attr.function)
5550     dont_write = true;
5551
5552   if (!gfc_check_symbol_access (sym))
5553     dont_write = true;
5554
5555   if (!dont_write)
5556     {
5557       p = get_pointer (sym);
5558       if (p->type == P_UNKNOWN)
5559         p->type = P_SYMBOL;
5560
5561       if (p->u.wsym.state != WRITTEN)
5562         {
5563           write_symbol (p->integer, sym);
5564           p->u.wsym.state = WRITTEN;
5565         }
5566     }
5567
5568   write_symbol0 (st->right);
5569 }
5570
5571
5572 static void
5573 write_omp_udr (gfc_omp_udr *udr)
5574 {
5575   switch (udr->rop)
5576     {
5577     case OMP_REDUCTION_USER:
5578       /* Non-operators can't be used outside of the module.  */
5579       if (udr->name[0] != '.')
5580         return;
5581       else
5582         {
5583           gfc_symtree *st;
5584           size_t len = strlen (udr->name + 1);
5585           char *name = XALLOCAVEC (char, len);
5586           memcpy (name, udr->name, len - 1);
5587           name[len - 1] = '\0';
5588           st = gfc_find_symtree (gfc_current_ns->uop_root, name);
5589           /* If corresponding user operator is private, don't write
5590              the UDR.  */
5591           if (st != NULL)
5592             {
5593               gfc_user_op *uop = st->n.uop;
5594               if (!check_access (uop->access, uop->ns->default_access))
5595                 return;
5596             }
5597         }
5598       break;
5599     case OMP_REDUCTION_PLUS:
5600     case OMP_REDUCTION_MINUS:
5601     case OMP_REDUCTION_TIMES:
5602     case OMP_REDUCTION_AND:
5603     case OMP_REDUCTION_OR:
5604     case OMP_REDUCTION_EQV:
5605     case OMP_REDUCTION_NEQV:
5606       /* If corresponding operator is private, don't write the UDR.  */
5607       if (!check_access (gfc_current_ns->operator_access[udr->rop],
5608                          gfc_current_ns->default_access))
5609         return;
5610       break;
5611     default:
5612       break;
5613     }
5614   if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
5615     {
5616       /* If derived type is private, don't write the UDR.  */
5617       if (!gfc_check_symbol_access (udr->ts.u.derived))
5618         return;
5619     }
5620
5621   mio_lparen ();
5622   mio_pool_string (&udr->name);
5623   mio_typespec (&udr->ts);
5624   mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
5625   if (udr->initializer_ns)
5626     mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
5627                       udr->initializer_ns, true);
5628   mio_rparen ();
5629 }
5630
5631
5632 static void
5633 write_omp_udrs (gfc_symtree *st)
5634 {
5635   if (st == NULL)
5636     return;
5637
5638   write_omp_udrs (st->left);
5639   gfc_omp_udr *udr;
5640   for (udr = st->n.omp_udr; udr; udr = udr->next)
5641     write_omp_udr (udr);
5642   write_omp_udrs (st->right);
5643 }
5644
5645
5646 /* Type for the temporary tree used when writing secondary symbols.  */
5647
5648 struct sorted_pointer_info
5649 {
5650   BBT_HEADER (sorted_pointer_info);
5651
5652   pointer_info *p;
5653 };
5654
5655 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5656
5657 /* Recursively traverse the temporary tree, free its contents.  */
5658
5659 static void
5660 free_sorted_pointer_info_tree (sorted_pointer_info *p)
5661 {
5662   if (!p)
5663     return;
5664
5665   free_sorted_pointer_info_tree (p->left);
5666   free_sorted_pointer_info_tree (p->right);
5667
5668   free (p);
5669 }
5670
5671 /* Comparison function for the temporary tree.  */
5672
5673 static int
5674 compare_sorted_pointer_info (void *_spi1, void *_spi2)
5675 {
5676   sorted_pointer_info *spi1, *spi2;
5677   spi1 = (sorted_pointer_info *)_spi1;
5678   spi2 = (sorted_pointer_info *)_spi2;
5679
5680   if (spi1->p->integer < spi2->p->integer)
5681     return -1;
5682   if (spi1->p->integer > spi2->p->integer)
5683     return 1;
5684   return 0;
5685 }
5686
5687
5688 /* Finds the symbols that need to be written and collects them in the
5689    sorted_pi tree so that they can be traversed in an order
5690    independent of memory addresses.  */
5691
5692 static void
5693 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
5694 {
5695   if (!p)
5696     return;
5697
5698   if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
5699     {
5700       sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
5701       sp->p = p;
5702
5703       gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
5704    }
5705
5706   find_symbols_to_write (tree, p->left);
5707   find_symbols_to_write (tree, p->right);
5708 }
5709
5710
5711 /* Recursive function that traverses the tree of symbols that need to be
5712    written and writes them in order.  */
5713
5714 static void
5715 write_symbol1_recursion (sorted_pointer_info *sp)
5716 {
5717   if (!sp)
5718     return;
5719
5720   write_symbol1_recursion (sp->left);
5721
5722   pointer_info *p1 = sp->p;
5723   gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
5724
5725   p1->u.wsym.state = WRITTEN;
5726   write_symbol (p1->integer, p1->u.wsym.sym);
5727   p1->u.wsym.sym->attr.public_used = 1;
5728
5729   write_symbol1_recursion (sp->right);
5730 }
5731
5732
5733 /* Write the secondary set of symbols to the module file.  These are
5734    symbols that were not public yet are needed by the public symbols
5735    or another dependent symbol.  The act of writing a symbol can add
5736    symbols to the pointer_info tree, so we return nonzero if a symbol
5737    was written and pass that information upwards.  The caller will
5738    then call this function again until nothing was written.  It uses
5739    the utility functions and a temporary tree to ensure a reproducible
5740    ordering of the symbol output and thus the module file.  */
5741
5742 static int
5743 write_symbol1 (pointer_info *p)
5744 {
5745   if (!p)
5746     return 0;
5747
5748   /* Put symbols that need to be written into a tree sorted on the
5749      integer field.  */
5750
5751   sorted_pointer_info *spi_root = NULL;
5752   find_symbols_to_write (&spi_root, p);
5753
5754   /* No symbols to write, return.  */
5755   if (!spi_root)
5756     return 0;
5757
5758   /* Otherwise, write and free the tree again.  */
5759   write_symbol1_recursion (spi_root);
5760   free_sorted_pointer_info_tree (spi_root);
5761
5762   return 1;
5763 }
5764
5765
5766 /* Write operator interfaces associated with a symbol.  */
5767
5768 static void
5769 write_operator (gfc_user_op *uop)
5770 {
5771   static char nullstring[] = "";
5772   const char *p = nullstring;
5773
5774   if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
5775     return;
5776
5777   mio_symbol_interface (&uop->name, &p, &uop->op);
5778 }
5779
5780
5781 /* Write generic interfaces from the namespace sym_root.  */
5782
5783 static void
5784 write_generic (gfc_symtree *st)
5785 {
5786   gfc_symbol *sym;
5787
5788   if (st == NULL)
5789     return;
5790
5791   write_generic (st->left);
5792
5793   sym = st->n.sym;
5794   if (sym && !check_unique_name (st->name)
5795       && sym->generic && gfc_check_symbol_access (sym))
5796     {
5797       if (!sym->module)
5798         sym->module = module_name;
5799
5800       mio_symbol_interface (&st->name, &sym->module, &sym->generic);
5801     }
5802
5803   write_generic (st->right);
5804 }
5805
5806
5807 static void
5808 write_symtree (gfc_symtree *st)
5809 {
5810   gfc_symbol *sym;
5811   pointer_info *p;
5812
5813   sym = st->n.sym;
5814
5815   /* A symbol in an interface body must not be visible in the
5816      module file.  */
5817   if (sym->ns != gfc_current_ns
5818         && sym->ns->proc_name
5819         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
5820     return;
5821
5822   if (!gfc_check_symbol_access (sym)
5823       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5824           && !sym->attr.subroutine && !sym->attr.function))
5825     return;
5826
5827   if (check_unique_name (st->name))
5828     return;
5829
5830   p = find_pointer (sym);
5831   if (p == NULL)
5832     gfc_internal_error ("write_symtree(): Symbol not written");
5833
5834   mio_pool_string (&st->name);
5835   mio_integer (&st->ambiguous);
5836   mio_integer (&p->integer);
5837 }
5838
5839
5840 static void
5841 write_module (void)
5842 {
5843   int i;
5844
5845   /* Write the operator interfaces.  */
5846   mio_lparen ();
5847
5848   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5849     {
5850       if (i == INTRINSIC_USER)
5851         continue;
5852
5853       mio_interface (check_access (gfc_current_ns->operator_access[i],
5854                                    gfc_current_ns->default_access)
5855                      ? &gfc_current_ns->op[i] : NULL);
5856     }
5857
5858   mio_rparen ();
5859   write_char ('\n');
5860   write_char ('\n');
5861
5862   mio_lparen ();
5863   gfc_traverse_user_op (gfc_current_ns, write_operator);
5864   mio_rparen ();
5865   write_char ('\n');
5866   write_char ('\n');
5867
5868   mio_lparen ();
5869   write_generic (gfc_current_ns->sym_root);
5870   mio_rparen ();
5871   write_char ('\n');
5872   write_char ('\n');
5873
5874   mio_lparen ();
5875   write_blank_common ();
5876   write_common (gfc_current_ns->common_root);
5877   mio_rparen ();
5878   write_char ('\n');
5879   write_char ('\n');
5880
5881   mio_lparen ();
5882   write_equiv ();
5883   mio_rparen ();
5884   write_char ('\n');
5885   write_char ('\n');
5886
5887   mio_lparen ();
5888   gfc_traverse_symtree (gfc_current_ns->sym_root,
5889                         write_derived_extensions);
5890   mio_rparen ();
5891   write_char ('\n');
5892   write_char ('\n');
5893
5894   mio_lparen ();
5895   write_omp_udrs (gfc_current_ns->omp_udr_root);
5896   mio_rparen ();
5897   write_char ('\n');
5898   write_char ('\n');
5899
5900   /* Write symbol information.  First we traverse all symbols in the
5901      primary namespace, writing those that need to be written.
5902      Sometimes writing one symbol will cause another to need to be
5903      written.  A list of these symbols ends up on the write stack, and
5904      we end by popping the bottom of the stack and writing the symbol
5905      until the stack is empty.  */
5906
5907   mio_lparen ();
5908
5909   write_symbol0 (gfc_current_ns->sym_root);
5910   while (write_symbol1 (pi_root))
5911     /* Nothing.  */;
5912
5913   mio_rparen ();
5914
5915   write_char ('\n');
5916   write_char ('\n');
5917
5918   mio_lparen ();
5919   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5920   mio_rparen ();
5921 }
5922
5923
5924 /* Read a CRC32 sum from the gzip trailer of a module file.  Returns
5925    true on success, false on failure.  */
5926
5927 static bool
5928 read_crc32_from_module_file (const char* filename, uLong* crc)
5929 {
5930   FILE *file;
5931   char buf[4];
5932   unsigned int val;
5933
5934   /* Open the file in binary mode.  */
5935   if ((file = fopen (filename, "rb")) == NULL)
5936     return false;
5937
5938   /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5939      file. See RFC 1952.  */
5940   if (fseek (file, -8, SEEK_END) != 0)
5941     {
5942       fclose (file);
5943       return false;
5944     }
5945
5946   /* Read the CRC32.  */
5947   if (fread (buf, 1, 4, file) != 4)
5948     {
5949       fclose (file);
5950       return false;
5951     }
5952
5953   /* Close the file.  */
5954   fclose (file);
5955
5956   val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
5957     + ((buf[3] & 0xFF) << 24);
5958   *crc = val;
5959
5960   /* For debugging, the CRC value printed in hexadecimal should match
5961      the CRC printed by "zcat -l -v filename".
5962      printf("CRC of file %s is %x\n", filename, val); */
5963
5964   return true;
5965 }
5966
5967
5968 /* Given module, dump it to disk.  If there was an error while
5969    processing the module, dump_flag will be set to zero and we delete
5970    the module file, even if it was already there.  */
5971
5972 void
5973 gfc_dump_module (const char *name, int dump_flag)
5974 {
5975   int n;
5976   char *filename, *filename_tmp;
5977   uLong crc, crc_old;
5978
5979   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
5980   if (gfc_option.module_dir != NULL)
5981     {
5982       n += strlen (gfc_option.module_dir);
5983       filename = (char *) alloca (n);
5984       strcpy (filename, gfc_option.module_dir);
5985       strcat (filename, name);
5986     }
5987   else
5988     {
5989       filename = (char *) alloca (n);
5990       strcpy (filename, name);
5991     }
5992   strcat (filename, MODULE_EXTENSION);
5993
5994   /* Name of the temporary file used to write the module.  */
5995   filename_tmp = (char *) alloca (n + 1);
5996   strcpy (filename_tmp, filename);
5997   strcat (filename_tmp, "0");
5998
5999   /* There was an error while processing the module.  We delete the
6000      module file, even if it was already there.  */
6001   if (!dump_flag)
6002     {
6003       remove (filename);
6004       return;
6005     }
6006
6007   if (gfc_cpp_makedep ())
6008     gfc_cpp_add_target (filename);
6009
6010   /* Write the module to the temporary file.  */
6011   module_fp = gzopen (filename_tmp, "w");
6012   if (module_fp == NULL)
6013     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
6014                      filename_tmp, xstrerror (errno));
6015
6016   gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
6017             MOD_VERSION, gfc_source_file);
6018
6019   /* Write the module itself.  */
6020   iomode = IO_OUTPUT;
6021   module_name = gfc_get_string (name);
6022
6023   init_pi_tree ();
6024
6025   write_module ();
6026
6027   free_pi_tree (pi_root);
6028   pi_root = NULL;
6029
6030   write_char ('\n');
6031
6032   if (gzclose (module_fp))
6033     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
6034                      filename_tmp, xstrerror (errno));
6035
6036   /* Read the CRC32 from the gzip trailers of the module files and
6037      compare.  */
6038   if (!read_crc32_from_module_file (filename_tmp, &crc)
6039       || !read_crc32_from_module_file (filename, &crc_old)
6040       || crc_old != crc)
6041     {
6042       /* Module file have changed, replace the old one.  */
6043       if (remove (filename) && errno != ENOENT)
6044         gfc_fatal_error ("Can't delete module file '%s': %s", filename,
6045                          xstrerror (errno));
6046       if (rename (filename_tmp, filename))
6047         gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
6048                          filename_tmp, filename, xstrerror (errno));
6049     }
6050   else
6051     {
6052       if (remove (filename_tmp))
6053         gfc_fatal_error ("Can't delete temporary module file '%s': %s",
6054                          filename_tmp, xstrerror (errno));
6055     }
6056 }
6057
6058
6059 static void
6060 create_intrinsic_function (const char *name, int id,
6061                            const char *modname, intmod_id module,
6062                            bool subroutine, gfc_symbol *result_type)
6063 {
6064   gfc_intrinsic_sym *isym;
6065   gfc_symtree *tmp_symtree;
6066   gfc_symbol *sym;
6067
6068   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6069   if (tmp_symtree)
6070     {
6071       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6072         return;
6073       gfc_error ("Symbol '%s' already declared", name);
6074     }
6075
6076   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6077   sym = tmp_symtree->n.sym;
6078
6079   if (subroutine)
6080     {
6081       gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6082       isym = gfc_intrinsic_subroutine_by_id (isym_id);
6083       sym->attr.subroutine = 1;
6084     }
6085   else
6086     {
6087       gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6088       isym = gfc_intrinsic_function_by_id (isym_id);
6089
6090       sym->attr.function = 1;
6091       if (result_type)
6092         {
6093           sym->ts.type = BT_DERIVED;
6094           sym->ts.u.derived = result_type;
6095           sym->ts.is_c_interop = 1;
6096           isym->ts.f90_type = BT_VOID;
6097           isym->ts.type = BT_DERIVED;
6098           isym->ts.f90_type = BT_VOID;
6099           isym->ts.u.derived = result_type;
6100           isym->ts.is_c_interop = 1;
6101         }
6102     }
6103   gcc_assert (isym);
6104
6105   sym->attr.flavor = FL_PROCEDURE;
6106   sym->attr.intrinsic = 1;
6107
6108   sym->module = gfc_get_string (modname);
6109   sym->attr.use_assoc = 1;
6110   sym->from_intmod = module;
6111   sym->intmod_sym_id = id;
6112 }
6113
6114
6115 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6116    the current namespace for all named constants, pointer types, and
6117    procedures in the module unless the only clause was used or a rename
6118    list was provided.  */
6119
6120 static void
6121 import_iso_c_binding_module (void)
6122 {
6123   gfc_symbol *mod_sym = NULL, *return_type;
6124   gfc_symtree *mod_symtree = NULL, *tmp_symtree;
6125   gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
6126   const char *iso_c_module_name = "__iso_c_binding";
6127   gfc_use_rename *u;
6128   int i;
6129   bool want_c_ptr = false, want_c_funptr = false;
6130
6131   /* Look only in the current namespace.  */
6132   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
6133
6134   if (mod_symtree == NULL)
6135     {
6136       /* symtree doesn't already exist in current namespace.  */
6137       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
6138                         false);
6139
6140       if (mod_symtree != NULL)
6141         mod_sym = mod_symtree->n.sym;
6142       else
6143         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6144                             "create symbol for %s", iso_c_module_name);
6145
6146       mod_sym->attr.flavor = FL_MODULE;
6147       mod_sym->attr.intrinsic = 1;
6148       mod_sym->module = gfc_get_string (iso_c_module_name);
6149       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
6150     }
6151
6152   /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6153      check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6154      need C_(FUN)PTR.  */
6155   for (u = gfc_rename_list; u; u = u->next)
6156     {
6157       if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
6158                   u->use_name) == 0)
6159         want_c_ptr = true;
6160       else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
6161                        u->use_name) == 0)
6162         want_c_ptr = true;
6163       else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
6164                        u->use_name) == 0)
6165         want_c_funptr = true;
6166       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
6167                        u->use_name) == 0)
6168         want_c_funptr = true;
6169       else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
6170                        u->use_name) == 0)
6171         {
6172           c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6173                                                (iso_c_binding_symbol)
6174                                                         ISOCBINDING_PTR,
6175                                                u->local_name[0] ? u->local_name
6176                                                                 : u->use_name,
6177                                                NULL, false);
6178         }
6179       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
6180                        u->use_name) == 0)
6181         {
6182           c_funptr
6183              = generate_isocbinding_symbol (iso_c_module_name,
6184                                             (iso_c_binding_symbol)
6185                                                         ISOCBINDING_FUNPTR,
6186                                              u->local_name[0] ? u->local_name
6187                                                               : u->use_name,
6188                                              NULL, false);
6189         }
6190     }
6191
6192   if ((want_c_ptr || !only_flag) && !c_ptr)
6193     c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6194                                          (iso_c_binding_symbol)
6195                                                         ISOCBINDING_PTR,
6196                                          NULL, NULL, only_flag);
6197   if ((want_c_funptr || !only_flag) && !c_funptr)
6198     c_funptr = generate_isocbinding_symbol (iso_c_module_name,
6199                                             (iso_c_binding_symbol)
6200                                                         ISOCBINDING_FUNPTR,
6201                                             NULL, NULL, only_flag);
6202
6203   /* Generate the symbols for the named constants representing
6204      the kinds for intrinsic data types.  */
6205   for (i = 0; i < ISOCBINDING_NUMBER; i++)
6206     {
6207       bool found = false;
6208       for (u = gfc_rename_list; u; u = u->next)
6209         if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
6210           {
6211             bool not_in_std;
6212             const char *name;
6213             u->found = 1;
6214             found = true;
6215
6216             switch (i)
6217               {
6218 #define NAMED_FUNCTION(a,b,c,d) \
6219                 case a: \
6220                   not_in_std = (gfc_option.allow_std & d) == 0; \
6221                   name = b; \
6222                   break;
6223 #define NAMED_SUBROUTINE(a,b,c,d) \
6224                 case a: \
6225                   not_in_std = (gfc_option.allow_std & d) == 0; \
6226                   name = b; \
6227                   break;
6228 #define NAMED_INTCST(a,b,c,d) \
6229                 case a: \
6230                   not_in_std = (gfc_option.allow_std & d) == 0; \
6231                   name = b; \
6232                   break;
6233 #define NAMED_REALCST(a,b,c,d) \
6234                 case a: \
6235                   not_in_std = (gfc_option.allow_std & d) == 0; \
6236                   name = b; \
6237                   break;
6238 #define NAMED_CMPXCST(a,b,c,d) \
6239                 case a: \
6240                   not_in_std = (gfc_option.allow_std & d) == 0; \
6241                   name = b; \
6242                   break;
6243 #include "iso-c-binding.def"
6244                 default:
6245                   not_in_std = false;
6246                   name = "";
6247               }
6248
6249             if (not_in_std)
6250               {
6251                 gfc_error ("The symbol '%s', referenced at %L, is not "
6252                            "in the selected standard", name, &u->where);
6253                 continue;
6254               }
6255
6256             switch (i)
6257               {
6258 #define NAMED_FUNCTION(a,b,c,d) \
6259                 case a: \
6260                   if (a == ISOCBINDING_LOC) \
6261                     return_type = c_ptr->n.sym; \
6262                   else if (a == ISOCBINDING_FUNLOC) \
6263                     return_type = c_funptr->n.sym; \
6264                   else \
6265                     return_type = NULL; \
6266                   create_intrinsic_function (u->local_name[0] \
6267                                              ? u->local_name : u->use_name, \
6268                                              a, iso_c_module_name, \
6269                                              INTMOD_ISO_C_BINDING, false, \
6270                                              return_type); \
6271                   break;
6272 #define NAMED_SUBROUTINE(a,b,c,d) \
6273                 case a: \
6274                   create_intrinsic_function (u->local_name[0] ? u->local_name \
6275                                                               : u->use_name, \
6276                                              a, iso_c_module_name, \
6277                                              INTMOD_ISO_C_BINDING, true, NULL); \
6278                   break;
6279 #include "iso-c-binding.def"
6280
6281                 case ISOCBINDING_PTR:
6282                 case ISOCBINDING_FUNPTR:
6283                   /* Already handled above.  */
6284                   break;
6285                 default:
6286                   if (i == ISOCBINDING_NULL_PTR)
6287                     tmp_symtree = c_ptr;
6288                   else if (i == ISOCBINDING_NULL_FUNPTR)
6289                     tmp_symtree = c_funptr;
6290                   else
6291                     tmp_symtree = NULL;
6292                   generate_isocbinding_symbol (iso_c_module_name,
6293                                                (iso_c_binding_symbol) i,
6294                                                u->local_name[0]
6295                                                ? u->local_name : u->use_name,
6296                                                tmp_symtree, false);
6297               }
6298           }
6299
6300       if (!found && !only_flag)
6301         {
6302           /* Skip, if the symbol is not in the enabled standard.  */
6303           switch (i)
6304             {
6305 #define NAMED_FUNCTION(a,b,c,d) \
6306               case a: \
6307                 if ((gfc_option.allow_std & d) == 0) \
6308                   continue; \
6309                 break;
6310 #define NAMED_SUBROUTINE(a,b,c,d) \
6311               case a: \
6312                 if ((gfc_option.allow_std & d) == 0) \
6313                   continue; \
6314                 break;
6315 #define NAMED_INTCST(a,b,c,d) \
6316               case a: \
6317                 if ((gfc_option.allow_std & d) == 0) \
6318                   continue; \
6319                 break;
6320 #define NAMED_REALCST(a,b,c,d) \
6321               case a: \
6322                 if ((gfc_option.allow_std & d) == 0) \
6323                   continue; \
6324                 break;
6325 #define NAMED_CMPXCST(a,b,c,d) \
6326               case a: \
6327                 if ((gfc_option.allow_std & d) == 0) \
6328                   continue; \
6329                 break;
6330 #include "iso-c-binding.def"
6331               default:
6332                 ; /* Not GFC_STD_* versioned.  */
6333             }
6334
6335           switch (i)
6336             {
6337 #define NAMED_FUNCTION(a,b,c,d) \
6338               case a: \
6339                 if (a == ISOCBINDING_LOC) \
6340                   return_type = c_ptr->n.sym; \
6341                 else if (a == ISOCBINDING_FUNLOC) \
6342                   return_type = c_funptr->n.sym; \
6343                 else \
6344                   return_type = NULL; \
6345                 create_intrinsic_function (b, a, iso_c_module_name, \
6346                                            INTMOD_ISO_C_BINDING, false, \
6347                                            return_type); \
6348                 break;
6349 #define NAMED_SUBROUTINE(a,b,c,d) \
6350               case a: \
6351                 create_intrinsic_function (b, a, iso_c_module_name, \
6352                                            INTMOD_ISO_C_BINDING, true, NULL); \
6353                   break;
6354 #include "iso-c-binding.def"
6355
6356               case ISOCBINDING_PTR:
6357               case ISOCBINDING_FUNPTR:
6358                 /* Already handled above.  */
6359                 break;
6360               default:
6361                 if (i == ISOCBINDING_NULL_PTR)
6362                   tmp_symtree = c_ptr;
6363                 else if (i == ISOCBINDING_NULL_FUNPTR)
6364                   tmp_symtree = c_funptr;
6365                 else
6366                   tmp_symtree = NULL;
6367                 generate_isocbinding_symbol (iso_c_module_name,
6368                                              (iso_c_binding_symbol) i, NULL,
6369                                              tmp_symtree, false);
6370             }
6371         }
6372    }
6373
6374    for (u = gfc_rename_list; u; u = u->next)
6375      {
6376       if (u->found)
6377         continue;
6378
6379       gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6380                  "module ISO_C_BINDING", u->use_name, &u->where);
6381      }
6382 }
6383
6384
6385 /* Add an integer named constant from a given module.  */
6386
6387 static void
6388 create_int_parameter (const char *name, int value, const char *modname,
6389                       intmod_id module, int id)
6390 {
6391   gfc_symtree *tmp_symtree;
6392   gfc_symbol *sym;
6393
6394   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6395   if (tmp_symtree != NULL)
6396     {
6397       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6398         return;
6399       else
6400         gfc_error ("Symbol '%s' already declared", name);
6401     }
6402
6403   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6404   sym = tmp_symtree->n.sym;
6405
6406   sym->module = gfc_get_string (modname);
6407   sym->attr.flavor = FL_PARAMETER;
6408   sym->ts.type = BT_INTEGER;
6409   sym->ts.kind = gfc_default_integer_kind;
6410   sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
6411   sym->attr.use_assoc = 1;
6412   sym->from_intmod = module;
6413   sym->intmod_sym_id = id;
6414 }
6415
6416
6417 /* Value is already contained by the array constructor, but not
6418    yet the shape.  */
6419
6420 static void
6421 create_int_parameter_array (const char *name, int size, gfc_expr *value,
6422                             const char *modname, intmod_id module, int id)
6423 {
6424   gfc_symtree *tmp_symtree;
6425   gfc_symbol *sym;
6426
6427   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6428   if (tmp_symtree != NULL)
6429     {
6430       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6431         return;
6432       else
6433         gfc_error ("Symbol '%s' already declared", name);
6434     }
6435
6436   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6437   sym = tmp_symtree->n.sym;
6438
6439   sym->module = gfc_get_string (modname);
6440   sym->attr.flavor = FL_PARAMETER;
6441   sym->ts.type = BT_INTEGER;
6442   sym->ts.kind = gfc_default_integer_kind;
6443   sym->attr.use_assoc = 1;
6444   sym->from_intmod = module;
6445   sym->intmod_sym_id = id;
6446   sym->attr.dimension = 1;
6447   sym->as = gfc_get_array_spec ();
6448   sym->as->rank = 1;
6449   sym->as->type = AS_EXPLICIT;
6450   sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6451   sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
6452
6453   sym->value = value;
6454   sym->value->shape = gfc_get_shape (1);
6455   mpz_init_set_ui (sym->value->shape[0], size);
6456 }
6457
6458
6459 /* Add an derived type for a given module.  */
6460
6461 static void
6462 create_derived_type (const char *name, const char *modname,
6463                       intmod_id module, int id)
6464 {
6465   gfc_symtree *tmp_symtree;
6466   gfc_symbol *sym, *dt_sym;
6467   gfc_interface *intr, *head;
6468
6469   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6470   if (tmp_symtree != NULL)
6471     {
6472       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6473         return;
6474       else
6475         gfc_error ("Symbol '%s' already declared", name);
6476     }
6477
6478   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6479   sym = tmp_symtree->n.sym;
6480   sym->module = gfc_get_string (modname);
6481   sym->from_intmod = module;
6482   sym->intmod_sym_id = id;
6483   sym->attr.flavor = FL_PROCEDURE;
6484   sym->attr.function = 1;
6485   sym->attr.generic = 1;
6486
6487   gfc_get_sym_tree (dt_upper_string (sym->name),
6488                     gfc_current_ns, &tmp_symtree, false);
6489   dt_sym = tmp_symtree->n.sym;
6490   dt_sym->name = gfc_get_string (sym->name);
6491   dt_sym->attr.flavor = FL_DERIVED;
6492   dt_sym->attr.private_comp = 1;
6493   dt_sym->attr.zero_comp = 1;
6494   dt_sym->attr.use_assoc = 1;
6495   dt_sym->module = gfc_get_string (modname);
6496   dt_sym->from_intmod = module;
6497   dt_sym->intmod_sym_id = id;
6498
6499   head = sym->generic;
6500   intr = gfc_get_interface ();
6501   intr->sym = dt_sym;
6502   intr->where = gfc_current_locus;
6503   intr->next = head;
6504   sym->generic = intr;
6505   sym->attr.if_source = IFSRC_DECL;
6506 }
6507
6508
6509 /* Read the contents of the module file into a temporary buffer.  */
6510
6511 static void
6512 read_module_to_tmpbuf ()
6513 {
6514   /* We don't know the uncompressed size, so enlarge the buffer as
6515      needed.  */
6516   int cursz = 4096;
6517   int rsize = cursz;
6518   int len = 0;
6519
6520   module_content = XNEWVEC (char, cursz);
6521
6522   while (1)
6523     {
6524       int nread = gzread (module_fp, module_content + len, rsize);
6525       len += nread;
6526       if (nread < rsize)
6527         break;
6528       cursz *= 2;
6529       module_content = XRESIZEVEC (char, module_content, cursz);
6530       rsize = cursz - len;
6531     }
6532
6533   module_content = XRESIZEVEC (char, module_content, len + 1);
6534   module_content[len] = '\0';
6535
6536   module_pos = 0;
6537 }
6538
6539
6540 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
6541
6542 static void
6543 use_iso_fortran_env_module (void)
6544 {
6545   static char mod[] = "iso_fortran_env";
6546   gfc_use_rename *u;
6547   gfc_symbol *mod_sym;
6548   gfc_symtree *mod_symtree;
6549   gfc_expr *expr;
6550   int i, j;
6551
6552   intmod_sym symbol[] = {
6553 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6554 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6555 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6556 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6557 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6558 #include "iso-fortran-env.def"
6559     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
6560
6561   i = 0;
6562 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6563 #include "iso-fortran-env.def"
6564
6565   /* Generate the symbol for the module itself.  */
6566   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
6567   if (mod_symtree == NULL)
6568     {
6569       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
6570       gcc_assert (mod_symtree);
6571       mod_sym = mod_symtree->n.sym;
6572
6573       mod_sym->attr.flavor = FL_MODULE;
6574       mod_sym->attr.intrinsic = 1;
6575       mod_sym->module = gfc_get_string (mod);
6576       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
6577     }
6578   else
6579     if (!mod_symtree->n.sym->attr.intrinsic)
6580       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
6581                  "non-intrinsic module name used previously", mod);
6582
6583   /* Generate the symbols for the module integer named constants.  */
6584
6585   for (i = 0; symbol[i].name; i++)
6586     {
6587       bool found = false;
6588       for (u = gfc_rename_list; u; u = u->next)
6589         {
6590           if (strcmp (symbol[i].name, u->use_name) == 0)
6591             {
6592               found = true;
6593               u->found = 1;
6594
6595               if (!gfc_notify_std (symbol[i].standard, "The symbol '%s', "
6596                                    "referenced at %L, is not in the selected "
6597                                    "standard", symbol[i].name, &u->where))
6598                 continue;
6599
6600               if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
6601                   && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6602                 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
6603                                  "constant from intrinsic module "
6604                                  "ISO_FORTRAN_ENV at %L is incompatible with "
6605                                  "option %s", &u->where,
6606                                  gfc_option.flag_default_integer
6607                                    ? "-fdefault-integer-8"
6608                                    : "-fdefault-real-8");
6609               switch (symbol[i].id)
6610                 {
6611 #define NAMED_INTCST(a,b,c,d) \
6612                 case a:
6613 #include "iso-fortran-env.def"
6614                   create_int_parameter (u->local_name[0] ? u->local_name
6615                                                          : u->use_name,
6616                                         symbol[i].value, mod,
6617                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6618                   break;
6619
6620 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6621                 case a:\
6622                   expr = gfc_get_array_expr (BT_INTEGER, \
6623                                              gfc_default_integer_kind,\
6624                                              NULL); \
6625                   for (j = 0; KINDS[j].kind != 0; j++) \
6626                     gfc_constructor_append_expr (&expr->value.constructor, \
6627                         gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6628                                           KINDS[j].kind), NULL); \
6629                   create_int_parameter_array (u->local_name[0] ? u->local_name \
6630                                                          : u->use_name, \
6631                                               j, expr, mod, \
6632                                               INTMOD_ISO_FORTRAN_ENV, \
6633                                               symbol[i].id); \
6634                   break;
6635 #include "iso-fortran-env.def"
6636
6637 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6638                 case a:
6639 #include "iso-fortran-env.def"
6640                   create_derived_type (u->local_name[0] ? u->local_name
6641                                                         : u->use_name,
6642                                        mod, INTMOD_ISO_FORTRAN_ENV,
6643                                        symbol[i].id);
6644                   break;
6645
6646 #define NAMED_FUNCTION(a,b,c,d) \
6647                 case a:
6648 #include "iso-fortran-env.def"
6649                   create_intrinsic_function (u->local_name[0] ? u->local_name
6650                                                               : u->use_name,
6651                                              symbol[i].id, mod,
6652                                              INTMOD_ISO_FORTRAN_ENV, false,
6653                                              NULL);
6654                   break;
6655
6656                 default:
6657                   gcc_unreachable ();
6658                 }
6659             }
6660         }
6661
6662       if (!found && !only_flag)
6663         {
6664           if ((gfc_option.allow_std & symbol[i].standard) == 0)
6665             continue;
6666
6667           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
6668               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6669             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
6670                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
6671                              "incompatible with option %s",
6672                              gfc_option.flag_default_integer
6673                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
6674
6675           switch (symbol[i].id)
6676             {
6677 #define NAMED_INTCST(a,b,c,d) \
6678             case a:
6679 #include "iso-fortran-env.def"
6680               create_int_parameter (symbol[i].name, symbol[i].value, mod,
6681                                     INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6682               break;
6683
6684 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6685             case a:\
6686               expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6687                                          NULL); \
6688               for (j = 0; KINDS[j].kind != 0; j++) \
6689                 gfc_constructor_append_expr (&expr->value.constructor, \
6690                       gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6691                                         KINDS[j].kind), NULL); \
6692             create_int_parameter_array (symbol[i].name, j, expr, mod, \
6693                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6694             break;
6695 #include "iso-fortran-env.def"
6696
6697 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6698           case a:
6699 #include "iso-fortran-env.def"
6700             create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
6701                                  symbol[i].id);
6702             break;
6703
6704 #define NAMED_FUNCTION(a,b,c,d) \
6705                 case a:
6706 #include "iso-fortran-env.def"
6707                   create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
6708                                              INTMOD_ISO_FORTRAN_ENV, false,
6709                                              NULL);
6710                   break;
6711
6712           default:
6713             gcc_unreachable ();
6714           }
6715         }
6716     }
6717
6718   for (u = gfc_rename_list; u; u = u->next)
6719     {
6720       if (u->found)
6721         continue;
6722
6723       gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6724                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
6725     }
6726 }
6727
6728
6729 /* Process a USE directive.  */
6730
6731 static void
6732 gfc_use_module (gfc_use_list *module)
6733 {
6734   char *filename;
6735   gfc_state_data *p;
6736   int c, line, start;
6737   gfc_symtree *mod_symtree;
6738   gfc_use_list *use_stmt;
6739   locus old_locus = gfc_current_locus;
6740
6741   gfc_current_locus = module->where;
6742   module_name = module->module_name;
6743   gfc_rename_list = module->rename;
6744   only_flag = module->only_flag;
6745   current_intmod = INTMOD_NONE;
6746
6747   if (!only_flag)
6748     gfc_warning_now_2 (OPT_Wuse_without_only,
6749                        "USE statement at %C has no ONLY qualifier");
6750
6751   filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
6752                                + 1);
6753   strcpy (filename, module_name);
6754   strcat (filename, MODULE_EXTENSION);
6755
6756   /* First, try to find an non-intrinsic module, unless the USE statement
6757      specified that the module is intrinsic.  */
6758   module_fp = NULL;
6759   if (!module->intrinsic)
6760     module_fp = gzopen_included_file (filename, true, true);
6761
6762   /* Then, see if it's an intrinsic one, unless the USE statement
6763      specified that the module is non-intrinsic.  */
6764   if (module_fp == NULL && !module->non_intrinsic)
6765     {
6766       if (strcmp (module_name, "iso_fortran_env") == 0
6767           && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
6768                              "intrinsic module at %C"))
6769        {
6770          use_iso_fortran_env_module ();
6771          free_rename (module->rename);
6772          module->rename = NULL;
6773          gfc_current_locus = old_locus;
6774          module->intrinsic = true;
6775          return;
6776        }
6777
6778       if (strcmp (module_name, "iso_c_binding") == 0
6779           && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
6780         {
6781           import_iso_c_binding_module();
6782           free_rename (module->rename);
6783           module->rename = NULL;
6784           gfc_current_locus = old_locus;
6785           module->intrinsic = true;
6786           return;
6787         }
6788
6789       module_fp = gzopen_intrinsic_module (filename);
6790
6791       if (module_fp == NULL && module->intrinsic)
6792         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6793                          module_name);
6794
6795       /* Check for the IEEE modules, so we can mark their symbols
6796          accordingly when we read them.  */
6797       if (strcmp (module_name, "ieee_features") == 0
6798           && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
6799         {
6800           current_intmod = INTMOD_IEEE_FEATURES;
6801         }
6802       else if (strcmp (module_name, "ieee_exceptions") == 0
6803                && gfc_notify_std (GFC_STD_F2003,
6804                                   "IEEE_EXCEPTIONS module at %C"))
6805         {
6806           current_intmod = INTMOD_IEEE_EXCEPTIONS;
6807         }
6808       else if (strcmp (module_name, "ieee_arithmetic") == 0
6809                && gfc_notify_std (GFC_STD_F2003,
6810                                   "IEEE_ARITHMETIC module at %C"))
6811         {
6812           current_intmod = INTMOD_IEEE_ARITHMETIC;
6813         }
6814     }
6815
6816   if (module_fp == NULL)
6817     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6818                      filename, xstrerror (errno));
6819
6820   /* Check that we haven't already USEd an intrinsic module with the
6821      same name.  */
6822
6823   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
6824   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
6825     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6826                "intrinsic module name used previously", module_name);
6827
6828   iomode = IO_INPUT;
6829   module_line = 1;
6830   module_column = 1;
6831   start = 0;
6832
6833   read_module_to_tmpbuf ();
6834   gzclose (module_fp);
6835
6836   /* Skip the first line of the module, after checking that this is
6837      a gfortran module file.  */
6838   line = 0;
6839   while (line < 1)
6840     {
6841       c = module_char ();
6842       if (c == EOF)
6843         bad_module ("Unexpected end of module");
6844       if (start++ < 3)
6845         parse_name (c);
6846       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
6847           || (start == 2 && strcmp (atom_name, " module") != 0))
6848         gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6849                          " module file", filename);
6850       if (start == 3)
6851         {
6852           if (strcmp (atom_name, " version") != 0
6853               || module_char () != ' '
6854               || parse_atom () != ATOM_STRING
6855               || strcmp (atom_string, MOD_VERSION))
6856             gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6857                              " because it was created by a different"
6858                              " version of GNU Fortran", filename);
6859
6860           free (atom_string);
6861         }
6862
6863       if (c == '\n')
6864         line++;
6865     }
6866
6867   /* Make sure we're not reading the same module that we may be building.  */
6868   for (p = gfc_state_stack; p; p = p->previous)
6869     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
6870       gfc_fatal_error ("Can't USE the same module we're building!");
6871
6872   init_pi_tree ();
6873   init_true_name_tree ();
6874
6875   read_module ();
6876
6877   free_true_name (true_name_root);
6878   true_name_root = NULL;
6879
6880   free_pi_tree (pi_root);
6881   pi_root = NULL;
6882
6883   XDELETEVEC (module_content);
6884   module_content = NULL;
6885
6886   use_stmt = gfc_get_use_list ();
6887   *use_stmt = *module;
6888   use_stmt->next = gfc_current_ns->use_stmts;
6889   gfc_current_ns->use_stmts = use_stmt;
6890
6891   gfc_current_locus = old_locus;
6892 }
6893
6894
6895 /* Remove duplicated intrinsic operators from the rename list.  */
6896
6897 static void
6898 rename_list_remove_duplicate (gfc_use_rename *list)
6899 {
6900   gfc_use_rename *seek, *last;
6901
6902   for (; list; list = list->next)
6903     if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
6904       {
6905         last = list;
6906         for (seek = list->next; seek; seek = last->next)
6907           {
6908             if (list->op == seek->op)
6909               {
6910                 last->next = seek->next;
6911                 free (seek);
6912               }
6913             else
6914               last = seek;
6915           }
6916       }
6917 }
6918
6919
6920 /* Process all USE directives.  */
6921
6922 void
6923 gfc_use_modules (void)
6924 {
6925   gfc_use_list *next, *seek, *last;
6926
6927   for (next = module_list; next; next = next->next)
6928     {
6929       bool non_intrinsic = next->non_intrinsic;
6930       bool intrinsic = next->intrinsic;
6931       bool neither = !non_intrinsic && !intrinsic;
6932
6933       for (seek = next->next; seek; seek = seek->next)
6934         {
6935           if (next->module_name != seek->module_name)
6936             continue;
6937
6938           if (seek->non_intrinsic)
6939             non_intrinsic = true;
6940           else if (seek->intrinsic)
6941             intrinsic = true;
6942           else
6943             neither = true;
6944         }
6945
6946       if (intrinsic && neither && !non_intrinsic)
6947         {
6948           char *filename;
6949           FILE *fp;
6950
6951           filename = XALLOCAVEC (char,
6952                                  strlen (next->module_name)
6953                                  + strlen (MODULE_EXTENSION) + 1);
6954           strcpy (filename, next->module_name);
6955           strcat (filename, MODULE_EXTENSION);
6956           fp = gfc_open_included_file (filename, true, true);
6957           if (fp != NULL)
6958             {
6959               non_intrinsic = true;
6960               fclose (fp);
6961             }
6962         }
6963
6964       last = next;
6965       for (seek = next->next; seek; seek = last->next)
6966         {
6967           if (next->module_name != seek->module_name)
6968             {
6969               last = seek;
6970               continue;
6971             }
6972
6973           if ((!next->intrinsic && !seek->intrinsic)
6974               || (next->intrinsic && seek->intrinsic)
6975               || !non_intrinsic)
6976             {
6977               if (!seek->only_flag)
6978                 next->only_flag = false;
6979               if (seek->rename)
6980                 {
6981                   gfc_use_rename *r = seek->rename;
6982                   while (r->next)
6983                     r = r->next;
6984                   r->next = next->rename;
6985                   next->rename = seek->rename;
6986                 }
6987               last->next = seek->next;
6988               free (seek);
6989             }
6990           else
6991             last = seek;
6992         }
6993     }
6994
6995   for (; module_list; module_list = next)
6996     {
6997       next = module_list->next;
6998       rename_list_remove_duplicate (module_list->rename);
6999       gfc_use_module (module_list);
7000       free (module_list);
7001     }
7002   gfc_rename_list = NULL;
7003 }
7004
7005
7006 void
7007 gfc_free_use_stmts (gfc_use_list *use_stmts)
7008 {
7009   gfc_use_list *next;
7010   for (; use_stmts; use_stmts = next)
7011     {
7012       gfc_use_rename *next_rename;
7013
7014       for (; use_stmts->rename; use_stmts->rename = next_rename)
7015         {
7016           next_rename = use_stmts->rename->next;
7017           free (use_stmts->rename);
7018         }
7019       next = use_stmts->next;
7020       free (use_stmts);
7021     }
7022 }
7023
7024
7025 void
7026 gfc_module_init_2 (void)
7027 {
7028   last_atom = ATOM_LPAREN;
7029   gfc_rename_list = NULL;
7030   module_list = NULL;
7031 }
7032
7033
7034 void
7035 gfc_module_done_2 (void)
7036 {
7037   free_rename (gfc_rename_list);
7038   gfc_rename_list = NULL;
7039 }