OSDN Git Service

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