OSDN Git Service

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