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