OSDN Git Service

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