OSDN Git Service

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