OSDN Git Service

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