OSDN Git Service

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