OSDN Git Service

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