OSDN Git Service

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