OSDN Git Service

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