xref: /netbsd/external/gpl3/gcc/dist/gcc/fortran/module.c (revision 7327edaf)
1 /* Handle modules, which amounts to loading and saving symbols and
2    their attendant structures.
3    Copyright (C) 2000-2020 Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5 
6 This file is part of GCC.
7 
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12 
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17 
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21 
22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23    sequence of atoms, which can be left or right parenthesis, names,
24    integers or strings.  Parenthesis are always matched which allows
25    us to skip over sections at high speed without having to know
26    anything about the internal structure of the lists.  A "name" is
27    usually a fortran 95 identifier, but can also start with '@' in
28    order to reference a hidden symbol.
29 
30    The first line of a module is an informational message about what
31    created the module, the file it came from and when it was created.
32    The second line is a warning for people not to edit the module.
33    The rest of the module looks like:
34 
35    ( ( <Interface info for UPLUS> )
36      ( <Interface info for UMINUS> )
37      ...
38    )
39    ( ( <name of operator interface> <module of op interface> <i/f1> ... )
40      ...
41    )
42    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
43      ...
44    )
45    ( ( <common name> <symbol> <saved flag>)
46      ...
47    )
48 
49    ( equivalence list )
50 
51    ( <Symbol Number (in no particular order)>
52      <True name of symbol>
53      <Module name of symbol>
54      ( <symbol information> )
55      ...
56    )
57    ( <Symtree name>
58      <Ambiguous flag>
59      <Symbol number>
60      ...
61    )
62 
63    In general, symbols refer to other symbols by their symbol number,
64    which are zero based.  Symbols are written to the module in no
65    particular order.  */
66 
67 #include "config.h"
68 #include "system.h"
69 #include "coretypes.h"
70 #include "options.h"
71 #include "tree.h"
72 #include "gfortran.h"
73 #include "stringpool.h"
74 #include "arith.h"
75 #include "match.h"
76 #include "parse.h" /* FIXME */
77 #include "constructor.h"
78 #include "cpp.h"
79 #include "scanner.h"
80 #include <zlib.h>
81 
82 #define MODULE_EXTENSION ".mod"
83 #define SUBMODULE_EXTENSION ".smod"
84 
85 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
86    recognized.  */
87 #define MOD_VERSION "15"
88 
89 
90 /* Structure that describes a position within a module file.  */
91 
92 typedef struct
93 {
94   int column, line;
95   long pos;
96 }
97 module_locus;
98 
99 /* Structure for list of symbols of intrinsic modules.  */
100 typedef struct
101 {
102   int id;
103   const char *name;
104   int value;
105   int standard;
106 }
107 intmod_sym;
108 
109 
110 typedef enum
111 {
112   P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
113 }
114 pointer_t;
115 
116 /* The fixup structure lists pointers to pointers that have to
117    be updated when a pointer value becomes known.  */
118 
119 typedef struct fixup_t
120 {
121   void **pointer;
122   struct fixup_t *next;
123 }
124 fixup_t;
125 
126 
127 /* Structure for holding extra info needed for pointers being read.  */
128 
129 enum gfc_rsym_state
130 {
131   UNUSED,
132   NEEDED,
133   USED
134 };
135 
136 enum gfc_wsym_state
137 {
138   UNREFERENCED = 0,
139   NEEDS_WRITE,
140   WRITTEN
141 };
142 
143 typedef struct pointer_info
144 {
145   BBT_HEADER (pointer_info);
146   HOST_WIDE_INT integer;
147   pointer_t type;
148 
149   /* The first component of each member of the union is the pointer
150      being stored.  */
151 
152   fixup_t *fixup;
153 
154   union
155   {
156     void *pointer;	/* Member for doing pointer searches.  */
157 
158     struct
159     {
160       gfc_symbol *sym;
161       char *true_name, *module, *binding_label;
162       fixup_t *stfixup;
163       gfc_symtree *symtree;
164       enum gfc_rsym_state state;
165       int ns, referenced, renamed;
166       module_locus where;
167     }
168     rsym;
169 
170     struct
171     {
172       gfc_symbol *sym;
173       enum gfc_wsym_state state;
174     }
175     wsym;
176   }
177   u;
178 
179 }
180 pointer_info;
181 
182 #define gfc_get_pointer_info() XCNEW (pointer_info)
183 
184 
185 /* Local variables */
186 
187 /* The gzFile for the module we're reading or writing.  */
188 static gzFile module_fp;
189 
190 /* Fully qualified module path */
191 static char *module_fullpath = NULL;
192 
193 /* The name of the module we're reading (USE'ing) or writing.  */
194 static const char *module_name;
195 /* The name of the .smod file that the submodule will write to.  */
196 static const char *submodule_name;
197 
198 static gfc_use_list *module_list;
199 
200 /* If we're reading an intrinsic module, this is its ID.  */
201 static intmod_id current_intmod;
202 
203 /* Content of module.  */
204 static char* module_content;
205 
206 static long module_pos;
207 static int module_line, module_column, only_flag;
208 static int prev_module_line, prev_module_column;
209 
210 static enum
211 { IO_INPUT, IO_OUTPUT }
212 iomode;
213 
214 static gfc_use_rename *gfc_rename_list;
215 static pointer_info *pi_root;
216 static int symbol_number;	/* Counter for assigning symbol numbers */
217 
218 /* Tells mio_expr_ref to make symbols for unused equivalence members.  */
219 static bool in_load_equiv;
220 
221 
222 
223 /*****************************************************************/
224 
225 /* Pointer/integer conversion.  Pointers between structures are stored
226    as integers in the module file.  The next couple of subroutines
227    handle this translation for reading and writing.  */
228 
229 /* Recursively free the tree of pointer structures.  */
230 
231 static void
free_pi_tree(pointer_info * p)232 free_pi_tree (pointer_info *p)
233 {
234   if (p == NULL)
235     return;
236 
237   if (p->fixup != NULL)
238     gfc_internal_error ("free_pi_tree(): Unresolved fixup");
239 
240   free_pi_tree (p->left);
241   free_pi_tree (p->right);
242 
243   if (iomode == IO_INPUT)
244     {
245       XDELETEVEC (p->u.rsym.true_name);
246       XDELETEVEC (p->u.rsym.module);
247       XDELETEVEC (p->u.rsym.binding_label);
248     }
249 
250   free (p);
251 }
252 
253 
254 /* Compare pointers when searching by pointer.  Used when writing a
255    module.  */
256 
257 static int
compare_pointers(void * _sn1,void * _sn2)258 compare_pointers (void *_sn1, void *_sn2)
259 {
260   pointer_info *sn1, *sn2;
261 
262   sn1 = (pointer_info *) _sn1;
263   sn2 = (pointer_info *) _sn2;
264 
265   if (sn1->u.pointer < sn2->u.pointer)
266     return -1;
267   if (sn1->u.pointer > sn2->u.pointer)
268     return 1;
269 
270   return 0;
271 }
272 
273 
274 /* Compare integers when searching by integer.  Used when reading a
275    module.  */
276 
277 static int
compare_integers(void * _sn1,void * _sn2)278 compare_integers (void *_sn1, void *_sn2)
279 {
280   pointer_info *sn1, *sn2;
281 
282   sn1 = (pointer_info *) _sn1;
283   sn2 = (pointer_info *) _sn2;
284 
285   if (sn1->integer < sn2->integer)
286     return -1;
287   if (sn1->integer > sn2->integer)
288     return 1;
289 
290   return 0;
291 }
292 
293 
294 /* Initialize the pointer_info tree.  */
295 
296 static void
init_pi_tree(void)297 init_pi_tree (void)
298 {
299   compare_fn compare;
300   pointer_info *p;
301 
302   pi_root = NULL;
303   compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
304 
305   /* Pointer 0 is the NULL pointer.  */
306   p = gfc_get_pointer_info ();
307   p->u.pointer = NULL;
308   p->integer = 0;
309   p->type = P_OTHER;
310 
311   gfc_insert_bbt (&pi_root, p, compare);
312 
313   /* Pointer 1 is the current namespace.  */
314   p = gfc_get_pointer_info ();
315   p->u.pointer = gfc_current_ns;
316   p->integer = 1;
317   p->type = P_NAMESPACE;
318 
319   gfc_insert_bbt (&pi_root, p, compare);
320 
321   symbol_number = 2;
322 }
323 
324 
325 /* During module writing, call here with a pointer to something,
326    returning the pointer_info node.  */
327 
328 static pointer_info *
find_pointer(void * gp)329 find_pointer (void *gp)
330 {
331   pointer_info *p;
332 
333   p = pi_root;
334   while (p != NULL)
335     {
336       if (p->u.pointer == gp)
337 	break;
338       p = (gp < p->u.pointer) ? p->left : p->right;
339     }
340 
341   return p;
342 }
343 
344 
345 /* Given a pointer while writing, returns the pointer_info tree node,
346    creating it if it doesn't exist.  */
347 
348 static pointer_info *
get_pointer(void * gp)349 get_pointer (void *gp)
350 {
351   pointer_info *p;
352 
353   p = find_pointer (gp);
354   if (p != NULL)
355     return p;
356 
357   /* Pointer doesn't have an integer.  Give it one.  */
358   p = gfc_get_pointer_info ();
359 
360   p->u.pointer = gp;
361   p->integer = symbol_number++;
362 
363   gfc_insert_bbt (&pi_root, p, compare_pointers);
364 
365   return p;
366 }
367 
368 
369 /* Given an integer during reading, find it in the pointer_info tree,
370    creating the node if not found.  */
371 
372 static pointer_info *
get_integer(HOST_WIDE_INT integer)373 get_integer (HOST_WIDE_INT integer)
374 {
375   pointer_info *p, t;
376   int c;
377 
378   t.integer = integer;
379 
380   p = pi_root;
381   while (p != NULL)
382     {
383       c = compare_integers (&t, p);
384       if (c == 0)
385 	break;
386 
387       p = (c < 0) ? p->left : p->right;
388     }
389 
390   if (p != NULL)
391     return p;
392 
393   p = gfc_get_pointer_info ();
394   p->integer = integer;
395   p->u.pointer = NULL;
396 
397   gfc_insert_bbt (&pi_root, p, compare_integers);
398 
399   return p;
400 }
401 
402 
403 /* Resolve any fixups using a known pointer.  */
404 
405 static void
resolve_fixups(fixup_t * f,void * gp)406 resolve_fixups (fixup_t *f, void *gp)
407 {
408   fixup_t *next;
409 
410   for (; f; f = next)
411     {
412       next = f->next;
413       *(f->pointer) = gp;
414       free (f);
415     }
416 }
417 
418 
419 /* Convert a string such that it starts with a lower-case character. Used
420    to convert the symtree name of a derived-type to the symbol name or to
421    the name of the associated generic function.  */
422 
423 const char *
gfc_dt_lower_string(const char * name)424 gfc_dt_lower_string (const char *name)
425 {
426   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
427     return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
428 			   &name[1]);
429   return gfc_get_string ("%s", name);
430 }
431 
432 
433 /* Convert a string such that it starts with an upper-case character. Used to
434    return the symtree-name for a derived type; the symbol name itself and the
435    symtree/symbol name of the associated generic function start with a lower-
436    case character.  */
437 
438 const char *
gfc_dt_upper_string(const char * name)439 gfc_dt_upper_string (const char *name)
440 {
441   if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
442     return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
443 			   &name[1]);
444   return gfc_get_string ("%s", name);
445 }
446 
447 /* Call here during module reading when we know what pointer to
448    associate with an integer.  Any fixups that exist are resolved at
449    this time.  */
450 
451 static void
associate_integer_pointer(pointer_info * p,void * gp)452 associate_integer_pointer (pointer_info *p, void *gp)
453 {
454   if (p->u.pointer != NULL)
455     gfc_internal_error ("associate_integer_pointer(): Already associated");
456 
457   p->u.pointer = gp;
458 
459   resolve_fixups (p->fixup, gp);
460 
461   p->fixup = NULL;
462 }
463 
464 
465 /* During module reading, given an integer and a pointer to a pointer,
466    either store the pointer from an already-known value or create a
467    fixup structure in order to store things later.  Returns zero if
468    the reference has been actually stored, or nonzero if the reference
469    must be fixed later (i.e., associate_integer_pointer must be called
470    sometime later.  Returns the pointer_info structure.  */
471 
472 static pointer_info *
add_fixup(HOST_WIDE_INT integer,void * gp)473 add_fixup (HOST_WIDE_INT integer, void *gp)
474 {
475   pointer_info *p;
476   fixup_t *f;
477   char **cp;
478 
479   p = get_integer (integer);
480 
481   if (p->integer == 0 || p->u.pointer != NULL)
482     {
483       cp = (char **) gp;
484       *cp = (char *) p->u.pointer;
485     }
486   else
487     {
488       f = XCNEW (fixup_t);
489 
490       f->next = p->fixup;
491       p->fixup = f;
492 
493       f->pointer = (void **) gp;
494     }
495 
496   return p;
497 }
498 
499 
500 /*****************************************************************/
501 
502 /* Parser related subroutines */
503 
504 /* Free the rename list left behind by a USE statement.  */
505 
506 static void
free_rename(gfc_use_rename * list)507 free_rename (gfc_use_rename *list)
508 {
509   gfc_use_rename *next;
510 
511   for (; list; list = next)
512     {
513       next = list->next;
514       free (list);
515     }
516 }
517 
518 
519 /* Match a USE statement.  */
520 
521 match
gfc_match_use(void)522 gfc_match_use (void)
523 {
524   char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
525   gfc_use_rename *tail = NULL, *new_use;
526   interface_type type, type2;
527   gfc_intrinsic_op op;
528   match m;
529   gfc_use_list *use_list;
530   gfc_symtree *st;
531   locus loc;
532 
533   use_list = gfc_get_use_list ();
534 
535   if (gfc_match (" , ") == MATCH_YES)
536     {
537       if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
538 	{
539 	  if (!gfc_notify_std (GFC_STD_F2003, "module "
540 			       "nature in USE statement at %C"))
541 	    goto cleanup;
542 
543 	  if (strcmp (module_nature, "intrinsic") == 0)
544 	    use_list->intrinsic = true;
545 	  else
546 	    {
547 	      if (strcmp (module_nature, "non_intrinsic") == 0)
548 		use_list->non_intrinsic = true;
549 	      else
550 		{
551 		  gfc_error ("Module nature in USE statement at %C shall "
552 			     "be either INTRINSIC or NON_INTRINSIC");
553 		  goto cleanup;
554 		}
555 	    }
556 	}
557       else
558 	{
559 	  /* Help output a better error message than "Unclassifiable
560 	     statement".  */
561 	  gfc_match (" %n", module_nature);
562 	  if (strcmp (module_nature, "intrinsic") == 0
563 	      || strcmp (module_nature, "non_intrinsic") == 0)
564 	    gfc_error ("\"::\" was expected after module nature at %C "
565 		       "but was not found");
566 	  free (use_list);
567 	  return m;
568 	}
569     }
570   else
571     {
572       m = gfc_match (" ::");
573       if (m == MATCH_YES &&
574 	  !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
575 	goto cleanup;
576 
577       if (m != MATCH_YES)
578 	{
579 	  m = gfc_match ("% ");
580 	  if (m != MATCH_YES)
581 	    {
582 	      free (use_list);
583 	      return m;
584 	    }
585 	}
586     }
587 
588   use_list->where = gfc_current_locus;
589 
590   m = gfc_match_name (name);
591   if (m != MATCH_YES)
592     {
593       free (use_list);
594       return m;
595     }
596 
597   use_list->module_name = gfc_get_string ("%s", name);
598 
599   if (gfc_match_eos () == MATCH_YES)
600     goto done;
601 
602   if (gfc_match_char (',') != MATCH_YES)
603     goto syntax;
604 
605   if (gfc_match (" only :") == MATCH_YES)
606     use_list->only_flag = true;
607 
608   if (gfc_match_eos () == MATCH_YES)
609     goto done;
610 
611   for (;;)
612     {
613       /* Get a new rename struct and add it to the rename list.  */
614       new_use = gfc_get_use_rename ();
615       new_use->where = gfc_current_locus;
616       new_use->found = 0;
617 
618       if (use_list->rename == NULL)
619 	use_list->rename = new_use;
620       else
621 	tail->next = new_use;
622       tail = new_use;
623 
624       /* See what kind of interface we're dealing with.  Assume it is
625 	 not an operator.  */
626       new_use->op = INTRINSIC_NONE;
627       if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
628 	goto cleanup;
629 
630       switch (type)
631 	{
632 	case INTERFACE_NAMELESS:
633 	  gfc_error ("Missing generic specification in USE statement at %C");
634 	  goto cleanup;
635 
636 	case INTERFACE_USER_OP:
637 	case INTERFACE_GENERIC:
638 	case INTERFACE_DTIO:
639 	  loc = gfc_current_locus;
640 
641 	  m = gfc_match (" =>");
642 
643 	  if (type == INTERFACE_USER_OP && m == MATCH_YES
644 	      && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
645 				  "operators in USE statements at %C")))
646 	    goto cleanup;
647 
648 	  if (type == INTERFACE_USER_OP)
649 	    new_use->op = INTRINSIC_USER;
650 
651 	  if (use_list->only_flag)
652 	    {
653 	      if (m != MATCH_YES)
654 		strcpy (new_use->use_name, name);
655 	      else
656 		{
657 		  strcpy (new_use->local_name, name);
658 		  m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
659 		  if (type != type2)
660 		    goto syntax;
661 		  if (m == MATCH_NO)
662 		    goto syntax;
663 		  if (m == MATCH_ERROR)
664 		    goto cleanup;
665 		}
666 	    }
667 	  else
668 	    {
669 	      if (m != MATCH_YES)
670 		goto syntax;
671 	      strcpy (new_use->local_name, name);
672 
673 	      m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
674 	      if (type != type2)
675 		goto syntax;
676 	      if (m == MATCH_NO)
677 		goto syntax;
678 	      if (m == MATCH_ERROR)
679 		goto cleanup;
680 	    }
681 
682 	  st = gfc_find_symtree (gfc_current_ns->sym_root, name);
683 	  if (st && type != INTERFACE_USER_OP
684 	      && (st->n.sym->module != use_list->module_name
685 		  || strcmp (st->n.sym->name, new_use->use_name) != 0))
686 	    {
687 	      if (m == MATCH_YES)
688 		gfc_error ("Symbol %qs at %L conflicts with the rename symbol "
689 			   "at %L", name, &st->n.sym->declared_at, &loc);
690 	      else
691 		gfc_error ("Symbol %qs at %L conflicts with the symbol "
692 			   "at %L", name, &st->n.sym->declared_at, &loc);
693 	      goto cleanup;
694 	    }
695 
696 	  if (strcmp (new_use->use_name, use_list->module_name) == 0
697 	      || strcmp (new_use->local_name, use_list->module_name) == 0)
698 	    {
699 	      gfc_error ("The name %qs at %C has already been used as "
700 			 "an external module name", use_list->module_name);
701 	      goto cleanup;
702 	    }
703 	  break;
704 
705 	case INTERFACE_INTRINSIC_OP:
706 	  new_use->op = op;
707 	  break;
708 
709 	default:
710 	  gcc_unreachable ();
711 	}
712 
713       if (gfc_match_eos () == MATCH_YES)
714 	break;
715       if (gfc_match_char (',') != MATCH_YES)
716 	goto syntax;
717     }
718 
719 done:
720   if (module_list)
721     {
722       gfc_use_list *last = module_list;
723       while (last->next)
724 	last = last->next;
725       last->next = use_list;
726     }
727   else
728     module_list = use_list;
729 
730   return MATCH_YES;
731 
732 syntax:
733   gfc_syntax_error (ST_USE);
734 
735 cleanup:
736   free_rename (use_list->rename);
737   free (use_list);
738   return MATCH_ERROR;
739 }
740 
741 
742 /* Match a SUBMODULE statement.
743 
744    According to F2008:11.2.3.2, "The submodule identifier is the
745    ordered pair whose first element is the ancestor module name and
746    whose second element is the submodule name. 'Submodule_name' is
747    used for the submodule filename and uses '@' as a separator, whilst
748    the name of the symbol for the module uses '.' as a separator.
749    The reasons for these choices are:
750    (i) To follow another leading brand in the submodule filenames;
751    (ii) Since '.' is not particularly visible in the filenames; and
752    (iii) The linker does not permit '@' in mnemonics.  */
753 
754 match
gfc_match_submodule(void)755 gfc_match_submodule (void)
756 {
757   match m;
758   char name[GFC_MAX_SYMBOL_LEN + 1];
759   gfc_use_list *use_list;
760   bool seen_colon = false;
761 
762   if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
763     return MATCH_ERROR;
764 
765   if (gfc_current_state () != COMP_NONE)
766     {
767       gfc_error ("SUBMODULE declaration at %C cannot appear within "
768 		 "another scoping unit");
769       return MATCH_ERROR;
770     }
771 
772   gfc_new_block = NULL;
773   gcc_assert (module_list == NULL);
774 
775   if (gfc_match_char ('(') != MATCH_YES)
776     goto syntax;
777 
778   while (1)
779     {
780       m = gfc_match (" %n", name);
781       if (m != MATCH_YES)
782 	goto syntax;
783 
784       use_list = gfc_get_use_list ();
785       use_list->where = gfc_current_locus;
786 
787       if (module_list)
788 	{
789 	  gfc_use_list *last = module_list;
790 	  while (last->next)
791 	    last = last->next;
792 	  last->next = use_list;
793 	  use_list->module_name
794 		= gfc_get_string ("%s.%s", module_list->module_name, name);
795 	  use_list->submodule_name
796 		= gfc_get_string ("%s@%s", module_list->module_name, name);
797 	}
798       else
799 	{
800 	  module_list = use_list;
801 	  use_list->module_name = gfc_get_string ("%s", name);
802 	  use_list->submodule_name = use_list->module_name;
803 	}
804 
805       if (gfc_match_char (')') == MATCH_YES)
806 	break;
807 
808       if (gfc_match_char (':') != MATCH_YES
809 	  || seen_colon)
810 	goto syntax;
811 
812       seen_colon = true;
813     }
814 
815   m = gfc_match (" %s%t", &gfc_new_block);
816   if (m != MATCH_YES)
817     goto syntax;
818 
819   submodule_name = gfc_get_string ("%s@%s", module_list->module_name,
820 				   gfc_new_block->name);
821 
822   gfc_new_block->name = gfc_get_string ("%s.%s",
823 					module_list->module_name,
824 					gfc_new_block->name);
825 
826   if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
827 		       gfc_new_block->name, NULL))
828     return MATCH_ERROR;
829 
830   /* Just retain the ultimate .(s)mod file for reading, since it
831      contains all the information in its ancestors.  */
832   use_list = module_list;
833   for (; module_list->next; use_list = module_list)
834     {
835       module_list = use_list->next;
836       free (use_list);
837     }
838 
839   return MATCH_YES;
840 
841 syntax:
842   gfc_error ("Syntax error in SUBMODULE statement at %C");
843   return MATCH_ERROR;
844 }
845 
846 
847 /* Given a name and a number, inst, return the inst name
848    under which to load this symbol. Returns NULL if this
849    symbol shouldn't be loaded. If inst is zero, returns
850    the number of instances of this name. If interface is
851    true, a user-defined operator is sought, otherwise only
852    non-operators are sought.  */
853 
854 static const char *
find_use_name_n(const char * name,int * inst,bool interface)855 find_use_name_n (const char *name, int *inst, bool interface)
856 {
857   gfc_use_rename *u;
858   const char *low_name = NULL;
859   int i;
860 
861   /* For derived types.  */
862   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
863     low_name = gfc_dt_lower_string (name);
864 
865   i = 0;
866   for (u = gfc_rename_list; u; u = u->next)
867     {
868       if ((!low_name && strcmp (u->use_name, name) != 0)
869 	  || (low_name && strcmp (u->use_name, low_name) != 0)
870 	  || (u->op == INTRINSIC_USER && !interface)
871 	  || (u->op != INTRINSIC_USER &&  interface))
872 	continue;
873       if (++i == *inst)
874 	break;
875     }
876 
877   if (!*inst)
878     {
879       *inst = i;
880       return NULL;
881     }
882 
883   if (u == NULL)
884     return only_flag ? NULL : name;
885 
886   u->found = 1;
887 
888   if (low_name)
889     {
890       if (u->local_name[0] == '\0')
891 	return name;
892       return gfc_dt_upper_string (u->local_name);
893     }
894 
895   return (u->local_name[0] != '\0') ? u->local_name : name;
896 }
897 
898 
899 /* Given a name, return the name under which to load this symbol.
900    Returns NULL if this symbol shouldn't be loaded.  */
901 
902 static const char *
find_use_name(const char * name,bool interface)903 find_use_name (const char *name, bool interface)
904 {
905   int i = 1;
906   return find_use_name_n (name, &i, interface);
907 }
908 
909 
910 /* Given a real name, return the number of use names associated with it.  */
911 
912 static int
number_use_names(const char * name,bool interface)913 number_use_names (const char *name, bool interface)
914 {
915   int i = 0;
916   find_use_name_n (name, &i, interface);
917   return i;
918 }
919 
920 
921 /* Try to find the operator in the current list.  */
922 
923 static gfc_use_rename *
find_use_operator(gfc_intrinsic_op op)924 find_use_operator (gfc_intrinsic_op op)
925 {
926   gfc_use_rename *u;
927 
928   for (u = gfc_rename_list; u; u = u->next)
929     if (u->op == op)
930       return u;
931 
932   return NULL;
933 }
934 
935 
936 /*****************************************************************/
937 
938 /* The next couple of subroutines maintain a tree used to avoid a
939    brute-force search for a combination of true name and module name.
940    While symtree names, the name that a particular symbol is known by
941    can changed with USE statements, we still have to keep track of the
942    true names to generate the correct reference, and also avoid
943    loading the same real symbol twice in a program unit.
944 
945    When we start reading, the true name tree is built and maintained
946    as symbols are read.  The tree is searched as we load new symbols
947    to see if it already exists someplace in the namespace.  */
948 
949 typedef struct true_name
950 {
951   BBT_HEADER (true_name);
952   const char *name;
953   gfc_symbol *sym;
954 }
955 true_name;
956 
957 static true_name *true_name_root;
958 
959 
960 /* Compare two true_name structures.  */
961 
962 static int
compare_true_names(void * _t1,void * _t2)963 compare_true_names (void *_t1, void *_t2)
964 {
965   true_name *t1, *t2;
966   int c;
967 
968   t1 = (true_name *) _t1;
969   t2 = (true_name *) _t2;
970 
971   c = ((t1->sym->module > t2->sym->module)
972        - (t1->sym->module < t2->sym->module));
973   if (c != 0)
974     return c;
975 
976   return strcmp (t1->name, t2->name);
977 }
978 
979 
980 /* Given a true name, search the true name tree to see if it exists
981    within the main namespace.  */
982 
983 static gfc_symbol *
find_true_name(const char * name,const char * module)984 find_true_name (const char *name, const char *module)
985 {
986   true_name t, *p;
987   gfc_symbol sym;
988   int c;
989 
990   t.name = gfc_get_string ("%s", name);
991   if (module != NULL)
992     sym.module = gfc_get_string ("%s", module);
993   else
994     sym.module = NULL;
995   t.sym = &sym;
996 
997   p = true_name_root;
998   while (p != NULL)
999     {
1000       c = compare_true_names ((void *) (&t), (void *) p);
1001       if (c == 0)
1002 	return p->sym;
1003 
1004       p = (c < 0) ? p->left : p->right;
1005     }
1006 
1007   return NULL;
1008 }
1009 
1010 
1011 /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
1012 
1013 static void
add_true_name(gfc_symbol * sym)1014 add_true_name (gfc_symbol *sym)
1015 {
1016   true_name *t;
1017 
1018   t = XCNEW (true_name);
1019   t->sym = sym;
1020   if (gfc_fl_struct (sym->attr.flavor))
1021     t->name = gfc_dt_upper_string (sym->name);
1022   else
1023     t->name = sym->name;
1024 
1025   gfc_insert_bbt (&true_name_root, t, compare_true_names);
1026 }
1027 
1028 
1029 /* Recursive function to build the initial true name tree by
1030    recursively traversing the current namespace.  */
1031 
1032 static void
build_tnt(gfc_symtree * st)1033 build_tnt (gfc_symtree *st)
1034 {
1035   const char *name;
1036   if (st == NULL)
1037     return;
1038 
1039   build_tnt (st->left);
1040   build_tnt (st->right);
1041 
1042   if (gfc_fl_struct (st->n.sym->attr.flavor))
1043     name = gfc_dt_upper_string (st->n.sym->name);
1044   else
1045     name = st->n.sym->name;
1046 
1047   if (find_true_name (name, st->n.sym->module) != NULL)
1048     return;
1049 
1050   add_true_name (st->n.sym);
1051 }
1052 
1053 
1054 /* Initialize the true name tree with the current namespace.  */
1055 
1056 static void
init_true_name_tree(void)1057 init_true_name_tree (void)
1058 {
1059   true_name_root = NULL;
1060   build_tnt (gfc_current_ns->sym_root);
1061 }
1062 
1063 
1064 /* Recursively free a true name tree node.  */
1065 
1066 static void
free_true_name(true_name * t)1067 free_true_name (true_name *t)
1068 {
1069   if (t == NULL)
1070     return;
1071   free_true_name (t->left);
1072   free_true_name (t->right);
1073 
1074   free (t);
1075 }
1076 
1077 
1078 /*****************************************************************/
1079 
1080 /* Module reading and writing.  */
1081 
1082 /* The following are versions similar to the ones in scanner.c, but
1083    for dealing with compressed module files.  */
1084 
1085 static gzFile
gzopen_included_file_1(const char * name,gfc_directorylist * list,bool module,bool system)1086 gzopen_included_file_1 (const char *name, gfc_directorylist *list,
1087                      bool module, bool system)
1088 {
1089   char *fullname;
1090   gfc_directorylist *p;
1091   gzFile f;
1092 
1093   for (p = list; p; p = p->next)
1094     {
1095       if (module && !p->use_for_modules)
1096        continue;
1097 
1098       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
1099       strcpy (fullname, p->path);
1100       strcat (fullname, name);
1101 
1102       f = gzopen (fullname, "r");
1103       if (f != NULL)
1104        {
1105          if (gfc_cpp_makedep ())
1106            gfc_cpp_add_dep (fullname, system);
1107 
1108 	 free (module_fullpath);
1109 	 module_fullpath = xstrdup (fullname);
1110          return f;
1111        }
1112     }
1113 
1114   return NULL;
1115 }
1116 
1117 static gzFile
gzopen_included_file(const char * name,bool include_cwd,bool module)1118 gzopen_included_file (const char *name, bool include_cwd, bool module)
1119 {
1120   gzFile f = NULL;
1121 
1122   if (IS_ABSOLUTE_PATH (name) || include_cwd)
1123     {
1124       f = gzopen (name, "r");
1125       if (f)
1126 	{
1127 	  if (gfc_cpp_makedep ())
1128 	    gfc_cpp_add_dep (name, false);
1129 
1130 	  free (module_fullpath);
1131 	  module_fullpath = xstrdup (name);
1132 	}
1133     }
1134 
1135   if (!f)
1136     f = gzopen_included_file_1 (name, include_dirs, module, false);
1137 
1138   return f;
1139 }
1140 
1141 static gzFile
gzopen_intrinsic_module(const char * name)1142 gzopen_intrinsic_module (const char* name)
1143 {
1144   gzFile f = NULL;
1145 
1146   if (IS_ABSOLUTE_PATH (name))
1147     {
1148       f = gzopen (name, "r");
1149       if (f)
1150 	{
1151 	  if (gfc_cpp_makedep ())
1152 	    gfc_cpp_add_dep (name, true);
1153 
1154 	  free (module_fullpath);
1155 	  module_fullpath = xstrdup (name);
1156 	}
1157     }
1158 
1159   if (!f)
1160     f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);
1161 
1162   return f;
1163 }
1164 
1165 
1166 enum atom_type
1167 {
1168   ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
1169 };
1170 
1171 static atom_type last_atom;
1172 
1173 
1174 /* The name buffer must be at least as long as a symbol name.  Right
1175    now it's not clear how we're going to store numeric constants--
1176    probably as a hexadecimal string, since this will allow the exact
1177    number to be preserved (this can't be done by a decimal
1178    representation).  Worry about that later.  TODO!  */
1179 
1180 #define MAX_ATOM_SIZE 100
1181 
1182 static HOST_WIDE_INT atom_int;
1183 static char *atom_string, atom_name[MAX_ATOM_SIZE];
1184 
1185 
1186 /* Report problems with a module.  Error reporting is not very
1187    elaborate, since this sorts of errors shouldn't really happen.
1188    This subroutine never returns.  */
1189 
1190 static void bad_module (const char *) ATTRIBUTE_NORETURN;
1191 
1192 static void
bad_module(const char * msgid)1193 bad_module (const char *msgid)
1194 {
1195   XDELETEVEC (module_content);
1196   module_content = NULL;
1197 
1198   switch (iomode)
1199     {
1200     case IO_INPUT:
1201       gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1202 	  	       module_fullpath, module_line, module_column, msgid);
1203       break;
1204     case IO_OUTPUT:
1205       gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1206 	  	       module_name, module_line, module_column, msgid);
1207       break;
1208     default:
1209       gfc_fatal_error ("Module %qs at line %d column %d: %s",
1210 	  	       module_name, module_line, module_column, msgid);
1211       break;
1212     }
1213 }
1214 
1215 
1216 /* Set the module's input pointer.  */
1217 
1218 static void
set_module_locus(module_locus * m)1219 set_module_locus (module_locus *m)
1220 {
1221   module_column = m->column;
1222   module_line = m->line;
1223   module_pos = m->pos;
1224 }
1225 
1226 
1227 /* Get the module's input pointer so that we can restore it later.  */
1228 
1229 static void
get_module_locus(module_locus * m)1230 get_module_locus (module_locus *m)
1231 {
1232   m->column = module_column;
1233   m->line = module_line;
1234   m->pos = module_pos;
1235 }
1236 
1237 
1238 /* Get the next character in the module, updating our reckoning of
1239    where we are.  */
1240 
1241 static int
module_char(void)1242 module_char (void)
1243 {
1244   const char c = module_content[module_pos++];
1245   if (c == '\0')
1246     bad_module ("Unexpected EOF");
1247 
1248   prev_module_line = module_line;
1249   prev_module_column = module_column;
1250 
1251   if (c == '\n')
1252     {
1253       module_line++;
1254       module_column = 0;
1255     }
1256 
1257   module_column++;
1258   return c;
1259 }
1260 
1261 /* Unget a character while remembering the line and column.  Works for
1262    a single character only.  */
1263 
1264 static void
module_unget_char(void)1265 module_unget_char (void)
1266 {
1267   module_line = prev_module_line;
1268   module_column = prev_module_column;
1269   module_pos--;
1270 }
1271 
1272 /* Parse a string constant.  The delimiter is guaranteed to be a
1273    single quote.  */
1274 
1275 static void
parse_string(void)1276 parse_string (void)
1277 {
1278   int c;
1279   size_t cursz = 30;
1280   size_t len = 0;
1281 
1282   atom_string = XNEWVEC (char, cursz);
1283 
1284   for ( ; ; )
1285     {
1286       c = module_char ();
1287 
1288       if (c == '\'')
1289 	{
1290 	  int c2 = module_char ();
1291 	  if (c2 != '\'')
1292 	    {
1293 	      module_unget_char ();
1294 	      break;
1295 	    }
1296 	}
1297 
1298       if (len >= cursz)
1299 	{
1300 	  cursz *= 2;
1301 	  atom_string = XRESIZEVEC (char, atom_string, cursz);
1302 	}
1303       atom_string[len] = c;
1304       len++;
1305     }
1306 
1307   atom_string = XRESIZEVEC (char, atom_string, len + 1);
1308   atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
1309 }
1310 
1311 
1312 /* Parse an integer. Should fit in a HOST_WIDE_INT.  */
1313 
1314 static void
parse_integer(int c)1315 parse_integer (int c)
1316 {
1317   atom_int = c - '0';
1318 
1319   for (;;)
1320     {
1321       c = module_char ();
1322       if (!ISDIGIT (c))
1323 	{
1324 	  module_unget_char ();
1325 	  break;
1326 	}
1327 
1328       atom_int = 10 * atom_int + c - '0';
1329     }
1330 
1331 }
1332 
1333 
1334 /* Parse a name.  */
1335 
1336 static void
parse_name(int c)1337 parse_name (int c)
1338 {
1339   char *p;
1340   int len;
1341 
1342   p = atom_name;
1343 
1344   *p++ = c;
1345   len = 1;
1346 
1347   for (;;)
1348     {
1349       c = module_char ();
1350       if (!ISALNUM (c) && c != '_' && c != '-')
1351 	{
1352 	  module_unget_char ();
1353 	  break;
1354 	}
1355 
1356       *p++ = c;
1357       if (++len > GFC_MAX_SYMBOL_LEN)
1358 	bad_module ("Name too long");
1359     }
1360 
1361   *p = '\0';
1362 
1363 }
1364 
1365 
1366 /* Read the next atom in the module's input stream.  */
1367 
1368 static atom_type
parse_atom(void)1369 parse_atom (void)
1370 {
1371   int c;
1372 
1373   do
1374     {
1375       c = module_char ();
1376     }
1377   while (c == ' ' || c == '\r' || c == '\n');
1378 
1379   switch (c)
1380     {
1381     case '(':
1382       return ATOM_LPAREN;
1383 
1384     case ')':
1385       return ATOM_RPAREN;
1386 
1387     case '\'':
1388       parse_string ();
1389       return ATOM_STRING;
1390 
1391     case '0':
1392     case '1':
1393     case '2':
1394     case '3':
1395     case '4':
1396     case '5':
1397     case '6':
1398     case '7':
1399     case '8':
1400     case '9':
1401       parse_integer (c);
1402       return ATOM_INTEGER;
1403 
1404     case 'a':
1405     case 'b':
1406     case 'c':
1407     case 'd':
1408     case 'e':
1409     case 'f':
1410     case 'g':
1411     case 'h':
1412     case 'i':
1413     case 'j':
1414     case 'k':
1415     case 'l':
1416     case 'm':
1417     case 'n':
1418     case 'o':
1419     case 'p':
1420     case 'q':
1421     case 'r':
1422     case 's':
1423     case 't':
1424     case 'u':
1425     case 'v':
1426     case 'w':
1427     case 'x':
1428     case 'y':
1429     case 'z':
1430     case 'A':
1431     case 'B':
1432     case 'C':
1433     case 'D':
1434     case 'E':
1435     case 'F':
1436     case 'G':
1437     case 'H':
1438     case 'I':
1439     case 'J':
1440     case 'K':
1441     case 'L':
1442     case 'M':
1443     case 'N':
1444     case 'O':
1445     case 'P':
1446     case 'Q':
1447     case 'R':
1448     case 'S':
1449     case 'T':
1450     case 'U':
1451     case 'V':
1452     case 'W':
1453     case 'X':
1454     case 'Y':
1455     case 'Z':
1456       parse_name (c);
1457       return ATOM_NAME;
1458 
1459     default:
1460       bad_module ("Bad name");
1461     }
1462 
1463   /* Not reached.  */
1464 }
1465 
1466 
1467 /* Peek at the next atom on the input.  */
1468 
1469 static atom_type
peek_atom(void)1470 peek_atom (void)
1471 {
1472   int c;
1473 
1474   do
1475     {
1476       c = module_char ();
1477     }
1478   while (c == ' ' || c == '\r' || c == '\n');
1479 
1480   switch (c)
1481     {
1482     case '(':
1483       module_unget_char ();
1484       return ATOM_LPAREN;
1485 
1486     case ')':
1487       module_unget_char ();
1488       return ATOM_RPAREN;
1489 
1490     case '\'':
1491       module_unget_char ();
1492       return ATOM_STRING;
1493 
1494     case '0':
1495     case '1':
1496     case '2':
1497     case '3':
1498     case '4':
1499     case '5':
1500     case '6':
1501     case '7':
1502     case '8':
1503     case '9':
1504       module_unget_char ();
1505       return ATOM_INTEGER;
1506 
1507     case 'a':
1508     case 'b':
1509     case 'c':
1510     case 'd':
1511     case 'e':
1512     case 'f':
1513     case 'g':
1514     case 'h':
1515     case 'i':
1516     case 'j':
1517     case 'k':
1518     case 'l':
1519     case 'm':
1520     case 'n':
1521     case 'o':
1522     case 'p':
1523     case 'q':
1524     case 'r':
1525     case 's':
1526     case 't':
1527     case 'u':
1528     case 'v':
1529     case 'w':
1530     case 'x':
1531     case 'y':
1532     case 'z':
1533     case 'A':
1534     case 'B':
1535     case 'C':
1536     case 'D':
1537     case 'E':
1538     case 'F':
1539     case 'G':
1540     case 'H':
1541     case 'I':
1542     case 'J':
1543     case 'K':
1544     case 'L':
1545     case 'M':
1546     case 'N':
1547     case 'O':
1548     case 'P':
1549     case 'Q':
1550     case 'R':
1551     case 'S':
1552     case 'T':
1553     case 'U':
1554     case 'V':
1555     case 'W':
1556     case 'X':
1557     case 'Y':
1558     case 'Z':
1559       module_unget_char ();
1560       return ATOM_NAME;
1561 
1562     default:
1563       bad_module ("Bad name");
1564     }
1565 }
1566 
1567 
1568 /* Read the next atom from the input, requiring that it be a
1569    particular kind.  */
1570 
1571 static void
require_atom(atom_type type)1572 require_atom (atom_type type)
1573 {
1574   atom_type t;
1575   const char *p;
1576   int column, line;
1577 
1578   column = module_column;
1579   line = module_line;
1580 
1581   t = parse_atom ();
1582   if (t != type)
1583     {
1584       switch (type)
1585 	{
1586 	case ATOM_NAME:
1587 	  p = _("Expected name");
1588 	  break;
1589 	case ATOM_LPAREN:
1590 	  p = _("Expected left parenthesis");
1591 	  break;
1592 	case ATOM_RPAREN:
1593 	  p = _("Expected right parenthesis");
1594 	  break;
1595 	case ATOM_INTEGER:
1596 	  p = _("Expected integer");
1597 	  break;
1598 	case ATOM_STRING:
1599 	  p = _("Expected string");
1600 	  break;
1601 	default:
1602 	  gfc_internal_error ("require_atom(): bad atom type required");
1603 	}
1604 
1605       module_column = column;
1606       module_line = line;
1607       bad_module (p);
1608     }
1609 }
1610 
1611 
1612 /* Given a pointer to an mstring array, require that the current input
1613    be one of the strings in the array.  We return the enum value.  */
1614 
1615 static int
find_enum(const mstring * m)1616 find_enum (const mstring *m)
1617 {
1618   int i;
1619 
1620   i = gfc_string2code (m, atom_name);
1621   if (i >= 0)
1622     return i;
1623 
1624   bad_module ("find_enum(): Enum not found");
1625 
1626   /* Not reached.  */
1627 }
1628 
1629 
1630 /* Read a string. The caller is responsible for freeing.  */
1631 
1632 static char*
read_string(void)1633 read_string (void)
1634 {
1635   char* p;
1636   require_atom (ATOM_STRING);
1637   p = atom_string;
1638   atom_string = NULL;
1639   return p;
1640 }
1641 
1642 
1643 /**************** Module output subroutines ***************************/
1644 
1645 /* Output a character to a module file.  */
1646 
1647 static void
write_char(char out)1648 write_char (char out)
1649 {
1650   if (gzputc (module_fp, out) == EOF)
1651     gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1652 
1653   if (out != '\n')
1654     module_column++;
1655   else
1656     {
1657       module_column = 1;
1658       module_line++;
1659     }
1660 }
1661 
1662 
1663 /* Write an atom to a module.  The line wrapping isn't perfect, but it
1664    should work most of the time.  This isn't that big of a deal, since
1665    the file really isn't meant to be read by people anyway.  */
1666 
1667 static void
write_atom(atom_type atom,const void * v)1668 write_atom (atom_type atom, const void *v)
1669 {
1670   char buffer[32];
1671 
1672   /* Workaround -Wmaybe-uninitialized false positive during
1673      profiledbootstrap by initializing them.  */
1674   int len;
1675   HOST_WIDE_INT i = 0;
1676   const char *p;
1677 
1678   switch (atom)
1679     {
1680     case ATOM_STRING:
1681     case ATOM_NAME:
1682       p = (const char *) v;
1683       break;
1684 
1685     case ATOM_LPAREN:
1686       p = "(";
1687       break;
1688 
1689     case ATOM_RPAREN:
1690       p = ")";
1691       break;
1692 
1693     case ATOM_INTEGER:
1694       i = *((const HOST_WIDE_INT *) v);
1695 
1696       snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i);
1697       p = buffer;
1698       break;
1699 
1700     default:
1701       gfc_internal_error ("write_atom(): Trying to write dab atom");
1702 
1703     }
1704 
1705   if(p == NULL || *p == '\0')
1706      len = 0;
1707   else
1708   len = strlen (p);
1709 
1710   if (atom != ATOM_RPAREN)
1711     {
1712       if (module_column + len > 72)
1713 	write_char ('\n');
1714       else
1715 	{
1716 
1717 	  if (last_atom != ATOM_LPAREN && module_column != 1)
1718 	    write_char (' ');
1719 	}
1720     }
1721 
1722   if (atom == ATOM_STRING)
1723     write_char ('\'');
1724 
1725   while (p != NULL && *p)
1726     {
1727       if (atom == ATOM_STRING && *p == '\'')
1728 	write_char ('\'');
1729       write_char (*p++);
1730     }
1731 
1732   if (atom == ATOM_STRING)
1733     write_char ('\'');
1734 
1735   last_atom = atom;
1736 }
1737 
1738 
1739 
1740 /***************** Mid-level I/O subroutines *****************/
1741 
1742 /* These subroutines let their caller read or write atoms without
1743    caring about which of the two is actually happening.  This lets a
1744    subroutine concentrate on the actual format of the data being
1745    written.  */
1746 
1747 static void mio_expr (gfc_expr **);
1748 pointer_info *mio_symbol_ref (gfc_symbol **);
1749 pointer_info *mio_interface_rest (gfc_interface **);
1750 static void mio_symtree_ref (gfc_symtree **);
1751 
1752 /* Read or write an enumerated value.  On writing, we return the input
1753    value for the convenience of callers.  We avoid using an integer
1754    pointer because enums are sometimes inside bitfields.  */
1755 
1756 static int
mio_name(int t,const mstring * m)1757 mio_name (int t, const mstring *m)
1758 {
1759   if (iomode == IO_OUTPUT)
1760     write_atom (ATOM_NAME, gfc_code2string (m, t));
1761   else
1762     {
1763       require_atom (ATOM_NAME);
1764       t = find_enum (m);
1765     }
1766 
1767   return t;
1768 }
1769 
1770 /* Specialization of mio_name.  */
1771 
1772 #define DECL_MIO_NAME(TYPE) \
1773  static inline TYPE \
1774  MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1775  { \
1776    return (TYPE) mio_name ((int) t, m); \
1777  }
1778 #define MIO_NAME(TYPE) mio_name_##TYPE
1779 
1780 static void
mio_lparen(void)1781 mio_lparen (void)
1782 {
1783   if (iomode == IO_OUTPUT)
1784     write_atom (ATOM_LPAREN, NULL);
1785   else
1786     require_atom (ATOM_LPAREN);
1787 }
1788 
1789 
1790 static void
mio_rparen(void)1791 mio_rparen (void)
1792 {
1793   if (iomode == IO_OUTPUT)
1794     write_atom (ATOM_RPAREN, NULL);
1795   else
1796     require_atom (ATOM_RPAREN);
1797 }
1798 
1799 
1800 static void
mio_integer(int * ip)1801 mio_integer (int *ip)
1802 {
1803   if (iomode == IO_OUTPUT)
1804     {
1805       HOST_WIDE_INT hwi = *ip;
1806       write_atom (ATOM_INTEGER, &hwi);
1807     }
1808   else
1809     {
1810       require_atom (ATOM_INTEGER);
1811       *ip = atom_int;
1812     }
1813 }
1814 
1815 static void
mio_hwi(HOST_WIDE_INT * hwi)1816 mio_hwi (HOST_WIDE_INT *hwi)
1817 {
1818   if (iomode == IO_OUTPUT)
1819     write_atom (ATOM_INTEGER, hwi);
1820   else
1821     {
1822       require_atom (ATOM_INTEGER);
1823       *hwi = atom_int;
1824     }
1825 }
1826 
1827 
1828 /* Read or write a gfc_intrinsic_op value.  */
1829 
1830 static void
mio_intrinsic_op(gfc_intrinsic_op * op)1831 mio_intrinsic_op (gfc_intrinsic_op* op)
1832 {
1833   /* FIXME: Would be nicer to do this via the operators symbolic name.  */
1834   if (iomode == IO_OUTPUT)
1835     {
1836       HOST_WIDE_INT converted = (HOST_WIDE_INT) *op;
1837       write_atom (ATOM_INTEGER, &converted);
1838     }
1839   else
1840     {
1841       require_atom (ATOM_INTEGER);
1842       *op = (gfc_intrinsic_op) atom_int;
1843     }
1844 }
1845 
1846 
1847 /* Read or write a character pointer that points to a string on the heap.  */
1848 
1849 static const char *
mio_allocated_string(const char * s)1850 mio_allocated_string (const char *s)
1851 {
1852   if (iomode == IO_OUTPUT)
1853     {
1854       write_atom (ATOM_STRING, s);
1855       return s;
1856     }
1857   else
1858     {
1859       require_atom (ATOM_STRING);
1860       return atom_string;
1861     }
1862 }
1863 
1864 
1865 /* Functions for quoting and unquoting strings.  */
1866 
1867 static char *
quote_string(const gfc_char_t * s,const size_t slength)1868 quote_string (const gfc_char_t *s, const size_t slength)
1869 {
1870   const gfc_char_t *p;
1871   char *res, *q;
1872   size_t len = 0, i;
1873 
1874   /* Calculate the length we'll need: a backslash takes two ("\\"),
1875      non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
1876   for (p = s, i = 0; i < slength; p++, i++)
1877     {
1878       if (*p == '\\')
1879 	len += 2;
1880       else if (!gfc_wide_is_printable (*p))
1881 	len += 10;
1882       else
1883 	len++;
1884     }
1885 
1886   q = res = XCNEWVEC (char, len + 1);
1887   for (p = s, i = 0; i < slength; p++, i++)
1888     {
1889       if (*p == '\\')
1890 	*q++ = '\\', *q++ = '\\';
1891       else if (!gfc_wide_is_printable (*p))
1892 	{
1893 	  sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1894 		   (unsigned HOST_WIDE_INT) *p);
1895 	  q += 10;
1896 	}
1897       else
1898 	*q++ = (unsigned char) *p;
1899     }
1900 
1901   res[len] = '\0';
1902   return res;
1903 }
1904 
1905 static gfc_char_t *
unquote_string(const char * s)1906 unquote_string (const char *s)
1907 {
1908   size_t len, i;
1909   const char *p;
1910   gfc_char_t *res;
1911 
1912   for (p = s, len = 0; *p; p++, len++)
1913     {
1914       if (*p != '\\')
1915 	continue;
1916 
1917       if (p[1] == '\\')
1918 	p++;
1919       else if (p[1] == 'U')
1920 	p += 9; /* That is a "\U????????".  */
1921       else
1922 	gfc_internal_error ("unquote_string(): got bad string");
1923     }
1924 
1925   res = gfc_get_wide_string (len + 1);
1926   for (i = 0, p = s; i < len; i++, p++)
1927     {
1928       gcc_assert (*p);
1929 
1930       if (*p != '\\')
1931 	res[i] = (unsigned char) *p;
1932       else if (p[1] == '\\')
1933 	{
1934 	  res[i] = (unsigned char) '\\';
1935 	  p++;
1936 	}
1937       else
1938 	{
1939 	  /* We read the 8-digits hexadecimal constant that follows.  */
1940 	  int j;
1941 	  unsigned n;
1942 	  gfc_char_t c = 0;
1943 
1944 	  gcc_assert (p[1] == 'U');
1945 	  for (j = 0; j < 8; j++)
1946 	    {
1947 	      c = c << 4;
1948 	      gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1949 	      c += n;
1950 	    }
1951 
1952 	  res[i] = c;
1953 	  p += 9;
1954 	}
1955     }
1956 
1957   res[len] = '\0';
1958   return res;
1959 }
1960 
1961 
1962 /* Read or write a character pointer that points to a wide string on the
1963    heap, performing quoting/unquoting of nonprintable characters using the
1964    form \U???????? (where each ? is a hexadecimal digit).
1965    Length is the length of the string, only known and used in output mode.  */
1966 
1967 static const gfc_char_t *
mio_allocated_wide_string(const gfc_char_t * s,const size_t length)1968 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1969 {
1970   if (iomode == IO_OUTPUT)
1971     {
1972       char *quoted = quote_string (s, length);
1973       write_atom (ATOM_STRING, quoted);
1974       free (quoted);
1975       return s;
1976     }
1977   else
1978     {
1979       gfc_char_t *unquoted;
1980 
1981       require_atom (ATOM_STRING);
1982       unquoted = unquote_string (atom_string);
1983       free (atom_string);
1984       return unquoted;
1985     }
1986 }
1987 
1988 
1989 /* Read or write a string that is in static memory.  */
1990 
1991 static void
mio_pool_string(const char ** stringp)1992 mio_pool_string (const char **stringp)
1993 {
1994   /* TODO: one could write the string only once, and refer to it via a
1995      fixup pointer.  */
1996 
1997   /* As a special case we have to deal with a NULL string.  This
1998      happens for the 'module' member of 'gfc_symbol's that are not in a
1999      module.  We read / write these as the empty string.  */
2000   if (iomode == IO_OUTPUT)
2001     {
2002       const char *p = *stringp == NULL ? "" : *stringp;
2003       write_atom (ATOM_STRING, p);
2004     }
2005   else
2006     {
2007       require_atom (ATOM_STRING);
2008       *stringp = (atom_string[0] == '\0'
2009 		  ? NULL : gfc_get_string ("%s", atom_string));
2010       free (atom_string);
2011     }
2012 }
2013 
2014 
2015 /* Read or write a string that is inside of some already-allocated
2016    structure.  */
2017 
2018 static void
mio_internal_string(char * string)2019 mio_internal_string (char *string)
2020 {
2021   if (iomode == IO_OUTPUT)
2022     write_atom (ATOM_STRING, string);
2023   else
2024     {
2025       require_atom (ATOM_STRING);
2026       strcpy (string, atom_string);
2027       free (atom_string);
2028     }
2029 }
2030 
2031 
2032 enum ab_attribute
2033 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
2034   AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
2035   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
2036   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
2037   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
2038   AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
2039   AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
2040   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
2041   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
2042   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
2043   AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
2044   AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
2045   AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
2046   AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
2047   AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
2048   AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING,
2049   AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER,
2050   AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ
2051 };
2052 
2053 static const mstring attr_bits[] =
2054 {
2055     minit ("ALLOCATABLE", AB_ALLOCATABLE),
2056     minit ("ARTIFICIAL", AB_ARTIFICIAL),
2057     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
2058     minit ("DIMENSION", AB_DIMENSION),
2059     minit ("CODIMENSION", AB_CODIMENSION),
2060     minit ("CONTIGUOUS", AB_CONTIGUOUS),
2061     minit ("EXTERNAL", AB_EXTERNAL),
2062     minit ("INTRINSIC", AB_INTRINSIC),
2063     minit ("OPTIONAL", AB_OPTIONAL),
2064     minit ("POINTER", AB_POINTER),
2065     minit ("VOLATILE", AB_VOLATILE),
2066     minit ("TARGET", AB_TARGET),
2067     minit ("THREADPRIVATE", AB_THREADPRIVATE),
2068     minit ("DUMMY", AB_DUMMY),
2069     minit ("RESULT", AB_RESULT),
2070     minit ("DATA", AB_DATA),
2071     minit ("IN_NAMELIST", AB_IN_NAMELIST),
2072     minit ("IN_COMMON", AB_IN_COMMON),
2073     minit ("FUNCTION", AB_FUNCTION),
2074     minit ("SUBROUTINE", AB_SUBROUTINE),
2075     minit ("SEQUENCE", AB_SEQUENCE),
2076     minit ("ELEMENTAL", AB_ELEMENTAL),
2077     minit ("PURE", AB_PURE),
2078     minit ("RECURSIVE", AB_RECURSIVE),
2079     minit ("GENERIC", AB_GENERIC),
2080     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
2081     minit ("CRAY_POINTER", AB_CRAY_POINTER),
2082     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
2083     minit ("IS_BIND_C", AB_IS_BIND_C),
2084     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
2085     minit ("IS_ISO_C", AB_IS_ISO_C),
2086     minit ("VALUE", AB_VALUE),
2087     minit ("ALLOC_COMP", AB_ALLOC_COMP),
2088     minit ("COARRAY_COMP", AB_COARRAY_COMP),
2089     minit ("LOCK_COMP", AB_LOCK_COMP),
2090     minit ("EVENT_COMP", AB_EVENT_COMP),
2091     minit ("POINTER_COMP", AB_POINTER_COMP),
2092     minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
2093     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
2094     minit ("ZERO_COMP", AB_ZERO_COMP),
2095     minit ("PROTECTED", AB_PROTECTED),
2096     minit ("ABSTRACT", AB_ABSTRACT),
2097     minit ("IS_CLASS", AB_IS_CLASS),
2098     minit ("PROCEDURE", AB_PROCEDURE),
2099     minit ("PROC_POINTER", AB_PROC_POINTER),
2100     minit ("VTYPE", AB_VTYPE),
2101     minit ("VTAB", AB_VTAB),
2102     minit ("CLASS_POINTER", AB_CLASS_POINTER),
2103     minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
2104     minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
2105     minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
2106     minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
2107     minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
2108     minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
2109     minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
2110     minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
2111     minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
2112     minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
2113     minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
2114     minit ("PDT_KIND", AB_PDT_KIND),
2115     minit ("PDT_LEN", AB_PDT_LEN),
2116     minit ("PDT_TYPE", AB_PDT_TYPE),
2117     minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
2118     minit ("PDT_ARRAY", AB_PDT_ARRAY),
2119     minit ("PDT_STRING", AB_PDT_STRING),
2120     minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG),
2121     minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER),
2122     minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR),
2123     minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ),
2124     minit (NULL, -1)
2125 };
2126 
2127 /* For binding attributes.  */
2128 static const mstring binding_passing[] =
2129 {
2130     minit ("PASS", 0),
2131     minit ("NOPASS", 1),
2132     minit (NULL, -1)
2133 };
2134 static const mstring binding_overriding[] =
2135 {
2136     minit ("OVERRIDABLE", 0),
2137     minit ("NON_OVERRIDABLE", 1),
2138     minit ("DEFERRED", 2),
2139     minit (NULL, -1)
2140 };
2141 static const mstring binding_generic[] =
2142 {
2143     minit ("SPECIFIC", 0),
2144     minit ("GENERIC", 1),
2145     minit (NULL, -1)
2146 };
2147 static const mstring binding_ppc[] =
2148 {
2149     minit ("NO_PPC", 0),
2150     minit ("PPC", 1),
2151     minit (NULL, -1)
2152 };
2153 
2154 /* Specialization of mio_name.  */
2155 DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME(ar_type)2156 DECL_MIO_NAME (ar_type)
2157 DECL_MIO_NAME (array_type)
2158 DECL_MIO_NAME (bt)
2159 DECL_MIO_NAME (expr_t)
2160 DECL_MIO_NAME (gfc_access)
2161 DECL_MIO_NAME (gfc_intrinsic_op)
2162 DECL_MIO_NAME (ifsrc)
2163 DECL_MIO_NAME (save_state)
2164 DECL_MIO_NAME (procedure_type)
2165 DECL_MIO_NAME (ref_type)
2166 DECL_MIO_NAME (sym_flavor)
2167 DECL_MIO_NAME (sym_intent)
2168 DECL_MIO_NAME (inquiry_type)
2169 #undef DECL_MIO_NAME
2170 
2171 /* Verify OACC_ROUTINE_LOP_NONE.  */
2172 
2173 static void
2174 verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop)
2175 {
2176   if (lop != OACC_ROUTINE_LOP_NONE)
2177     bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2178 }
2179 
2180 /* Symbol attributes are stored in list with the first three elements
2181    being the enumerated fields, while the remaining elements (if any)
2182    indicate the individual attribute bits.  The access field is not
2183    saved-- it controls what symbols are exported when a module is
2184    written.  */
2185 
2186 static void
mio_symbol_attribute(symbol_attribute * attr)2187 mio_symbol_attribute (symbol_attribute *attr)
2188 {
2189   atom_type t;
2190   unsigned ext_attr,extension_level;
2191 
2192   mio_lparen ();
2193 
2194   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
2195   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
2196   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
2197   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
2198   attr->save = MIO_NAME (save_state) (attr->save, save_status);
2199 
2200   ext_attr = attr->ext_attr;
2201   mio_integer ((int *) &ext_attr);
2202   attr->ext_attr = ext_attr;
2203 
2204   extension_level = attr->extension;
2205   mio_integer ((int *) &extension_level);
2206   attr->extension = extension_level;
2207 
2208   if (iomode == IO_OUTPUT)
2209     {
2210       if (attr->allocatable)
2211 	MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
2212       if (attr->artificial)
2213 	MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
2214       if (attr->asynchronous)
2215 	MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
2216       if (attr->dimension)
2217 	MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
2218       if (attr->codimension)
2219 	MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
2220       if (attr->contiguous)
2221 	MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
2222       if (attr->external)
2223 	MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
2224       if (attr->intrinsic)
2225 	MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
2226       if (attr->optional)
2227 	MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
2228       if (attr->pointer)
2229 	MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
2230       if (attr->class_pointer)
2231 	MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
2232       if (attr->is_protected)
2233 	MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
2234       if (attr->value)
2235 	MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
2236       if (attr->volatile_)
2237 	MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2238       if (attr->target)
2239 	MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2240       if (attr->threadprivate)
2241 	MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2242       if (attr->dummy)
2243 	MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2244       if (attr->result)
2245 	MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2246       /* We deliberately don't preserve the "entry" flag.  */
2247 
2248       if (attr->data)
2249 	MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2250       if (attr->in_namelist)
2251 	MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2252       if (attr->in_common)
2253 	MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2254 
2255       if (attr->function)
2256 	MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2257       if (attr->subroutine)
2258 	MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2259       if (attr->generic)
2260 	MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2261       if (attr->abstract)
2262 	MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2263 
2264       if (attr->sequence)
2265 	MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2266       if (attr->elemental)
2267 	MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2268       if (attr->pure)
2269 	MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2270       if (attr->implicit_pure)
2271 	MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2272       if (attr->unlimited_polymorphic)
2273 	MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2274       if (attr->recursive)
2275 	MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2276       if (attr->always_explicit)
2277 	MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2278       if (attr->cray_pointer)
2279 	MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2280       if (attr->cray_pointee)
2281 	MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2282       if (attr->is_bind_c)
2283 	MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2284       if (attr->is_c_interop)
2285 	MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2286       if (attr->is_iso_c)
2287 	MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2288       if (attr->alloc_comp)
2289 	MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2290       if (attr->pointer_comp)
2291 	MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2292       if (attr->proc_pointer_comp)
2293 	MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2294       if (attr->private_comp)
2295 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2296       if (attr->coarray_comp)
2297 	MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2298       if (attr->lock_comp)
2299 	MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2300       if (attr->event_comp)
2301 	MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
2302       if (attr->zero_comp)
2303 	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2304       if (attr->is_class)
2305 	MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2306       if (attr->procedure)
2307 	MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2308       if (attr->proc_pointer)
2309 	MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2310       if (attr->vtype)
2311 	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2312       if (attr->vtab)
2313 	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2314       if (attr->omp_declare_target)
2315 	MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
2316       if (attr->array_outer_dependency)
2317 	MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
2318       if (attr->module_procedure)
2319 	MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
2320       if (attr->oacc_declare_create)
2321 	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
2322       if (attr->oacc_declare_copyin)
2323 	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
2324       if (attr->oacc_declare_deviceptr)
2325 	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
2326       if (attr->oacc_declare_device_resident)
2327 	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
2328       if (attr->oacc_declare_link)
2329 	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
2330       if (attr->omp_declare_target_link)
2331 	MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
2332       if (attr->pdt_kind)
2333 	MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
2334       if (attr->pdt_len)
2335 	MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
2336       if (attr->pdt_type)
2337 	MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
2338       if (attr->pdt_template)
2339 	MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
2340       if (attr->pdt_array)
2341 	MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
2342       if (attr->pdt_string)
2343 	MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
2344       switch (attr->oacc_routine_lop)
2345 	{
2346 	case OACC_ROUTINE_LOP_NONE:
2347 	  /* This is the default anyway, and for maintaining compatibility with
2348 	     the current MOD_VERSION, we're not emitting anything in that
2349 	     case.  */
2350 	  break;
2351 	case OACC_ROUTINE_LOP_GANG:
2352 	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits);
2353 	  break;
2354 	case OACC_ROUTINE_LOP_WORKER:
2355 	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits);
2356 	  break;
2357 	case OACC_ROUTINE_LOP_VECTOR:
2358 	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits);
2359 	  break;
2360 	case OACC_ROUTINE_LOP_SEQ:
2361 	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits);
2362 	  break;
2363 	case OACC_ROUTINE_LOP_ERROR:
2364 	  /* ... intentionally omitted here; it's only unsed internally.  */
2365 	default:
2366 	  gcc_unreachable ();
2367 	}
2368 
2369       mio_rparen ();
2370 
2371     }
2372   else
2373     {
2374       for (;;)
2375 	{
2376 	  t = parse_atom ();
2377 	  if (t == ATOM_RPAREN)
2378 	    break;
2379 	  if (t != ATOM_NAME)
2380 	    bad_module ("Expected attribute bit name");
2381 
2382 	  switch ((ab_attribute) find_enum (attr_bits))
2383 	    {
2384 	    case AB_ALLOCATABLE:
2385 	      attr->allocatable = 1;
2386 	      break;
2387 	    case AB_ARTIFICIAL:
2388 	      attr->artificial = 1;
2389 	      break;
2390 	    case AB_ASYNCHRONOUS:
2391 	      attr->asynchronous = 1;
2392 	      break;
2393 	    case AB_DIMENSION:
2394 	      attr->dimension = 1;
2395 	      break;
2396 	    case AB_CODIMENSION:
2397 	      attr->codimension = 1;
2398 	      break;
2399 	    case AB_CONTIGUOUS:
2400 	      attr->contiguous = 1;
2401 	      break;
2402 	    case AB_EXTERNAL:
2403 	      attr->external = 1;
2404 	      break;
2405 	    case AB_INTRINSIC:
2406 	      attr->intrinsic = 1;
2407 	      break;
2408 	    case AB_OPTIONAL:
2409 	      attr->optional = 1;
2410 	      break;
2411 	    case AB_POINTER:
2412 	      attr->pointer = 1;
2413 	      break;
2414 	    case AB_CLASS_POINTER:
2415 	      attr->class_pointer = 1;
2416 	      break;
2417 	    case AB_PROTECTED:
2418 	      attr->is_protected = 1;
2419 	      break;
2420 	    case AB_VALUE:
2421 	      attr->value = 1;
2422 	      break;
2423 	    case AB_VOLATILE:
2424 	      attr->volatile_ = 1;
2425 	      break;
2426 	    case AB_TARGET:
2427 	      attr->target = 1;
2428 	      break;
2429 	    case AB_THREADPRIVATE:
2430 	      attr->threadprivate = 1;
2431 	      break;
2432 	    case AB_DUMMY:
2433 	      attr->dummy = 1;
2434 	      break;
2435 	    case AB_RESULT:
2436 	      attr->result = 1;
2437 	      break;
2438 	    case AB_DATA:
2439 	      attr->data = 1;
2440 	      break;
2441 	    case AB_IN_NAMELIST:
2442 	      attr->in_namelist = 1;
2443 	      break;
2444 	    case AB_IN_COMMON:
2445 	      attr->in_common = 1;
2446 	      break;
2447 	    case AB_FUNCTION:
2448 	      attr->function = 1;
2449 	      break;
2450 	    case AB_SUBROUTINE:
2451 	      attr->subroutine = 1;
2452 	      break;
2453 	    case AB_GENERIC:
2454 	      attr->generic = 1;
2455 	      break;
2456 	    case AB_ABSTRACT:
2457 	      attr->abstract = 1;
2458 	      break;
2459 	    case AB_SEQUENCE:
2460 	      attr->sequence = 1;
2461 	      break;
2462 	    case AB_ELEMENTAL:
2463 	      attr->elemental = 1;
2464 	      break;
2465 	    case AB_PURE:
2466 	      attr->pure = 1;
2467 	      break;
2468 	    case AB_IMPLICIT_PURE:
2469 	      attr->implicit_pure = 1;
2470 	      break;
2471 	    case AB_UNLIMITED_POLY:
2472 	      attr->unlimited_polymorphic = 1;
2473 	      break;
2474 	    case AB_RECURSIVE:
2475 	      attr->recursive = 1;
2476 	      break;
2477 	    case AB_ALWAYS_EXPLICIT:
2478 	      attr->always_explicit = 1;
2479 	      break;
2480 	    case AB_CRAY_POINTER:
2481 	      attr->cray_pointer = 1;
2482 	      break;
2483 	    case AB_CRAY_POINTEE:
2484 	      attr->cray_pointee = 1;
2485 	      break;
2486 	    case AB_IS_BIND_C:
2487 	      attr->is_bind_c = 1;
2488 	      break;
2489 	    case AB_IS_C_INTEROP:
2490 	      attr->is_c_interop = 1;
2491 	      break;
2492 	    case AB_IS_ISO_C:
2493 	      attr->is_iso_c = 1;
2494 	      break;
2495 	    case AB_ALLOC_COMP:
2496 	      attr->alloc_comp = 1;
2497 	      break;
2498 	    case AB_COARRAY_COMP:
2499 	      attr->coarray_comp = 1;
2500 	      break;
2501 	    case AB_LOCK_COMP:
2502 	      attr->lock_comp = 1;
2503 	      break;
2504 	    case AB_EVENT_COMP:
2505 	      attr->event_comp = 1;
2506 	      break;
2507 	    case AB_POINTER_COMP:
2508 	      attr->pointer_comp = 1;
2509 	      break;
2510 	    case AB_PROC_POINTER_COMP:
2511 	      attr->proc_pointer_comp = 1;
2512 	      break;
2513 	    case AB_PRIVATE_COMP:
2514 	      attr->private_comp = 1;
2515 	      break;
2516 	    case AB_ZERO_COMP:
2517 	      attr->zero_comp = 1;
2518 	      break;
2519 	    case AB_IS_CLASS:
2520 	      attr->is_class = 1;
2521 	      break;
2522 	    case AB_PROCEDURE:
2523 	      attr->procedure = 1;
2524 	      break;
2525 	    case AB_PROC_POINTER:
2526 	      attr->proc_pointer = 1;
2527 	      break;
2528 	    case AB_VTYPE:
2529 	      attr->vtype = 1;
2530 	      break;
2531 	    case AB_VTAB:
2532 	      attr->vtab = 1;
2533 	      break;
2534 	    case AB_OMP_DECLARE_TARGET:
2535 	      attr->omp_declare_target = 1;
2536 	      break;
2537 	    case AB_OMP_DECLARE_TARGET_LINK:
2538 	      attr->omp_declare_target_link = 1;
2539 	      break;
2540 	    case AB_ARRAY_OUTER_DEPENDENCY:
2541 	      attr->array_outer_dependency =1;
2542 	      break;
2543 	    case AB_MODULE_PROCEDURE:
2544 	      attr->module_procedure =1;
2545 	      break;
2546 	    case AB_OACC_DECLARE_CREATE:
2547 	      attr->oacc_declare_create = 1;
2548 	      break;
2549 	    case AB_OACC_DECLARE_COPYIN:
2550 	      attr->oacc_declare_copyin = 1;
2551 	      break;
2552 	    case AB_OACC_DECLARE_DEVICEPTR:
2553 	      attr->oacc_declare_deviceptr = 1;
2554 	      break;
2555 	    case AB_OACC_DECLARE_DEVICE_RESIDENT:
2556 	      attr->oacc_declare_device_resident = 1;
2557 	      break;
2558 	    case AB_OACC_DECLARE_LINK:
2559 	      attr->oacc_declare_link = 1;
2560 	      break;
2561 	    case AB_PDT_KIND:
2562 	      attr->pdt_kind = 1;
2563 	      break;
2564 	    case AB_PDT_LEN:
2565 	      attr->pdt_len = 1;
2566 	      break;
2567 	    case AB_PDT_TYPE:
2568 	      attr->pdt_type = 1;
2569 	      break;
2570 	    case AB_PDT_TEMPLATE:
2571 	      attr->pdt_template = 1;
2572 	      break;
2573 	    case AB_PDT_ARRAY:
2574 	      attr->pdt_array = 1;
2575 	      break;
2576 	    case AB_PDT_STRING:
2577 	      attr->pdt_string = 1;
2578 	      break;
2579 	    case AB_OACC_ROUTINE_LOP_GANG:
2580 	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2581 	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG;
2582 	      break;
2583 	    case AB_OACC_ROUTINE_LOP_WORKER:
2584 	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2585 	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER;
2586 	      break;
2587 	    case AB_OACC_ROUTINE_LOP_VECTOR:
2588 	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2589 	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR;
2590 	      break;
2591 	    case AB_OACC_ROUTINE_LOP_SEQ:
2592 	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2593 	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ;
2594 	      break;
2595 	    }
2596 	}
2597     }
2598 }
2599 
2600 
2601 static const mstring bt_types[] = {
2602     minit ("INTEGER", BT_INTEGER),
2603     minit ("REAL", BT_REAL),
2604     minit ("COMPLEX", BT_COMPLEX),
2605     minit ("LOGICAL", BT_LOGICAL),
2606     minit ("CHARACTER", BT_CHARACTER),
2607     minit ("UNION", BT_UNION),
2608     minit ("DERIVED", BT_DERIVED),
2609     minit ("CLASS", BT_CLASS),
2610     minit ("PROCEDURE", BT_PROCEDURE),
2611     minit ("UNKNOWN", BT_UNKNOWN),
2612     minit ("VOID", BT_VOID),
2613     minit ("ASSUMED", BT_ASSUMED),
2614     minit (NULL, -1)
2615 };
2616 
2617 
2618 static void
mio_charlen(gfc_charlen ** clp)2619 mio_charlen (gfc_charlen **clp)
2620 {
2621   gfc_charlen *cl;
2622 
2623   mio_lparen ();
2624 
2625   if (iomode == IO_OUTPUT)
2626     {
2627       cl = *clp;
2628       if (cl != NULL)
2629 	mio_expr (&cl->length);
2630     }
2631   else
2632     {
2633       if (peek_atom () != ATOM_RPAREN)
2634 	{
2635 	  cl = gfc_new_charlen (gfc_current_ns, NULL);
2636 	  mio_expr (&cl->length);
2637 	  *clp = cl;
2638 	}
2639     }
2640 
2641   mio_rparen ();
2642 }
2643 
2644 
2645 /* See if a name is a generated name.  */
2646 
2647 static int
check_unique_name(const char * name)2648 check_unique_name (const char *name)
2649 {
2650   return *name == '@';
2651 }
2652 
2653 
2654 static void
mio_typespec(gfc_typespec * ts)2655 mio_typespec (gfc_typespec *ts)
2656 {
2657   mio_lparen ();
2658 
2659   ts->type = MIO_NAME (bt) (ts->type, bt_types);
2660 
2661   if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
2662     mio_integer (&ts->kind);
2663   else
2664     mio_symbol_ref (&ts->u.derived);
2665 
2666   mio_symbol_ref (&ts->interface);
2667 
2668   /* Add info for C interop and is_iso_c.  */
2669   mio_integer (&ts->is_c_interop);
2670   mio_integer (&ts->is_iso_c);
2671 
2672   /* If the typespec is for an identifier either from iso_c_binding, or
2673      a constant that was initialized to an identifier from it, use the
2674      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
2675   if (ts->is_iso_c)
2676     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2677   else
2678     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2679 
2680   if (ts->type != BT_CHARACTER)
2681     {
2682       /* ts->u.cl is only valid for BT_CHARACTER.  */
2683       mio_lparen ();
2684       mio_rparen ();
2685     }
2686   else
2687     mio_charlen (&ts->u.cl);
2688 
2689   /* So as not to disturb the existing API, use an ATOM_NAME to
2690      transmit deferred characteristic for characters (F2003).  */
2691   if (iomode == IO_OUTPUT)
2692     {
2693       if (ts->type == BT_CHARACTER && ts->deferred)
2694 	write_atom (ATOM_NAME, "DEFERRED_CL");
2695     }
2696   else if (peek_atom () != ATOM_RPAREN)
2697     {
2698       if (parse_atom () != ATOM_NAME)
2699 	bad_module ("Expected string");
2700       ts->deferred = 1;
2701     }
2702 
2703   mio_rparen ();
2704 }
2705 
2706 
2707 static const mstring array_spec_types[] = {
2708     minit ("EXPLICIT", AS_EXPLICIT),
2709     minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2710     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2711     minit ("DEFERRED", AS_DEFERRED),
2712     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2713     minit (NULL, -1)
2714 };
2715 
2716 
2717 static void
mio_array_spec(gfc_array_spec ** asp)2718 mio_array_spec (gfc_array_spec **asp)
2719 {
2720   gfc_array_spec *as;
2721   int i;
2722 
2723   mio_lparen ();
2724 
2725   if (iomode == IO_OUTPUT)
2726     {
2727       int rank;
2728 
2729       if (*asp == NULL)
2730 	goto done;
2731       as = *asp;
2732 
2733       /* mio_integer expects nonnegative values.  */
2734       rank = as->rank > 0 ? as->rank : 0;
2735       mio_integer (&rank);
2736     }
2737   else
2738     {
2739       if (peek_atom () == ATOM_RPAREN)
2740 	{
2741 	  *asp = NULL;
2742 	  goto done;
2743 	}
2744 
2745       *asp = as = gfc_get_array_spec ();
2746       mio_integer (&as->rank);
2747     }
2748 
2749   mio_integer (&as->corank);
2750   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2751 
2752   if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2753     as->rank = -1;
2754   if (iomode == IO_INPUT && as->corank)
2755     as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2756 
2757   if (as->rank + as->corank > 0)
2758     for (i = 0; i < as->rank + as->corank; i++)
2759       {
2760 	mio_expr (&as->lower[i]);
2761 	mio_expr (&as->upper[i]);
2762       }
2763 
2764 done:
2765   mio_rparen ();
2766 }
2767 
2768 
2769 /* Given a pointer to an array reference structure (which lives in a
2770    gfc_ref structure), find the corresponding array specification
2771    structure.  Storing the pointer in the ref structure doesn't quite
2772    work when loading from a module. Generating code for an array
2773    reference also needs more information than just the array spec.  */
2774 
2775 static const mstring array_ref_types[] = {
2776     minit ("FULL", AR_FULL),
2777     minit ("ELEMENT", AR_ELEMENT),
2778     minit ("SECTION", AR_SECTION),
2779     minit (NULL, -1)
2780 };
2781 
2782 
2783 static void
mio_array_ref(gfc_array_ref * ar)2784 mio_array_ref (gfc_array_ref *ar)
2785 {
2786   int i;
2787 
2788   mio_lparen ();
2789   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2790   mio_integer (&ar->dimen);
2791 
2792   switch (ar->type)
2793     {
2794     case AR_FULL:
2795       break;
2796 
2797     case AR_ELEMENT:
2798       for (i = 0; i < ar->dimen; i++)
2799 	mio_expr (&ar->start[i]);
2800 
2801       break;
2802 
2803     case AR_SECTION:
2804       for (i = 0; i < ar->dimen; i++)
2805 	{
2806 	  mio_expr (&ar->start[i]);
2807 	  mio_expr (&ar->end[i]);
2808 	  mio_expr (&ar->stride[i]);
2809 	}
2810 
2811       break;
2812 
2813     case AR_UNKNOWN:
2814       gfc_internal_error ("mio_array_ref(): Unknown array ref");
2815     }
2816 
2817   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2818      we can't call mio_integer directly.  Instead loop over each element
2819      and cast it to/from an integer.  */
2820   if (iomode == IO_OUTPUT)
2821     {
2822       for (i = 0; i < ar->dimen; i++)
2823 	{
2824 	  HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
2825 	  write_atom (ATOM_INTEGER, &tmp);
2826 	}
2827     }
2828   else
2829     {
2830       for (i = 0; i < ar->dimen; i++)
2831 	{
2832 	  require_atom (ATOM_INTEGER);
2833 	  ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2834 	}
2835     }
2836 
2837   if (iomode == IO_INPUT)
2838     {
2839       ar->where = gfc_current_locus;
2840 
2841       for (i = 0; i < ar->dimen; i++)
2842 	ar->c_where[i] = gfc_current_locus;
2843     }
2844 
2845   mio_rparen ();
2846 }
2847 
2848 
2849 /* Saves or restores a pointer.  The pointer is converted back and
2850    forth from an integer.  We return the pointer_info pointer so that
2851    the caller can take additional action based on the pointer type.  */
2852 
2853 static pointer_info *
mio_pointer_ref(void * gp)2854 mio_pointer_ref (void *gp)
2855 {
2856   pointer_info *p;
2857 
2858   if (iomode == IO_OUTPUT)
2859     {
2860       p = get_pointer (*((char **) gp));
2861       HOST_WIDE_INT hwi = p->integer;
2862       write_atom (ATOM_INTEGER, &hwi);
2863     }
2864   else
2865     {
2866       require_atom (ATOM_INTEGER);
2867       p = add_fixup (atom_int, gp);
2868     }
2869 
2870   return p;
2871 }
2872 
2873 
2874 /* Save and load references to components that occur within
2875    expressions.  We have to describe these references by a number and
2876    by name.  The number is necessary for forward references during
2877    reading, and the name is necessary if the symbol already exists in
2878    the namespace and is not loaded again.  */
2879 
2880 static void
mio_component_ref(gfc_component ** cp)2881 mio_component_ref (gfc_component **cp)
2882 {
2883   pointer_info *p;
2884 
2885   p = mio_pointer_ref (cp);
2886   if (p->type == P_UNKNOWN)
2887     p->type = P_COMPONENT;
2888 }
2889 
2890 
2891 static void mio_namespace_ref (gfc_namespace **nsp);
2892 static void mio_formal_arglist (gfc_formal_arglist **formal);
2893 static void mio_typebound_proc (gfc_typebound_proc** proc);
2894 static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
2895 
2896 static void
mio_component(gfc_component * c,int vtype)2897 mio_component (gfc_component *c, int vtype)
2898 {
2899   pointer_info *p;
2900 
2901   mio_lparen ();
2902 
2903   if (iomode == IO_OUTPUT)
2904     {
2905       p = get_pointer (c);
2906       mio_hwi (&p->integer);
2907     }
2908   else
2909     {
2910       HOST_WIDE_INT n;
2911       mio_hwi (&n);
2912       p = get_integer (n);
2913       associate_integer_pointer (p, c);
2914     }
2915 
2916   if (p->type == P_UNKNOWN)
2917     p->type = P_COMPONENT;
2918 
2919   mio_pool_string (&c->name);
2920   mio_typespec (&c->ts);
2921   mio_array_spec (&c->as);
2922 
2923   /* PDT templates store the expression for the kind of a component here.  */
2924   mio_expr (&c->kind_expr);
2925 
2926   /* PDT types store the component specification list here. */
2927   mio_actual_arglist (&c->param_list, true);
2928 
2929   mio_symbol_attribute (&c->attr);
2930   if (c->ts.type == BT_CLASS)
2931     c->attr.class_ok = 1;
2932   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2933 
2934   if (!vtype || strcmp (c->name, "_final") == 0
2935       || strcmp (c->name, "_hash") == 0)
2936     mio_expr (&c->initializer);
2937 
2938   if (c->attr.proc_pointer)
2939     mio_typebound_proc (&c->tb);
2940 
2941   c->loc = gfc_current_locus;
2942 
2943   mio_rparen ();
2944 }
2945 
2946 
2947 static void
mio_component_list(gfc_component ** cp,int vtype)2948 mio_component_list (gfc_component **cp, int vtype)
2949 {
2950   gfc_component *c, *tail;
2951 
2952   mio_lparen ();
2953 
2954   if (iomode == IO_OUTPUT)
2955     {
2956       for (c = *cp; c; c = c->next)
2957 	mio_component (c, vtype);
2958     }
2959   else
2960     {
2961       *cp = NULL;
2962       tail = NULL;
2963 
2964       for (;;)
2965 	{
2966 	  if (peek_atom () == ATOM_RPAREN)
2967 	    break;
2968 
2969 	  c = gfc_get_component ();
2970 	  mio_component (c, vtype);
2971 
2972 	  if (tail == NULL)
2973 	    *cp = c;
2974 	  else
2975 	    tail->next = c;
2976 
2977 	  tail = c;
2978 	}
2979     }
2980 
2981   mio_rparen ();
2982 }
2983 
2984 
2985 static void
mio_actual_arg(gfc_actual_arglist * a,bool pdt)2986 mio_actual_arg (gfc_actual_arglist *a, bool pdt)
2987 {
2988   mio_lparen ();
2989   mio_pool_string (&a->name);
2990   mio_expr (&a->expr);
2991   if (pdt)
2992     mio_integer ((int *)&a->spec_type);
2993   mio_rparen ();
2994 }
2995 
2996 
2997 static void
mio_actual_arglist(gfc_actual_arglist ** ap,bool pdt)2998 mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
2999 {
3000   gfc_actual_arglist *a, *tail;
3001 
3002   mio_lparen ();
3003 
3004   if (iomode == IO_OUTPUT)
3005     {
3006       for (a = *ap; a; a = a->next)
3007 	mio_actual_arg (a, pdt);
3008 
3009     }
3010   else
3011     {
3012       tail = NULL;
3013 
3014       for (;;)
3015 	{
3016 	  if (peek_atom () != ATOM_LPAREN)
3017 	    break;
3018 
3019 	  a = gfc_get_actual_arglist ();
3020 
3021 	  if (tail == NULL)
3022 	    *ap = a;
3023 	  else
3024 	    tail->next = a;
3025 
3026 	  tail = a;
3027 	  mio_actual_arg (a, pdt);
3028 	}
3029     }
3030 
3031   mio_rparen ();
3032 }
3033 
3034 
3035 /* Read and write formal argument lists.  */
3036 
3037 static void
mio_formal_arglist(gfc_formal_arglist ** formal)3038 mio_formal_arglist (gfc_formal_arglist **formal)
3039 {
3040   gfc_formal_arglist *f, *tail;
3041 
3042   mio_lparen ();
3043 
3044   if (iomode == IO_OUTPUT)
3045     {
3046       for (f = *formal; f; f = f->next)
3047 	mio_symbol_ref (&f->sym);
3048     }
3049   else
3050     {
3051       *formal = tail = NULL;
3052 
3053       while (peek_atom () != ATOM_RPAREN)
3054 	{
3055 	  f = gfc_get_formal_arglist ();
3056 	  mio_symbol_ref (&f->sym);
3057 
3058 	  if (*formal == NULL)
3059 	    *formal = f;
3060 	  else
3061 	    tail->next = f;
3062 
3063 	  tail = f;
3064 	}
3065     }
3066 
3067   mio_rparen ();
3068 }
3069 
3070 
3071 /* Save or restore a reference to a symbol node.  */
3072 
3073 pointer_info *
mio_symbol_ref(gfc_symbol ** symp)3074 mio_symbol_ref (gfc_symbol **symp)
3075 {
3076   pointer_info *p;
3077 
3078   p = mio_pointer_ref (symp);
3079   if (p->type == P_UNKNOWN)
3080     p->type = P_SYMBOL;
3081 
3082   if (iomode == IO_OUTPUT)
3083     {
3084       if (p->u.wsym.state == UNREFERENCED)
3085 	p->u.wsym.state = NEEDS_WRITE;
3086     }
3087   else
3088     {
3089       if (p->u.rsym.state == UNUSED)
3090 	p->u.rsym.state = NEEDED;
3091     }
3092   return p;
3093 }
3094 
3095 
3096 /* Save or restore a reference to a symtree node.  */
3097 
3098 static void
mio_symtree_ref(gfc_symtree ** stp)3099 mio_symtree_ref (gfc_symtree **stp)
3100 {
3101   pointer_info *p;
3102   fixup_t *f;
3103 
3104   if (iomode == IO_OUTPUT)
3105     mio_symbol_ref (&(*stp)->n.sym);
3106   else
3107     {
3108       require_atom (ATOM_INTEGER);
3109       p = get_integer (atom_int);
3110 
3111       /* An unused equivalence member; make a symbol and a symtree
3112 	 for it.  */
3113       if (in_load_equiv && p->u.rsym.symtree == NULL)
3114 	{
3115 	  /* Since this is not used, it must have a unique name.  */
3116 	  p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
3117 
3118 	  /* Make the symbol.  */
3119 	  if (p->u.rsym.sym == NULL)
3120 	    {
3121 	      p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
3122 					      gfc_current_ns);
3123 	      p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
3124 	    }
3125 
3126 	  p->u.rsym.symtree->n.sym = p->u.rsym.sym;
3127 	  p->u.rsym.symtree->n.sym->refs++;
3128 	  p->u.rsym.referenced = 1;
3129 
3130 	  /* If the symbol is PRIVATE and in COMMON, load_commons will
3131 	     generate a fixup symbol, which must be associated.  */
3132 	  if (p->fixup)
3133 	    resolve_fixups (p->fixup, p->u.rsym.sym);
3134 	  p->fixup = NULL;
3135 	}
3136 
3137       if (p->type == P_UNKNOWN)
3138 	p->type = P_SYMBOL;
3139 
3140       if (p->u.rsym.state == UNUSED)
3141 	p->u.rsym.state = NEEDED;
3142 
3143       if (p->u.rsym.symtree != NULL)
3144 	{
3145 	  *stp = p->u.rsym.symtree;
3146 	}
3147       else
3148 	{
3149 	  f = XCNEW (fixup_t);
3150 
3151 	  f->next = p->u.rsym.stfixup;
3152 	  p->u.rsym.stfixup = f;
3153 
3154 	  f->pointer = (void **) stp;
3155 	}
3156     }
3157 }
3158 
3159 
3160 static void
mio_iterator(gfc_iterator ** ip)3161 mio_iterator (gfc_iterator **ip)
3162 {
3163   gfc_iterator *iter;
3164 
3165   mio_lparen ();
3166 
3167   if (iomode == IO_OUTPUT)
3168     {
3169       if (*ip == NULL)
3170 	goto done;
3171     }
3172   else
3173     {
3174       if (peek_atom () == ATOM_RPAREN)
3175 	{
3176 	  *ip = NULL;
3177 	  goto done;
3178 	}
3179 
3180       *ip = gfc_get_iterator ();
3181     }
3182 
3183   iter = *ip;
3184 
3185   mio_expr (&iter->var);
3186   mio_expr (&iter->start);
3187   mio_expr (&iter->end);
3188   mio_expr (&iter->step);
3189 
3190 done:
3191   mio_rparen ();
3192 }
3193 
3194 
3195 static void
mio_constructor(gfc_constructor_base * cp)3196 mio_constructor (gfc_constructor_base *cp)
3197 {
3198   gfc_constructor *c;
3199 
3200   mio_lparen ();
3201 
3202   if (iomode == IO_OUTPUT)
3203     {
3204       for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
3205 	{
3206 	  mio_lparen ();
3207 	  mio_expr (&c->expr);
3208 	  mio_iterator (&c->iterator);
3209 	  mio_rparen ();
3210 	}
3211     }
3212   else
3213     {
3214       while (peek_atom () != ATOM_RPAREN)
3215 	{
3216 	  c = gfc_constructor_append_expr (cp, NULL, NULL);
3217 
3218 	  mio_lparen ();
3219 	  mio_expr (&c->expr);
3220 	  mio_iterator (&c->iterator);
3221 	  mio_rparen ();
3222 	}
3223     }
3224 
3225   mio_rparen ();
3226 }
3227 
3228 
3229 static const mstring ref_types[] = {
3230     minit ("ARRAY", REF_ARRAY),
3231     minit ("COMPONENT", REF_COMPONENT),
3232     minit ("SUBSTRING", REF_SUBSTRING),
3233     minit ("INQUIRY", REF_INQUIRY),
3234     minit (NULL, -1)
3235 };
3236 
3237 static const mstring inquiry_types[] = {
3238     minit ("RE", INQUIRY_RE),
3239     minit ("IM", INQUIRY_IM),
3240     minit ("KIND", INQUIRY_KIND),
3241     minit ("LEN", INQUIRY_LEN),
3242     minit (NULL, -1)
3243 };
3244 
3245 
3246 static void
mio_ref(gfc_ref ** rp)3247 mio_ref (gfc_ref **rp)
3248 {
3249   gfc_ref *r;
3250 
3251   mio_lparen ();
3252 
3253   r = *rp;
3254   r->type = MIO_NAME (ref_type) (r->type, ref_types);
3255 
3256   switch (r->type)
3257     {
3258     case REF_ARRAY:
3259       mio_array_ref (&r->u.ar);
3260       break;
3261 
3262     case REF_COMPONENT:
3263       mio_symbol_ref (&r->u.c.sym);
3264       mio_component_ref (&r->u.c.component);
3265       break;
3266 
3267     case REF_SUBSTRING:
3268       mio_expr (&r->u.ss.start);
3269       mio_expr (&r->u.ss.end);
3270       mio_charlen (&r->u.ss.length);
3271       break;
3272 
3273     case REF_INQUIRY:
3274       r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types);
3275       break;
3276     }
3277 
3278   mio_rparen ();
3279 }
3280 
3281 
3282 static void
mio_ref_list(gfc_ref ** rp)3283 mio_ref_list (gfc_ref **rp)
3284 {
3285   gfc_ref *ref, *head, *tail;
3286 
3287   mio_lparen ();
3288 
3289   if (iomode == IO_OUTPUT)
3290     {
3291       for (ref = *rp; ref; ref = ref->next)
3292 	mio_ref (&ref);
3293     }
3294   else
3295     {
3296       head = tail = NULL;
3297 
3298       while (peek_atom () != ATOM_RPAREN)
3299 	{
3300 	  if (head == NULL)
3301 	    head = tail = gfc_get_ref ();
3302 	  else
3303 	    {
3304 	      tail->next = gfc_get_ref ();
3305 	      tail = tail->next;
3306 	    }
3307 
3308 	  mio_ref (&tail);
3309 	}
3310 
3311       *rp = head;
3312     }
3313 
3314   mio_rparen ();
3315 }
3316 
3317 
3318 /* Read and write an integer value.  */
3319 
3320 static void
mio_gmp_integer(mpz_t * integer)3321 mio_gmp_integer (mpz_t *integer)
3322 {
3323   char *p;
3324 
3325   if (iomode == IO_INPUT)
3326     {
3327       if (parse_atom () != ATOM_STRING)
3328 	bad_module ("Expected integer string");
3329 
3330       mpz_init (*integer);
3331       if (mpz_set_str (*integer, atom_string, 10))
3332 	bad_module ("Error converting integer");
3333 
3334       free (atom_string);
3335     }
3336   else
3337     {
3338       p = mpz_get_str (NULL, 10, *integer);
3339       write_atom (ATOM_STRING, p);
3340       free (p);
3341     }
3342 }
3343 
3344 
3345 static void
mio_gmp_real(mpfr_t * real)3346 mio_gmp_real (mpfr_t *real)
3347 {
3348   mpfr_exp_t exponent;
3349   char *p;
3350 
3351   if (iomode == IO_INPUT)
3352     {
3353       if (parse_atom () != ATOM_STRING)
3354 	bad_module ("Expected real string");
3355 
3356       mpfr_init (*real);
3357       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3358       free (atom_string);
3359     }
3360   else
3361     {
3362       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3363 
3364       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3365 	{
3366 	  write_atom (ATOM_STRING, p);
3367 	  free (p);
3368 	  return;
3369 	}
3370 
3371       atom_string = XCNEWVEC (char, strlen (p) + 20);
3372 
3373       sprintf (atom_string, "0.%s@%ld", p, exponent);
3374 
3375       /* Fix negative numbers.  */
3376       if (atom_string[2] == '-')
3377 	{
3378 	  atom_string[0] = '-';
3379 	  atom_string[1] = '0';
3380 	  atom_string[2] = '.';
3381 	}
3382 
3383       write_atom (ATOM_STRING, atom_string);
3384 
3385       free (atom_string);
3386       free (p);
3387     }
3388 }
3389 
3390 
3391 /* Save and restore the shape of an array constructor.  */
3392 
3393 static void
mio_shape(mpz_t ** pshape,int rank)3394 mio_shape (mpz_t **pshape, int rank)
3395 {
3396   mpz_t *shape;
3397   atom_type t;
3398   int n;
3399 
3400   /* A NULL shape is represented by ().  */
3401   mio_lparen ();
3402 
3403   if (iomode == IO_OUTPUT)
3404     {
3405       shape = *pshape;
3406       if (!shape)
3407 	{
3408 	  mio_rparen ();
3409 	  return;
3410 	}
3411     }
3412   else
3413     {
3414       t = peek_atom ();
3415       if (t == ATOM_RPAREN)
3416 	{
3417 	  *pshape = NULL;
3418 	  mio_rparen ();
3419 	  return;
3420 	}
3421 
3422       shape = gfc_get_shape (rank);
3423       *pshape = shape;
3424     }
3425 
3426   for (n = 0; n < rank; n++)
3427     mio_gmp_integer (&shape[n]);
3428 
3429   mio_rparen ();
3430 }
3431 
3432 
3433 static const mstring expr_types[] = {
3434     minit ("OP", EXPR_OP),
3435     minit ("FUNCTION", EXPR_FUNCTION),
3436     minit ("CONSTANT", EXPR_CONSTANT),
3437     minit ("VARIABLE", EXPR_VARIABLE),
3438     minit ("SUBSTRING", EXPR_SUBSTRING),
3439     minit ("STRUCTURE", EXPR_STRUCTURE),
3440     minit ("ARRAY", EXPR_ARRAY),
3441     minit ("NULL", EXPR_NULL),
3442     minit ("COMPCALL", EXPR_COMPCALL),
3443     minit (NULL, -1)
3444 };
3445 
3446 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3447    generic operators, not in expressions.  INTRINSIC_USER is also
3448    replaced by the correct function name by the time we see it.  */
3449 
3450 static const mstring intrinsics[] =
3451 {
3452     minit ("UPLUS", INTRINSIC_UPLUS),
3453     minit ("UMINUS", INTRINSIC_UMINUS),
3454     minit ("PLUS", INTRINSIC_PLUS),
3455     minit ("MINUS", INTRINSIC_MINUS),
3456     minit ("TIMES", INTRINSIC_TIMES),
3457     minit ("DIVIDE", INTRINSIC_DIVIDE),
3458     minit ("POWER", INTRINSIC_POWER),
3459     minit ("CONCAT", INTRINSIC_CONCAT),
3460     minit ("AND", INTRINSIC_AND),
3461     minit ("OR", INTRINSIC_OR),
3462     minit ("EQV", INTRINSIC_EQV),
3463     minit ("NEQV", INTRINSIC_NEQV),
3464     minit ("EQ_SIGN", INTRINSIC_EQ),
3465     minit ("EQ", INTRINSIC_EQ_OS),
3466     minit ("NE_SIGN", INTRINSIC_NE),
3467     minit ("NE", INTRINSIC_NE_OS),
3468     minit ("GT_SIGN", INTRINSIC_GT),
3469     minit ("GT", INTRINSIC_GT_OS),
3470     minit ("GE_SIGN", INTRINSIC_GE),
3471     minit ("GE", INTRINSIC_GE_OS),
3472     minit ("LT_SIGN", INTRINSIC_LT),
3473     minit ("LT", INTRINSIC_LT_OS),
3474     minit ("LE_SIGN", INTRINSIC_LE),
3475     minit ("LE", INTRINSIC_LE_OS),
3476     minit ("NOT", INTRINSIC_NOT),
3477     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3478     minit ("USER", INTRINSIC_USER),
3479     minit (NULL, -1)
3480 };
3481 
3482 
3483 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
3484 
3485 static void
fix_mio_expr(gfc_expr * e)3486 fix_mio_expr (gfc_expr *e)
3487 {
3488   gfc_symtree *ns_st = NULL;
3489   const char *fname;
3490 
3491   if (iomode != IO_OUTPUT)
3492     return;
3493 
3494   if (e->symtree)
3495     {
3496       /* If this is a symtree for a symbol that came from a contained module
3497 	 namespace, it has a unique name and we should look in the current
3498 	 namespace to see if the required, non-contained symbol is available
3499 	 yet. If so, the latter should be written.  */
3500       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3501 	{
3502           const char *name = e->symtree->n.sym->name;
3503 	  if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
3504 	    name = gfc_dt_upper_string (name);
3505 	  ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3506 	}
3507 
3508       /* On the other hand, if the existing symbol is the module name or the
3509 	 new symbol is a dummy argument, do not do the promotion.  */
3510       if (ns_st && ns_st->n.sym
3511 	  && ns_st->n.sym->attr.flavor != FL_MODULE
3512 	  && !e->symtree->n.sym->attr.dummy)
3513 	e->symtree = ns_st;
3514     }
3515   else if (e->expr_type == EXPR_FUNCTION
3516 	   && (e->value.function.name || e->value.function.isym))
3517     {
3518       gfc_symbol *sym;
3519 
3520       /* In some circumstances, a function used in an initialization
3521 	 expression, in one use associated module, can fail to be
3522 	 coupled to its symtree when used in a specification
3523 	 expression in another module.  */
3524       fname = e->value.function.esym ? e->value.function.esym->name
3525 				     : e->value.function.isym->name;
3526       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3527 
3528       if (e->symtree)
3529 	return;
3530 
3531       /* This is probably a reference to a private procedure from another
3532 	 module.  To prevent a segfault, make a generic with no specific
3533 	 instances.  If this module is used, without the required
3534 	 specific coming from somewhere, the appropriate error message
3535 	 is issued.  */
3536       gfc_get_symbol (fname, gfc_current_ns, &sym);
3537       sym->attr.flavor = FL_PROCEDURE;
3538       sym->attr.generic = 1;
3539       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3540       gfc_commit_symbol (sym);
3541     }
3542 }
3543 
3544 
3545 /* Read and write expressions.  The form "()" is allowed to indicate a
3546    NULL expression.  */
3547 
3548 static void
mio_expr(gfc_expr ** ep)3549 mio_expr (gfc_expr **ep)
3550 {
3551   HOST_WIDE_INT hwi;
3552   gfc_expr *e;
3553   atom_type t;
3554   int flag;
3555 
3556   mio_lparen ();
3557 
3558   if (iomode == IO_OUTPUT)
3559     {
3560       if (*ep == NULL)
3561 	{
3562 	  mio_rparen ();
3563 	  return;
3564 	}
3565 
3566       e = *ep;
3567       MIO_NAME (expr_t) (e->expr_type, expr_types);
3568     }
3569   else
3570     {
3571       t = parse_atom ();
3572       if (t == ATOM_RPAREN)
3573 	{
3574 	  *ep = NULL;
3575 	  return;
3576 	}
3577 
3578       if (t != ATOM_NAME)
3579 	bad_module ("Expected expression type");
3580 
3581       e = *ep = gfc_get_expr ();
3582       e->where = gfc_current_locus;
3583       e->expr_type = (expr_t) find_enum (expr_types);
3584     }
3585 
3586   mio_typespec (&e->ts);
3587   mio_integer (&e->rank);
3588 
3589   fix_mio_expr (e);
3590 
3591   switch (e->expr_type)
3592     {
3593     case EXPR_OP:
3594       e->value.op.op
3595 	= MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3596 
3597       switch (e->value.op.op)
3598 	{
3599 	case INTRINSIC_UPLUS:
3600 	case INTRINSIC_UMINUS:
3601 	case INTRINSIC_NOT:
3602 	case INTRINSIC_PARENTHESES:
3603 	  mio_expr (&e->value.op.op1);
3604 	  break;
3605 
3606 	case INTRINSIC_PLUS:
3607 	case INTRINSIC_MINUS:
3608 	case INTRINSIC_TIMES:
3609 	case INTRINSIC_DIVIDE:
3610 	case INTRINSIC_POWER:
3611 	case INTRINSIC_CONCAT:
3612 	case INTRINSIC_AND:
3613 	case INTRINSIC_OR:
3614 	case INTRINSIC_EQV:
3615 	case INTRINSIC_NEQV:
3616 	case INTRINSIC_EQ:
3617 	case INTRINSIC_EQ_OS:
3618 	case INTRINSIC_NE:
3619 	case INTRINSIC_NE_OS:
3620 	case INTRINSIC_GT:
3621 	case INTRINSIC_GT_OS:
3622 	case INTRINSIC_GE:
3623 	case INTRINSIC_GE_OS:
3624 	case INTRINSIC_LT:
3625 	case INTRINSIC_LT_OS:
3626 	case INTRINSIC_LE:
3627 	case INTRINSIC_LE_OS:
3628 	  mio_expr (&e->value.op.op1);
3629 	  mio_expr (&e->value.op.op2);
3630 	  break;
3631 
3632 	case INTRINSIC_USER:
3633 	  /* INTRINSIC_USER should not appear in resolved expressions,
3634 	     though for UDRs we need to stream unresolved ones.  */
3635 	  if (iomode == IO_OUTPUT)
3636 	    write_atom (ATOM_STRING, e->value.op.uop->name);
3637 	  else
3638 	    {
3639 	      char *name = read_string ();
3640 	      const char *uop_name = find_use_name (name, true);
3641 	      if (uop_name == NULL)
3642 		{
3643 		  size_t len = strlen (name);
3644 		  char *name2 = XCNEWVEC (char, len + 2);
3645 		  memcpy (name2, name, len);
3646 		  name2[len] = ' ';
3647 		  name2[len + 1] = '\0';
3648 		  free (name);
3649 		  uop_name = name = name2;
3650 		}
3651 	      e->value.op.uop = gfc_get_uop (uop_name);
3652 	      free (name);
3653 	    }
3654 	  mio_expr (&e->value.op.op1);
3655 	  mio_expr (&e->value.op.op2);
3656 	  break;
3657 
3658 	default:
3659 	  bad_module ("Bad operator");
3660 	}
3661 
3662       break;
3663 
3664     case EXPR_FUNCTION:
3665       mio_symtree_ref (&e->symtree);
3666       mio_actual_arglist (&e->value.function.actual, false);
3667 
3668       if (iomode == IO_OUTPUT)
3669 	{
3670 	  e->value.function.name
3671 	    = mio_allocated_string (e->value.function.name);
3672 	  if (e->value.function.esym)
3673 	    flag = 1;
3674 	  else if (e->ref)
3675 	    flag = 2;
3676 	  else if (e->value.function.isym == NULL)
3677 	    flag = 3;
3678 	  else
3679 	    flag = 0;
3680 	  mio_integer (&flag);
3681 	  switch (flag)
3682 	    {
3683 	    case 1:
3684 	      mio_symbol_ref (&e->value.function.esym);
3685 	      break;
3686 	    case 2:
3687 	      mio_ref_list (&e->ref);
3688 	      break;
3689 	    case 3:
3690 	      break;
3691 	    default:
3692 	      write_atom (ATOM_STRING, e->value.function.isym->name);
3693 	    }
3694 	}
3695       else
3696 	{
3697 	  require_atom (ATOM_STRING);
3698 	  if (atom_string[0] == '\0')
3699 	    e->value.function.name = NULL;
3700 	  else
3701 	    e->value.function.name = gfc_get_string ("%s", atom_string);
3702 	  free (atom_string);
3703 
3704 	  mio_integer (&flag);
3705 	  switch (flag)
3706 	    {
3707 	    case 1:
3708 	      mio_symbol_ref (&e->value.function.esym);
3709 	      break;
3710 	    case 2:
3711 	      mio_ref_list (&e->ref);
3712 	      break;
3713 	    case 3:
3714 	      break;
3715 	    default:
3716 	      require_atom (ATOM_STRING);
3717 	      e->value.function.isym = gfc_find_function (atom_string);
3718 	      free (atom_string);
3719 	    }
3720 	}
3721 
3722       break;
3723 
3724     case EXPR_VARIABLE:
3725       mio_symtree_ref (&e->symtree);
3726       mio_ref_list (&e->ref);
3727       break;
3728 
3729     case EXPR_SUBSTRING:
3730       e->value.character.string
3731 	= CONST_CAST (gfc_char_t *,
3732 		      mio_allocated_wide_string (e->value.character.string,
3733 						 e->value.character.length));
3734       mio_ref_list (&e->ref);
3735       break;
3736 
3737     case EXPR_STRUCTURE:
3738     case EXPR_ARRAY:
3739       mio_constructor (&e->value.constructor);
3740       mio_shape (&e->shape, e->rank);
3741       break;
3742 
3743     case EXPR_CONSTANT:
3744       switch (e->ts.type)
3745 	{
3746 	case BT_INTEGER:
3747 	  mio_gmp_integer (&e->value.integer);
3748 	  break;
3749 
3750 	case BT_REAL:
3751 	  gfc_set_model_kind (e->ts.kind);
3752 	  mio_gmp_real (&e->value.real);
3753 	  break;
3754 
3755 	case BT_COMPLEX:
3756 	  gfc_set_model_kind (e->ts.kind);
3757 	  mio_gmp_real (&mpc_realref (e->value.complex));
3758 	  mio_gmp_real (&mpc_imagref (e->value.complex));
3759 	  break;
3760 
3761 	case BT_LOGICAL:
3762 	  mio_integer (&e->value.logical);
3763 	  break;
3764 
3765 	case BT_CHARACTER:
3766 	  hwi = e->value.character.length;
3767 	  mio_hwi (&hwi);
3768 	  e->value.character.length = hwi;
3769 	  e->value.character.string
3770 	    = CONST_CAST (gfc_char_t *,
3771 			  mio_allocated_wide_string (e->value.character.string,
3772 						     e->value.character.length));
3773 	  break;
3774 
3775 	default:
3776 	  bad_module ("Bad type in constant expression");
3777 	}
3778 
3779       break;
3780 
3781     case EXPR_NULL:
3782       break;
3783 
3784     case EXPR_COMPCALL:
3785     case EXPR_PPC:
3786     case EXPR_UNKNOWN:
3787       gcc_unreachable ();
3788       break;
3789     }
3790 
3791   /* PDT types store the expression specification list here. */
3792   mio_actual_arglist (&e->param_list, true);
3793 
3794   mio_rparen ();
3795 }
3796 
3797 
3798 /* Read and write namelists.  */
3799 
3800 static void
mio_namelist(gfc_symbol * sym)3801 mio_namelist (gfc_symbol *sym)
3802 {
3803   gfc_namelist *n, *m;
3804 
3805   mio_lparen ();
3806 
3807   if (iomode == IO_OUTPUT)
3808     {
3809       for (n = sym->namelist; n; n = n->next)
3810 	mio_symbol_ref (&n->sym);
3811     }
3812   else
3813     {
3814       m = NULL;
3815       while (peek_atom () != ATOM_RPAREN)
3816 	{
3817 	  n = gfc_get_namelist ();
3818 	  mio_symbol_ref (&n->sym);
3819 
3820 	  if (sym->namelist == NULL)
3821 	    sym->namelist = n;
3822 	  else
3823 	    m->next = n;
3824 
3825 	  m = n;
3826 	}
3827       sym->namelist_tail = m;
3828     }
3829 
3830   mio_rparen ();
3831 }
3832 
3833 
3834 /* Save/restore lists of gfc_interface structures.  When loading an
3835    interface, we are really appending to the existing list of
3836    interfaces.  Checking for duplicate and ambiguous interfaces has to
3837    be done later when all symbols have been loaded.  */
3838 
3839 pointer_info *
mio_interface_rest(gfc_interface ** ip)3840 mio_interface_rest (gfc_interface **ip)
3841 {
3842   gfc_interface *tail, *p;
3843   pointer_info *pi = NULL;
3844 
3845   if (iomode == IO_OUTPUT)
3846     {
3847       if (ip != NULL)
3848 	for (p = *ip; p; p = p->next)
3849 	  mio_symbol_ref (&p->sym);
3850     }
3851   else
3852     {
3853       if (*ip == NULL)
3854 	tail = NULL;
3855       else
3856 	{
3857 	  tail = *ip;
3858 	  while (tail->next)
3859 	    tail = tail->next;
3860 	}
3861 
3862       for (;;)
3863 	{
3864 	  if (peek_atom () == ATOM_RPAREN)
3865 	    break;
3866 
3867 	  p = gfc_get_interface ();
3868 	  p->where = gfc_current_locus;
3869 	  pi = mio_symbol_ref (&p->sym);
3870 
3871 	  if (tail == NULL)
3872 	    *ip = p;
3873 	  else
3874 	    tail->next = p;
3875 
3876 	  tail = p;
3877 	}
3878     }
3879 
3880   mio_rparen ();
3881   return pi;
3882 }
3883 
3884 
3885 /* Save/restore a nameless operator interface.  */
3886 
3887 static void
mio_interface(gfc_interface ** ip)3888 mio_interface (gfc_interface **ip)
3889 {
3890   mio_lparen ();
3891   mio_interface_rest (ip);
3892 }
3893 
3894 
3895 /* Save/restore a named operator interface.  */
3896 
3897 static void
mio_symbol_interface(const char ** name,const char ** module,gfc_interface ** ip)3898 mio_symbol_interface (const char **name, const char **module,
3899 		      gfc_interface **ip)
3900 {
3901   mio_lparen ();
3902   mio_pool_string (name);
3903   mio_pool_string (module);
3904   mio_interface_rest (ip);
3905 }
3906 
3907 
3908 static void
mio_namespace_ref(gfc_namespace ** nsp)3909 mio_namespace_ref (gfc_namespace **nsp)
3910 {
3911   gfc_namespace *ns;
3912   pointer_info *p;
3913 
3914   p = mio_pointer_ref (nsp);
3915 
3916   if (p->type == P_UNKNOWN)
3917     p->type = P_NAMESPACE;
3918 
3919   if (iomode == IO_INPUT && p->integer != 0)
3920     {
3921       ns = (gfc_namespace *) p->u.pointer;
3922       if (ns == NULL)
3923 	{
3924 	  ns = gfc_get_namespace (NULL, 0);
3925 	  associate_integer_pointer (p, ns);
3926 	}
3927       else
3928 	ns->refs++;
3929     }
3930 }
3931 
3932 
3933 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
3934 
3935 static gfc_namespace* current_f2k_derived;
3936 
3937 static void
mio_typebound_proc(gfc_typebound_proc ** proc)3938 mio_typebound_proc (gfc_typebound_proc** proc)
3939 {
3940   int flag;
3941   int overriding_flag;
3942 
3943   if (iomode == IO_INPUT)
3944     {
3945       *proc = gfc_get_typebound_proc (NULL);
3946       (*proc)->where = gfc_current_locus;
3947     }
3948   gcc_assert (*proc);
3949 
3950   mio_lparen ();
3951 
3952   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3953 
3954   /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
3955   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3956   overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3957   overriding_flag = mio_name (overriding_flag, binding_overriding);
3958   (*proc)->deferred = ((overriding_flag & 2) != 0);
3959   (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3960   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3961 
3962   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3963   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3964   (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3965 
3966   mio_pool_string (&((*proc)->pass_arg));
3967 
3968   flag = (int) (*proc)->pass_arg_num;
3969   mio_integer (&flag);
3970   (*proc)->pass_arg_num = (unsigned) flag;
3971 
3972   if ((*proc)->is_generic)
3973     {
3974       gfc_tbp_generic* g;
3975       int iop;
3976 
3977       mio_lparen ();
3978 
3979       if (iomode == IO_OUTPUT)
3980 	for (g = (*proc)->u.generic; g; g = g->next)
3981 	  {
3982 	    iop = (int) g->is_operator;
3983 	    mio_integer (&iop);
3984 	    mio_allocated_string (g->specific_st->name);
3985 	  }
3986       else
3987 	{
3988 	  (*proc)->u.generic = NULL;
3989 	  while (peek_atom () != ATOM_RPAREN)
3990 	    {
3991 	      gfc_symtree** sym_root;
3992 
3993 	      g = gfc_get_tbp_generic ();
3994 	      g->specific = NULL;
3995 
3996 	      mio_integer (&iop);
3997 	      g->is_operator = (bool) iop;
3998 
3999 	      require_atom (ATOM_STRING);
4000 	      sym_root = &current_f2k_derived->tb_sym_root;
4001 	      g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
4002 	      free (atom_string);
4003 
4004 	      g->next = (*proc)->u.generic;
4005 	      (*proc)->u.generic = g;
4006 	    }
4007 	}
4008 
4009       mio_rparen ();
4010     }
4011   else if (!(*proc)->ppc)
4012     mio_symtree_ref (&(*proc)->u.specific);
4013 
4014   mio_rparen ();
4015 }
4016 
4017 /* Walker-callback function for this purpose.  */
4018 static void
mio_typebound_symtree(gfc_symtree * st)4019 mio_typebound_symtree (gfc_symtree* st)
4020 {
4021   if (iomode == IO_OUTPUT && !st->n.tb)
4022     return;
4023 
4024   if (iomode == IO_OUTPUT)
4025     {
4026       mio_lparen ();
4027       mio_allocated_string (st->name);
4028     }
4029   /* For IO_INPUT, the above is done in mio_f2k_derived.  */
4030 
4031   mio_typebound_proc (&st->n.tb);
4032   mio_rparen ();
4033 }
4034 
4035 /* IO a full symtree (in all depth).  */
4036 static void
mio_full_typebound_tree(gfc_symtree ** root)4037 mio_full_typebound_tree (gfc_symtree** root)
4038 {
4039   mio_lparen ();
4040 
4041   if (iomode == IO_OUTPUT)
4042     gfc_traverse_symtree (*root, &mio_typebound_symtree);
4043   else
4044     {
4045       while (peek_atom () == ATOM_LPAREN)
4046 	{
4047 	  gfc_symtree* st;
4048 
4049 	  mio_lparen ();
4050 
4051 	  require_atom (ATOM_STRING);
4052 	  st = gfc_get_tbp_symtree (root, atom_string);
4053 	  free (atom_string);
4054 
4055 	  mio_typebound_symtree (st);
4056 	}
4057     }
4058 
4059   mio_rparen ();
4060 }
4061 
4062 static void
mio_finalizer(gfc_finalizer ** f)4063 mio_finalizer (gfc_finalizer **f)
4064 {
4065   if (iomode == IO_OUTPUT)
4066     {
4067       gcc_assert (*f);
4068       gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
4069       mio_symtree_ref (&(*f)->proc_tree);
4070     }
4071   else
4072     {
4073       *f = gfc_get_finalizer ();
4074       (*f)->where = gfc_current_locus; /* Value should not matter.  */
4075       (*f)->next = NULL;
4076 
4077       mio_symtree_ref (&(*f)->proc_tree);
4078       (*f)->proc_sym = NULL;
4079     }
4080 }
4081 
4082 static void
mio_f2k_derived(gfc_namespace * f2k)4083 mio_f2k_derived (gfc_namespace *f2k)
4084 {
4085   current_f2k_derived = f2k;
4086 
4087   /* Handle the list of finalizer procedures.  */
4088   mio_lparen ();
4089   if (iomode == IO_OUTPUT)
4090     {
4091       gfc_finalizer *f;
4092       for (f = f2k->finalizers; f; f = f->next)
4093 	mio_finalizer (&f);
4094     }
4095   else
4096     {
4097       f2k->finalizers = NULL;
4098       while (peek_atom () != ATOM_RPAREN)
4099 	{
4100 	  gfc_finalizer *cur = NULL;
4101 	  mio_finalizer (&cur);
4102 	  cur->next = f2k->finalizers;
4103 	  f2k->finalizers = cur;
4104 	}
4105     }
4106   mio_rparen ();
4107 
4108   /* Handle type-bound procedures.  */
4109   mio_full_typebound_tree (&f2k->tb_sym_root);
4110 
4111   /* Type-bound user operators.  */
4112   mio_full_typebound_tree (&f2k->tb_uop_root);
4113 
4114   /* Type-bound intrinsic operators.  */
4115   mio_lparen ();
4116   if (iomode == IO_OUTPUT)
4117     {
4118       int op;
4119       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
4120 	{
4121 	  gfc_intrinsic_op realop;
4122 
4123 	  if (op == INTRINSIC_USER || !f2k->tb_op[op])
4124 	    continue;
4125 
4126 	  mio_lparen ();
4127 	  realop = (gfc_intrinsic_op) op;
4128 	  mio_intrinsic_op (&realop);
4129 	  mio_typebound_proc (&f2k->tb_op[op]);
4130 	  mio_rparen ();
4131 	}
4132     }
4133   else
4134     while (peek_atom () != ATOM_RPAREN)
4135       {
4136 	gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
4137 
4138 	mio_lparen ();
4139 	mio_intrinsic_op (&op);
4140 	mio_typebound_proc (&f2k->tb_op[op]);
4141 	mio_rparen ();
4142       }
4143   mio_rparen ();
4144 }
4145 
4146 static void
mio_full_f2k_derived(gfc_symbol * sym)4147 mio_full_f2k_derived (gfc_symbol *sym)
4148 {
4149   mio_lparen ();
4150 
4151   if (iomode == IO_OUTPUT)
4152     {
4153       if (sym->f2k_derived)
4154 	mio_f2k_derived (sym->f2k_derived);
4155     }
4156   else
4157     {
4158       if (peek_atom () != ATOM_RPAREN)
4159 	{
4160 	  gfc_namespace *ns;
4161 
4162 	  sym->f2k_derived = gfc_get_namespace (NULL, 0);
4163 
4164 	  /* PDT templates make use of the mechanisms for formal args
4165 	     and so the parameter symbols are stored in the formal
4166 	     namespace.  Transfer the sym_root to f2k_derived and then
4167 	     free the formal namespace since it is uneeded.  */
4168 	  if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
4169 	    {
4170 	      ns = sym->formal->sym->ns;
4171 	      sym->f2k_derived->sym_root = ns->sym_root;
4172 	      ns->sym_root = NULL;
4173 	      ns->refs++;
4174 	      gfc_free_namespace (ns);
4175 	      ns = NULL;
4176 	    }
4177 
4178 	  mio_f2k_derived (sym->f2k_derived);
4179 	}
4180       else
4181 	gcc_assert (!sym->f2k_derived);
4182     }
4183 
4184   mio_rparen ();
4185 }
4186 
4187 static const mstring omp_declare_simd_clauses[] =
4188 {
4189     minit ("INBRANCH", 0),
4190     minit ("NOTINBRANCH", 1),
4191     minit ("SIMDLEN", 2),
4192     minit ("UNIFORM", 3),
4193     minit ("LINEAR", 4),
4194     minit ("ALIGNED", 5),
4195     minit ("LINEAR_REF", 33),
4196     minit ("LINEAR_VAL", 34),
4197     minit ("LINEAR_UVAL", 35),
4198     minit (NULL, -1)
4199 };
4200 
4201 /* Handle !$omp declare simd.  */
4202 
4203 static void
mio_omp_declare_simd(gfc_namespace * ns,gfc_omp_declare_simd ** odsp)4204 mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
4205 {
4206   if (iomode == IO_OUTPUT)
4207     {
4208       if (*odsp == NULL)
4209 	return;
4210     }
4211   else if (peek_atom () != ATOM_LPAREN)
4212     return;
4213 
4214   gfc_omp_declare_simd *ods = *odsp;
4215 
4216   mio_lparen ();
4217   if (iomode == IO_OUTPUT)
4218     {
4219       write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
4220       if (ods->clauses)
4221 	{
4222 	  gfc_omp_namelist *n;
4223 
4224 	  if (ods->clauses->inbranch)
4225 	    mio_name (0, omp_declare_simd_clauses);
4226 	  if (ods->clauses->notinbranch)
4227 	    mio_name (1, omp_declare_simd_clauses);
4228 	  if (ods->clauses->simdlen_expr)
4229 	    {
4230 	      mio_name (2, omp_declare_simd_clauses);
4231 	      mio_expr (&ods->clauses->simdlen_expr);
4232 	    }
4233 	  for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
4234 	    {
4235 	      mio_name (3, omp_declare_simd_clauses);
4236 	      mio_symbol_ref (&n->sym);
4237 	    }
4238 	  for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
4239 	    {
4240 	      if (n->u.linear_op == OMP_LINEAR_DEFAULT)
4241 		mio_name (4, omp_declare_simd_clauses);
4242 	      else
4243 		mio_name (32 + n->u.linear_op, omp_declare_simd_clauses);
4244 	      mio_symbol_ref (&n->sym);
4245 	      mio_expr (&n->expr);
4246 	    }
4247 	  for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4248 	    {
4249 	      mio_name (5, omp_declare_simd_clauses);
4250 	      mio_symbol_ref (&n->sym);
4251 	      mio_expr (&n->expr);
4252 	    }
4253 	}
4254     }
4255   else
4256     {
4257       gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
4258 
4259       require_atom (ATOM_NAME);
4260       *odsp = ods = gfc_get_omp_declare_simd ();
4261       ods->where = gfc_current_locus;
4262       ods->proc_name = ns->proc_name;
4263       if (peek_atom () == ATOM_NAME)
4264 	{
4265 	  ods->clauses = gfc_get_omp_clauses ();
4266 	  ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
4267 	  ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
4268 	  ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
4269 	}
4270       while (peek_atom () == ATOM_NAME)
4271 	{
4272 	  gfc_omp_namelist *n;
4273 	  int t = mio_name (0, omp_declare_simd_clauses);
4274 
4275 	  switch (t)
4276 	    {
4277 	    case 0: ods->clauses->inbranch = true; break;
4278 	    case 1: ods->clauses->notinbranch = true; break;
4279 	    case 2: mio_expr (&ods->clauses->simdlen_expr); break;
4280 	    case 3:
4281 	    case 4:
4282 	    case 5:
4283 	      *ptrs[t - 3] = n = gfc_get_omp_namelist ();
4284 	    finish_namelist:
4285 	      n->where = gfc_current_locus;
4286 	      ptrs[t - 3] = &n->next;
4287 	      mio_symbol_ref (&n->sym);
4288 	      if (t != 3)
4289 		mio_expr (&n->expr);
4290 	      break;
4291 	    case 33:
4292 	    case 34:
4293 	    case 35:
4294 	      *ptrs[1] = n = gfc_get_omp_namelist ();
4295 	      n->u.linear_op = (enum gfc_omp_linear_op) (t - 32);
4296 	      t = 4;
4297 	      goto finish_namelist;
4298 	    }
4299 	}
4300     }
4301 
4302   mio_omp_declare_simd (ns, &ods->next);
4303 
4304   mio_rparen ();
4305 }
4306 
4307 
4308 static const mstring omp_declare_reduction_stmt[] =
4309 {
4310     minit ("ASSIGN", 0),
4311     minit ("CALL", 1),
4312     minit (NULL, -1)
4313 };
4314 
4315 
4316 static void
mio_omp_udr_expr(gfc_omp_udr * udr,gfc_symbol ** sym1,gfc_symbol ** sym2,gfc_namespace * ns,bool is_initializer)4317 mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
4318 		  gfc_namespace *ns, bool is_initializer)
4319 {
4320   if (iomode == IO_OUTPUT)
4321     {
4322       if ((*sym1)->module == NULL)
4323 	{
4324 	  (*sym1)->module = module_name;
4325 	  (*sym2)->module = module_name;
4326 	}
4327       mio_symbol_ref (sym1);
4328       mio_symbol_ref (sym2);
4329       if (ns->code->op == EXEC_ASSIGN)
4330 	{
4331 	  mio_name (0, omp_declare_reduction_stmt);
4332 	  mio_expr (&ns->code->expr1);
4333 	  mio_expr (&ns->code->expr2);
4334 	}
4335       else
4336 	{
4337 	  int flag;
4338 	  mio_name (1, omp_declare_reduction_stmt);
4339 	  mio_symtree_ref (&ns->code->symtree);
4340 	  mio_actual_arglist (&ns->code->ext.actual, false);
4341 
4342 	  flag = ns->code->resolved_isym != NULL;
4343 	  mio_integer (&flag);
4344 	  if (flag)
4345 	    write_atom (ATOM_STRING, ns->code->resolved_isym->name);
4346 	  else
4347 	    mio_symbol_ref (&ns->code->resolved_sym);
4348 	}
4349     }
4350   else
4351     {
4352       pointer_info *p1 = mio_symbol_ref (sym1);
4353       pointer_info *p2 = mio_symbol_ref (sym2);
4354       gfc_symbol *sym;
4355       gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
4356       gcc_assert (p1->u.rsym.sym == NULL);
4357       /* Add hidden symbols to the symtree.  */
4358       pointer_info *q = get_integer (p1->u.rsym.ns);
4359       q->u.pointer = (void *) ns;
4360       sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
4361       sym->ts = udr->ts;
4362       sym->module = gfc_get_string ("%s", p1->u.rsym.module);
4363       associate_integer_pointer (p1, sym);
4364       sym->attr.omp_udr_artificial_var = 1;
4365       gcc_assert (p2->u.rsym.sym == NULL);
4366       sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
4367       sym->ts = udr->ts;
4368       sym->module = gfc_get_string ("%s", p2->u.rsym.module);
4369       associate_integer_pointer (p2, sym);
4370       sym->attr.omp_udr_artificial_var = 1;
4371       if (mio_name (0, omp_declare_reduction_stmt) == 0)
4372 	{
4373 	  ns->code = gfc_get_code (EXEC_ASSIGN);
4374 	  mio_expr (&ns->code->expr1);
4375 	  mio_expr (&ns->code->expr2);
4376 	}
4377       else
4378 	{
4379 	  int flag;
4380 	  ns->code = gfc_get_code (EXEC_CALL);
4381 	  mio_symtree_ref (&ns->code->symtree);
4382 	  mio_actual_arglist (&ns->code->ext.actual, false);
4383 
4384 	  mio_integer (&flag);
4385 	  if (flag)
4386 	    {
4387 	      require_atom (ATOM_STRING);
4388 	      ns->code->resolved_isym = gfc_find_subroutine (atom_string);
4389 	      free (atom_string);
4390 	    }
4391 	  else
4392 	    mio_symbol_ref (&ns->code->resolved_sym);
4393 	}
4394       ns->code->loc = gfc_current_locus;
4395       ns->omp_udr_ns = 1;
4396     }
4397 }
4398 
4399 
4400 /* Unlike most other routines, the address of the symbol node is already
4401    fixed on input and the name/module has already been filled in.
4402    If you update the symbol format here, don't forget to update read_module
4403    as well (look for "seek to the symbol's component list").   */
4404 
4405 static void
mio_symbol(gfc_symbol * sym)4406 mio_symbol (gfc_symbol *sym)
4407 {
4408   int intmod = INTMOD_NONE;
4409 
4410   mio_lparen ();
4411 
4412   mio_symbol_attribute (&sym->attr);
4413 
4414   if (sym->attr.pdt_type)
4415     sym->name = gfc_dt_upper_string (sym->name);
4416 
4417   /* Note that components are always saved, even if they are supposed
4418      to be private.  Component access is checked during searching.  */
4419   mio_component_list (&sym->components, sym->attr.vtype);
4420   if (sym->components != NULL)
4421     sym->component_access
4422       = MIO_NAME (gfc_access) (sym->component_access, access_types);
4423 
4424   mio_typespec (&sym->ts);
4425   if (sym->ts.type == BT_CLASS)
4426     sym->attr.class_ok = 1;
4427 
4428   if (iomode == IO_OUTPUT)
4429     mio_namespace_ref (&sym->formal_ns);
4430   else
4431     {
4432       mio_namespace_ref (&sym->formal_ns);
4433       if (sym->formal_ns)
4434 	sym->formal_ns->proc_name = sym;
4435     }
4436 
4437   /* Save/restore common block links.  */
4438   mio_symbol_ref (&sym->common_next);
4439 
4440   mio_formal_arglist (&sym->formal);
4441 
4442   if (sym->attr.flavor == FL_PARAMETER)
4443     mio_expr (&sym->value);
4444 
4445   mio_array_spec (&sym->as);
4446 
4447   mio_symbol_ref (&sym->result);
4448 
4449   if (sym->attr.cray_pointee)
4450     mio_symbol_ref (&sym->cp_pointer);
4451 
4452   /* Load/save the f2k_derived namespace of a derived-type symbol.  */
4453   mio_full_f2k_derived (sym);
4454 
4455   /* PDT types store the symbol specification list here. */
4456   mio_actual_arglist (&sym->param_list, true);
4457 
4458   mio_namelist (sym);
4459 
4460   /* Add the fields that say whether this is from an intrinsic module,
4461      and if so, what symbol it is within the module.  */
4462 /*   mio_integer (&(sym->from_intmod)); */
4463   if (iomode == IO_OUTPUT)
4464     {
4465       intmod = sym->from_intmod;
4466       mio_integer (&intmod);
4467     }
4468   else
4469     {
4470       mio_integer (&intmod);
4471       if (current_intmod)
4472 	sym->from_intmod = current_intmod;
4473       else
4474 	sym->from_intmod = (intmod_id) intmod;
4475     }
4476 
4477   mio_integer (&(sym->intmod_sym_id));
4478 
4479   if (gfc_fl_struct (sym->attr.flavor))
4480     mio_integer (&(sym->hash_value));
4481 
4482   if (sym->formal_ns
4483       && sym->formal_ns->proc_name == sym
4484       && sym->formal_ns->entries == NULL)
4485     mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
4486 
4487   mio_rparen ();
4488 }
4489 
4490 
4491 /************************* Top level subroutines *************************/
4492 
4493 /* A recursive function to look for a specific symbol by name and by
4494    module.  Whilst several symtrees might point to one symbol, its
4495    is sufficient for the purposes here than one exist.  Note that
4496    generic interfaces are distinguished as are symbols that have been
4497    renamed in another module.  */
4498 static gfc_symtree *
find_symbol(gfc_symtree * st,const char * name,const char * module,int generic)4499 find_symbol (gfc_symtree *st, const char *name,
4500 	     const char *module, int generic)
4501 {
4502   int c;
4503   gfc_symtree *retval, *s;
4504 
4505   if (st == NULL || st->n.sym == NULL)
4506     return NULL;
4507 
4508   c = strcmp (name, st->n.sym->name);
4509   if (c == 0 && st->n.sym->module
4510 	     && strcmp (module, st->n.sym->module) == 0
4511 	     && !check_unique_name (st->name))
4512     {
4513       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
4514 
4515       /* Detect symbols that are renamed by use association in another
4516 	 module by the absence of a symtree and null attr.use_rename,
4517 	 since the latter is not transmitted in the module file.  */
4518       if (((!generic && !st->n.sym->attr.generic)
4519 		|| (generic && st->n.sym->attr.generic))
4520 	    && !(s == NULL && !st->n.sym->attr.use_rename))
4521 	return st;
4522     }
4523 
4524   retval = find_symbol (st->left, name, module, generic);
4525 
4526   if (retval == NULL)
4527     retval = find_symbol (st->right, name, module, generic);
4528 
4529   return retval;
4530 }
4531 
4532 
4533 /* Skip a list between balanced left and right parens.
4534    By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4535    have been already parsed by hand, and the remaining of the content is to be
4536    skipped here.  The default value is 0 (balanced parens).  */
4537 
4538 static void
4539 skip_list (int nest_level = 0)
4540 {
4541   int level;
4542 
4543   level = nest_level;
4544   do
4545     {
4546       switch (parse_atom ())
4547 	{
4548 	case ATOM_LPAREN:
4549 	  level++;
4550 	  break;
4551 
4552 	case ATOM_RPAREN:
4553 	  level--;
4554 	  break;
4555 
4556 	case ATOM_STRING:
4557 	  free (atom_string);
4558 	  break;
4559 
4560 	case ATOM_NAME:
4561 	case ATOM_INTEGER:
4562 	  break;
4563 	}
4564     }
4565   while (level > 0);
4566 }
4567 
4568 
4569 /* Load operator interfaces from the module.  Interfaces are unusual
4570    in that they attach themselves to existing symbols.  */
4571 
4572 static void
load_operator_interfaces(void)4573 load_operator_interfaces (void)
4574 {
4575   const char *p;
4576   /* "module" must be large enough for the case of submodules in which the name
4577      has the form module.submodule */
4578   char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
4579   gfc_user_op *uop;
4580   pointer_info *pi = NULL;
4581   int n, i;
4582 
4583   mio_lparen ();
4584 
4585   while (peek_atom () != ATOM_RPAREN)
4586     {
4587       mio_lparen ();
4588 
4589       mio_internal_string (name);
4590       mio_internal_string (module);
4591 
4592       n = number_use_names (name, true);
4593       n = n ? n : 1;
4594 
4595       for (i = 1; i <= n; i++)
4596 	{
4597 	  /* Decide if we need to load this one or not.  */
4598 	  p = find_use_name_n (name, &i, true);
4599 
4600 	  if (p == NULL)
4601 	    {
4602 	      while (parse_atom () != ATOM_RPAREN);
4603 	      continue;
4604 	    }
4605 
4606 	  if (i == 1)
4607 	    {
4608 	      uop = gfc_get_uop (p);
4609 	      pi = mio_interface_rest (&uop->op);
4610 	    }
4611 	  else
4612 	    {
4613 	      if (gfc_find_uop (p, NULL))
4614 		continue;
4615 	      uop = gfc_get_uop (p);
4616 	      uop->op = gfc_get_interface ();
4617 	      uop->op->where = gfc_current_locus;
4618 	      add_fixup (pi->integer, &uop->op->sym);
4619 	    }
4620 	}
4621     }
4622 
4623   mio_rparen ();
4624 }
4625 
4626 
4627 /* Load interfaces from the module.  Interfaces are unusual in that
4628    they attach themselves to existing symbols.  */
4629 
4630 static void
load_generic_interfaces(void)4631 load_generic_interfaces (void)
4632 {
4633   const char *p;
4634   /* "module" must be large enough for the case of submodules in which the name
4635      has the form module.submodule */
4636   char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
4637   gfc_symbol *sym;
4638   gfc_interface *generic = NULL, *gen = NULL;
4639   int n, i, renamed;
4640   bool ambiguous_set = false;
4641 
4642   mio_lparen ();
4643 
4644   while (peek_atom () != ATOM_RPAREN)
4645     {
4646       mio_lparen ();
4647 
4648       mio_internal_string (name);
4649       mio_internal_string (module);
4650 
4651       n = number_use_names (name, false);
4652       renamed = n ? 1 : 0;
4653       n = n ? n : 1;
4654 
4655       for (i = 1; i <= n; i++)
4656 	{
4657 	  gfc_symtree *st;
4658 	  /* Decide if we need to load this one or not.  */
4659 	  p = find_use_name_n (name, &i, false);
4660 
4661 	  if (!p || gfc_find_symbol (p, NULL, 0, &sym))
4662 	    {
4663 	      /* Skip the specific names for these cases.  */
4664 	      while (i == 1 && parse_atom () != ATOM_RPAREN);
4665 
4666 	      continue;
4667 	    }
4668 
4669 	  st = find_symbol (gfc_current_ns->sym_root,
4670 			    name, module_name, 1);
4671 
4672 	  /* If the symbol exists already and is being USEd without being
4673 	     in an ONLY clause, do not load a new symtree(11.3.2).  */
4674 	  if (!only_flag && st)
4675 	    sym = st->n.sym;
4676 
4677 	  if (!sym)
4678 	    {
4679 	      if (st)
4680 		{
4681 		  sym = st->n.sym;
4682 		  if (strcmp (st->name, p) != 0)
4683 		    {
4684 	              st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4685 		      st->n.sym = sym;
4686 		      sym->refs++;
4687 		    }
4688 		}
4689 
4690 	      /* Since we haven't found a valid generic interface, we had
4691 		 better make one.  */
4692 	      if (!sym)
4693 		{
4694 		  gfc_get_symbol (p, NULL, &sym);
4695 		  sym->name = gfc_get_string ("%s", name);
4696 		  sym->module = module_name;
4697 		  sym->attr.flavor = FL_PROCEDURE;
4698 		  sym->attr.generic = 1;
4699 		  sym->attr.use_assoc = 1;
4700 		}
4701 	    }
4702 	  else
4703 	    {
4704 	      /* Unless sym is a generic interface, this reference
4705 		 is ambiguous.  */
4706 	      if (st == NULL)
4707 	        st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4708 
4709 	      sym = st->n.sym;
4710 
4711 	      if (st && !sym->attr.generic
4712 		     && !st->ambiguous
4713 		     && sym->module
4714 		     && strcmp (module, sym->module))
4715 		{
4716 		  ambiguous_set = true;
4717 		  st->ambiguous = 1;
4718 		}
4719 	    }
4720 
4721 	  sym->attr.use_only = only_flag;
4722 	  sym->attr.use_rename = renamed;
4723 
4724 	  if (i == 1)
4725 	    {
4726 	      mio_interface_rest (&sym->generic);
4727 	      generic = sym->generic;
4728 	    }
4729 	  else if (!sym->generic)
4730 	    {
4731 	      sym->generic = generic;
4732 	      sym->attr.generic_copy = 1;
4733 	    }
4734 
4735 	  /* If a procedure that is not generic has generic interfaces
4736 	     that include itself, it is generic! We need to take care
4737 	     to retain symbols ambiguous that were already so.  */
4738 	  if (sym->attr.use_assoc
4739 		&& !sym->attr.generic
4740 		&& sym->attr.flavor == FL_PROCEDURE)
4741 	    {
4742 	      for (gen = generic; gen; gen = gen->next)
4743 		{
4744 		  if (gen->sym == sym)
4745 		    {
4746 		      sym->attr.generic = 1;
4747 		      if (ambiguous_set)
4748 		        st->ambiguous = 0;
4749 		      break;
4750 		    }
4751 		}
4752 	    }
4753 
4754 	}
4755     }
4756 
4757   mio_rparen ();
4758 }
4759 
4760 
4761 /* Load common blocks.  */
4762 
4763 static void
load_commons(void)4764 load_commons (void)
4765 {
4766   char name[GFC_MAX_SYMBOL_LEN + 1];
4767   gfc_common_head *p;
4768 
4769   mio_lparen ();
4770 
4771   while (peek_atom () != ATOM_RPAREN)
4772     {
4773       int flags = 0;
4774       char* label;
4775       mio_lparen ();
4776       mio_internal_string (name);
4777 
4778       p = gfc_get_common (name, 1);
4779 
4780       mio_symbol_ref (&p->head);
4781       mio_integer (&flags);
4782       if (flags & 1)
4783 	p->saved = 1;
4784       if (flags & 2)
4785 	p->threadprivate = 1;
4786       p->use_assoc = 1;
4787 
4788       /* Get whether this was a bind(c) common or not.  */
4789       mio_integer (&p->is_bind_c);
4790       /* Get the binding label.  */
4791       label = read_string ();
4792       if (strlen (label))
4793 	p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4794       XDELETEVEC (label);
4795 
4796       mio_rparen ();
4797     }
4798 
4799   mio_rparen ();
4800 }
4801 
4802 
4803 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
4804    so that unused variables are not loaded and so that the expression can
4805    be safely freed.  */
4806 
4807 static void
load_equiv(void)4808 load_equiv (void)
4809 {
4810   gfc_equiv *head, *tail, *end, *eq, *equiv;
4811   bool duplicate;
4812 
4813   mio_lparen ();
4814   in_load_equiv = true;
4815 
4816   end = gfc_current_ns->equiv;
4817   while (end != NULL && end->next != NULL)
4818     end = end->next;
4819 
4820   while (peek_atom () != ATOM_RPAREN) {
4821     mio_lparen ();
4822     head = tail = NULL;
4823 
4824     while(peek_atom () != ATOM_RPAREN)
4825       {
4826 	if (head == NULL)
4827 	  head = tail = gfc_get_equiv ();
4828 	else
4829 	  {
4830 	    tail->eq = gfc_get_equiv ();
4831 	    tail = tail->eq;
4832 	  }
4833 
4834 	mio_pool_string (&tail->module);
4835 	mio_expr (&tail->expr);
4836       }
4837 
4838     /* Check for duplicate equivalences being loaded from different modules */
4839     duplicate = false;
4840     for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next)
4841       {
4842 	if (equiv->module && head->module
4843 	    && strcmp (equiv->module, head->module) == 0)
4844 	  {
4845 	    duplicate = true;
4846 	    break;
4847 	  }
4848       }
4849 
4850     if (duplicate)
4851       {
4852 	for (eq = head; eq; eq = head)
4853 	  {
4854 	    head = eq->eq;
4855 	    gfc_free_expr (eq->expr);
4856 	    free (eq);
4857 	  }
4858       }
4859 
4860     if (end == NULL)
4861       gfc_current_ns->equiv = head;
4862     else
4863       end->next = head;
4864 
4865     if (head != NULL)
4866       end = head;
4867 
4868     mio_rparen ();
4869   }
4870 
4871   mio_rparen ();
4872   in_load_equiv = false;
4873 }
4874 
4875 
4876 /* This function loads OpenMP user defined reductions.  */
4877 static void
load_omp_udrs(void)4878 load_omp_udrs (void)
4879 {
4880   mio_lparen ();
4881   while (peek_atom () != ATOM_RPAREN)
4882     {
4883       const char *name = NULL, *newname;
4884       char *altname;
4885       gfc_typespec ts;
4886       gfc_symtree *st;
4887       gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
4888 
4889       mio_lparen ();
4890       mio_pool_string (&name);
4891       gfc_clear_ts (&ts);
4892       mio_typespec (&ts);
4893       if (gfc_str_startswith (name, "operator "))
4894 	{
4895 	  const char *p = name + sizeof ("operator ") - 1;
4896 	  if (strcmp (p, "+") == 0)
4897 	    rop = OMP_REDUCTION_PLUS;
4898 	  else if (strcmp (p, "*") == 0)
4899 	    rop = OMP_REDUCTION_TIMES;
4900 	  else if (strcmp (p, "-") == 0)
4901 	    rop = OMP_REDUCTION_MINUS;
4902 	  else if (strcmp (p, ".and.") == 0)
4903 	    rop = OMP_REDUCTION_AND;
4904 	  else if (strcmp (p, ".or.") == 0)
4905 	    rop = OMP_REDUCTION_OR;
4906 	  else if (strcmp (p, ".eqv.") == 0)
4907 	    rop = OMP_REDUCTION_EQV;
4908 	  else if (strcmp (p, ".neqv.") == 0)
4909 	    rop = OMP_REDUCTION_NEQV;
4910 	}
4911       altname = NULL;
4912       if (rop == OMP_REDUCTION_USER && name[0] == '.')
4913 	{
4914 	  size_t len = strlen (name + 1);
4915 	  altname = XALLOCAVEC (char, len);
4916 	  gcc_assert (name[len] == '.');
4917 	  memcpy (altname, name + 1, len - 1);
4918 	  altname[len - 1] = '\0';
4919 	}
4920       newname = name;
4921       if (rop == OMP_REDUCTION_USER)
4922 	newname = find_use_name (altname ? altname : name, !!altname);
4923       else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
4924 	newname = NULL;
4925       if (newname == NULL)
4926 	{
4927 	  skip_list (1);
4928 	  continue;
4929 	}
4930       if (altname && newname != altname)
4931 	{
4932 	  size_t len = strlen (newname);
4933 	  altname = XALLOCAVEC (char, len + 3);
4934 	  altname[0] = '.';
4935 	  memcpy (altname + 1, newname, len);
4936 	  altname[len + 1] = '.';
4937 	  altname[len + 2] = '\0';
4938 	  name = gfc_get_string ("%s", altname);
4939 	}
4940       st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
4941       gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
4942       if (udr)
4943 	{
4944 	  require_atom (ATOM_INTEGER);
4945 	  pointer_info *p = get_integer (atom_int);
4946 	  if (strcmp (p->u.rsym.module, udr->omp_out->module))
4947 	    {
4948 	      gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4949 			 "module %s at %L",
4950 			 p->u.rsym.module, &gfc_current_locus);
4951 	      gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4952 			 "%s at %L",
4953 			 udr->omp_out->module, &udr->where);
4954 	    }
4955 	  skip_list (1);
4956 	  continue;
4957 	}
4958       udr = gfc_get_omp_udr ();
4959       udr->name = name;
4960       udr->rop = rop;
4961       udr->ts = ts;
4962       udr->where = gfc_current_locus;
4963       udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
4964       udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
4965       mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
4966 			false);
4967       if (peek_atom () != ATOM_RPAREN)
4968 	{
4969 	  udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
4970 	  udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
4971 	  mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
4972 			    udr->initializer_ns, true);
4973 	}
4974       if (st)
4975 	{
4976 	  udr->next = st->n.omp_udr;
4977 	  st->n.omp_udr = udr;
4978 	}
4979       else
4980 	{
4981 	  st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
4982 	  st->n.omp_udr = udr;
4983 	}
4984       mio_rparen ();
4985     }
4986   mio_rparen ();
4987 }
4988 
4989 
4990 /* Recursive function to traverse the pointer_info tree and load a
4991    needed symbol.  We return nonzero if we load a symbol and stop the
4992    traversal, because the act of loading can alter the tree.  */
4993 
4994 static int
load_needed(pointer_info * p)4995 load_needed (pointer_info *p)
4996 {
4997   gfc_namespace *ns;
4998   pointer_info *q;
4999   gfc_symbol *sym;
5000   int rv;
5001 
5002   rv = 0;
5003   if (p == NULL)
5004     return rv;
5005 
5006   rv |= load_needed (p->left);
5007   rv |= load_needed (p->right);
5008 
5009   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
5010     return rv;
5011 
5012   p->u.rsym.state = USED;
5013 
5014   set_module_locus (&p->u.rsym.where);
5015 
5016   sym = p->u.rsym.sym;
5017   if (sym == NULL)
5018     {
5019       q = get_integer (p->u.rsym.ns);
5020 
5021       ns = (gfc_namespace *) q->u.pointer;
5022       if (ns == NULL)
5023 	{
5024 	  /* Create an interface namespace if necessary.  These are
5025 	     the namespaces that hold the formal parameters of module
5026 	     procedures.  */
5027 
5028 	  ns = gfc_get_namespace (NULL, 0);
5029 	  associate_integer_pointer (q, ns);
5030 	}
5031 
5032       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
5033 	 doesn't go pear-shaped if the symbol is used.  */
5034       if (!ns->proc_name)
5035 	gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
5036 				 1, &ns->proc_name);
5037 
5038       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
5039       sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
5040       sym->module = gfc_get_string ("%s", p->u.rsym.module);
5041       if (p->u.rsym.binding_label)
5042 	sym->binding_label = IDENTIFIER_POINTER (get_identifier
5043 						 (p->u.rsym.binding_label));
5044 
5045       associate_integer_pointer (p, sym);
5046     }
5047 
5048   mio_symbol (sym);
5049   sym->attr.use_assoc = 1;
5050 
5051   /* Unliked derived types, a STRUCTURE may share names with other symbols.
5052      We greedily converted the symbol name to lowercase before we knew its
5053      type, so now we must fix it. */
5054   if (sym->attr.flavor == FL_STRUCT)
5055     sym->name = gfc_dt_upper_string (sym->name);
5056 
5057   /* Mark as only or rename for later diagnosis for explicitly imported
5058      but not used warnings; don't mark internal symbols such as __vtab,
5059      __def_init etc. Only mark them if they have been explicitly loaded.  */
5060 
5061   if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
5062     {
5063       gfc_use_rename *u;
5064 
5065       /* Search the use/rename list for the variable; if the variable is
5066 	 found, mark it.  */
5067       for (u = gfc_rename_list; u; u = u->next)
5068 	{
5069 	  if (strcmp (u->use_name, sym->name) == 0)
5070 	    {
5071 	      sym->attr.use_only = 1;
5072 	      break;
5073 	    }
5074 	}
5075     }
5076 
5077   if (p->u.rsym.renamed)
5078     sym->attr.use_rename = 1;
5079 
5080   return 1;
5081 }
5082 
5083 
5084 /* Recursive function for cleaning up things after a module has been read.  */
5085 
5086 static void
read_cleanup(pointer_info * p)5087 read_cleanup (pointer_info *p)
5088 {
5089   gfc_symtree *st;
5090   pointer_info *q;
5091 
5092   if (p == NULL)
5093     return;
5094 
5095   read_cleanup (p->left);
5096   read_cleanup (p->right);
5097 
5098   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
5099     {
5100       gfc_namespace *ns;
5101       /* Add hidden symbols to the symtree.  */
5102       q = get_integer (p->u.rsym.ns);
5103       ns = (gfc_namespace *) q->u.pointer;
5104 
5105       if (!p->u.rsym.sym->attr.vtype
5106 	    && !p->u.rsym.sym->attr.vtab)
5107 	st = gfc_get_unique_symtree (ns);
5108       else
5109 	{
5110 	  /* There is no reason to use 'unique_symtrees' for vtabs or
5111 	     vtypes - their name is fine for a symtree and reduces the
5112 	     namespace pollution.  */
5113 	  st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
5114 	  if (!st)
5115 	    st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
5116 	}
5117 
5118       st->n.sym = p->u.rsym.sym;
5119       st->n.sym->refs++;
5120 
5121       /* Fixup any symtree references.  */
5122       p->u.rsym.symtree = st;
5123       resolve_fixups (p->u.rsym.stfixup, st);
5124       p->u.rsym.stfixup = NULL;
5125     }
5126 
5127   /* Free unused symbols.  */
5128   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
5129     gfc_free_symbol (p->u.rsym.sym);
5130 }
5131 
5132 
5133 /* It is not quite enough to check for ambiguity in the symbols by
5134    the loaded symbol and the new symbol not being identical.  */
5135 static bool
check_for_ambiguous(gfc_symtree * st,pointer_info * info)5136 check_for_ambiguous (gfc_symtree *st, pointer_info *info)
5137 {
5138   gfc_symbol *rsym;
5139   module_locus locus;
5140   symbol_attribute attr;
5141   gfc_symbol *st_sym;
5142 
5143   if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
5144     {
5145       gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5146 		 "current program unit", st->name, module_name);
5147       return true;
5148     }
5149 
5150   st_sym = st->n.sym;
5151   rsym = info->u.rsym.sym;
5152   if (st_sym == rsym)
5153     return false;
5154 
5155   if (st_sym->attr.vtab || st_sym->attr.vtype)
5156     return false;
5157 
5158   /* If the existing symbol is generic from a different module and
5159      the new symbol is generic there can be no ambiguity.  */
5160   if (st_sym->attr.generic
5161 	&& st_sym->module
5162 	&& st_sym->module != module_name)
5163     {
5164       /* The new symbol's attributes have not yet been read.  Since
5165 	 we need attr.generic, read it directly.  */
5166       get_module_locus (&locus);
5167       set_module_locus (&info->u.rsym.where);
5168       mio_lparen ();
5169       attr.generic = 0;
5170       mio_symbol_attribute (&attr);
5171       set_module_locus (&locus);
5172       if (attr.generic)
5173 	return false;
5174     }
5175 
5176   return true;
5177 }
5178 
5179 
5180 /* Read a module file.  */
5181 
5182 static void
read_module(void)5183 read_module (void)
5184 {
5185   module_locus operator_interfaces, user_operators, omp_udrs;
5186   const char *p;
5187   char name[GFC_MAX_SYMBOL_LEN + 1];
5188   int i;
5189   /* Workaround -Wmaybe-uninitialized false positive during
5190      profiledbootstrap by initializing them.  */
5191   int ambiguous = 0, j, nuse, symbol = 0;
5192   pointer_info *info, *q;
5193   gfc_use_rename *u = NULL;
5194   gfc_symtree *st;
5195   gfc_symbol *sym;
5196 
5197   get_module_locus (&operator_interfaces);	/* Skip these for now.  */
5198   skip_list ();
5199 
5200   get_module_locus (&user_operators);
5201   skip_list ();
5202   skip_list ();
5203 
5204   /* Skip commons and equivalences for now.  */
5205   skip_list ();
5206   skip_list ();
5207 
5208   /* Skip OpenMP UDRs.  */
5209   get_module_locus (&omp_udrs);
5210   skip_list ();
5211 
5212   mio_lparen ();
5213 
5214   /* Create the fixup nodes for all the symbols.  */
5215 
5216   while (peek_atom () != ATOM_RPAREN)
5217     {
5218       char* bind_label;
5219       require_atom (ATOM_INTEGER);
5220       info = get_integer (atom_int);
5221 
5222       info->type = P_SYMBOL;
5223       info->u.rsym.state = UNUSED;
5224 
5225       info->u.rsym.true_name = read_string ();
5226       info->u.rsym.module = read_string ();
5227       bind_label = read_string ();
5228       if (strlen (bind_label))
5229 	info->u.rsym.binding_label = bind_label;
5230       else
5231 	XDELETEVEC (bind_label);
5232 
5233       require_atom (ATOM_INTEGER);
5234       info->u.rsym.ns = atom_int;
5235 
5236       get_module_locus (&info->u.rsym.where);
5237 
5238       /* See if the symbol has already been loaded by a previous module.
5239 	 If so, we reference the existing symbol and prevent it from
5240 	 being loaded again.  This should not happen if the symbol being
5241 	 read is an index for an assumed shape dummy array (ns != 1).  */
5242 
5243       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
5244 
5245       if (sym == NULL
5246 	  || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
5247 	{
5248 	  skip_list ();
5249 	  continue;
5250 	}
5251 
5252       info->u.rsym.state = USED;
5253       info->u.rsym.sym = sym;
5254       /* The current symbol has already been loaded, so we can avoid loading
5255 	 it again.  However, if it is a derived type, some of its components
5256 	 can be used in expressions in the module.  To avoid the module loading
5257 	 failing, we need to associate the module's component pointer indexes
5258 	 with the existing symbol's component pointers.  */
5259       if (gfc_fl_struct (sym->attr.flavor))
5260 	{
5261 	  gfc_component *c;
5262 
5263 	  /* First seek to the symbol's component list.  */
5264 	  mio_lparen (); /* symbol opening.  */
5265 	  skip_list (); /* skip symbol attribute.  */
5266 
5267 	  mio_lparen (); /* component list opening.  */
5268 	  for (c = sym->components; c; c = c->next)
5269 	    {
5270 	      pointer_info *p;
5271 	      const char *comp_name = NULL;
5272 	      int n = 0;
5273 
5274 	      mio_lparen (); /* component opening.  */
5275 	      mio_integer (&n);
5276 	      p = get_integer (n);
5277 	      if (p->u.pointer == NULL)
5278 		associate_integer_pointer (p, c);
5279 	      mio_pool_string (&comp_name);
5280 	      if (comp_name != c->name)
5281 		{
5282 		  gfc_fatal_error ("Mismatch in components of derived type "
5283 				   "%qs from %qs at %C: expecting %qs, "
5284 				   "but got %qs", sym->name, sym->module,
5285 				   c->name, comp_name);
5286 		}
5287 	      skip_list (1); /* component end.  */
5288 	    }
5289 	  mio_rparen (); /* component list closing.  */
5290 
5291 	  skip_list (1); /* symbol end.  */
5292 	}
5293       else
5294 	skip_list ();
5295 
5296       /* Some symbols do not have a namespace (eg. formal arguments),
5297 	 so the automatic "unique symtree" mechanism must be suppressed
5298 	 by marking them as referenced.  */
5299       q = get_integer (info->u.rsym.ns);
5300       if (q->u.pointer == NULL)
5301 	{
5302 	  info->u.rsym.referenced = 1;
5303 	  continue;
5304 	}
5305     }
5306 
5307   mio_rparen ();
5308 
5309   /* Parse the symtree lists.  This lets us mark which symbols need to
5310      be loaded.  Renaming is also done at this point by replacing the
5311      symtree name.  */
5312 
5313   mio_lparen ();
5314 
5315   while (peek_atom () != ATOM_RPAREN)
5316     {
5317       mio_internal_string (name);
5318       mio_integer (&ambiguous);
5319       mio_integer (&symbol);
5320 
5321       info = get_integer (symbol);
5322 
5323       /* See how many use names there are.  If none, go through the start
5324 	 of the loop at least once.  */
5325       nuse = number_use_names (name, false);
5326       info->u.rsym.renamed = nuse ? 1 : 0;
5327 
5328       if (nuse == 0)
5329 	nuse = 1;
5330 
5331       for (j = 1; j <= nuse; j++)
5332 	{
5333 	  /* Get the jth local name for this symbol.  */
5334 	  p = find_use_name_n (name, &j, false);
5335 
5336 	  if (p == NULL && strcmp (name, module_name) == 0)
5337 	    p = name;
5338 
5339 	  /* Exception: Always import vtabs & vtypes.  */
5340 	  if (p == NULL && name[0] == '_'
5341 	      && (gfc_str_startswith (name, "__vtab_")
5342 		  || gfc_str_startswith (name, "__vtype_")))
5343 	    p = name;
5344 
5345 	  /* Skip symtree nodes not in an ONLY clause, unless there
5346 	     is an existing symtree loaded from another USE statement.  */
5347 	  if (p == NULL)
5348 	    {
5349 	      st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5350 	      if (st != NULL
5351 		  && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
5352 		  && st->n.sym->module != NULL
5353 		  && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
5354 		{
5355 		  info->u.rsym.symtree = st;
5356 		  info->u.rsym.sym = st->n.sym;
5357 		}
5358 	      continue;
5359 	    }
5360 
5361 	  /* If a symbol of the same name and module exists already,
5362 	     this symbol, which is not in an ONLY clause, must not be
5363 	     added to the namespace(11.3.2).  Note that find_symbol
5364 	     only returns the first occurrence that it finds.  */
5365 	  if (!only_flag && !info->u.rsym.renamed
5366 		&& strcmp (name, module_name) != 0
5367 		&& find_symbol (gfc_current_ns->sym_root, name,
5368 				module_name, 0))
5369 	    continue;
5370 
5371 	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
5372 
5373 	  if (st != NULL
5374 	      && !(st->n.sym && st->n.sym->attr.used_in_submodule))
5375 	    {
5376 	      /* Check for ambiguous symbols.  */
5377 	      if (check_for_ambiguous (st, info))
5378 		st->ambiguous = 1;
5379 	      else
5380 		info->u.rsym.symtree = st;
5381 	    }
5382 	  else
5383 	    {
5384 	      if (st)
5385 		{
5386 		  /* This symbol is host associated from a module in a
5387 		     submodule.  Hide it with a unique symtree.  */
5388 		  gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
5389 		  s->n.sym = st->n.sym;
5390 		  st->n.sym = NULL;
5391 		}
5392 	      else
5393 		{
5394 		  /* Create a symtree node in the current namespace for this
5395 		     symbol.  */
5396 		  st = check_unique_name (p)
5397 		       ? gfc_get_unique_symtree (gfc_current_ns)
5398 		       : gfc_new_symtree (&gfc_current_ns->sym_root, p);
5399 		  st->ambiguous = ambiguous;
5400 		}
5401 
5402 	      sym = info->u.rsym.sym;
5403 
5404 	      /* Create a symbol node if it doesn't already exist.  */
5405 	      if (sym == NULL)
5406 		{
5407 		  info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
5408 						     gfc_current_ns);
5409 		  info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
5410 		  sym = info->u.rsym.sym;
5411 		  sym->module = gfc_get_string ("%s", info->u.rsym.module);
5412 
5413 		  if (info->u.rsym.binding_label)
5414 		    {
5415 		      tree id = get_identifier (info->u.rsym.binding_label);
5416 		      sym->binding_label = IDENTIFIER_POINTER (id);
5417 		    }
5418 		}
5419 
5420 	      st->n.sym = sym;
5421 	      st->n.sym->refs++;
5422 
5423 	      if (strcmp (name, p) != 0)
5424 		sym->attr.use_rename = 1;
5425 
5426 	      if (name[0] != '_'
5427 		  || (!gfc_str_startswith (name, "__vtab_")
5428 		      && !gfc_str_startswith (name, "__vtype_")))
5429 		sym->attr.use_only = only_flag;
5430 
5431 	      /* Store the symtree pointing to this symbol.  */
5432 	      info->u.rsym.symtree = st;
5433 
5434 	      if (info->u.rsym.state == UNUSED)
5435 		info->u.rsym.state = NEEDED;
5436 	      info->u.rsym.referenced = 1;
5437 	    }
5438 	}
5439     }
5440 
5441   mio_rparen ();
5442 
5443   /* Load intrinsic operator interfaces.  */
5444   set_module_locus (&operator_interfaces);
5445   mio_lparen ();
5446 
5447   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5448     {
5449       if (i == INTRINSIC_USER)
5450 	continue;
5451 
5452       if (only_flag)
5453 	{
5454 	  u = find_use_operator ((gfc_intrinsic_op) i);
5455 
5456 	  if (u == NULL)
5457 	    {
5458 	      skip_list ();
5459 	      continue;
5460 	    }
5461 
5462 	  u->found = 1;
5463 	}
5464 
5465       mio_interface (&gfc_current_ns->op[i]);
5466       if (u && !gfc_current_ns->op[i])
5467 	u->found = 0;
5468     }
5469 
5470   mio_rparen ();
5471 
5472   /* Load generic and user operator interfaces.  These must follow the
5473      loading of symtree because otherwise symbols can be marked as
5474      ambiguous.  */
5475 
5476   set_module_locus (&user_operators);
5477 
5478   load_operator_interfaces ();
5479   load_generic_interfaces ();
5480 
5481   load_commons ();
5482   load_equiv ();
5483 
5484   /* Load OpenMP user defined reductions.  */
5485   set_module_locus (&omp_udrs);
5486   load_omp_udrs ();
5487 
5488   /* At this point, we read those symbols that are needed but haven't
5489      been loaded yet.  If one symbol requires another, the other gets
5490      marked as NEEDED if its previous state was UNUSED.  */
5491 
5492   while (load_needed (pi_root));
5493 
5494   /* Make sure all elements of the rename-list were found in the module.  */
5495 
5496   for (u = gfc_rename_list; u; u = u->next)
5497     {
5498       if (u->found)
5499 	continue;
5500 
5501       if (u->op == INTRINSIC_NONE)
5502 	{
5503 	  gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5504 		     u->use_name, &u->where, module_name);
5505 	  continue;
5506 	}
5507 
5508       if (u->op == INTRINSIC_USER)
5509 	{
5510 	  gfc_error ("User operator %qs referenced at %L not found "
5511 		     "in module %qs", u->use_name, &u->where, module_name);
5512 	  continue;
5513 	}
5514 
5515       gfc_error ("Intrinsic operator %qs referenced at %L not found "
5516 		 "in module %qs", gfc_op2string (u->op), &u->where,
5517 		 module_name);
5518     }
5519 
5520   /* Clean up symbol nodes that were never loaded, create references
5521      to hidden symbols.  */
5522 
5523   read_cleanup (pi_root);
5524 }
5525 
5526 
5527 /* Given an access type that is specific to an entity and the default
5528    access, return nonzero if the entity is publicly accessible.  If the
5529    element is declared as PUBLIC, then it is public; if declared
5530    PRIVATE, then private, and otherwise it is public unless the default
5531    access in this context has been declared PRIVATE.  */
5532 
5533 static bool dump_smod = false;
5534 
5535 static bool
check_access(gfc_access specific_access,gfc_access default_access)5536 check_access (gfc_access specific_access, gfc_access default_access)
5537 {
5538   if (dump_smod)
5539     return true;
5540 
5541   if (specific_access == ACCESS_PUBLIC)
5542     return TRUE;
5543   if (specific_access == ACCESS_PRIVATE)
5544     return FALSE;
5545 
5546   if (flag_module_private)
5547     return default_access == ACCESS_PUBLIC;
5548   else
5549     return default_access != ACCESS_PRIVATE;
5550 }
5551 
5552 
5553 bool
gfc_check_symbol_access(gfc_symbol * sym)5554 gfc_check_symbol_access (gfc_symbol *sym)
5555 {
5556   if (sym->attr.vtab || sym->attr.vtype)
5557     return true;
5558   else
5559     return check_access (sym->attr.access, sym->ns->default_access);
5560 }
5561 
5562 
5563 /* A structure to remember which commons we've already written.  */
5564 
5565 struct written_common
5566 {
5567   BBT_HEADER(written_common);
5568   const char *name, *label;
5569 };
5570 
5571 static struct written_common *written_commons = NULL;
5572 
5573 /* Comparison function used for balancing the binary tree.  */
5574 
5575 static int
compare_written_commons(void * a1,void * b1)5576 compare_written_commons (void *a1, void *b1)
5577 {
5578   const char *aname = ((struct written_common *) a1)->name;
5579   const char *alabel = ((struct written_common *) a1)->label;
5580   const char *bname = ((struct written_common *) b1)->name;
5581   const char *blabel = ((struct written_common *) b1)->label;
5582   int c = strcmp (aname, bname);
5583 
5584   return (c != 0 ? c : strcmp (alabel, blabel));
5585 }
5586 
5587 /* Free a list of written commons.  */
5588 
5589 static void
free_written_common(struct written_common * w)5590 free_written_common (struct written_common *w)
5591 {
5592   if (!w)
5593     return;
5594 
5595   if (w->left)
5596     free_written_common (w->left);
5597   if (w->right)
5598     free_written_common (w->right);
5599 
5600   free (w);
5601 }
5602 
5603 /* Write a common block to the module -- recursive helper function.  */
5604 
5605 static void
write_common_0(gfc_symtree * st,bool this_module)5606 write_common_0 (gfc_symtree *st, bool this_module)
5607 {
5608   gfc_common_head *p;
5609   const char * name;
5610   int flags;
5611   const char *label;
5612   struct written_common *w;
5613   bool write_me = true;
5614 
5615   if (st == NULL)
5616     return;
5617 
5618   write_common_0 (st->left, this_module);
5619 
5620   /* We will write out the binding label, or "" if no label given.  */
5621   name = st->n.common->name;
5622   p = st->n.common;
5623   label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
5624 
5625   /* Check if we've already output this common.  */
5626   w = written_commons;
5627   while (w)
5628     {
5629       int c = strcmp (name, w->name);
5630       c = (c != 0 ? c : strcmp (label, w->label));
5631       if (c == 0)
5632 	write_me = false;
5633 
5634       w = (c < 0) ? w->left : w->right;
5635     }
5636 
5637   if (this_module && p->use_assoc)
5638     write_me = false;
5639 
5640   if (write_me)
5641     {
5642       /* Write the common to the module.  */
5643       mio_lparen ();
5644       mio_pool_string (&name);
5645 
5646       mio_symbol_ref (&p->head);
5647       flags = p->saved ? 1 : 0;
5648       if (p->threadprivate)
5649 	flags |= 2;
5650       mio_integer (&flags);
5651 
5652       /* Write out whether the common block is bind(c) or not.  */
5653       mio_integer (&(p->is_bind_c));
5654 
5655       mio_pool_string (&label);
5656       mio_rparen ();
5657 
5658       /* Record that we have written this common.  */
5659       w = XCNEW (struct written_common);
5660       w->name = p->name;
5661       w->label = label;
5662       gfc_insert_bbt (&written_commons, w, compare_written_commons);
5663     }
5664 
5665   write_common_0 (st->right, this_module);
5666 }
5667 
5668 
5669 /* Write a common, by initializing the list of written commons, calling
5670    the recursive function write_common_0() and cleaning up afterwards.  */
5671 
5672 static void
write_common(gfc_symtree * st)5673 write_common (gfc_symtree *st)
5674 {
5675   written_commons = NULL;
5676   write_common_0 (st, true);
5677   write_common_0 (st, false);
5678   free_written_common (written_commons);
5679   written_commons = NULL;
5680 }
5681 
5682 
5683 /* Write the blank common block to the module.  */
5684 
5685 static void
write_blank_common(void)5686 write_blank_common (void)
5687 {
5688   const char * name = BLANK_COMMON_NAME;
5689   int saved;
5690   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
5691      this, but it hasn't been checked.  Just making it so for now.  */
5692   int is_bind_c = 0;
5693 
5694   if (gfc_current_ns->blank_common.head == NULL)
5695     return;
5696 
5697   mio_lparen ();
5698 
5699   mio_pool_string (&name);
5700 
5701   mio_symbol_ref (&gfc_current_ns->blank_common.head);
5702   saved = gfc_current_ns->blank_common.saved;
5703   mio_integer (&saved);
5704 
5705   /* Write out whether the common block is bind(c) or not.  */
5706   mio_integer (&is_bind_c);
5707 
5708   /* Write out an empty binding label.  */
5709   write_atom (ATOM_STRING, "");
5710 
5711   mio_rparen ();
5712 }
5713 
5714 
5715 /* Write equivalences to the module.  */
5716 
5717 static void
write_equiv(void)5718 write_equiv (void)
5719 {
5720   gfc_equiv *eq, *e;
5721   int num;
5722 
5723   num = 0;
5724   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
5725     {
5726       mio_lparen ();
5727 
5728       for (e = eq; e; e = e->eq)
5729 	{
5730 	  if (e->module == NULL)
5731 	    e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5732 	  mio_allocated_string (e->module);
5733 	  mio_expr (&e->expr);
5734 	}
5735 
5736       num++;
5737       mio_rparen ();
5738     }
5739 }
5740 
5741 
5742 /* Write a symbol to the module.  */
5743 
5744 static void
write_symbol(int n,gfc_symbol * sym)5745 write_symbol (int n, gfc_symbol *sym)
5746 {
5747   const char *label;
5748 
5749   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5750     gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name);
5751 
5752   mio_integer (&n);
5753 
5754   if (gfc_fl_struct (sym->attr.flavor))
5755     {
5756       const char *name;
5757       name = gfc_dt_upper_string (sym->name);
5758       mio_pool_string (&name);
5759     }
5760   else
5761     mio_pool_string (&sym->name);
5762 
5763   mio_pool_string (&sym->module);
5764   if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5765     {
5766       label = sym->binding_label;
5767       mio_pool_string (&label);
5768     }
5769   else
5770     write_atom (ATOM_STRING, "");
5771 
5772   mio_pointer_ref (&sym->ns);
5773 
5774   mio_symbol (sym);
5775   write_char ('\n');
5776 }
5777 
5778 
5779 /* Recursive traversal function to write the initial set of symbols to
5780    the module.  We check to see if the symbol should be written
5781    according to the access specification.  */
5782 
5783 static void
write_symbol0(gfc_symtree * st)5784 write_symbol0 (gfc_symtree *st)
5785 {
5786   gfc_symbol *sym;
5787   pointer_info *p;
5788   bool dont_write = false;
5789 
5790   if (st == NULL)
5791     return;
5792 
5793   write_symbol0 (st->left);
5794 
5795   sym = st->n.sym;
5796   if (sym->module == NULL)
5797     sym->module = module_name;
5798 
5799   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5800       && !sym->attr.subroutine && !sym->attr.function)
5801     dont_write = true;
5802 
5803   if (!gfc_check_symbol_access (sym))
5804     dont_write = true;
5805 
5806   if (!dont_write)
5807     {
5808       p = get_pointer (sym);
5809       if (p->type == P_UNKNOWN)
5810 	p->type = P_SYMBOL;
5811 
5812       if (p->u.wsym.state != WRITTEN)
5813 	{
5814 	  write_symbol (p->integer, sym);
5815 	  p->u.wsym.state = WRITTEN;
5816 	}
5817     }
5818 
5819   write_symbol0 (st->right);
5820 }
5821 
5822 
5823 static void
write_omp_udr(gfc_omp_udr * udr)5824 write_omp_udr (gfc_omp_udr *udr)
5825 {
5826   switch (udr->rop)
5827     {
5828     case OMP_REDUCTION_USER:
5829       /* Non-operators can't be used outside of the module.  */
5830       if (udr->name[0] != '.')
5831 	return;
5832       else
5833 	{
5834 	  gfc_symtree *st;
5835 	  size_t len = strlen (udr->name + 1);
5836 	  char *name = XALLOCAVEC (char, len);
5837 	  memcpy (name, udr->name, len - 1);
5838 	  name[len - 1] = '\0';
5839 	  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
5840 	  /* If corresponding user operator is private, don't write
5841 	     the UDR.  */
5842 	  if (st != NULL)
5843 	    {
5844 	      gfc_user_op *uop = st->n.uop;
5845 	      if (!check_access (uop->access, uop->ns->default_access))
5846 		return;
5847 	    }
5848 	}
5849       break;
5850     case OMP_REDUCTION_PLUS:
5851     case OMP_REDUCTION_MINUS:
5852     case OMP_REDUCTION_TIMES:
5853     case OMP_REDUCTION_AND:
5854     case OMP_REDUCTION_OR:
5855     case OMP_REDUCTION_EQV:
5856     case OMP_REDUCTION_NEQV:
5857       /* If corresponding operator is private, don't write the UDR.  */
5858       if (!check_access (gfc_current_ns->operator_access[udr->rop],
5859 			 gfc_current_ns->default_access))
5860 	return;
5861       break;
5862     default:
5863       break;
5864     }
5865   if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
5866     {
5867       /* If derived type is private, don't write the UDR.  */
5868       if (!gfc_check_symbol_access (udr->ts.u.derived))
5869 	return;
5870     }
5871 
5872   mio_lparen ();
5873   mio_pool_string (&udr->name);
5874   mio_typespec (&udr->ts);
5875   mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
5876   if (udr->initializer_ns)
5877     mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
5878 		      udr->initializer_ns, true);
5879   mio_rparen ();
5880 }
5881 
5882 
5883 static void
write_omp_udrs(gfc_symtree * st)5884 write_omp_udrs (gfc_symtree *st)
5885 {
5886   if (st == NULL)
5887     return;
5888 
5889   write_omp_udrs (st->left);
5890   gfc_omp_udr *udr;
5891   for (udr = st->n.omp_udr; udr; udr = udr->next)
5892     write_omp_udr (udr);
5893   write_omp_udrs (st->right);
5894 }
5895 
5896 
5897 /* Type for the temporary tree used when writing secondary symbols.  */
5898 
5899 struct sorted_pointer_info
5900 {
5901   BBT_HEADER (sorted_pointer_info);
5902 
5903   pointer_info *p;
5904 };
5905 
5906 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5907 
5908 /* Recursively traverse the temporary tree, free its contents.  */
5909 
5910 static void
free_sorted_pointer_info_tree(sorted_pointer_info * p)5911 free_sorted_pointer_info_tree (sorted_pointer_info *p)
5912 {
5913   if (!p)
5914     return;
5915 
5916   free_sorted_pointer_info_tree (p->left);
5917   free_sorted_pointer_info_tree (p->right);
5918 
5919   free (p);
5920 }
5921 
5922 /* Comparison function for the temporary tree.  */
5923 
5924 static int
compare_sorted_pointer_info(void * _spi1,void * _spi2)5925 compare_sorted_pointer_info (void *_spi1, void *_spi2)
5926 {
5927   sorted_pointer_info *spi1, *spi2;
5928   spi1 = (sorted_pointer_info *)_spi1;
5929   spi2 = (sorted_pointer_info *)_spi2;
5930 
5931   if (spi1->p->integer < spi2->p->integer)
5932     return -1;
5933   if (spi1->p->integer > spi2->p->integer)
5934     return 1;
5935   return 0;
5936 }
5937 
5938 
5939 /* Finds the symbols that need to be written and collects them in the
5940    sorted_pi tree so that they can be traversed in an order
5941    independent of memory addresses.  */
5942 
5943 static void
find_symbols_to_write(sorted_pointer_info ** tree,pointer_info * p)5944 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
5945 {
5946   if (!p)
5947     return;
5948 
5949   if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
5950     {
5951       sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
5952       sp->p = p;
5953 
5954       gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
5955    }
5956 
5957   find_symbols_to_write (tree, p->left);
5958   find_symbols_to_write (tree, p->right);
5959 }
5960 
5961 
5962 /* Recursive function that traverses the tree of symbols that need to be
5963    written and writes them in order.  */
5964 
5965 static void
write_symbol1_recursion(sorted_pointer_info * sp)5966 write_symbol1_recursion (sorted_pointer_info *sp)
5967 {
5968   if (!sp)
5969     return;
5970 
5971   write_symbol1_recursion (sp->left);
5972 
5973   pointer_info *p1 = sp->p;
5974   gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
5975 
5976   p1->u.wsym.state = WRITTEN;
5977   write_symbol (p1->integer, p1->u.wsym.sym);
5978   p1->u.wsym.sym->attr.public_used = 1;
5979 
5980   write_symbol1_recursion (sp->right);
5981 }
5982 
5983 
5984 /* Write the secondary set of symbols to the module file.  These are
5985    symbols that were not public yet are needed by the public symbols
5986    or another dependent symbol.  The act of writing a symbol can add
5987    symbols to the pointer_info tree, so we return nonzero if a symbol
5988    was written and pass that information upwards.  The caller will
5989    then call this function again until nothing was written.  It uses
5990    the utility functions and a temporary tree to ensure a reproducible
5991    ordering of the symbol output and thus the module file.  */
5992 
5993 static int
write_symbol1(pointer_info * p)5994 write_symbol1 (pointer_info *p)
5995 {
5996   if (!p)
5997     return 0;
5998 
5999   /* Put symbols that need to be written into a tree sorted on the
6000      integer field.  */
6001 
6002   sorted_pointer_info *spi_root = NULL;
6003   find_symbols_to_write (&spi_root, p);
6004 
6005   /* No symbols to write, return.  */
6006   if (!spi_root)
6007     return 0;
6008 
6009   /* Otherwise, write and free the tree again.  */
6010   write_symbol1_recursion (spi_root);
6011   free_sorted_pointer_info_tree (spi_root);
6012 
6013   return 1;
6014 }
6015 
6016 
6017 /* Write operator interfaces associated with a symbol.  */
6018 
6019 static void
write_operator(gfc_user_op * uop)6020 write_operator (gfc_user_op *uop)
6021 {
6022   static char nullstring[] = "";
6023   const char *p = nullstring;
6024 
6025   if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
6026     return;
6027 
6028   mio_symbol_interface (&uop->name, &p, &uop->op);
6029 }
6030 
6031 
6032 /* Write generic interfaces from the namespace sym_root.  */
6033 
6034 static void
write_generic(gfc_symtree * st)6035 write_generic (gfc_symtree *st)
6036 {
6037   gfc_symbol *sym;
6038 
6039   if (st == NULL)
6040     return;
6041 
6042   write_generic (st->left);
6043 
6044   sym = st->n.sym;
6045   if (sym && !check_unique_name (st->name)
6046       && sym->generic && gfc_check_symbol_access (sym))
6047     {
6048       if (!sym->module)
6049 	sym->module = module_name;
6050 
6051       mio_symbol_interface (&st->name, &sym->module, &sym->generic);
6052     }
6053 
6054   write_generic (st->right);
6055 }
6056 
6057 
6058 static void
write_symtree(gfc_symtree * st)6059 write_symtree (gfc_symtree *st)
6060 {
6061   gfc_symbol *sym;
6062   pointer_info *p;
6063 
6064   sym = st->n.sym;
6065 
6066   /* A symbol in an interface body must not be visible in the
6067      module file.  */
6068   if (sym->ns != gfc_current_ns
6069 	&& sym->ns->proc_name
6070 	&& sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
6071     return;
6072 
6073   if (!gfc_check_symbol_access (sym)
6074       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
6075 	  && !sym->attr.subroutine && !sym->attr.function))
6076     return;
6077 
6078   if (check_unique_name (st->name))
6079     return;
6080 
6081   /* From F2003 onwards, intrinsic procedures are no longer subject to
6082      the restriction, "that an elemental intrinsic function here be of
6083      type integer or character and each argument must be an initialization
6084      expr of type integer or character" is lifted so that intrinsic
6085      procedures can be over-ridden. This requires that the intrinsic
6086      symbol not appear in the module file, thereby preventing ambiguity
6087      when USEd.  */
6088   if (strcmp (sym->module, "(intrinsic)") == 0
6089       && (gfc_option.allow_std & GFC_STD_F2003))
6090     return;
6091 
6092   p = find_pointer (sym);
6093   if (p == NULL)
6094     gfc_internal_error ("write_symtree(): Symbol not written");
6095 
6096   mio_pool_string (&st->name);
6097   mio_integer (&st->ambiguous);
6098   mio_hwi (&p->integer);
6099 }
6100 
6101 
6102 static void
write_module(void)6103 write_module (void)
6104 {
6105   int i;
6106 
6107   /* Initialize the column counter. */
6108   module_column = 1;
6109 
6110   /* Write the operator interfaces.  */
6111   mio_lparen ();
6112 
6113   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
6114     {
6115       if (i == INTRINSIC_USER)
6116 	continue;
6117 
6118       mio_interface (check_access (gfc_current_ns->operator_access[i],
6119 				   gfc_current_ns->default_access)
6120 		     ? &gfc_current_ns->op[i] : NULL);
6121     }
6122 
6123   mio_rparen ();
6124   write_char ('\n');
6125   write_char ('\n');
6126 
6127   mio_lparen ();
6128   gfc_traverse_user_op (gfc_current_ns, write_operator);
6129   mio_rparen ();
6130   write_char ('\n');
6131   write_char ('\n');
6132 
6133   mio_lparen ();
6134   write_generic (gfc_current_ns->sym_root);
6135   mio_rparen ();
6136   write_char ('\n');
6137   write_char ('\n');
6138 
6139   mio_lparen ();
6140   write_blank_common ();
6141   write_common (gfc_current_ns->common_root);
6142   mio_rparen ();
6143   write_char ('\n');
6144   write_char ('\n');
6145 
6146   mio_lparen ();
6147   write_equiv ();
6148   mio_rparen ();
6149   write_char ('\n');
6150   write_char ('\n');
6151 
6152   mio_lparen ();
6153   write_omp_udrs (gfc_current_ns->omp_udr_root);
6154   mio_rparen ();
6155   write_char ('\n');
6156   write_char ('\n');
6157 
6158   /* Write symbol information.  First we traverse all symbols in the
6159      primary namespace, writing those that need to be written.
6160      Sometimes writing one symbol will cause another to need to be
6161      written.  A list of these symbols ends up on the write stack, and
6162      we end by popping the bottom of the stack and writing the symbol
6163      until the stack is empty.  */
6164 
6165   mio_lparen ();
6166 
6167   write_symbol0 (gfc_current_ns->sym_root);
6168   while (write_symbol1 (pi_root))
6169     /* Nothing.  */;
6170 
6171   mio_rparen ();
6172 
6173   write_char ('\n');
6174   write_char ('\n');
6175 
6176   mio_lparen ();
6177   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
6178   mio_rparen ();
6179 }
6180 
6181 
6182 /* Read a CRC32 sum from the gzip trailer of a module file.  Returns
6183    true on success, false on failure.  */
6184 
6185 static bool
read_crc32_from_module_file(const char * filename,uLong * crc)6186 read_crc32_from_module_file (const char* filename, uLong* crc)
6187 {
6188   FILE *file;
6189   char buf[4];
6190   unsigned int val;
6191 
6192   /* Open the file in binary mode.  */
6193   if ((file = fopen (filename, "rb")) == NULL)
6194     return false;
6195 
6196   /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6197      file. See RFC 1952.  */
6198   if (fseek (file, -8, SEEK_END) != 0)
6199     {
6200       fclose (file);
6201       return false;
6202     }
6203 
6204   /* Read the CRC32.  */
6205   if (fread (buf, 1, 4, file) != 4)
6206     {
6207       fclose (file);
6208       return false;
6209     }
6210 
6211   /* Close the file.  */
6212   fclose (file);
6213 
6214   val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
6215     + ((buf[3] & 0xFF) << 24);
6216   *crc = val;
6217 
6218   /* For debugging, the CRC value printed in hexadecimal should match
6219      the CRC printed by "zcat -l -v filename".
6220      printf("CRC of file %s is %x\n", filename, val); */
6221 
6222   return true;
6223 }
6224 
6225 
6226 /* Given module, dump it to disk.  If there was an error while
6227    processing the module, dump_flag will be set to zero and we delete
6228    the module file, even if it was already there.  */
6229 
6230 static void
dump_module(const char * name,int dump_flag)6231 dump_module (const char *name, int dump_flag)
6232 {
6233   int n;
6234   char *filename, *filename_tmp;
6235   uLong crc, crc_old;
6236 
6237   module_name = gfc_get_string ("%s", name);
6238 
6239   if (dump_smod)
6240     {
6241       name = submodule_name;
6242       n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
6243     }
6244   else
6245     n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
6246 
6247   if (gfc_option.module_dir != NULL)
6248     {
6249       n += strlen (gfc_option.module_dir);
6250       filename = (char *) alloca (n);
6251       strcpy (filename, gfc_option.module_dir);
6252       strcat (filename, name);
6253     }
6254   else
6255     {
6256       filename = (char *) alloca (n);
6257       strcpy (filename, name);
6258     }
6259 
6260   if (dump_smod)
6261     strcat (filename, SUBMODULE_EXTENSION);
6262   else
6263   strcat (filename, MODULE_EXTENSION);
6264 
6265   /* Name of the temporary file used to write the module.  */
6266   filename_tmp = (char *) alloca (n + 1);
6267   strcpy (filename_tmp, filename);
6268   strcat (filename_tmp, "0");
6269 
6270   /* There was an error while processing the module.  We delete the
6271      module file, even if it was already there.  */
6272   if (!dump_flag)
6273     {
6274       remove (filename);
6275       return;
6276     }
6277 
6278   if (gfc_cpp_makedep ())
6279     gfc_cpp_add_target (filename);
6280 
6281   /* Write the module to the temporary file.  */
6282   module_fp = gzopen (filename_tmp, "w");
6283   if (module_fp == NULL)
6284     gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
6285 		     filename_tmp, xstrerror (errno));
6286 
6287   /* Use lbasename to ensure module files are reproducible regardless
6288      of the build path (see the reproducible builds project).  */
6289   gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
6290 	    MOD_VERSION, lbasename (gfc_source_file));
6291 
6292   /* Write the module itself.  */
6293   iomode = IO_OUTPUT;
6294 
6295   init_pi_tree ();
6296 
6297   write_module ();
6298 
6299   free_pi_tree (pi_root);
6300   pi_root = NULL;
6301 
6302   write_char ('\n');
6303 
6304   if (gzclose (module_fp))
6305     gfc_fatal_error ("Error writing module file %qs for writing: %s",
6306 		     filename_tmp, xstrerror (errno));
6307 
6308   /* Read the CRC32 from the gzip trailers of the module files and
6309      compare.  */
6310   if (!read_crc32_from_module_file (filename_tmp, &crc)
6311       || !read_crc32_from_module_file (filename, &crc_old)
6312       || crc_old != crc)
6313     {
6314       /* Module file have changed, replace the old one.  */
6315       if (remove (filename) && errno != ENOENT)
6316 	gfc_fatal_error ("Cannot delete module file %qs: %s", filename,
6317 			 xstrerror (errno));
6318       if (rename (filename_tmp, filename))
6319 	gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
6320 			 filename_tmp, filename, xstrerror (errno));
6321     }
6322   else
6323     {
6324       if (remove (filename_tmp))
6325 	gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
6326 			 filename_tmp, xstrerror (errno));
6327     }
6328 }
6329 
6330 
6331 /* Suppress the output of a .smod file by module, if no module
6332    procedures have been seen.  */
6333 static bool no_module_procedures;
6334 
6335 static void
check_for_module_procedures(gfc_symbol * sym)6336 check_for_module_procedures (gfc_symbol *sym)
6337 {
6338   if (sym && sym->attr.module_procedure)
6339     no_module_procedures = false;
6340 }
6341 
6342 
6343 void
gfc_dump_module(const char * name,int dump_flag)6344 gfc_dump_module (const char *name, int dump_flag)
6345 {
6346   if (gfc_state_stack->state == COMP_SUBMODULE)
6347     dump_smod = true;
6348   else
6349     dump_smod =false;
6350 
6351   no_module_procedures = true;
6352   gfc_traverse_ns (gfc_current_ns, check_for_module_procedures);
6353 
6354   dump_module (name, dump_flag);
6355 
6356   if (no_module_procedures || dump_smod)
6357     return;
6358 
6359   /* Write a submodule file from a module.  The 'dump_smod' flag switches
6360      off the check for PRIVATE entities.  */
6361   dump_smod = true;
6362   submodule_name = module_name;
6363   dump_module (name, dump_flag);
6364   dump_smod = false;
6365 }
6366 
6367 static void
create_intrinsic_function(const char * name,int id,const char * modname,intmod_id module,bool subroutine,gfc_symbol * result_type)6368 create_intrinsic_function (const char *name, int id,
6369 			   const char *modname, intmod_id module,
6370 			   bool subroutine, gfc_symbol *result_type)
6371 {
6372   gfc_intrinsic_sym *isym;
6373   gfc_symtree *tmp_symtree;
6374   gfc_symbol *sym;
6375 
6376   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6377   if (tmp_symtree)
6378     {
6379       if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
6380 	  && strcmp (modname, tmp_symtree->n.sym->module) == 0)
6381 	return;
6382       gfc_error ("Symbol %qs at %C already declared", name);
6383       return;
6384     }
6385 
6386   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6387   sym = tmp_symtree->n.sym;
6388 
6389   if (subroutine)
6390     {
6391       gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6392       isym = gfc_intrinsic_subroutine_by_id (isym_id);
6393       sym->attr.subroutine = 1;
6394     }
6395   else
6396     {
6397       gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6398       isym = gfc_intrinsic_function_by_id (isym_id);
6399 
6400       sym->attr.function = 1;
6401       if (result_type)
6402 	{
6403 	  sym->ts.type = BT_DERIVED;
6404 	  sym->ts.u.derived = result_type;
6405 	  sym->ts.is_c_interop = 1;
6406 	  isym->ts.f90_type = BT_VOID;
6407 	  isym->ts.type = BT_DERIVED;
6408 	  isym->ts.f90_type = BT_VOID;
6409 	  isym->ts.u.derived = result_type;
6410 	  isym->ts.is_c_interop = 1;
6411 	}
6412     }
6413   gcc_assert (isym);
6414 
6415   sym->attr.flavor = FL_PROCEDURE;
6416   sym->attr.intrinsic = 1;
6417 
6418   sym->module = gfc_get_string ("%s", modname);
6419   sym->attr.use_assoc = 1;
6420   sym->from_intmod = module;
6421   sym->intmod_sym_id = id;
6422 }
6423 
6424 
6425 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6426    the current namespace for all named constants, pointer types, and
6427    procedures in the module unless the only clause was used or a rename
6428    list was provided.  */
6429 
6430 static void
import_iso_c_binding_module(void)6431 import_iso_c_binding_module (void)
6432 {
6433   gfc_symbol *mod_sym = NULL, *return_type;
6434   gfc_symtree *mod_symtree = NULL, *tmp_symtree;
6435   gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
6436   const char *iso_c_module_name = "__iso_c_binding";
6437   gfc_use_rename *u;
6438   int i;
6439   bool want_c_ptr = false, want_c_funptr = false;
6440 
6441   /* Look only in the current namespace.  */
6442   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
6443 
6444   if (mod_symtree == NULL)
6445     {
6446       /* symtree doesn't already exist in current namespace.  */
6447       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
6448 			false);
6449 
6450       if (mod_symtree != NULL)
6451 	mod_sym = mod_symtree->n.sym;
6452       else
6453 	gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6454 			    "create symbol for %s", iso_c_module_name);
6455 
6456       mod_sym->attr.flavor = FL_MODULE;
6457       mod_sym->attr.intrinsic = 1;
6458       mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
6459       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
6460     }
6461 
6462   /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6463      check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6464      need C_(FUN)PTR.  */
6465   for (u = gfc_rename_list; u; u = u->next)
6466     {
6467       if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
6468 		  u->use_name) == 0)
6469         want_c_ptr = true;
6470       else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
6471 		       u->use_name) == 0)
6472         want_c_ptr = true;
6473       else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
6474 		       u->use_name) == 0)
6475         want_c_funptr = true;
6476       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
6477 		       u->use_name) == 0)
6478         want_c_funptr = true;
6479       else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
6480                        u->use_name) == 0)
6481 	{
6482 	  c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6483                                                (iso_c_binding_symbol)
6484 							ISOCBINDING_PTR,
6485                                                u->local_name[0] ? u->local_name
6486                                                                 : u->use_name,
6487                                                NULL, false);
6488 	}
6489       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
6490                        u->use_name) == 0)
6491 	{
6492 	  c_funptr
6493 	     = generate_isocbinding_symbol (iso_c_module_name,
6494 					    (iso_c_binding_symbol)
6495 							ISOCBINDING_FUNPTR,
6496 					     u->local_name[0] ? u->local_name
6497 							      : u->use_name,
6498 					     NULL, false);
6499 	}
6500     }
6501 
6502   if ((want_c_ptr || !only_flag) && !c_ptr)
6503     c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6504 					 (iso_c_binding_symbol)
6505 							ISOCBINDING_PTR,
6506 					 NULL, NULL, only_flag);
6507   if ((want_c_funptr || !only_flag) && !c_funptr)
6508     c_funptr = generate_isocbinding_symbol (iso_c_module_name,
6509 					    (iso_c_binding_symbol)
6510 							ISOCBINDING_FUNPTR,
6511 					    NULL, NULL, only_flag);
6512 
6513   /* Generate the symbols for the named constants representing
6514      the kinds for intrinsic data types.  */
6515   for (i = 0; i < ISOCBINDING_NUMBER; i++)
6516     {
6517       bool found = false;
6518       for (u = gfc_rename_list; u; u = u->next)
6519 	if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
6520 	  {
6521 	    bool not_in_std;
6522 	    const char *name;
6523 	    u->found = 1;
6524 	    found = true;
6525 
6526 	    switch (i)
6527 	      {
6528 #define NAMED_FUNCTION(a,b,c,d) \
6529 	        case a: \
6530 		  not_in_std = (gfc_option.allow_std & d) == 0; \
6531 		  name = b; \
6532 		  break;
6533 #define NAMED_SUBROUTINE(a,b,c,d) \
6534 	        case a: \
6535 		  not_in_std = (gfc_option.allow_std & d) == 0; \
6536 		  name = b; \
6537 		  break;
6538 #define NAMED_INTCST(a,b,c,d) \
6539 	        case a: \
6540 		  not_in_std = (gfc_option.allow_std & d) == 0; \
6541 		  name = b; \
6542 		  break;
6543 #define NAMED_REALCST(a,b,c,d) \
6544 	        case a: \
6545 		  not_in_std = (gfc_option.allow_std & d) == 0; \
6546 		  name = b; \
6547 		  break;
6548 #define NAMED_CMPXCST(a,b,c,d) \
6549 	        case a: \
6550 		  not_in_std = (gfc_option.allow_std & d) == 0; \
6551 		  name = b; \
6552 		  break;
6553 #include "iso-c-binding.def"
6554 		default:
6555 		  not_in_std = false;
6556 		  name = "";
6557 	      }
6558 
6559 	    if (not_in_std)
6560 	      {
6561 		gfc_error ("The symbol %qs, referenced at %L, is not "
6562 			   "in the selected standard", name, &u->where);
6563 		continue;
6564 	      }
6565 
6566 	    switch (i)
6567 	      {
6568 #define NAMED_FUNCTION(a,b,c,d) \
6569 	        case a: \
6570 		  if (a == ISOCBINDING_LOC) \
6571 		    return_type = c_ptr->n.sym; \
6572 		  else if (a == ISOCBINDING_FUNLOC) \
6573 		    return_type = c_funptr->n.sym; \
6574 		  else \
6575 		    return_type = NULL; \
6576 		  create_intrinsic_function (u->local_name[0] \
6577 					     ? u->local_name : u->use_name, \
6578 					     a, iso_c_module_name, \
6579 					     INTMOD_ISO_C_BINDING, false, \
6580 					     return_type); \
6581 		  break;
6582 #define NAMED_SUBROUTINE(a,b,c,d) \
6583 	        case a: \
6584 		  create_intrinsic_function (u->local_name[0] ? u->local_name \
6585 							      : u->use_name, \
6586                                              a, iso_c_module_name, \
6587                                              INTMOD_ISO_C_BINDING, true, NULL); \
6588 		  break;
6589 #include "iso-c-binding.def"
6590 
6591 		case ISOCBINDING_PTR:
6592 		case ISOCBINDING_FUNPTR:
6593 		  /* Already handled above.  */
6594 		  break;
6595 		default:
6596 		  if (i == ISOCBINDING_NULL_PTR)
6597 		    tmp_symtree = c_ptr;
6598 		  else if (i == ISOCBINDING_NULL_FUNPTR)
6599 		    tmp_symtree = c_funptr;
6600 		  else
6601 		    tmp_symtree = NULL;
6602 		  generate_isocbinding_symbol (iso_c_module_name,
6603 					       (iso_c_binding_symbol) i,
6604 					       u->local_name[0]
6605 					       ? u->local_name : u->use_name,
6606 					       tmp_symtree, false);
6607 	      }
6608 	  }
6609 
6610       if (!found && !only_flag)
6611 	{
6612 	  /* Skip, if the symbol is not in the enabled standard.  */
6613 	  switch (i)
6614 	    {
6615 #define NAMED_FUNCTION(a,b,c,d) \
6616 	      case a: \
6617 		if ((gfc_option.allow_std & d) == 0) \
6618 		  continue; \
6619 		break;
6620 #define NAMED_SUBROUTINE(a,b,c,d) \
6621 	      case a: \
6622 		if ((gfc_option.allow_std & d) == 0) \
6623 		  continue; \
6624 		break;
6625 #define NAMED_INTCST(a,b,c,d) \
6626 	      case a: \
6627 		if ((gfc_option.allow_std & d) == 0) \
6628 		  continue; \
6629 		break;
6630 #define NAMED_REALCST(a,b,c,d) \
6631 	      case a: \
6632 		if ((gfc_option.allow_std & d) == 0) \
6633 		  continue; \
6634 		break;
6635 #define NAMED_CMPXCST(a,b,c,d) \
6636 	      case a: \
6637 		if ((gfc_option.allow_std & d) == 0) \
6638 		  continue; \
6639 		break;
6640 #include "iso-c-binding.def"
6641 	      default:
6642 		; /* Not GFC_STD_* versioned.  */
6643 	    }
6644 
6645 	  switch (i)
6646 	    {
6647 #define NAMED_FUNCTION(a,b,c,d) \
6648 	      case a: \
6649 		if (a == ISOCBINDING_LOC) \
6650 		  return_type = c_ptr->n.sym; \
6651 		else if (a == ISOCBINDING_FUNLOC) \
6652 		  return_type = c_funptr->n.sym; \
6653 		else \
6654 		  return_type = NULL; \
6655 		create_intrinsic_function (b, a, iso_c_module_name, \
6656 					   INTMOD_ISO_C_BINDING, false, \
6657 					   return_type); \
6658 		break;
6659 #define NAMED_SUBROUTINE(a,b,c,d) \
6660 	      case a: \
6661 		create_intrinsic_function (b, a, iso_c_module_name, \
6662 					   INTMOD_ISO_C_BINDING, true, NULL); \
6663 		  break;
6664 #include "iso-c-binding.def"
6665 
6666 	      case ISOCBINDING_PTR:
6667 	      case ISOCBINDING_FUNPTR:
6668 		/* Already handled above.  */
6669 		break;
6670 	      default:
6671 		if (i == ISOCBINDING_NULL_PTR)
6672 		  tmp_symtree = c_ptr;
6673 		else if (i == ISOCBINDING_NULL_FUNPTR)
6674 		  tmp_symtree = c_funptr;
6675 		else
6676 		  tmp_symtree = NULL;
6677 		generate_isocbinding_symbol (iso_c_module_name,
6678 					     (iso_c_binding_symbol) i, NULL,
6679 					     tmp_symtree, false);
6680 	    }
6681 	}
6682    }
6683 
6684    for (u = gfc_rename_list; u; u = u->next)
6685      {
6686       if (u->found)
6687 	continue;
6688 
6689       gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6690 		 "module ISO_C_BINDING", u->use_name, &u->where);
6691      }
6692 }
6693 
6694 
6695 /* Add an integer named constant from a given module.  */
6696 
6697 static void
create_int_parameter(const char * name,int value,const char * modname,intmod_id module,int id)6698 create_int_parameter (const char *name, int value, const char *modname,
6699 		      intmod_id module, int id)
6700 {
6701   gfc_symtree *tmp_symtree;
6702   gfc_symbol *sym;
6703 
6704   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6705   if (tmp_symtree != NULL)
6706     {
6707       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6708 	return;
6709       else
6710 	gfc_error ("Symbol %qs already declared", name);
6711     }
6712 
6713   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6714   sym = tmp_symtree->n.sym;
6715 
6716   sym->module = gfc_get_string ("%s", modname);
6717   sym->attr.flavor = FL_PARAMETER;
6718   sym->ts.type = BT_INTEGER;
6719   sym->ts.kind = gfc_default_integer_kind;
6720   sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
6721   sym->attr.use_assoc = 1;
6722   sym->from_intmod = module;
6723   sym->intmod_sym_id = id;
6724 }
6725 
6726 
6727 /* Value is already contained by the array constructor, but not
6728    yet the shape.  */
6729 
6730 static void
create_int_parameter_array(const char * name,int size,gfc_expr * value,const char * modname,intmod_id module,int id)6731 create_int_parameter_array (const char *name, int size, gfc_expr *value,
6732 			    const char *modname, intmod_id module, int id)
6733 {
6734   gfc_symtree *tmp_symtree;
6735   gfc_symbol *sym;
6736 
6737   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6738   if (tmp_symtree != NULL)
6739     {
6740       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6741 	return;
6742       else
6743 	gfc_error ("Symbol %qs already declared", name);
6744     }
6745 
6746   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6747   sym = tmp_symtree->n.sym;
6748 
6749   sym->module = gfc_get_string ("%s", modname);
6750   sym->attr.flavor = FL_PARAMETER;
6751   sym->ts.type = BT_INTEGER;
6752   sym->ts.kind = gfc_default_integer_kind;
6753   sym->attr.use_assoc = 1;
6754   sym->from_intmod = module;
6755   sym->intmod_sym_id = id;
6756   sym->attr.dimension = 1;
6757   sym->as = gfc_get_array_spec ();
6758   sym->as->rank = 1;
6759   sym->as->type = AS_EXPLICIT;
6760   sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6761   sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
6762 
6763   sym->value = value;
6764   sym->value->shape = gfc_get_shape (1);
6765   mpz_init_set_ui (sym->value->shape[0], size);
6766 }
6767 
6768 
6769 /* Add an derived type for a given module.  */
6770 
6771 static void
create_derived_type(const char * name,const char * modname,intmod_id module,int id)6772 create_derived_type (const char *name, const char *modname,
6773 		      intmod_id module, int id)
6774 {
6775   gfc_symtree *tmp_symtree;
6776   gfc_symbol *sym, *dt_sym;
6777   gfc_interface *intr, *head;
6778 
6779   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6780   if (tmp_symtree != NULL)
6781     {
6782       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6783 	return;
6784       else
6785 	gfc_error ("Symbol %qs already declared", name);
6786     }
6787 
6788   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6789   sym = tmp_symtree->n.sym;
6790   sym->module = gfc_get_string ("%s", modname);
6791   sym->from_intmod = module;
6792   sym->intmod_sym_id = id;
6793   sym->attr.flavor = FL_PROCEDURE;
6794   sym->attr.function = 1;
6795   sym->attr.generic = 1;
6796 
6797   gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
6798 		    gfc_current_ns, &tmp_symtree, false);
6799   dt_sym = tmp_symtree->n.sym;
6800   dt_sym->name = gfc_get_string ("%s", sym->name);
6801   dt_sym->attr.flavor = FL_DERIVED;
6802   dt_sym->attr.private_comp = 1;
6803   dt_sym->attr.zero_comp = 1;
6804   dt_sym->attr.use_assoc = 1;
6805   dt_sym->module = gfc_get_string ("%s", modname);
6806   dt_sym->from_intmod = module;
6807   dt_sym->intmod_sym_id = id;
6808 
6809   head = sym->generic;
6810   intr = gfc_get_interface ();
6811   intr->sym = dt_sym;
6812   intr->where = gfc_current_locus;
6813   intr->next = head;
6814   sym->generic = intr;
6815   sym->attr.if_source = IFSRC_DECL;
6816 }
6817 
6818 
6819 /* Read the contents of the module file into a temporary buffer.  */
6820 
6821 static void
read_module_to_tmpbuf()6822 read_module_to_tmpbuf ()
6823 {
6824   /* We don't know the uncompressed size, so enlarge the buffer as
6825      needed.  */
6826   int cursz = 4096;
6827   int rsize = cursz;
6828   int len = 0;
6829 
6830   module_content = XNEWVEC (char, cursz);
6831 
6832   while (1)
6833     {
6834       int nread = gzread (module_fp, module_content + len, rsize);
6835       len += nread;
6836       if (nread < rsize)
6837 	break;
6838       cursz *= 2;
6839       module_content = XRESIZEVEC (char, module_content, cursz);
6840       rsize = cursz - len;
6841     }
6842 
6843   module_content = XRESIZEVEC (char, module_content, len + 1);
6844   module_content[len] = '\0';
6845 
6846   module_pos = 0;
6847 }
6848 
6849 
6850 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
6851 
6852 static void
use_iso_fortran_env_module(void)6853 use_iso_fortran_env_module (void)
6854 {
6855   static char mod[] = "iso_fortran_env";
6856   gfc_use_rename *u;
6857   gfc_symbol *mod_sym;
6858   gfc_symtree *mod_symtree;
6859   gfc_expr *expr;
6860   int i, j;
6861 
6862   intmod_sym symbol[] = {
6863 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6864 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6865 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6866 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6867 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6868 #include "iso-fortran-env.def"
6869     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
6870 
6871   i = 0;
6872 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6873 #include "iso-fortran-env.def"
6874 
6875   /* Generate the symbol for the module itself.  */
6876   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
6877   if (mod_symtree == NULL)
6878     {
6879       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
6880       gcc_assert (mod_symtree);
6881       mod_sym = mod_symtree->n.sym;
6882 
6883       mod_sym->attr.flavor = FL_MODULE;
6884       mod_sym->attr.intrinsic = 1;
6885       mod_sym->module = gfc_get_string ("%s", mod);
6886       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
6887     }
6888   else
6889     if (!mod_symtree->n.sym->attr.intrinsic)
6890       gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6891 		 "non-intrinsic module name used previously", mod);
6892 
6893   /* Generate the symbols for the module integer named constants.  */
6894 
6895   for (i = 0; symbol[i].name; i++)
6896     {
6897       bool found = false;
6898       for (u = gfc_rename_list; u; u = u->next)
6899 	{
6900 	  if (strcmp (symbol[i].name, u->use_name) == 0)
6901 	    {
6902 	      found = true;
6903 	      u->found = 1;
6904 
6905 	      if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
6906 				   "referenced at %L, is not in the selected "
6907 				   "standard", symbol[i].name, &u->where))
6908 	        continue;
6909 
6910 	      if ((flag_default_integer || flag_default_real_8)
6911 		  && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6912 		gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6913 				 "constant from intrinsic module "
6914 				 "ISO_FORTRAN_ENV at %L is incompatible with "
6915 				 "option %qs", &u->where,
6916 				 flag_default_integer
6917 				   ? "-fdefault-integer-8"
6918 				   : "-fdefault-real-8");
6919 	      switch (symbol[i].id)
6920 		{
6921 #define NAMED_INTCST(a,b,c,d) \
6922 		case a:
6923 #include "iso-fortran-env.def"
6924 		  create_int_parameter (u->local_name[0] ? u->local_name
6925 							 : u->use_name,
6926 					symbol[i].value, mod,
6927 					INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6928 		  break;
6929 
6930 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6931 		case a:\
6932 		  expr = gfc_get_array_expr (BT_INTEGER, \
6933 					     gfc_default_integer_kind,\
6934 					     NULL); \
6935 		  for (j = 0; KINDS[j].kind != 0; j++) \
6936 		    gfc_constructor_append_expr (&expr->value.constructor, \
6937 			gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6938 					  KINDS[j].kind), NULL); \
6939 		  create_int_parameter_array (u->local_name[0] ? u->local_name \
6940 							 : u->use_name, \
6941 					      j, expr, mod, \
6942 					      INTMOD_ISO_FORTRAN_ENV, \
6943 					      symbol[i].id); \
6944 		  break;
6945 #include "iso-fortran-env.def"
6946 
6947 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6948 		case a:
6949 #include "iso-fortran-env.def"
6950                   create_derived_type (u->local_name[0] ? u->local_name
6951 							: u->use_name,
6952 				       mod, INTMOD_ISO_FORTRAN_ENV,
6953 				       symbol[i].id);
6954 		  break;
6955 
6956 #define NAMED_FUNCTION(a,b,c,d) \
6957 		case a:
6958 #include "iso-fortran-env.def"
6959 		  create_intrinsic_function (u->local_name[0] ? u->local_name
6960 							      : u->use_name,
6961 					     symbol[i].id, mod,
6962 					     INTMOD_ISO_FORTRAN_ENV, false,
6963 					     NULL);
6964 		  break;
6965 
6966 		default:
6967 		  gcc_unreachable ();
6968 		}
6969 	    }
6970 	}
6971 
6972       if (!found && !only_flag)
6973 	{
6974 	  if ((gfc_option.allow_std & symbol[i].standard) == 0)
6975 	    continue;
6976 
6977 	  if ((flag_default_integer || flag_default_real_8)
6978 	      && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6979 	    gfc_warning_now (0,
6980 			     "Use of the NUMERIC_STORAGE_SIZE named constant "
6981 			     "from intrinsic module ISO_FORTRAN_ENV at %C is "
6982 			     "incompatible with option %s",
6983 			     flag_default_integer
6984 				? "-fdefault-integer-8" : "-fdefault-real-8");
6985 
6986 	  switch (symbol[i].id)
6987 	    {
6988 #define NAMED_INTCST(a,b,c,d) \
6989 	    case a:
6990 #include "iso-fortran-env.def"
6991 	      create_int_parameter (symbol[i].name, symbol[i].value, mod,
6992 				    INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6993 	      break;
6994 
6995 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6996 	    case a:\
6997 	      expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6998 					 NULL); \
6999 	      for (j = 0; KINDS[j].kind != 0; j++) \
7000 		gfc_constructor_append_expr (&expr->value.constructor, \
7001                       gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7002                                         KINDS[j].kind), NULL); \
7003             create_int_parameter_array (symbol[i].name, j, expr, mod, \
7004                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
7005             break;
7006 #include "iso-fortran-env.def"
7007 
7008 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7009 	  case a:
7010 #include "iso-fortran-env.def"
7011 	    create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
7012 				 symbol[i].id);
7013 	    break;
7014 
7015 #define NAMED_FUNCTION(a,b,c,d) \
7016 		case a:
7017 #include "iso-fortran-env.def"
7018 		  create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
7019 					     INTMOD_ISO_FORTRAN_ENV, false,
7020 					     NULL);
7021 		  break;
7022 
7023 	  default:
7024 	    gcc_unreachable ();
7025 	  }
7026 	}
7027     }
7028 
7029   for (u = gfc_rename_list; u; u = u->next)
7030     {
7031       if (u->found)
7032 	continue;
7033 
7034       gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
7035 		     "module ISO_FORTRAN_ENV", u->use_name, &u->where);
7036     }
7037 }
7038 
7039 
7040 /* Process a USE directive.  */
7041 
7042 static void
gfc_use_module(gfc_use_list * module)7043 gfc_use_module (gfc_use_list *module)
7044 {
7045   char *filename;
7046   gfc_state_data *p;
7047   int c, line, start;
7048   gfc_symtree *mod_symtree;
7049   gfc_use_list *use_stmt;
7050   locus old_locus = gfc_current_locus;
7051 
7052   gfc_current_locus = module->where;
7053   module_name = module->module_name;
7054   gfc_rename_list = module->rename;
7055   only_flag = module->only_flag;
7056   current_intmod = INTMOD_NONE;
7057 
7058   if (!only_flag)
7059     gfc_warning_now (OPT_Wuse_without_only,
7060 		     "USE statement at %C has no ONLY qualifier");
7061 
7062   if (gfc_state_stack->state == COMP_MODULE
7063       || module->submodule_name == NULL)
7064     {
7065       filename = XALLOCAVEC (char, strlen (module_name)
7066 				   + strlen (MODULE_EXTENSION) + 1);
7067       strcpy (filename, module_name);
7068       strcat (filename, MODULE_EXTENSION);
7069     }
7070   else
7071     {
7072       filename = XALLOCAVEC (char, strlen (module->submodule_name)
7073 				   + strlen (SUBMODULE_EXTENSION) + 1);
7074       strcpy (filename, module->submodule_name);
7075       strcat (filename, SUBMODULE_EXTENSION);
7076     }
7077 
7078   /* First, try to find an non-intrinsic module, unless the USE statement
7079      specified that the module is intrinsic.  */
7080   module_fp = NULL;
7081   if (!module->intrinsic)
7082     module_fp = gzopen_included_file (filename, true, true);
7083 
7084   /* Then, see if it's an intrinsic one, unless the USE statement
7085      specified that the module is non-intrinsic.  */
7086   if (module_fp == NULL && !module->non_intrinsic)
7087     {
7088       if (strcmp (module_name, "iso_fortran_env") == 0
7089 	  && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
7090 			     "intrinsic module at %C"))
7091        {
7092 	 use_iso_fortran_env_module ();
7093 	 free_rename (module->rename);
7094 	 module->rename = NULL;
7095 	 gfc_current_locus = old_locus;
7096 	 module->intrinsic = true;
7097 	 return;
7098        }
7099 
7100       if (strcmp (module_name, "iso_c_binding") == 0
7101 	  && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
7102 	{
7103 	  import_iso_c_binding_module();
7104 	  free_rename (module->rename);
7105 	  module->rename = NULL;
7106 	  gfc_current_locus = old_locus;
7107 	  module->intrinsic = true;
7108 	  return;
7109 	}
7110 
7111       module_fp = gzopen_intrinsic_module (filename);
7112 
7113       if (module_fp == NULL && module->intrinsic)
7114 	gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
7115 			 module_name);
7116 
7117       /* Check for the IEEE modules, so we can mark their symbols
7118 	 accordingly when we read them.  */
7119       if (strcmp (module_name, "ieee_features") == 0
7120 	  && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
7121 	{
7122 	  current_intmod = INTMOD_IEEE_FEATURES;
7123 	}
7124       else if (strcmp (module_name, "ieee_exceptions") == 0
7125 	       && gfc_notify_std (GFC_STD_F2003,
7126 				  "IEEE_EXCEPTIONS module at %C"))
7127 	{
7128 	  current_intmod = INTMOD_IEEE_EXCEPTIONS;
7129 	}
7130       else if (strcmp (module_name, "ieee_arithmetic") == 0
7131 	       && gfc_notify_std (GFC_STD_F2003,
7132 				  "IEEE_ARITHMETIC module at %C"))
7133 	{
7134 	  current_intmod = INTMOD_IEEE_ARITHMETIC;
7135 	}
7136     }
7137 
7138   if (module_fp == NULL)
7139     {
7140       if (gfc_state_stack->state != COMP_SUBMODULE
7141 	  && module->submodule_name == NULL)
7142 	gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
7143 			 filename, xstrerror (errno));
7144       else
7145 	gfc_fatal_error ("Module file %qs has not been generated, either "
7146 			 "because the module does not contain a MODULE "
7147 			 "PROCEDURE or there is an error in the module.",
7148 			 filename);
7149     }
7150 
7151   /* Check that we haven't already USEd an intrinsic module with the
7152      same name.  */
7153 
7154   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
7155   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
7156     gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7157 	       "intrinsic module name used previously", module_name);
7158 
7159   iomode = IO_INPUT;
7160   module_line = 1;
7161   module_column = 1;
7162   start = 0;
7163 
7164   read_module_to_tmpbuf ();
7165   gzclose (module_fp);
7166 
7167   /* Skip the first line of the module, after checking that this is
7168      a gfortran module file.  */
7169   line = 0;
7170   while (line < 1)
7171     {
7172       c = module_char ();
7173       if (c == EOF)
7174 	bad_module ("Unexpected end of module");
7175       if (start++ < 3)
7176 	parse_name (c);
7177       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
7178 	  || (start == 2 && strcmp (atom_name, " module") != 0))
7179 	gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7180 			 " module file", module_fullpath);
7181       if (start == 3)
7182 	{
7183 	  if (strcmp (atom_name, " version") != 0
7184 	      || module_char () != ' '
7185 	      || parse_atom () != ATOM_STRING
7186 	      || strcmp (atom_string, MOD_VERSION))
7187 	    gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7188 			     " because it was created by a different"
7189 			     " version of GNU Fortran", module_fullpath);
7190 
7191 	  free (atom_string);
7192 	}
7193 
7194       if (c == '\n')
7195 	line++;
7196     }
7197 
7198   /* Make sure we're not reading the same module that we may be building.  */
7199   for (p = gfc_state_stack; p; p = p->previous)
7200     if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
7201 	 && strcmp (p->sym->name, module_name) == 0)
7202       {
7203 	if (p->state == COMP_SUBMODULE)
7204 	  gfc_fatal_error ("Cannot USE a submodule that is currently built");
7205 	else
7206 	  gfc_fatal_error ("Cannot USE a module that is currently built");
7207       }
7208 
7209   init_pi_tree ();
7210   init_true_name_tree ();
7211 
7212   read_module ();
7213 
7214   free_true_name (true_name_root);
7215   true_name_root = NULL;
7216 
7217   free_pi_tree (pi_root);
7218   pi_root = NULL;
7219 
7220   XDELETEVEC (module_content);
7221   module_content = NULL;
7222 
7223   use_stmt = gfc_get_use_list ();
7224   *use_stmt = *module;
7225   use_stmt->next = gfc_current_ns->use_stmts;
7226   gfc_current_ns->use_stmts = use_stmt;
7227 
7228   gfc_current_locus = old_locus;
7229 }
7230 
7231 
7232 /* Remove duplicated intrinsic operators from the rename list.  */
7233 
7234 static void
rename_list_remove_duplicate(gfc_use_rename * list)7235 rename_list_remove_duplicate (gfc_use_rename *list)
7236 {
7237   gfc_use_rename *seek, *last;
7238 
7239   for (; list; list = list->next)
7240     if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
7241       {
7242 	last = list;
7243 	for (seek = list->next; seek; seek = last->next)
7244 	  {
7245 	    if (list->op == seek->op)
7246 	      {
7247 		last->next = seek->next;
7248 		free (seek);
7249 	      }
7250 	    else
7251 	      last = seek;
7252 	  }
7253       }
7254 }
7255 
7256 
7257 /* Process all USE directives.  */
7258 
7259 void
gfc_use_modules(void)7260 gfc_use_modules (void)
7261 {
7262   gfc_use_list *next, *seek, *last;
7263 
7264   for (next = module_list; next; next = next->next)
7265     {
7266       bool non_intrinsic = next->non_intrinsic;
7267       bool intrinsic = next->intrinsic;
7268       bool neither = !non_intrinsic && !intrinsic;
7269 
7270       for (seek = next->next; seek; seek = seek->next)
7271 	{
7272 	  if (next->module_name != seek->module_name)
7273 	    continue;
7274 
7275 	  if (seek->non_intrinsic)
7276 	    non_intrinsic = true;
7277 	  else if (seek->intrinsic)
7278 	    intrinsic = true;
7279 	  else
7280 	    neither = true;
7281 	}
7282 
7283       if (intrinsic && neither && !non_intrinsic)
7284 	{
7285 	  char *filename;
7286           FILE *fp;
7287 
7288 	  filename = XALLOCAVEC (char,
7289 				 strlen (next->module_name)
7290 				 + strlen (MODULE_EXTENSION) + 1);
7291 	  strcpy (filename, next->module_name);
7292 	  strcat (filename, MODULE_EXTENSION);
7293 	  fp = gfc_open_included_file (filename, true, true);
7294 	  if (fp != NULL)
7295 	    {
7296 	      non_intrinsic = true;
7297 	      fclose (fp);
7298 	    }
7299 	}
7300 
7301       last = next;
7302       for (seek = next->next; seek; seek = last->next)
7303 	{
7304 	  if (next->module_name != seek->module_name)
7305 	    {
7306 	      last = seek;
7307 	      continue;
7308 	    }
7309 
7310 	  if ((!next->intrinsic && !seek->intrinsic)
7311 	      || (next->intrinsic && seek->intrinsic)
7312 	      || !non_intrinsic)
7313 	    {
7314 	      if (!seek->only_flag)
7315 		next->only_flag = false;
7316 	      if (seek->rename)
7317 		{
7318 		  gfc_use_rename *r = seek->rename;
7319 		  while (r->next)
7320 		    r = r->next;
7321 		  r->next = next->rename;
7322 		  next->rename = seek->rename;
7323 		}
7324 	      last->next = seek->next;
7325 	      free (seek);
7326 	    }
7327 	  else
7328 	    last = seek;
7329 	}
7330     }
7331 
7332   for (; module_list; module_list = next)
7333     {
7334       next = module_list->next;
7335       rename_list_remove_duplicate (module_list->rename);
7336       gfc_use_module (module_list);
7337       free (module_list);
7338     }
7339   gfc_rename_list = NULL;
7340 }
7341 
7342 
7343 void
gfc_free_use_stmts(gfc_use_list * use_stmts)7344 gfc_free_use_stmts (gfc_use_list *use_stmts)
7345 {
7346   gfc_use_list *next;
7347   for (; use_stmts; use_stmts = next)
7348     {
7349       gfc_use_rename *next_rename;
7350 
7351       for (; use_stmts->rename; use_stmts->rename = next_rename)
7352 	{
7353 	  next_rename = use_stmts->rename->next;
7354 	  free (use_stmts->rename);
7355 	}
7356       next = use_stmts->next;
7357       free (use_stmts);
7358     }
7359 }
7360 
7361 
7362 void
gfc_module_init_2(void)7363 gfc_module_init_2 (void)
7364 {
7365   last_atom = ATOM_LPAREN;
7366   gfc_rename_list = NULL;
7367   module_list = NULL;
7368 }
7369 
7370 
7371 void
gfc_module_done_2(void)7372 gfc_module_done_2 (void)
7373 {
7374   free_rename (gfc_rename_list);
7375   gfc_rename_list = NULL;
7376 }
7377