OSDN Git Service

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