1	/* Parse tree dumper
2	Copyright (C) 2003-2023 Free Software Foundation, Inc.
3	Contributed by Steven Bosscher
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21
22	/* Actually this is just a collection of routines that used to be
23	scattered around the sources. Now that they are all in a single
24	file, almost all of them can be static, and the other files don't
25	have this mess in them.
26
27	As a nice side-effect, this file can act as documentation of the
28	gfc_code and gfc_expr structures and all their friends and
29	relatives.
30
31	TODO: Dump DATA. */
32
33	#include "config.h"
34	#include "system.h"
35	#include "coretypes.h"
36	#include "gfortran.h"
37	#include "constructor.h"
38	#include "version.h"
39	#include "parse.h" /* For gfc_ascii_statement. */
40
41	/* Keep track of indentation for symbol tree dumps. */
42	static int show_level = 0;
43
44	/* The file handle we're dumping to is kept in a static variable. This
45	is not too cool, but it avoids a lot of passing it around. */
46	static FILE *dumpfile;
47
48	/* Forward declaration of some of the functions. */
49	static void show_expr (gfc_expr *p);
50	static void show_code_node (int, gfc_code *);
51	static void show_namespace (gfc_namespace *ns);
52	static void show_code (int, gfc_code *);
53	static void show_symbol (gfc_symbol *);
54	static void show_typespec (gfc_typespec *);
55	static void show_ref (gfc_ref *);
56	static void show_attr (symbol_attribute *, const char *);
57
58	DEBUG_FUNCTION void
59	debug (symbol_attribute *attr)
60	{
61	FILE *tmp = dumpfile;
62	dumpfile = stderr;
63	show_attr (attr, NULL);
64	fputc (c: '\n', stream: dumpfile);
65	dumpfile = tmp;
66	}
67
68	DEBUG_FUNCTION void
69	debug (gfc_formal_arglist *formal)
70	{
71	FILE *tmp = dumpfile;
72	dumpfile = stderr;
73	for (; formal; formal = formal->next)
74	{
75	fputc (c: '\n', stream: dumpfile);
76	show_symbol (formal->sym);
77	}
78	fputc (c: '\n', stream: dumpfile);
79	dumpfile = tmp;
80	}
81
82	DEBUG_FUNCTION void
83	debug (symbol_attribute attr)
84	{
85	debug (attr: &attr);
86	}
87
88	DEBUG_FUNCTION void
89	debug (gfc_expr *e)
90	{
91	FILE *tmp = dumpfile;
92	dumpfile = stderr;
93	if (e != NULL)
94	{
95	show_expr (p: e);
96	fputc (c: ' ', stream: dumpfile);
97	show_typespec (&e->ts);
98	}
99	else
100	fputs (s: "() ", stream: dumpfile);
101
102	fputc (c: '\n', stream: dumpfile);
103	dumpfile = tmp;
104	}
105
106	DEBUG_FUNCTION void
107	debug (gfc_typespec *ts)
108	{
109	FILE *tmp = dumpfile;
110	dumpfile = stderr;
111	show_typespec (ts);
112	fputc (c: '\n', stream: dumpfile);
113	dumpfile = tmp;
114	}
115
116	DEBUG_FUNCTION void
117	debug (gfc_typespec ts)
118	{
119	debug (ts: &ts);
120	}
121
122	DEBUG_FUNCTION void
123	debug (gfc_ref *p)
124	{
125	FILE *tmp = dumpfile;
126	dumpfile = stderr;
127	show_ref (p);
128	fputc (c: '\n', stream: dumpfile);
129	dumpfile = tmp;
130	}
131
132	DEBUG_FUNCTION void
133	debug (gfc_namespace *ns)
134	{
135	FILE *tmp = dumpfile;
136	dumpfile = stderr;
137	show_namespace (ns);
138	fputc (c: '\n', stream: dumpfile);
139	dumpfile = tmp;
140	}
141
142	DEBUG_FUNCTION void
143	gfc_debug_expr (gfc_expr *e)
144	{
145	FILE *tmp = dumpfile;
146	dumpfile = stderr;
147	show_expr (p: e);
148	fputc (c: '\n', stream: dumpfile);
149	dumpfile = tmp;
150	}
151
152	/* Allow for dumping of a piece of code in the debugger. */
153
154	DEBUG_FUNCTION void
155	gfc_debug_code (gfc_code *c)
156	{
157	FILE *tmp = dumpfile;
158	dumpfile = stderr;
159	show_code (1, c);
160	fputc (c: '\n', stream: dumpfile);
161	dumpfile = tmp;
162	}
163
164	DEBUG_FUNCTION void
165	debug (gfc_symbol *sym)
166	{
167	FILE *tmp = dumpfile;
168	dumpfile = stderr;
169	show_symbol (sym);
170	fputc (c: '\n', stream: dumpfile);
171	dumpfile = tmp;
172	}
173
174	/* Do indentation for a specific level. */
175
176	static inline void
177	code_indent (int level, gfc_st_label *label)
178	{
179	int i;
180
181	if (label != NULL)
182	fprintf (stream: dumpfile, format: "%-5d ", label->value);
183
184	for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
185	fputc (c: ' ', stream: dumpfile);
186	}
187
188
189	/* Simple indentation at the current level. This one
190	is used to show symbols. */
191
192	static inline void
193	show_indent (void)
194	{
195	fputc (c: '\n', stream: dumpfile);
196	code_indent (level: show_level, NULL);
197	}
198
199
200	/* Show type-specific information. */
201
202	static void
203	show_typespec (gfc_typespec *ts)
204	{
205	if (ts->type == BT_ASSUMED)
206	{
207	fputs (s: "(TYPE(*))", stream: dumpfile);
208	return;
209	}
210
211	fprintf (stream: dumpfile, format: "(%s ", gfc_basic_typename (ts->type));
212
213	switch (ts->type)
214	{
215	case BT_DERIVED:
216	case BT_CLASS:
217	case BT_UNION:
218	fprintf (stream: dumpfile, format: "%s", ts->u.derived->name);
219	break;
220
221	case BT_CHARACTER:
222	if (ts->u.cl)
223	show_expr (p: ts->u.cl->length);
224	fprintf(stream: dumpfile, format: " %d", ts->kind);
225	break;
226
227	default:
228	fprintf (stream: dumpfile, format: "%d", ts->kind);
229	break;
230	}
231	if (ts->is_c_interop)
232	fputs (s: " C_INTEROP", stream: dumpfile);
233
234	if (ts->is_iso_c)
235	fputs (s: " ISO_C", stream: dumpfile);
236
237	if (ts->deferred)
238	fputs (s: " DEFERRED", stream: dumpfile);
239
240	fputc (c: ')', stream: dumpfile);
241	}
242
243
244	/* Show an actual argument list. */
245
246	static void
247	show_actual_arglist (gfc_actual_arglist *a)
248	{
249	fputc (c: '(', stream: dumpfile);
250
251	for (; a; a = a->next)
252	{
253	fputc (c: '(', stream: dumpfile);
254	if (a->name != NULL)
255	fprintf (stream: dumpfile, format: "%s = ", a->name);
256	if (a->expr != NULL)
257	show_expr (p: a->expr);
258	else
259	fputs (s: "(arg not-present)", stream: dumpfile);
260
261	fputc (c: ')', stream: dumpfile);
262	if (a->next != NULL)
263	fputc (c: ' ', stream: dumpfile);
264	}
265
266	fputc (c: ')', stream: dumpfile);
267	}
268
269
270	/* Show a gfc_array_spec array specification structure. */
271
272	static void
273	show_array_spec (gfc_array_spec *as)
274	{
275	const char *c;
276	int i;
277
278	if (as == NULL)
279	{
280	fputs (s: "()", stream: dumpfile);
281	return;
282	}
283
284	fprintf (stream: dumpfile, format: "(%d [%d]", as->rank, as->corank);
285
286	if (as->rank + as->corank > 0 || as->rank == -1)
287	{
288	switch (as->type)
289	{
290	case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
291	case AS_DEFERRED: c = "AS_DEFERRED"; break;
292	case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
293	case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
294	case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
295	default:
296	gfc_internal_error ("show_array_spec(): Unhandled array shape "
297	"type.");
298	}
299	fprintf (stream: dumpfile, format: " %s ", c);
300
301	for (i = 0; i < as->rank + as->corank; i++)
302	{
303	show_expr (p: as->lower[i]);
304	fputc (c: ' ', stream: dumpfile);
305	show_expr (p: as->upper[i]);
306	fputc (c: ' ', stream: dumpfile);
307	}
308	}
309
310	fputc (c: ')', stream: dumpfile);
311	}
312
313
314	/* Show a gfc_array_ref array reference structure. */
315
316	static void
317	show_array_ref (gfc_array_ref * ar)
318	{
319	int i;
320
321	fputc (c: '(', stream: dumpfile);
322
323	switch (ar->type)
324	{
325	case AR_FULL:
326	fputs (s: "FULL", stream: dumpfile);
327	break;
328
329	case AR_SECTION:
330	for (i = 0; i < ar->dimen; i++)
331	{
332	/* There are two types of array sections: either the
333	elements are identified by an integer array ('vector'),
334	or by an index range. In the former case we only have to
335	print the start expression which contains the vector, in
336	the latter case we have to print any of lower and upper
337	bound and the stride, if they're present. */
338
339	if (ar->start[i] != NULL)
340	show_expr (p: ar->start[i]);
341
342	if (ar->dimen_type[i] == DIMEN_RANGE)
343	{
344	fputc (c: ':', stream: dumpfile);
345
346	if (ar->end[i] != NULL)
347	show_expr (p: ar->end[i]);
348
349	if (ar->stride[i] != NULL)
350	{
351	fputc (c: ':', stream: dumpfile);
352	show_expr (p: ar->stride[i]);
353	}
354	}
355
356	if (i != ar->dimen - 1)
357	fputs (s: " , ", stream: dumpfile);
358	}
359	break;
360
361	case AR_ELEMENT:
362	for (i = 0; i < ar->dimen; i++)
363	{
364	show_expr (p: ar->start[i]);
365	if (i != ar->dimen - 1)
366	fputs (s: " , ", stream: dumpfile);
367	}
368	break;
369
370	case AR_UNKNOWN:
371	fputs (s: "UNKNOWN", stream: dumpfile);
372	break;
373
374	default:
375	gfc_internal_error ("show_array_ref(): Unknown array reference");
376	}
377
378	fputc (c: ')', stream: dumpfile);
379	if (ar->codimen == 0)
380	return;
381
382	/* Show coarray part of the reference, if any. */
383	fputc (c: '[',stream: dumpfile);
384	for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
385	{
386	if (ar->dimen_type[i] == DIMEN_STAR)
387	fputc(c: '*',stream: dumpfile);
388	else if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
389	fputs(s: "THIS_IMAGE", stream: dumpfile);
390	else
391	{
392	show_expr (p: ar->start[i]);
393	if (ar->end[i])
394	{
395	fputc(c: ':', stream: dumpfile);
396	show_expr (p: ar->end[i]);
397	}
398	}
399	if (i != ar->dimen + ar->codimen - 1)
400	fputs (s: " , ", stream: dumpfile);
401
402	}
403	fputc (c: ']',stream: dumpfile);
404	}
405
406
407	/* Show a list of gfc_ref structures. */
408
409	static void
410	show_ref (gfc_ref *p)
411	{
412	for (; p; p = p->next)
413	switch (p->type)
414	{
415	case REF_ARRAY:
416	show_array_ref (ar: &p->u.ar);
417	break;
418
419	case REF_COMPONENT:
420	fprintf (stream: dumpfile, format: " %% %s", p->u.c.component->name);
421	break;
422
423	case REF_SUBSTRING:
424	fputc (c: '(', stream: dumpfile);
425	show_expr (p: p->u.ss.start);
426	fputc (c: ':', stream: dumpfile);
427	show_expr (p: p->u.ss.end);
428	fputc (c: ')', stream: dumpfile);
429	break;
430
431	case REF_INQUIRY:
432	switch (p->u.i)
433	{
434	case INQUIRY_KIND:
435	fprintf (stream: dumpfile, format: " INQUIRY_KIND ");
436	break;
437	case INQUIRY_LEN:
438	fprintf (stream: dumpfile, format: " INQUIRY_LEN ");
439	break;
440	case INQUIRY_RE:
441	fprintf (stream: dumpfile, format: " INQUIRY_RE ");
442	break;
443	case INQUIRY_IM:
444	fprintf (stream: dumpfile, format: " INQUIRY_IM ");
445	}
446	break;
447
448	default:
449	gfc_internal_error ("show_ref(): Bad component code");
450	}
451	}
452
453
454	/* Display a constructor. Works recursively for array constructors. */
455
456	static void
457	show_constructor (gfc_constructor_base base)
458	{
459	gfc_constructor *c;
460	for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (ctor: c))
461	{
462	if (c->iterator == NULL)
463	show_expr (p: c->expr);
464	else
465	{
466	fputc (c: '(', stream: dumpfile);
467	show_expr (p: c->expr);
468
469	fputc (c: ' ', stream: dumpfile);
470	show_expr (p: c->iterator->var);
471	fputc (c: '=', stream: dumpfile);
472	show_expr (p: c->iterator->start);
473	fputc (c: ',', stream: dumpfile);
474	show_expr (p: c->iterator->end);
475	fputc (c: ',', stream: dumpfile);
476	show_expr (p: c->iterator->step);
477
478	fputc (c: ')', stream: dumpfile);
479	}
480
481	if (gfc_constructor_next (ctor: c) != NULL)
482	fputs (s: " , ", stream: dumpfile);
483	}
484	}
485
486
487	static void
488	show_char_const (const gfc_char_t *c, gfc_charlen_t length)
489	{
490	fputc (c: '\'', stream: dumpfile);
491	for (size_t i = 0; i < (size_t) length; i++)
492	{
493	if (c[i] == '\'')
494	fputs (s: "''", stream: dumpfile);
495	else
496	fputs (s: gfc_print_wide_char (c[i]), stream: dumpfile);
497	}
498	fputc (c: '\'', stream: dumpfile);
499	}
500
501
502	/* Show a component-call expression. */
503
504	static void
505	show_compcall (gfc_expr* p)
506	{
507	gcc_assert (p->expr_type == EXPR_COMPCALL);
508
509	fprintf (stream: dumpfile, format: "%s", p->symtree->n.sym->name);
510	show_ref (p: p->ref);
511	fprintf (stream: dumpfile, format: "%s", p->value.compcall.name);
512
513	show_actual_arglist (a: p->value.compcall.actual);
514	}
515
516
517	/* Show an expression. */
518
519	static void
520	show_expr (gfc_expr *p)
521	{
522	const char *c;
523	int i;
524
525	if (p == NULL)
526	{
527	fputs (s: "()", stream: dumpfile);
528	return;
529	}
530
531	switch (p->expr_type)
532	{
533	case EXPR_SUBSTRING:
534	show_char_const (c: p->value.character.string, length: p->value.character.length);
535	show_ref (p: p->ref);
536	break;
537
538	case EXPR_STRUCTURE:
539	fprintf (stream: dumpfile, format: "%s(", p->ts.u.derived->name);
540	show_constructor (base: p->value.constructor);
541	fputc (c: ')', stream: dumpfile);
542	break;
543
544	case EXPR_ARRAY:
545	fputs (s: "(/ ", stream: dumpfile);
546	show_constructor (base: p->value.constructor);
547	fputs (s: " /)", stream: dumpfile);
548
549	show_ref (p: p->ref);
550	break;
551
552	case EXPR_NULL:
553	fputs (s: "NULL()", stream: dumpfile);
554	break;
555
556	case EXPR_CONSTANT:
557	switch (p->ts.type)
558	{
559	case BT_INTEGER:
560	mpz_out_str (dumpfile, 10, p->value.integer);
561
562	if (p->ts.kind != gfc_default_integer_kind)
563	fprintf (stream: dumpfile, format: "_%d", p->ts.kind);
564	break;
565
566	case BT_LOGICAL:
567	if (p->value.logical)
568	fputs (s: ".true.", stream: dumpfile);
569	else
570	fputs (s: ".false.", stream: dumpfile);
571	break;
572
573	case BT_REAL:
574	mpfr_out_str (dumpfile, 10, 0, p->value.real, GFC_RND_MODE);
575	if (p->ts.kind != gfc_default_real_kind)
576	fprintf (stream: dumpfile, format: "_%d", p->ts.kind);
577	break;
578
579	case BT_CHARACTER:
580	show_char_const (c: p->value.character.string,
581	length: p->value.character.length);
582	break;
583
584	case BT_COMPLEX:
585	fputs (s: "(complex ", stream: dumpfile);
586
587	mpfr_out_str (dumpfile, 10, 0, mpc_realref (p->value.complex),
588	GFC_RND_MODE);
589	if (p->ts.kind != gfc_default_complex_kind)
590	fprintf (stream: dumpfile, format: "_%d", p->ts.kind);
591
592	fputc (c: ' ', stream: dumpfile);
593
594	mpfr_out_str (dumpfile, 10, 0, mpc_imagref (p->value.complex),
595	GFC_RND_MODE);
596	if (p->ts.kind != gfc_default_complex_kind)
597	fprintf (stream: dumpfile, format: "_%d", p->ts.kind);
598
599	fputc (c: ')', stream: dumpfile);
600	break;
601
602	case BT_BOZ:
603	if (p->boz.rdx == 2)
604	fputs (s: "b'", stream: dumpfile);
605	else if (p->boz.rdx == 8)
606	fputs (s: "o'", stream: dumpfile);
607	else
608	fputs (s: "z'", stream: dumpfile);
609	fprintf (stream: dumpfile, format: "%s'", p->boz.str);
610	break;
611
612	case BT_HOLLERITH:
613	fprintf (stream: dumpfile, HOST_WIDE_INT_PRINT_DEC "H",
614	p->representation.length);
615	c = p->representation.string;
616	for (i = 0; i < p->representation.length; i++, c++)
617	{
618	fputc (c: *c, stream: dumpfile);
619	}
620	break;
621
622	default:
623	fputs (s: "???", stream: dumpfile);
624	break;
625	}
626
627	if (p->representation.string)
628	{
629	fputs (s: " {", stream: dumpfile);
630	c = p->representation.string;
631	for (i = 0; i < p->representation.length; i++, c++)
632	{
633	fprintf (stream: dumpfile, format: "%.2x", (unsigned int) *c);
634	if (i < p->representation.length - 1)
635	fputc (c: ',', stream: dumpfile);
636	}
637	fputc (c: '}', stream: dumpfile);
638	}
639
640	break;
641
642	case EXPR_VARIABLE:
643	if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
644	fprintf (stream: dumpfile, format: "%s:", p->symtree->n.sym->ns->proc_name->name);
645	fprintf (stream: dumpfile, format: "%s", p->symtree->n.sym->name);
646	show_ref (p: p->ref);
647	break;
648
649	case EXPR_OP:
650	fputc (c: '(', stream: dumpfile);
651	switch (p->value.op.op)
652	{
653	case INTRINSIC_UPLUS:
654	fputs (s: "U+ ", stream: dumpfile);
655	break;
656	case INTRINSIC_UMINUS:
657	fputs (s: "U- ", stream: dumpfile);
658	break;
659	case INTRINSIC_PLUS:
660	fputs (s: "+ ", stream: dumpfile);
661	break;
662	case INTRINSIC_MINUS:
663	fputs (s: "- ", stream: dumpfile);
664	break;
665	case INTRINSIC_TIMES:
666	fputs (s: "* ", stream: dumpfile);
667	break;
668	case INTRINSIC_DIVIDE:
669	fputs (s: "/ ", stream: dumpfile);
670	break;
671	case INTRINSIC_POWER:
672	fputs (s: "** ", stream: dumpfile);
673	break;
674	case INTRINSIC_CONCAT:
675	fputs (s: "// ", stream: dumpfile);
676	break;
677	case INTRINSIC_AND:
678	fputs (s: "AND ", stream: dumpfile);
679	break;
680	case INTRINSIC_OR:
681	fputs (s: "OR ", stream: dumpfile);
682	break;
683	case INTRINSIC_EQV:
684	fputs (s: "EQV ", stream: dumpfile);
685	break;
686	case INTRINSIC_NEQV:
687	fputs (s: "NEQV ", stream: dumpfile);
688	break;
689	case INTRINSIC_EQ:
690	case INTRINSIC_EQ_OS:
691	fputs (s: "== ", stream: dumpfile);
692	break;
693	case INTRINSIC_NE:
694	case INTRINSIC_NE_OS:
695	fputs (s: "/= ", stream: dumpfile);
696	break;
697	case INTRINSIC_GT:
698	case INTRINSIC_GT_OS:
699	fputs (s: "> ", stream: dumpfile);
700	break;
701	case INTRINSIC_GE:
702	case INTRINSIC_GE_OS:
703	fputs (s: ">= ", stream: dumpfile);
704	break;
705	case INTRINSIC_LT:
706	case INTRINSIC_LT_OS:
707	fputs (s: "< ", stream: dumpfile);
708	break;
709	case INTRINSIC_LE:
710	case INTRINSIC_LE_OS:
711	fputs (s: "<= ", stream: dumpfile);
712	break;
713	case INTRINSIC_NOT:
714	fputs (s: "NOT ", stream: dumpfile);
715	break;
716	case INTRINSIC_PARENTHESES:
717	fputs (s: "parens ", stream: dumpfile);
718	break;
719
720	default:
721	gfc_internal_error
722	("show_expr(): Bad intrinsic in expression");
723	}
724
725	show_expr (p: p->value.op.op1);
726
727	if (p->value.op.op2)
728	{
729	fputc (c: ' ', stream: dumpfile);
730	show_expr (p: p->value.op.op2);
731	}
732
733	fputc (c: ')', stream: dumpfile);
734	break;
735
736	case EXPR_FUNCTION:
737	if (p->value.function.name == NULL)
738	{
739	fprintf (stream: dumpfile, format: "%s", p->symtree->n.sym->name);
740	if (gfc_is_proc_ptr_comp (p))
741	show_ref (p: p->ref);
742	fputc (c: '[', stream: dumpfile);
743	show_actual_arglist (a: p->value.function.actual);
744	fputc (c: ']', stream: dumpfile);
745	}
746	else
747	{
748	fprintf (stream: dumpfile, format: "%s", p->value.function.name);
749	if (gfc_is_proc_ptr_comp (p))
750	show_ref (p: p->ref);
751	fputc (c: '[', stream: dumpfile);
752	fputc (c: '[', stream: dumpfile);
753	show_actual_arglist (a: p->value.function.actual);
754	fputc (c: ']', stream: dumpfile);
755	fputc (c: ']', stream: dumpfile);
756	}
757
758	break;
759
760	case EXPR_COMPCALL:
761	show_compcall (p);
762	break;
763
764	default:
765	gfc_internal_error ("show_expr(): Don't know how to show expr");
766	}
767	}
768
769	/* Show symbol attributes. The flavor and intent are followed by
770	whatever single bit attributes are present. */
771
772	static void
773	show_attr (symbol_attribute *attr, const char * module)
774	{
775	fputc (c: '(', stream: dumpfile);
776	if (attr->flavor != FL_UNKNOWN)
777	{
778	if (attr->flavor == FL_DERIVED && attr->pdt_template)
779	fputs (s: "PDT-TEMPLATE ", stream: dumpfile);
780	else
781	fprintf (stream: dumpfile, format: "%s ", gfc_code2string (flavors, attr->flavor));
782	}
783	if (attr->access != ACCESS_UNKNOWN)
784	fprintf (stream: dumpfile, format: "%s ", gfc_code2string (access_types, attr->access));
785	if (attr->proc != PROC_UNKNOWN)
786	fprintf (stream: dumpfile, format: "%s ", gfc_code2string (procedures, attr->proc));
787	if (attr->save != SAVE_NONE)
788	fprintf (stream: dumpfile, format: "%s", gfc_code2string (save_status, attr->save));
789
790	if (attr->artificial)
791	fputs (s: " ARTIFICIAL", stream: dumpfile);
792	if (attr->allocatable)
793	fputs (s: " ALLOCATABLE", stream: dumpfile);
794	if (attr->asynchronous)
795	fputs (s: " ASYNCHRONOUS", stream: dumpfile);
796	if (attr->codimension)
797	fputs (s: " CODIMENSION", stream: dumpfile);
798	if (attr->dimension)
799	fputs (s: " DIMENSION", stream: dumpfile);
800	if (attr->contiguous)
801	fputs (s: " CONTIGUOUS", stream: dumpfile);
802	if (attr->external)
803	fputs (s: " EXTERNAL", stream: dumpfile);
804	if (attr->intrinsic)
805	fputs (s: " INTRINSIC", stream: dumpfile);
806	if (attr->optional)
807	fputs (s: " OPTIONAL", stream: dumpfile);
808	if (attr->pdt_kind)
809	fputs (s: " KIND", stream: dumpfile);
810	if (attr->pdt_len)
811	fputs (s: " LEN", stream: dumpfile);
812	if (attr->pointer)
813	fputs (s: " POINTER", stream: dumpfile);
814	if (attr->subref_array_pointer)
815	fputs (s: " SUBREF-ARRAY-POINTER", stream: dumpfile);
816	if (attr->cray_pointer)
817	fputs (s: " CRAY-POINTER", stream: dumpfile);
818	if (attr->cray_pointee)
819	fputs (s: " CRAY-POINTEE", stream: dumpfile);
820	if (attr->is_protected)
821	fputs (s: " PROTECTED", stream: dumpfile);
822	if (attr->value)
823	fputs (s: " VALUE", stream: dumpfile);
824	if (attr->volatile_)
825	fputs (s: " VOLATILE", stream: dumpfile);
826	if (attr->threadprivate)
827	fputs (s: " THREADPRIVATE", stream: dumpfile);
828	if (attr->target)
829	fputs (s: " TARGET", stream: dumpfile);
830	if (attr->dummy)
831	{
832	fputs (s: " DUMMY", stream: dumpfile);
833	if (attr->intent != INTENT_UNKNOWN)
834	fprintf (stream: dumpfile, format: "(%s)", gfc_intent_string (attr->intent));
835	}
836
837	if (attr->result)
838	fputs (s: " RESULT", stream: dumpfile);
839	if (attr->entry)
840	fputs (s: " ENTRY", stream: dumpfile);
841	if (attr->entry_master)
842	fputs (s: " ENTRY-MASTER", stream: dumpfile);
843	if (attr->mixed_entry_master)
844	fputs (s: " MIXED-ENTRY-MASTER", stream: dumpfile);
845	if (attr->is_bind_c)
846	fputs (s: " BIND(C)", stream: dumpfile);
847
848	if (attr->data)
849	fputs (s: " DATA", stream: dumpfile);
850	if (attr->use_assoc)
851	{
852	fputs (s: " USE-ASSOC", stream: dumpfile);
853	if (module != NULL)
854	fprintf (stream: dumpfile, format: "(%s)", module);
855	}
856
857	if (attr->in_namelist)
858	fputs (s: " IN-NAMELIST", stream: dumpfile);
859	if (attr->in_common)
860	fputs (s: " IN-COMMON", stream: dumpfile);
861
862	if (attr->abstract)
863	fputs (s: " ABSTRACT", stream: dumpfile);
864	if (attr->function)
865	fputs (s: " FUNCTION", stream: dumpfile);
866	if (attr->subroutine)
867	fputs (s: " SUBROUTINE", stream: dumpfile);
868	if (attr->implicit_type)
869	fputs (s: " IMPLICIT-TYPE", stream: dumpfile);
870
871	if (attr->sequence)
872	fputs (s: " SEQUENCE", stream: dumpfile);
873	if (attr->alloc_comp)
874	fputs (s: " ALLOC-COMP", stream: dumpfile);
875	if (attr->pointer_comp)
876	fputs (s: " POINTER-COMP", stream: dumpfile);
877	if (attr->proc_pointer_comp)
878	fputs (s: " PROC-POINTER-COMP", stream: dumpfile);
879	if (attr->private_comp)
880	fputs (s: " PRIVATE-COMP", stream: dumpfile);
881	if (attr->zero_comp)
882	fputs (s: " ZERO-COMP", stream: dumpfile);
883	if (attr->coarray_comp)
884	fputs (s: " COARRAY-COMP", stream: dumpfile);
885	if (attr->lock_comp)
886	fputs (s: " LOCK-COMP", stream: dumpfile);
887	if (attr->event_comp)
888	fputs (s: " EVENT-COMP", stream: dumpfile);
889	if (attr->defined_assign_comp)
890	fputs (s: " DEFINED-ASSIGNED-COMP", stream: dumpfile);
891	if (attr->unlimited_polymorphic)
892	fputs (s: " UNLIMITED-POLYMORPHIC", stream: dumpfile);
893	if (attr->has_dtio_procs)
894	fputs (s: " HAS-DTIO-PROCS", stream: dumpfile);
895	if (attr->caf_token)
896	fputs (s: " CAF-TOKEN", stream: dumpfile);
897	if (attr->select_type_temporary)
898	fputs (s: " SELECT-TYPE-TEMPORARY", stream: dumpfile);
899	if (attr->associate_var)
900	fputs (s: " ASSOCIATE-VAR", stream: dumpfile);
901	if (attr->pdt_kind)
902	fputs (s: " PDT-KIND", stream: dumpfile);
903	if (attr->pdt_len)
904	fputs (s: " PDT-LEN", stream: dumpfile);
905	if (attr->pdt_type)
906	fputs (s: " PDT-TYPE", stream: dumpfile);
907	if (attr->pdt_array)
908	fputs (s: " PDT-ARRAY", stream: dumpfile);
909	if (attr->pdt_string)
910	fputs (s: " PDT-STRING", stream: dumpfile);
911	if (attr->omp_udr_artificial_var)
912	fputs (s: " OMP-UDR-ARTIFICIAL-VAR", stream: dumpfile);
913	if (attr->omp_declare_target)
914	fputs (s: " OMP-DECLARE-TARGET", stream: dumpfile);
915	if (attr->omp_declare_target_link)
916	fputs (s: " OMP-DECLARE-TARGET-LINK", stream: dumpfile);
917	if (attr->elemental)
918	fputs (s: " ELEMENTAL", stream: dumpfile);
919	if (attr->pure)
920	fputs (s: " PURE", stream: dumpfile);
921	if (attr->implicit_pure)
922	fputs (s: " IMPLICIT-PURE", stream: dumpfile);
923	if (attr->recursive)
924	fputs (s: " RECURSIVE", stream: dumpfile);
925	if (attr->unmaskable)
926	fputs (s: " UNMASKABKE", stream: dumpfile);
927	if (attr->masked)
928	fputs (s: " MASKED", stream: dumpfile);
929	if (attr->contained)
930	fputs (s: " CONTAINED", stream: dumpfile);
931	if (attr->mod_proc)
932	fputs (s: " MOD-PROC", stream: dumpfile);
933	if (attr->module_procedure)
934	fputs (s: " MODULE-PROCEDURE", stream: dumpfile);
935	if (attr->public_used)
936	fputs (s: " PUBLIC_USED", stream: dumpfile);
937	if (attr->array_outer_dependency)
938	fputs (s: " ARRAY-OUTER-DEPENDENCY", stream: dumpfile);
939	if (attr->noreturn)
940	fputs (s: " NORETURN", stream: dumpfile);
941	if (attr->always_explicit)
942	fputs (s: " ALWAYS-EXPLICIT", stream: dumpfile);
943	if (attr->is_main_program)
944	fputs (s: " IS-MAIN-PROGRAM", stream: dumpfile);
945	if (attr->oacc_routine_nohost)
946	fputs (s: " OACC-ROUTINE-NOHOST", stream: dumpfile);
947
948	/* FIXME: Still missing are oacc_routine_lop and ext_attr. */
949	fputc (c: ')', stream: dumpfile);
950	}
951
952
953	/* Show components of a derived type. */
954
955	static void
956	show_components (gfc_symbol *sym)
957	{
958	gfc_component *c;
959
960	for (c = sym->components; c; c = c->next)
961	{
962	show_indent ();
963	fprintf (stream: dumpfile, format: "(%s ", c->name);
964	show_typespec (ts: &c->ts);
965	if (c->kind_expr)
966	{
967	fputs (s: " kind_expr: ", stream: dumpfile);
968	show_expr (p: c->kind_expr);
969	}
970	if (c->param_list)
971	{
972	fputs (s: "PDT parameters", stream: dumpfile);
973	show_actual_arglist (a: c->param_list);
974	}
975
976	if (c->attr.allocatable)
977	fputs (s: " ALLOCATABLE", stream: dumpfile);
978	if (c->attr.pdt_kind)
979	fputs (s: " KIND", stream: dumpfile);
980	if (c->attr.pdt_len)
981	fputs (s: " LEN", stream: dumpfile);
982	if (c->attr.pointer)
983	fputs (s: " POINTER", stream: dumpfile);
984	if (c->attr.proc_pointer)
985	fputs (s: " PPC", stream: dumpfile);
986	if (c->attr.dimension)
987	fputs (s: " DIMENSION", stream: dumpfile);
988	fputc (c: ' ', stream: dumpfile);
989	show_array_spec (as: c->as);
990	if (c->attr.access)
991	fprintf (stream: dumpfile, format: " %s", gfc_code2string (access_types, c->attr.access));
992	fputc (c: ')', stream: dumpfile);
993	if (c->next != NULL)
994	fputc (c: ' ', stream: dumpfile);
995	}
996	}
997
998
999	/* Show the f2k_derived namespace with procedure bindings. */
1000
1001	static void
1002	show_typebound_proc (gfc_typebound_proc* tb, const char* name)
1003	{
1004	show_indent ();
1005
1006	if (tb->is_generic)
1007	fputs (s: "GENERIC", stream: dumpfile);
1008	else
1009	{
1010	fputs (s: "PROCEDURE, ", stream: dumpfile);
1011	if (tb->nopass)
1012	fputs (s: "NOPASS", stream: dumpfile);
1013	else
1014	{
1015	if (tb->pass_arg)
1016	fprintf (stream: dumpfile, format: "PASS(%s)", tb->pass_arg);
1017	else
1018	fputs (s: "PASS", stream: dumpfile);
1019	}
1020	if (tb->non_overridable)
1021	fputs (s: ", NON_OVERRIDABLE", stream: dumpfile);
1022	}
1023
1024	if (tb->access == ACCESS_PUBLIC)
1025	fputs (s: ", PUBLIC", stream: dumpfile);
1026	else
1027	fputs (s: ", PRIVATE", stream: dumpfile);
1028
1029	fprintf (stream: dumpfile, format: " :: %s => ", name);
1030
1031	if (tb->is_generic)
1032	{
1033	gfc_tbp_generic* g;
1034	for (g = tb->u.generic; g; g = g->next)
1035	{
1036	fputs (s: g->specific_st->name, stream: dumpfile);
1037	if (g->next)
1038	fputs (s: ", ", stream: dumpfile);
1039	}
1040	}
1041	else
1042	fputs (s: tb->u.specific->n.sym->name, stream: dumpfile);
1043	}
1044
1045	static void
1046	show_typebound_symtree (gfc_symtree* st)
1047	{
1048	gcc_assert (st->n.tb);
1049	show_typebound_proc (tb: st->n.tb, name: st->name);
1050	}
1051
1052	static void
1053	show_f2k_derived (gfc_namespace* f2k)
1054	{
1055	gfc_finalizer* f;
1056	int op;
1057
1058	show_indent ();
1059	fputs (s: "Procedure bindings:", stream: dumpfile);
1060	++show_level;
1061
1062	/* Finalizer bindings. */
1063	for (f = f2k->finalizers; f; f = f->next)
1064	{
1065	show_indent ();
1066	fprintf (stream: dumpfile, format: "FINAL %s", f->proc_tree->n.sym->name);
1067	}
1068
1069	/* Type-bound procedures. */
1070	gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
1071
1072	--show_level;
1073
1074	show_indent ();
1075	fputs (s: "Operator bindings:", stream: dumpfile);
1076	++show_level;
1077
1078	/* User-defined operators. */
1079	gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
1080
1081	/* Intrinsic operators. */
1082	for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
1083	if (f2k->tb_op[op])
1084	show_typebound_proc (tb: f2k->tb_op[op],
1085	name: gfc_op2string ((gfc_intrinsic_op) op));
1086
1087	--show_level;
1088	}
1089
1090
1091	/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
1092	show the interface. Information needed to reconstruct the list of
1093	specific interfaces associated with a generic symbol is done within
1094	that symbol. */
1095
1096	static void
1097	show_symbol (gfc_symbol *sym)
1098	{
1099	gfc_formal_arglist *formal;
1100	gfc_interface *intr;
1101	int i,len;
1102
1103	if (sym == NULL)
1104	return;
1105
1106	fprintf (stream: dumpfile, format: "|| symbol: '%s' ", sym->name);
1107	len = strlen (s: sym->name);
1108	for (i=len; i<12; i++)
1109	fputc(c: ' ', stream: dumpfile);
1110
1111	if (sym->binding_label)
1112	fprintf (stream: dumpfile,format: "|| binding_label: '%s' ", sym->binding_label);
1113
1114	++show_level;
1115
1116	show_indent ();
1117	fputs (s: "type spec : ", stream: dumpfile);
1118	show_typespec (ts: &sym->ts);
1119
1120	show_indent ();
1121	fputs (s: "attributes: ", stream: dumpfile);
1122	show_attr (attr: &sym->attr, module: sym->module);
1123
1124	if (sym->value)
1125	{
1126	show_indent ();
1127	fputs (s: "value: ", stream: dumpfile);
1128	show_expr (p: sym->value);
1129	}
1130
1131	if (sym->ts.type != BT_CLASS && sym->as)
1132	{
1133	show_indent ();
1134	fputs (s: "Array spec:", stream: dumpfile);
1135	show_array_spec (as: sym->as);
1136	}
1137	else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
1138	{
1139	show_indent ();
1140	fputs (s: "Array spec:", stream: dumpfile);
1141	show_array_spec (CLASS_DATA (sym)->as);
1142	}
1143
1144	if (sym->generic)
1145	{
1146	show_indent ();
1147	fputs (s: "Generic interfaces:", stream: dumpfile);
1148	for (intr = sym->generic; intr; intr = intr->next)
1149	fprintf (stream: dumpfile, format: " %s", intr->sym->name);
1150	}
1151
1152	if (sym->result)
1153	{
1154	show_indent ();
1155	fprintf (stream: dumpfile, format: "result: %s", sym->result->name);
1156	}
1157
1158	if (sym->components)
1159	{
1160	show_indent ();
1161	fputs (s: "components: ", stream: dumpfile);
1162	show_components (sym);
1163	}
1164
1165	if (sym->f2k_derived)
1166	{
1167	show_indent ();
1168	if (sym->hash_value)
1169	fprintf (stream: dumpfile, format: "hash: %d", sym->hash_value);
1170	show_f2k_derived (f2k: sym->f2k_derived);
1171	}
1172
1173	if (sym->formal)
1174	{
1175	show_indent ();
1176	fputs (s: "Formal arglist:", stream: dumpfile);
1177
1178	for (formal = sym->formal; formal; formal = formal->next)
1179	{
1180	if (formal->sym != NULL)
1181	fprintf (stream: dumpfile, format: " %s", formal->sym->name);
1182	else
1183	fputs (s: " [Alt Return]", stream: dumpfile);
1184	}
1185	}
1186
1187	if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
1188	&& sym->attr.proc != PROC_ST_FUNCTION
1189	&& !sym->attr.entry)
1190	{
1191	show_indent ();
1192	fputs (s: "Formal namespace", stream: dumpfile);
1193	show_namespace (ns: sym->formal_ns);
1194	}
1195
1196	if (sym->attr.flavor == FL_VARIABLE
1197	&& sym->param_list)
1198	{
1199	show_indent ();
1200	fputs (s: "PDT parameters", stream: dumpfile);
1201	show_actual_arglist (a: sym->param_list);
1202	}
1203
1204	if (sym->attr.flavor == FL_NAMELIST)
1205	{
1206	gfc_namelist *nl;
1207	show_indent ();
1208	fputs (s: "variables : ", stream: dumpfile);
1209	for (nl = sym->namelist; nl; nl = nl->next)
1210	fprintf (stream: dumpfile, format: " %s",nl->sym->name);
1211	}
1212
1213	--show_level;
1214	}
1215
1216
1217	/* Show a user-defined operator. Just prints an operator
1218	and the name of the associated subroutine, really. */
1219
1220	static void
1221	show_uop (gfc_user_op *uop)
1222	{
1223	gfc_interface *intr;
1224
1225	show_indent ();
1226	fprintf (stream: dumpfile, format: "%s:", uop->name);
1227
1228	for (intr = uop->op; intr; intr = intr->next)
1229	fprintf (stream: dumpfile, format: " %s", intr->sym->name);
1230	}
1231
1232
1233	/* Workhorse function for traversing the user operator symtree. */
1234
1235	static void
1236	traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
1237	{
1238	if (st == NULL)
1239	return;
1240
1241	(*func) (st->n.uop);
1242
1243	traverse_uop (st: st->left, func);
1244	traverse_uop (st: st->right, func);
1245	}
1246
1247
1248	/* Traverse the tree of user operator nodes. */
1249
1250	void
1251	gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
1252	{
1253	traverse_uop (st: ns->uop_root, func);
1254	}
1255
1256
1257	/* Function to display a common block. */
1258
1259	static void
1260	show_common (gfc_symtree *st)
1261	{
1262	gfc_symbol *s;
1263
1264	show_indent ();
1265	fprintf (stream: dumpfile, format: "common: /%s/ ", st->name);
1266
1267	s = st->n.common->head;
1268	while (s)
1269	{
1270	fprintf (stream: dumpfile, format: "%s", s->name);
1271	s = s->common_next;
1272	if (s)
1273	fputs (s: ", ", stream: dumpfile);
1274	}
1275	fputc (c: '\n', stream: dumpfile);
1276	}
1277
1278
1279	/* Worker function to display the symbol tree. */
1280
1281	static void
1282	show_symtree (gfc_symtree *st)
1283	{
1284	int len, i;
1285
1286	show_indent ();
1287
1288	len = strlen(s: st->name);
1289	fprintf (stream: dumpfile, format: "symtree: '%s'", st->name);
1290
1291	for (i=len; i<12; i++)
1292	fputc(c: ' ', stream: dumpfile);
1293
1294	if (st->ambiguous)
1295	fputs( s: " Ambiguous", stream: dumpfile);
1296
1297	if (st->n.sym->ns != gfc_current_ns)
1298	fprintf (stream: dumpfile, format: "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
1299	st->n.sym->ns->proc_name->name);
1300	else
1301	show_symbol (sym: st->n.sym);
1302	}
1303
1304
1305	/******************* Show gfc_code structures **************/
1306
1307
1308	/* Show a list of code structures. Mutually recursive with
1309	show_code_node(). */
1310
1311	static void
1312	show_code (int level, gfc_code *c)
1313	{
1314	for (; c; c = c->next)
1315	show_code_node (level, c);
1316	}
1317
1318	static void
1319	show_iterator (gfc_namespace *ns)
1320	{
1321	for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
1322	{
1323	gfc_constructor *c;
1324	if (sym != ns->omp_affinity_iterators)
1325	fputc (c: ',', stream: dumpfile);
1326	fputs (s: sym->name, stream: dumpfile);
1327	fputc (c: '=', stream: dumpfile);
1328	c = gfc_constructor_first (base: sym->value->value.constructor);
1329	show_expr (p: c->expr);
1330	fputc (c: ':', stream: dumpfile);
1331	c = gfc_constructor_next (ctor: c);
1332	show_expr (p: c->expr);
1333	c = gfc_constructor_next (ctor: c);
1334	if (c)
1335	{
1336	fputc (c: ':', stream: dumpfile);
1337	show_expr (p: c->expr);
1338	}
1339	}
1340	}
1341
1342	static void
1343	show_omp_namelist (int list_type, gfc_omp_namelist *n)
1344	{
1345	gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1346	gfc_omp_namelist *n2 = n;
1347	for (; n; n = n->next)
1348	{
1349	gfc_current_ns = ns_curr;
1350	if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND)
1351	{
1352	gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr;
1353	if (n->u2.ns != ns_iter)
1354	{
1355	if (n != n2)
1356	{
1357	fputs (s: ") ", stream: dumpfile);
1358	if (list_type == OMP_LIST_AFFINITY)
1359	fputs (s: "AFFINITY (", stream: dumpfile);
1360	else if (n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST)
1361	fputs (s: "DOACROSS (", stream: dumpfile);
1362	else
1363	fputs (s: "DEPEND (", stream: dumpfile);
1364	}
1365	if (n->u2.ns)
1366	{
1367	fputs (s: "ITERATOR(", stream: dumpfile);
1368	show_iterator (ns: n->u2.ns);
1369	fputc (c: ')', stream: dumpfile);
1370	fputc (c: list_type == OMP_LIST_AFFINITY ? ':' : ',', stream: dumpfile);
1371	}
1372	}
1373	ns_iter = n->u2.ns;
1374	}
1375	if (list_type == OMP_LIST_ALLOCATE)
1376	{
1377	if (n->u2.allocator)
1378	{
1379	fputs (s: "allocator(", stream: dumpfile);
1380	show_expr (p: n->u2.allocator);
1381	fputc (c: ')', stream: dumpfile);
1382	}
1383	if (n->expr && n->u.align)
1384	fputc (c: ',', stream: dumpfile);
1385	if (n->u.align)
1386	{
1387	fputs (s: "align(", stream: dumpfile);
1388	show_expr (p: n->u.align);
1389	fputc (c: ')', stream: dumpfile);
1390	}
1391	if (n->u2.allocator || n->u.align)
1392	fputc (c: ':', stream: dumpfile);
1393	if (n->expr)
1394	show_expr (p: n->expr);
1395	else
1396	fputs (s: n->sym->name, stream: dumpfile);
1397	if (n->next)
1398	fputs (s: ") ALLOCATE(", stream: dumpfile);
1399	continue;
1400	}
1401	if (list_type == OMP_LIST_REDUCTION)
1402	switch (n->u.reduction_op)
1403	{
1404	case OMP_REDUCTION_PLUS:
1405	case OMP_REDUCTION_TIMES:
1406	case OMP_REDUCTION_MINUS:
1407	case OMP_REDUCTION_AND:
1408	case OMP_REDUCTION_OR:
1409	case OMP_REDUCTION_EQV:
1410	case OMP_REDUCTION_NEQV:
1411	fprintf (stream: dumpfile, format: "%s:",
1412	gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op));
1413	break;
1414	case OMP_REDUCTION_MAX: fputs (s: "max:", stream: dumpfile); break;
1415	case OMP_REDUCTION_MIN: fputs (s: "min:", stream: dumpfile); break;
1416	case OMP_REDUCTION_IAND: fputs (s: "iand:", stream: dumpfile); break;
1417	case OMP_REDUCTION_IOR: fputs (s: "ior:", stream: dumpfile); break;
1418	case OMP_REDUCTION_IEOR: fputs (s: "ieor:", stream: dumpfile); break;
1419	case OMP_REDUCTION_USER:
1420	if (n->u2.udr)
1421	fprintf (stream: dumpfile, format: "%s:", n->u2.udr->udr->name);
1422	break;
1423	default: break;
1424	}
1425	else if (list_type == OMP_LIST_DEPEND)
1426	switch (n->u.depend_doacross_op)
1427	{
1428	case OMP_DEPEND_IN: fputs (s: "in:", stream: dumpfile); break;
1429	case OMP_DEPEND_OUT: fputs (s: "out:", stream: dumpfile); break;
1430	case OMP_DEPEND_INOUT: fputs (s: "inout:", stream: dumpfile); break;
1431	case OMP_DEPEND_INOUTSET: fputs (s: "inoutset:", stream: dumpfile); break;
1432	case OMP_DEPEND_DEPOBJ: fputs (s: "depobj:", stream: dumpfile); break;
1433	case OMP_DEPEND_MUTEXINOUTSET:
1434	fputs (s: "mutexinoutset:", stream: dumpfile);
1435	break;
1436	case OMP_DEPEND_SINK_FIRST:
1437	case OMP_DOACROSS_SINK_FIRST:
1438	fputs (s: "sink:", stream: dumpfile);
1439	while (1)
1440	{
1441	if (!n->sym)
1442	fputs (s: "omp_cur_iteration", stream: dumpfile);
1443	else
1444	fprintf (stream: dumpfile, format: "%s", n->sym->name);
1445	if (n->expr)
1446	{
1447	fputc (c: '+', stream: dumpfile);
1448	show_expr (p: n->expr);
1449	}
1450	if (n->next == NULL)
1451	break;
1452	else if (n->next->u.depend_doacross_op != OMP_DOACROSS_SINK)
1453	{
1454	if (n->next->u.depend_doacross_op
1455	== OMP_DOACROSS_SINK_FIRST)
1456	fputs (s: ") DOACROSS(", stream: dumpfile);
1457	else
1458	fputs (s: ") DEPEND(", stream: dumpfile);
1459	break;
1460	}
1461	fputc (c: ',', stream: dumpfile);
1462	n = n->next;
1463	}
1464	continue;
1465	default: break;
1466	}
1467	else if (list_type == OMP_LIST_MAP)
1468	switch (n->u.map_op)
1469	{
1470	case OMP_MAP_ALLOC: fputs (s: "alloc:", stream: dumpfile); break;
1471	case OMP_MAP_TO: fputs (s: "to:", stream: dumpfile); break;
1472	case OMP_MAP_FROM: fputs (s: "from:", stream: dumpfile); break;
1473	case OMP_MAP_TOFROM: fputs (s: "tofrom:", stream: dumpfile); break;
1474	case OMP_MAP_PRESENT_ALLOC: fputs (s: "present,alloc:", stream: dumpfile); break;
1475	case OMP_MAP_PRESENT_TO: fputs (s: "present,to:", stream: dumpfile); break;
1476	case OMP_MAP_PRESENT_FROM: fputs (s: "present,from:", stream: dumpfile); break;
1477	case OMP_MAP_PRESENT_TOFROM:
1478	fputs (s: "present,tofrom:", stream: dumpfile); break;
1479	case OMP_MAP_ALWAYS_TO: fputs (s: "always,to:", stream: dumpfile); break;
1480	case OMP_MAP_ALWAYS_FROM: fputs (s: "always,from:", stream: dumpfile); break;
1481	case OMP_MAP_ALWAYS_TOFROM: fputs (s: "always,tofrom:", stream: dumpfile); break;
1482	case OMP_MAP_ALWAYS_PRESENT_TO:
1483	fputs (s: "always,present,to:", stream: dumpfile); break;
1484	case OMP_MAP_ALWAYS_PRESENT_FROM:
1485	fputs (s: "always,present,from:", stream: dumpfile); break;
1486	case OMP_MAP_ALWAYS_PRESENT_TOFROM:
1487	fputs (s: "always,present,tofrom:", stream: dumpfile); break;
1488	case OMP_MAP_DELETE: fputs (s: "delete:", stream: dumpfile); break;
1489	case OMP_MAP_RELEASE: fputs (s: "release:", stream: dumpfile); break;
1490	default: break;
1491	}
1492	else if (list_type == OMP_LIST_LINEAR && n->u.linear.old_modifier)
1493	switch (n->u.linear.op)
1494	{
1495	case OMP_LINEAR_REF: fputs (s: "ref(", stream: dumpfile); break;
1496	case OMP_LINEAR_VAL: fputs (s: "val(", stream: dumpfile); break;
1497	case OMP_LINEAR_UVAL: fputs (s: "uval(", stream: dumpfile); break;
1498	default: break;
1499	}
1500	else if (list_type == OMP_LIST_USES_ALLOCATORS)
1501	{
1502	if (n->u.memspace_sym)
1503	{
1504	fputs (s: "memspace(", stream: dumpfile);
1505	fputs (s: n->sym->name, stream: dumpfile);
1506	fputc (c: ')', stream: dumpfile);
1507	}
1508	if (n->u.memspace_sym && n->u2.traits_sym)
1509	fputc (c: ',', stream: dumpfile);
1510	if (n->u2.traits_sym)
1511	{
1512	fputs (s: "traits(", stream: dumpfile);
1513	fputs (s: n->u2.traits_sym->name, stream: dumpfile);
1514	fputc (c: ')', stream: dumpfile);
1515	}
1516	if (n->u.memspace_sym || n->u2.traits_sym)
1517	fputc (c: ':', stream: dumpfile);
1518	fputs (s: n->sym->name, stream: dumpfile);
1519	if (n->next)
1520	fputs (s: ", ", stream: dumpfile);
1521	continue;
1522	}
1523	fprintf (stream: dumpfile, format: "%s", n->sym ? n->sym->name : "omp_all_memory");
1524	if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT)
1525	fputc (c: ')', stream: dumpfile);
1526	if (n->expr)
1527	{
1528	fputc (c: ':', stream: dumpfile);
1529	show_expr (p: n->expr);
1530	}
1531	if (n->next)
1532	fputc (c: ',', stream: dumpfile);
1533	}
1534	gfc_current_ns = ns_curr;
1535	}
1536
1537	static void
1538	show_omp_assumes (gfc_omp_assumptions *assume)
1539	{
1540	for (int i = 0; i < assume->n_absent; i++)
1541	{
1542	fputs (s: " ABSENT (", stream: dumpfile);
1543	fputs (s: gfc_ascii_statement (assume->absent[i], strip_sentinel: true), stream: dumpfile);
1544	fputc (c: ')', stream: dumpfile);
1545	}
1546	for (int i = 0; i < assume->n_contains; i++)
1547	{
1548	fputs (s: " CONTAINS (", stream: dumpfile);
1549	fputs (s: gfc_ascii_statement (assume->contains[i], strip_sentinel: true), stream: dumpfile);
1550	fputc (c: ')', stream: dumpfile);
1551	}
1552	for (gfc_expr_list *el = assume->holds; el; el = el->next)
1553	{
1554	fputs (s: " HOLDS (", stream: dumpfile);
1555	show_expr (p: el->expr);
1556	fputc (c: ')', stream: dumpfile);
1557	}
1558	if (assume->no_openmp)
1559	fputs (s: " NO_OPENMP", stream: dumpfile);
1560	if (assume->no_openmp_routines)
1561	fputs (s: " NO_OPENMP_ROUTINES", stream: dumpfile);
1562	if (assume->no_parallelism)
1563	fputs (s: " NO_PARALLELISM", stream: dumpfile);
1564	}
1565
1566	/* Show OpenMP or OpenACC clauses. */
1567
1568	static void
1569	show_omp_clauses (gfc_omp_clauses *omp_clauses)
1570	{
1571	int list_type, i;
1572
1573	switch (omp_clauses->cancel)
1574	{
1575	case OMP_CANCEL_UNKNOWN:
1576	break;
1577	case OMP_CANCEL_PARALLEL:
1578	fputs (s: " PARALLEL", stream: dumpfile);
1579	break;
1580	case OMP_CANCEL_SECTIONS:
1581	fputs (s: " SECTIONS", stream: dumpfile);
1582	break;
1583	case OMP_CANCEL_DO:
1584	fputs (s: " DO", stream: dumpfile);
1585	break;
1586	case OMP_CANCEL_TASKGROUP:
1587	fputs (s: " TASKGROUP", stream: dumpfile);
1588	break;
1589	}
1590	if (omp_clauses->if_expr)
1591	{
1592	fputs (s: " IF(", stream: dumpfile);
1593	show_expr (p: omp_clauses->if_expr);
1594	fputc (c: ')', stream: dumpfile);
1595	}
1596	for (i = 0; i < OMP_IF_LAST; i++)
1597	if (omp_clauses->if_exprs[i])
1598	{
1599	static const char *ifs[] = {
1600	"CANCEL",
1601	"PARALLEL",
1602	"SIMD",
1603	"TASK",
1604	"TASKLOOP",
1605	"TARGET",
1606	"TARGET DATA",
1607	"TARGET UPDATE",
1608	"TARGET ENTER DATA",
1609	"TARGET EXIT DATA"
1610	};
1611	fputs (s: " IF(", stream: dumpfile);
1612	fputs (s: ifs[i], stream: dumpfile);
1613	fputs (s: ": ", stream: dumpfile);
1614	show_expr (p: omp_clauses->if_exprs[i]);
1615	fputc (c: ')', stream: dumpfile);
1616	}
1617	if (omp_clauses->final_expr)
1618	{
1619	fputs (s: " FINAL(", stream: dumpfile);
1620	show_expr (p: omp_clauses->final_expr);
1621	fputc (c: ')', stream: dumpfile);
1622	}
1623	if (omp_clauses->num_threads)
1624	{
1625	fputs (s: " NUM_THREADS(", stream: dumpfile);
1626	show_expr (p: omp_clauses->num_threads);
1627	fputc (c: ')', stream: dumpfile);
1628	}
1629	if (omp_clauses->async)
1630	{
1631	fputs (s: " ASYNC", stream: dumpfile);
1632	if (omp_clauses->async_expr)
1633	{
1634	fputc (c: '(', stream: dumpfile);
1635	show_expr (p: omp_clauses->async_expr);
1636	fputc (c: ')', stream: dumpfile);
1637	}
1638	}
1639	if (omp_clauses->num_gangs_expr)
1640	{
1641	fputs (s: " NUM_GANGS(", stream: dumpfile);
1642	show_expr (p: omp_clauses->num_gangs_expr);
1643	fputc (c: ')', stream: dumpfile);
1644	}
1645	if (omp_clauses->num_workers_expr)
1646	{
1647	fputs (s: " NUM_WORKERS(", stream: dumpfile);
1648	show_expr (p: omp_clauses->num_workers_expr);
1649	fputc (c: ')', stream: dumpfile);
1650	}
1651	if (omp_clauses->vector_length_expr)
1652	{
1653	fputs (s: " VECTOR_LENGTH(", stream: dumpfile);
1654	show_expr (p: omp_clauses->vector_length_expr);
1655	fputc (c: ')', stream: dumpfile);
1656	}
1657	if (omp_clauses->gang)
1658	{
1659	fputs (s: " GANG", stream: dumpfile);
1660	if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr)
1661	{
1662	fputc (c: '(', stream: dumpfile);
1663	if (omp_clauses->gang_num_expr)
1664	{
1665	fprintf (stream: dumpfile, format: "num:");
1666	show_expr (p: omp_clauses->gang_num_expr);
1667	}
1668	if (omp_clauses->gang_num_expr && omp_clauses->gang_static)
1669	fputc (c: ',', stream: dumpfile);
1670	if (omp_clauses->gang_static)
1671	{
1672	fprintf (stream: dumpfile, format: "static:");
1673	if (omp_clauses->gang_static_expr)
1674	show_expr (p: omp_clauses->gang_static_expr);
1675	else
1676	fputc (c: '*', stream: dumpfile);
1677	}
1678	fputc (c: ')', stream: dumpfile);
1679	}
1680	}
1681	if (omp_clauses->worker)
1682	{
1683	fputs (s: " WORKER", stream: dumpfile);
1684	if (omp_clauses->worker_expr)
1685	{
1686	fputc (c: '(', stream: dumpfile);
1687	show_expr (p: omp_clauses->worker_expr);
1688	fputc (c: ')', stream: dumpfile);
1689	}
1690	}
1691	if (omp_clauses->vector)
1692	{
1693	fputs (s: " VECTOR", stream: dumpfile);
1694	if (omp_clauses->vector_expr)
1695	{
1696	fputc (c: '(', stream: dumpfile);
1697	show_expr (p: omp_clauses->vector_expr);
1698	fputc (c: ')', stream: dumpfile);
1699	}
1700	}
1701	if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1702	{
1703	const char *type;
1704	switch (omp_clauses->sched_kind)
1705	{
1706	case OMP_SCHED_STATIC: type = "STATIC"; break;
1707	case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1708	case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1709	case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1710	case OMP_SCHED_AUTO: type = "AUTO"; break;
1711	default:
1712	gcc_unreachable ();
1713	}
1714	fputs (s: " SCHEDULE (", stream: dumpfile);
1715	if (omp_clauses->sched_simd)
1716	{
1717	if (omp_clauses->sched_monotonic
1718	|| omp_clauses->sched_nonmonotonic)
1719	fputs (s: "SIMD, ", stream: dumpfile);
1720	else
1721	fputs (s: "SIMD: ", stream: dumpfile);
1722	}
1723	if (omp_clauses->sched_monotonic)
1724	fputs (s: "MONOTONIC: ", stream: dumpfile);
1725	else if (omp_clauses->sched_nonmonotonic)
1726	fputs (s: "NONMONOTONIC: ", stream: dumpfile);
1727	fputs (s: type, stream: dumpfile);
1728	if (omp_clauses->chunk_size)
1729	{
1730	fputc (c: ',', stream: dumpfile);
1731	show_expr (p: omp_clauses->chunk_size);
1732	}
1733	fputc (c: ')', stream: dumpfile);
1734	}
1735	if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1736	{
1737	const char *type;
1738	switch (omp_clauses->default_sharing)
1739	{
1740	case OMP_DEFAULT_NONE: type = "NONE"; break;
1741	case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1742	case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1743	case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1744	case OMP_DEFAULT_PRESENT: type = "PRESENT"; break;
1745	default:
1746	gcc_unreachable ();
1747	}
1748	fprintf (stream: dumpfile, format: " DEFAULT(%s)", type);
1749	}
1750	if (omp_clauses->tile_list)
1751	{
1752	gfc_expr_list *list;
1753	fputs (s: " TILE(", stream: dumpfile);
1754	for (list = omp_clauses->tile_list; list; list = list->next)
1755	{
1756	show_expr (p: list->expr);
1757	if (list->next)
1758	fputs (s: ", ", stream: dumpfile);
1759	}
1760	fputc (c: ')', stream: dumpfile);
1761	}
1762	if (omp_clauses->wait_list)
1763	{
1764	gfc_expr_list *list;
1765	fputs (s: " WAIT(", stream: dumpfile);
1766	for (list = omp_clauses->wait_list; list; list = list->next)
1767	{
1768	show_expr (p: list->expr);
1769	if (list->next)
1770	fputs (s: ", ", stream: dumpfile);
1771	}
1772	fputc (c: ')', stream: dumpfile);
1773	}
1774	if (omp_clauses->seq)
1775	fputs (s: " SEQ", stream: dumpfile);
1776	if (omp_clauses->independent)
1777	fputs (s: " INDEPENDENT", stream: dumpfile);
1778	if (omp_clauses->order_concurrent)
1779	{
1780	fputs (s: " ORDER(", stream: dumpfile);
1781	if (omp_clauses->order_unconstrained)
1782	fputs (s: "UNCONSTRAINED:", stream: dumpfile);
1783	else if (omp_clauses->order_reproducible)
1784	fputs (s: "REPRODUCIBLE:", stream: dumpfile);
1785	fputs (s: "CONCURRENT)", stream: dumpfile);
1786	}
1787	if (omp_clauses->ordered)
1788	{
1789	if (omp_clauses->orderedc)
1790	fprintf (stream: dumpfile, format: " ORDERED(%d)", omp_clauses->orderedc);
1791	else
1792	fputs (s: " ORDERED", stream: dumpfile);
1793	}
1794	if (omp_clauses->untied)
1795	fputs (s: " UNTIED", stream: dumpfile);
1796	if (omp_clauses->mergeable)
1797	fputs (s: " MERGEABLE", stream: dumpfile);
1798	if (omp_clauses->collapse)
1799	fprintf (stream: dumpfile, format: " COLLAPSE(%d)", omp_clauses->collapse);
1800	for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1801	if (omp_clauses->lists[list_type] != NULL
1802	&& list_type != OMP_LIST_COPYPRIVATE)
1803	{
1804	const char *type = NULL;
1805	switch (list_type)
1806	{
1807	case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1808	case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1809	case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1810	case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break;
1811	case OMP_LIST_SHARED: type = "SHARED"; break;
1812	case OMP_LIST_COPYIN: type = "COPYIN"; break;
1813	case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
1814	case OMP_LIST_AFFINITY: type = "AFFINITY"; break;
1815	case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
1816	case OMP_LIST_LINEAR: type = "LINEAR"; break;
1817	case OMP_LIST_DEPEND:
1818	if (omp_clauses->lists[list_type]
1819	&& (omp_clauses->lists[list_type]->u.depend_doacross_op
1820	== OMP_DOACROSS_SINK_FIRST))
1821	type = "DOACROSS";
1822	else
1823	type = "DEPEND";
1824	break;
1825	case OMP_LIST_MAP: type = "MAP"; break;
1826	case OMP_LIST_TO: type = "TO"; break;
1827	case OMP_LIST_FROM: type = "FROM"; break;
1828	case OMP_LIST_REDUCTION:
1829	case OMP_LIST_REDUCTION_INSCAN:
1830	case OMP_LIST_REDUCTION_TASK: type = "REDUCTION"; break;
1831	case OMP_LIST_IN_REDUCTION: type = "IN_REDUCTION"; break;
1832	case OMP_LIST_TASK_REDUCTION: type = "TASK_REDUCTION"; break;
1833	case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break;
1834	case OMP_LIST_ENTER: type = "ENTER"; break;
1835	case OMP_LIST_LINK: type = "LINK"; break;
1836	case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
1837	case OMP_LIST_CACHE: type = "CACHE"; break;
1838	case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break;
1839	case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break;
1840	case OMP_LIST_HAS_DEVICE_ADDR: type = "HAS_DEVICE_ADDR"; break;
1841	case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break;
1842	case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break;
1843	case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break;
1844	case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break;
1845	case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break;
1846	case OMP_LIST_USES_ALLOCATORS: type = "USES_ALLOCATORS"; break;
1847	default:
1848	gcc_unreachable ();
1849	}
1850	fprintf (stream: dumpfile, format: " %s(", type);
1851	if (list_type == OMP_LIST_REDUCTION_INSCAN)
1852	fputs (s: "inscan, ", stream: dumpfile);
1853	if (list_type == OMP_LIST_REDUCTION_TASK)
1854	fputs (s: "task, ", stream: dumpfile);
1855	if ((list_type == OMP_LIST_TO || list_type == OMP_LIST_FROM)
1856	&& omp_clauses->lists[list_type]->u.present_modifier)
1857	fputs (s: "present:", stream: dumpfile);
1858	show_omp_namelist (list_type, n: omp_clauses->lists[list_type]);
1859	fputc (c: ')', stream: dumpfile);
1860	}
1861	if (omp_clauses->safelen_expr)
1862	{
1863	fputs (s: " SAFELEN(", stream: dumpfile);
1864	show_expr (p: omp_clauses->safelen_expr);
1865	fputc (c: ')', stream: dumpfile);
1866	}
1867	if (omp_clauses->simdlen_expr)
1868	{
1869	fputs (s: " SIMDLEN(", stream: dumpfile);
1870	show_expr (p: omp_clauses->simdlen_expr);
1871	fputc (c: ')', stream: dumpfile);
1872	}
1873	if (omp_clauses->inbranch)
1874	fputs (s: " INBRANCH", stream: dumpfile);
1875	if (omp_clauses->notinbranch)
1876	fputs (s: " NOTINBRANCH", stream: dumpfile);
1877	if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
1878	{
1879	const char *type;
1880	switch (omp_clauses->proc_bind)
1881	{
1882	case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break;
1883	case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
1884	case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
1885	case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
1886	default:
1887	gcc_unreachable ();
1888	}
1889	fprintf (stream: dumpfile, format: " PROC_BIND(%s)", type);
1890	}
1891	if (omp_clauses->bind != OMP_BIND_UNSET)
1892	{
1893	const char *type;
1894	switch (omp_clauses->bind)
1895	{
1896	case OMP_BIND_TEAMS: type = "TEAMS"; break;
1897	case OMP_BIND_PARALLEL: type = "PARALLEL"; break;
1898	case OMP_BIND_THREAD: type = "THREAD"; break;
1899	default:
1900	gcc_unreachable ();
1901	}
1902	fprintf (stream: dumpfile, format: " BIND(%s)", type);
1903	}
1904	if (omp_clauses->num_teams_upper)
1905	{
1906	fputs (s: " NUM_TEAMS(", stream: dumpfile);
1907	if (omp_clauses->num_teams_lower)
1908	{
1909	show_expr (p: omp_clauses->num_teams_lower);
1910	fputc (c: ':', stream: dumpfile);
1911	}
1912	show_expr (p: omp_clauses->num_teams_upper);
1913	fputc (c: ')', stream: dumpfile);
1914	}
1915	if (omp_clauses->device)
1916	{
1917	fputs (s: " DEVICE(", stream: dumpfile);
1918	if (omp_clauses->ancestor)
1919	fputs (s: "ANCESTOR:", stream: dumpfile);
1920	show_expr (p: omp_clauses->device);
1921	fputc (c: ')', stream: dumpfile);
1922	}
1923	if (omp_clauses->thread_limit)
1924	{
1925	fputs (s: " THREAD_LIMIT(", stream: dumpfile);
1926	show_expr (p: omp_clauses->thread_limit);
1927	fputc (c: ')', stream: dumpfile);
1928	}
1929	if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
1930	{
1931	fputs (s: " DIST_SCHEDULE (STATIC", stream: dumpfile);
1932	if (omp_clauses->dist_chunk_size)
1933	{
1934	fputc (c: ',', stream: dumpfile);
1935	show_expr (p: omp_clauses->dist_chunk_size);
1936	}
1937	fputc (c: ')', stream: dumpfile);
1938	}
1939	for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
1940	{
1941	const char *dfltmap;
1942	if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
1943	continue;
1944	fputs (s: " DEFAULTMAP (", stream: dumpfile);
1945	switch (omp_clauses->defaultmap[i])
1946	{
1947	case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break;
1948	case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break;
1949	case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break;
1950	case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break;
1951	case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break;
1952	case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break;
1953	case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break;
1954	case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break;
1955	default: gcc_unreachable ();
1956	}
1957	fputs (s: dfltmap, stream: dumpfile);
1958	if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
1959	{
1960	fputc (c: ':', stream: dumpfile);
1961	switch ((enum gfc_omp_defaultmap_category) i)
1962	{
1963	case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break;
1964	case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break;
1965	case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break;
1966	case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break;
1967	default: gcc_unreachable ();
1968	}
1969	fputs (s: dfltmap, stream: dumpfile);
1970	}
1971	fputc (c: ')', stream: dumpfile);
1972	}
1973	if (omp_clauses->weak)
1974	fputs (s: " WEAK", stream: dumpfile);
1975	if (omp_clauses->compare)
1976	fputs (s: " COMPARE", stream: dumpfile);
1977	if (omp_clauses->nogroup)
1978	fputs (s: " NOGROUP", stream: dumpfile);
1979	if (omp_clauses->simd)
1980	fputs (s: " SIMD", stream: dumpfile);
1981	if (omp_clauses->threads)
1982	fputs (s: " THREADS", stream: dumpfile);
1983	if (omp_clauses->grainsize)
1984	{
1985	fputs (s: " GRAINSIZE(", stream: dumpfile);
1986	if (omp_clauses->grainsize_strict)
1987	fputs (s: "strict: ", stream: dumpfile);
1988	show_expr (p: omp_clauses->grainsize);
1989	fputc (c: ')', stream: dumpfile);
1990	}
1991	if (omp_clauses->filter)
1992	{
1993	fputs (s: " FILTER(", stream: dumpfile);
1994	show_expr (p: omp_clauses->filter);
1995	fputc (c: ')', stream: dumpfile);
1996	}
1997	if (omp_clauses->hint)
1998	{
1999	fputs (s: " HINT(", stream: dumpfile);
2000	show_expr (p: omp_clauses->hint);
2001	fputc (c: ')', stream: dumpfile);
2002	}
2003	if (omp_clauses->num_tasks)
2004	{
2005	fputs (s: " NUM_TASKS(", stream: dumpfile);
2006	if (omp_clauses->num_tasks_strict)
2007	fputs (s: "strict: ", stream: dumpfile);
2008	show_expr (p: omp_clauses->num_tasks);
2009	fputc (c: ')', stream: dumpfile);
2010	}
2011	if (omp_clauses->priority)
2012	{
2013	fputs (s: " PRIORITY(", stream: dumpfile);
2014	show_expr (p: omp_clauses->priority);
2015	fputc (c: ')', stream: dumpfile);
2016	}
2017	if (omp_clauses->detach)
2018	{
2019	fputs (s: " DETACH(", stream: dumpfile);
2020	show_expr (p: omp_clauses->detach);
2021	fputc (c: ')', stream: dumpfile);
2022	}
2023	if (omp_clauses->destroy)
2024	fputs (s: " DESTROY", stream: dumpfile);
2025	if (omp_clauses->depend_source)
2026	fputs (s: " DEPEND(source)", stream: dumpfile);
2027	if (omp_clauses->doacross_source)
2028	fputs (s: " DOACROSS(source:)", stream: dumpfile);
2029	if (omp_clauses->capture)
2030	fputs (s: " CAPTURE", stream: dumpfile);
2031	if (omp_clauses->depobj_update != OMP_DEPEND_UNSET)
2032	{
2033	const char *deptype;
2034	fputs (s: " UPDATE(", stream: dumpfile);
2035	switch (omp_clauses->depobj_update)
2036	{
2037	case OMP_DEPEND_IN: deptype = "IN"; break;
2038	case OMP_DEPEND_OUT: deptype = "OUT"; break;
2039	case OMP_DEPEND_INOUT: deptype = "INOUT"; break;
2040	case OMP_DEPEND_INOUTSET: deptype = "INOUTSET"; break;
2041	case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break;
2042	default: gcc_unreachable ();
2043	}
2044	fputs (s: deptype, stream: dumpfile);
2045	fputc (c: ')', stream: dumpfile);
2046	}
2047	if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET)
2048	{
2049	const char *atomic_op;
2050	switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
2051	{
2052	case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break;
2053	case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break;
2054	case GFC_OMP_ATOMIC_UPDATE: atomic_op = "UPDATE"; break;
2055	default: gcc_unreachable ();
2056	}
2057	fputc (c: ' ', stream: dumpfile);
2058	fputs (s: atomic_op, stream: dumpfile);
2059	}
2060	if (omp_clauses->memorder != OMP_MEMORDER_UNSET)
2061	{
2062	const char *memorder;
2063	switch (omp_clauses->memorder)
2064	{
2065	case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break;
2066	case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
2067	case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
2068	case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break;
2069	case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
2070	default: gcc_unreachable ();
2071	}
2072	fputc (c: ' ', stream: dumpfile);
2073	fputs (s: memorder, stream: dumpfile);
2074	}
2075	if (omp_clauses->fail != OMP_MEMORDER_UNSET)
2076	{
2077	const char *memorder;
2078	switch (omp_clauses->fail)
2079	{
2080	case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
2081	case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
2082	case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
2083	default: gcc_unreachable ();
2084	}
2085	fputs (s: " FAIL(", stream: dumpfile);
2086	fputs (s: memorder, stream: dumpfile);
2087	putc (c: ')', stream: dumpfile);
2088	}
2089	if (omp_clauses->at != OMP_AT_UNSET)
2090	{
2091	if (omp_clauses->at != OMP_AT_COMPILATION)
2092	fputs (s: " AT (COMPILATION)", stream: dumpfile);
2093	else
2094	fputs (s: " AT (EXECUTION)", stream: dumpfile);
2095	}
2096	if (omp_clauses->severity != OMP_SEVERITY_UNSET)
2097	{
2098	if (omp_clauses->severity != OMP_SEVERITY_FATAL)
2099	fputs (s: " SEVERITY (FATAL)", stream: dumpfile);
2100	else
2101	fputs (s: " SEVERITY (WARNING)", stream: dumpfile);
2102	}
2103	if (omp_clauses->message)
2104	{
2105	fputs (s: " ERROR (", stream: dumpfile);
2106	show_expr (p: omp_clauses->message);
2107	fputc (c: ')', stream: dumpfile);
2108	}
2109	if (omp_clauses->assume)
2110	show_omp_assumes (assume: omp_clauses->assume);
2111	}
2112
2113	/* Show a single OpenMP or OpenACC directive node and everything underneath it
2114	if necessary. */
2115
2116	static void
2117	show_omp_node (int level, gfc_code *c)
2118	{
2119	gfc_omp_clauses *omp_clauses = NULL;
2120	const char *name = NULL;
2121	bool is_oacc = false;
2122
2123	switch (c->op)
2124	{
2125	case EXEC_OACC_PARALLEL_LOOP:
2126	name = "PARALLEL LOOP"; is_oacc = true; break;
2127	case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break;
2128	case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break;
2129	case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break;
2130	case EXEC_OACC_SERIAL_LOOP: name = "SERIAL LOOP"; is_oacc = true; break;
2131	case EXEC_OACC_SERIAL: name = "SERIAL"; is_oacc = true; break;
2132	case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break;
2133	case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break;
2134	case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break;
2135	case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break;
2136	case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break;
2137	case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
2138	case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
2139	case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
2140	case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break;
2141	case EXEC_OMP_ALLOCATORS: name = "ALLOCATORS"; break;
2142	case EXEC_OMP_ASSUME: name = "ASSUME"; break;
2143	case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
2144	case EXEC_OMP_BARRIER: name = "BARRIER"; break;
2145	case EXEC_OMP_CANCEL: name = "CANCEL"; break;
2146	case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
2147	case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
2148	case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
2149	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2150	name = "DISTRIBUTE PARALLEL DO"; break;
2151	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2152	name = "DISTRIBUTE PARALLEL DO SIMD"; break;
2153	case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break;
2154	case EXEC_OMP_DO: name = "DO"; break;
2155	case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
2156	case EXEC_OMP_ERROR: name = "ERROR"; break;
2157	case EXEC_OMP_FLUSH: name = "FLUSH"; break;
2158	case EXEC_OMP_LOOP: name = "LOOP"; break;
2159	case EXEC_OMP_MASKED: name = "MASKED"; break;
2160	case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break;
2161	case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break;
2162	case EXEC_OMP_MASTER: name = "MASTER"; break;
2163	case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break;
2164	case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break;
2165	case EXEC_OMP_ORDERED: name = "ORDERED"; break;
2166	case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break;
2167	case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
2168	case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
2169	case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
2170	case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break;
2171	case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break;
2172	case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break;
2173	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2174	name = "PARALLEL MASK TASKLOOP"; break;
2175	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2176	name = "PARALLEL MASK TASKLOOP SIMD"; break;
2177	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2178	name = "PARALLEL MASTER TASKLOOP"; break;
2179	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2180	name = "PARALLEL MASTER TASKLOOP SIMD"; break;
2181	case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
2182	case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
2183	case EXEC_OMP_SCAN: name = "SCAN"; break;
2184	case EXEC_OMP_SCOPE: name = "SCOPE"; break;
2185	case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
2186	case EXEC_OMP_SIMD: name = "SIMD"; break;
2187	case EXEC_OMP_SINGLE: name = "SINGLE"; break;
2188	case EXEC_OMP_TARGET: name = "TARGET"; break;
2189	case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break;
2190	case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break;
2191	case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break;
2192	case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break;
2193	case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break;
2194	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2195	name = "TARGET_PARALLEL_DO_SIMD"; break;
2196	case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break;
2197	case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break;
2198	case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break;
2199	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2200	name = "TARGET TEAMS DISTRIBUTE"; break;
2201	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2202	name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break;
2203	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2204	name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2205	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2206	name = "TARGET TEAMS DISTRIBUTE SIMD"; break;
2207	case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break;
2208	case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break;
2209	case EXEC_OMP_TASK: name = "TASK"; break;
2210	case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
2211	case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break;
2212	case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break;
2213	case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
2214	case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
2215	case EXEC_OMP_TEAMS: name = "TEAMS"; break;
2216	case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break;
2217	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2218	name = "TEAMS DISTRIBUTE PARALLEL DO"; break;
2219	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2220	name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break;
2221	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break;
2222	case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break;
2223	case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
2224	default:
2225	gcc_unreachable ();
2226	}
2227	fprintf (stream: dumpfile, format: "!$%s %s", is_oacc ? "ACC" : "OMP", name);
2228	switch (c->op)
2229	{
2230	case EXEC_OACC_PARALLEL_LOOP:
2231	case EXEC_OACC_PARALLEL:
2232	case EXEC_OACC_KERNELS_LOOP:
2233	case EXEC_OACC_KERNELS:
2234	case EXEC_OACC_SERIAL_LOOP:
2235	case EXEC_OACC_SERIAL:
2236	case EXEC_OACC_DATA:
2237	case EXEC_OACC_HOST_DATA:
2238	case EXEC_OACC_LOOP:
2239	case EXEC_OACC_UPDATE:
2240	case EXEC_OACC_WAIT:
2241	case EXEC_OACC_CACHE:
2242	case EXEC_OACC_ENTER_DATA:
2243	case EXEC_OACC_EXIT_DATA:
2244	case EXEC_OMP_ASSUME:
2245	case EXEC_OMP_CANCEL:
2246	case EXEC_OMP_CANCELLATION_POINT:
2247	case EXEC_OMP_DISTRIBUTE:
2248	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2249	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2250	case EXEC_OMP_DISTRIBUTE_SIMD:
2251	case EXEC_OMP_DO:
2252	case EXEC_OMP_DO_SIMD:
2253	case EXEC_OMP_ERROR:
2254	case EXEC_OMP_LOOP:
2255	case EXEC_OMP_ORDERED:
2256	case EXEC_OMP_MASKED:
2257	case EXEC_OMP_PARALLEL:
2258	case EXEC_OMP_PARALLEL_DO:
2259	case EXEC_OMP_PARALLEL_DO_SIMD:
2260	case EXEC_OMP_PARALLEL_LOOP:
2261	case EXEC_OMP_PARALLEL_MASKED:
2262	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2263	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2264	case EXEC_OMP_PARALLEL_MASTER:
2265	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2266	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2267	case EXEC_OMP_PARALLEL_SECTIONS:
2268	case EXEC_OMP_PARALLEL_WORKSHARE:
2269	case EXEC_OMP_SCAN:
2270	case EXEC_OMP_SCOPE:
2271	case EXEC_OMP_SECTIONS:
2272	case EXEC_OMP_SIMD:
2273	case EXEC_OMP_SINGLE:
2274	case EXEC_OMP_TARGET:
2275	case EXEC_OMP_TARGET_DATA:
2276	case EXEC_OMP_TARGET_ENTER_DATA:
2277	case EXEC_OMP_TARGET_EXIT_DATA:
2278	case EXEC_OMP_TARGET_PARALLEL:
2279	case EXEC_OMP_TARGET_PARALLEL_DO:
2280	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2281	case EXEC_OMP_TARGET_PARALLEL_LOOP:
2282	case EXEC_OMP_TARGET_SIMD:
2283	case EXEC_OMP_TARGET_TEAMS:
2284	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2285	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2286	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2287	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2288	case EXEC_OMP_TARGET_TEAMS_LOOP:
2289	case EXEC_OMP_TARGET_UPDATE:
2290	case EXEC_OMP_TASK:
2291	case EXEC_OMP_TASKLOOP:
2292	case EXEC_OMP_TASKLOOP_SIMD:
2293	case EXEC_OMP_TEAMS:
2294	case EXEC_OMP_TEAMS_DISTRIBUTE:
2295	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2296	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2297	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2298	case EXEC_OMP_TEAMS_LOOP:
2299	case EXEC_OMP_WORKSHARE:
2300	omp_clauses = c->ext.omp_clauses;
2301	break;
2302	case EXEC_OMP_CRITICAL:
2303	omp_clauses = c->ext.omp_clauses;
2304	if (omp_clauses)
2305	fprintf (stream: dumpfile, format: " (%s)", c->ext.omp_clauses->critical_name);
2306	break;
2307	case EXEC_OMP_DEPOBJ:
2308	omp_clauses = c->ext.omp_clauses;
2309	if (omp_clauses)
2310	{
2311	fputc (c: '(', stream: dumpfile);
2312	show_expr (p: c->ext.omp_clauses->depobj);
2313	fputc (c: ')', stream: dumpfile);
2314	}
2315	break;
2316	case EXEC_OMP_FLUSH:
2317	if (c->ext.omp_namelist)
2318	{
2319	fputs (s: " (", stream: dumpfile);
2320	show_omp_namelist (list_type: OMP_LIST_NUM, n: c->ext.omp_namelist);
2321	fputc (c: ')', stream: dumpfile);
2322	}
2323	return;
2324	case EXEC_OMP_BARRIER:
2325	case EXEC_OMP_TASKWAIT:
2326	case EXEC_OMP_TASKYIELD:
2327	return;
2328	case EXEC_OACC_ATOMIC:
2329	case EXEC_OMP_ATOMIC:
2330	omp_clauses = c->block ? c->block->ext.omp_clauses : NULL;
2331	break;
2332	default:
2333	break;
2334	}
2335	if (omp_clauses)
2336	show_omp_clauses (omp_clauses);
2337	fputc (c: '\n', stream: dumpfile);
2338
2339	/* OpenMP and OpenACC executable directives don't have associated blocks. */
2340	if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE
2341	|| c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA
2342	|| c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
2343	|| c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
2344	|| c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
2345	|| (c->op == EXEC_OMP_ORDERED && c->block == NULL))
2346	return;
2347	if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
2348	{
2349	gfc_code *d = c->block;
2350	while (d != NULL)
2351	{
2352	show_code (level: level + 1, c: d->next);
2353	if (d->block == NULL)
2354	break;
2355	code_indent (level, label: 0);
2356	fputs (s: "!$OMP SECTION\n", stream: dumpfile);
2357	d = d->block;
2358	}
2359	}
2360	else
2361	show_code (level: level + 1, c: c->block->next);
2362	if (c->op == EXEC_OMP_ATOMIC)
2363	return;
2364	fputc (c: '\n', stream: dumpfile);
2365	code_indent (level, label: 0);
2366	fprintf (stream: dumpfile, format: "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
2367	if (omp_clauses != NULL)
2368	{
2369	if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
2370	{
2371	fputs (s: " COPYPRIVATE(", stream: dumpfile);
2372	show_omp_namelist (list_type: OMP_LIST_COPYPRIVATE,
2373	n: omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
2374	fputc (c: ')', stream: dumpfile);
2375	}
2376	else if (omp_clauses->nowait)
2377	fputs (s: " NOWAIT", stream: dumpfile);
2378	}
2379	else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
2380	fprintf (stream: dumpfile, format: " (%s)", c->ext.omp_clauses->critical_name);
2381	}
2382
2383
2384	/* Show a single code node and everything underneath it if necessary. */
2385
2386	static void
2387	show_code_node (int level, gfc_code *c)
2388	{
2389	gfc_forall_iterator *fa;
2390	gfc_open *open;
2391	gfc_case *cp;
2392	gfc_alloc *a;
2393	gfc_code *d;
2394	gfc_close *close;
2395	gfc_filepos *fp;
2396	gfc_inquire *i;
2397	gfc_dt *dt;
2398	gfc_namespace *ns;
2399
2400	if (c->here)
2401	{
2402	fputc (c: '\n', stream: dumpfile);
2403	code_indent (level, label: c->here);
2404	}
2405	else
2406	show_indent ();
2407
2408	switch (c->op)
2409	{
2410	case EXEC_END_PROCEDURE:
2411	break;
2412
2413	case EXEC_NOP:
2414	fputs (s: "NOP", stream: dumpfile);
2415	break;
2416
2417	case EXEC_CONTINUE:
2418	fputs (s: "CONTINUE", stream: dumpfile);
2419	break;
2420
2421	case EXEC_ENTRY:
2422	fprintf (stream: dumpfile, format: "ENTRY %s", c->ext.entry->sym->name);
2423	break;
2424
2425	case EXEC_INIT_ASSIGN:
2426	case EXEC_ASSIGN:
2427	fputs (s: "ASSIGN ", stream: dumpfile);
2428	show_expr (p: c->expr1);
2429	fputc (c: ' ', stream: dumpfile);
2430	show_expr (p: c->expr2);
2431	break;
2432
2433	case EXEC_LABEL_ASSIGN:
2434	fputs (s: "LABEL ASSIGN ", stream: dumpfile);
2435	show_expr (p: c->expr1);
2436	fprintf (stream: dumpfile, format: " %d", c->label1->value);
2437	break;
2438
2439	case EXEC_POINTER_ASSIGN:
2440	fputs (s: "POINTER ASSIGN ", stream: dumpfile);
2441	show_expr (p: c->expr1);
2442	fputc (c: ' ', stream: dumpfile);
2443	show_expr (p: c->expr2);
2444	break;
2445
2446	case EXEC_GOTO:
2447	fputs (s: "GOTO ", stream: dumpfile);
2448	if (c->label1)
2449	fprintf (stream: dumpfile, format: "%d", c->label1->value);
2450	else
2451	{
2452	show_expr (p: c->expr1);
2453	d = c->block;
2454	if (d != NULL)
2455	{
2456	fputs (s: ", (", stream: dumpfile);
2457	for (; d; d = d ->block)
2458	{
2459	code_indent (level, label: d->label1);
2460	if (d->block != NULL)
2461	fputc (c: ',', stream: dumpfile);
2462	else
2463	fputc (c: ')', stream: dumpfile);
2464	}
2465	}
2466	}
2467	break;
2468
2469	case EXEC_CALL:
2470	case EXEC_ASSIGN_CALL:
2471	if (c->resolved_sym)
2472	fprintf (stream: dumpfile, format: "CALL %s ", c->resolved_sym->name);
2473	else if (c->symtree)
2474	fprintf (stream: dumpfile, format: "CALL %s ", c->symtree->name);
2475	else
2476	fputs (s: "CALL ?? ", stream: dumpfile);
2477
2478	show_actual_arglist (a: c->ext.actual);
2479	break;
2480
2481	case EXEC_COMPCALL:
2482	fputs (s: "CALL ", stream: dumpfile);
2483	show_compcall (p: c->expr1);
2484	break;
2485
2486	case EXEC_CALL_PPC:
2487	fputs (s: "CALL ", stream: dumpfile);
2488	show_expr (p: c->expr1);
2489	show_actual_arglist (a: c->ext.actual);
2490	break;
2491
2492	case EXEC_RETURN:
2493	fputs (s: "RETURN ", stream: dumpfile);
2494	if (c->expr1)
2495	show_expr (p: c->expr1);
2496	break;
2497
2498	case EXEC_PAUSE:
2499	fputs (s: "PAUSE ", stream: dumpfile);
2500
2501	if (c->expr1 != NULL)
2502	show_expr (p: c->expr1);
2503	else
2504	fprintf (stream: dumpfile, format: "%d", c->ext.stop_code);
2505
2506	break;
2507
2508	case EXEC_ERROR_STOP:
2509	fputs (s: "ERROR ", stream: dumpfile);
2510	/* Fall through. */
2511
2512	case EXEC_STOP:
2513	fputs (s: "STOP ", stream: dumpfile);
2514
2515	if (c->expr1 != NULL)
2516	show_expr (p: c->expr1);
2517	else
2518	fprintf (stream: dumpfile, format: "%d", c->ext.stop_code);
2519	if (c->expr2 != NULL)
2520	{
2521	fputs (s: " QUIET=", stream: dumpfile);
2522	show_expr (p: c->expr2);
2523	}
2524
2525	break;
2526
2527	case EXEC_FAIL_IMAGE:
2528	fputs (s: "FAIL IMAGE ", stream: dumpfile);
2529	break;
2530
2531	case EXEC_CHANGE_TEAM:
2532	fputs (s: "CHANGE TEAM", stream: dumpfile);
2533	break;
2534
2535	case EXEC_END_TEAM:
2536	fputs (s: "END TEAM", stream: dumpfile);
2537	break;
2538
2539	case EXEC_FORM_TEAM:
2540	fputs (s: "FORM TEAM", stream: dumpfile);
2541	break;
2542
2543	case EXEC_SYNC_TEAM:
2544	fputs (s: "SYNC TEAM", stream: dumpfile);
2545	break;
2546
2547	case EXEC_SYNC_ALL:
2548	fputs (s: "SYNC ALL ", stream: dumpfile);
2549	if (c->expr2 != NULL)
2550	{
2551	fputs (s: " stat=", stream: dumpfile);
2552	show_expr (p: c->expr2);
2553	}
2554	if (c->expr3 != NULL)
2555	{
2556	fputs (s: " errmsg=", stream: dumpfile);
2557	show_expr (p: c->expr3);
2558	}
2559	break;
2560
2561	case EXEC_SYNC_MEMORY:
2562	fputs (s: "SYNC MEMORY ", stream: dumpfile);
2563	if (c->expr2 != NULL)
2564	{
2565	fputs (s: " stat=", stream: dumpfile);
2566	show_expr (p: c->expr2);
2567	}
2568	if (c->expr3 != NULL)
2569	{
2570	fputs (s: " errmsg=", stream: dumpfile);
2571	show_expr (p: c->expr3);
2572	}
2573	break;
2574
2575	case EXEC_SYNC_IMAGES:
2576	fputs (s: "SYNC IMAGES image-set=", stream: dumpfile);
2577	if (c->expr1 != NULL)
2578	show_expr (p: c->expr1);
2579	else
2580	fputs (s: "* ", stream: dumpfile);
2581	if (c->expr2 != NULL)
2582	{
2583	fputs (s: " stat=", stream: dumpfile);
2584	show_expr (p: c->expr2);
2585	}
2586	if (c->expr3 != NULL)
2587	{
2588	fputs (s: " errmsg=", stream: dumpfile);
2589	show_expr (p: c->expr3);
2590	}
2591	break;
2592
2593	case EXEC_EVENT_POST:
2594	case EXEC_EVENT_WAIT:
2595	if (c->op == EXEC_EVENT_POST)
2596	fputs (s: "EVENT POST ", stream: dumpfile);
2597	else
2598	fputs (s: "EVENT WAIT ", stream: dumpfile);
2599
2600	fputs (s: "event-variable=", stream: dumpfile);
2601	if (c->expr1 != NULL)
2602	show_expr (p: c->expr1);
2603	if (c->expr4 != NULL)
2604	{
2605	fputs (s: " until_count=", stream: dumpfile);
2606	show_expr (p: c->expr4);
2607	}
2608	if (c->expr2 != NULL)
2609	{
2610	fputs (s: " stat=", stream: dumpfile);
2611	show_expr (p: c->expr2);
2612	}
2613	if (c->expr3 != NULL)
2614	{
2615	fputs (s: " errmsg=", stream: dumpfile);
2616	show_expr (p: c->expr3);
2617	}
2618	break;
2619
2620	case EXEC_LOCK:
2621	case EXEC_UNLOCK:
2622	if (c->op == EXEC_LOCK)
2623	fputs (s: "LOCK ", stream: dumpfile);
2624	else
2625	fputs (s: "UNLOCK ", stream: dumpfile);
2626
2627	fputs (s: "lock-variable=", stream: dumpfile);
2628	if (c->expr1 != NULL)
2629	show_expr (p: c->expr1);
2630	if (c->expr4 != NULL)
2631	{
2632	fputs (s: " acquired_lock=", stream: dumpfile);
2633	show_expr (p: c->expr4);
2634	}
2635	if (c->expr2 != NULL)
2636	{
2637	fputs (s: " stat=", stream: dumpfile);
2638	show_expr (p: c->expr2);
2639	}
2640	if (c->expr3 != NULL)
2641	{
2642	fputs (s: " errmsg=", stream: dumpfile);
2643	show_expr (p: c->expr3);
2644	}
2645	break;
2646
2647	case EXEC_ARITHMETIC_IF:
2648	fputs (s: "IF ", stream: dumpfile);
2649	show_expr (p: c->expr1);
2650	fprintf (stream: dumpfile, format: " %d, %d, %d",
2651	c->label1->value, c->label2->value, c->label3->value);
2652	break;
2653
2654	case EXEC_IF:
2655	d = c->block;
2656	fputs (s: "IF ", stream: dumpfile);
2657	show_expr (p: d->expr1);
2658
2659	++show_level;
2660	show_code (level: level + 1, c: d->next);
2661	--show_level;
2662
2663	d = d->block;
2664	for (; d; d = d->block)
2665	{
2666	fputs(s: "\n", stream: dumpfile);
2667	code_indent (level, label: 0);
2668	if (d->expr1 == NULL)
2669	fputs (s: "ELSE", stream: dumpfile);
2670	else
2671	{
2672	fputs (s: "ELSE IF ", stream: dumpfile);
2673	show_expr (p: d->expr1);
2674	}
2675
2676	++show_level;
2677	show_code (level: level + 1, c: d->next);
2678	--show_level;
2679	}
2680
2681	if (c->label1)
2682	code_indent (level, label: c->label1);
2683	else
2684	show_indent ();
2685
2686	fputs (s: "ENDIF", stream: dumpfile);
2687	break;
2688
2689	case EXEC_BLOCK:
2690	{
2691	const char* blocktype;
2692	gfc_namespace *saved_ns;
2693	gfc_association_list *alist;
2694
2695	if (c->ext.block.assoc)
2696	blocktype = "ASSOCIATE";
2697	else
2698	blocktype = "BLOCK";
2699	show_indent ();
2700	fprintf (stream: dumpfile, format: "%s ", blocktype);
2701	for (alist = c->ext.block.assoc; alist; alist = alist->next)
2702	{
2703	fprintf (stream: dumpfile, format: " %s = ", alist->name);
2704	show_expr (p: alist->target);
2705	}
2706
2707	++show_level;
2708	ns = c->ext.block.ns;
2709	saved_ns = gfc_current_ns;
2710	gfc_current_ns = ns;
2711	gfc_traverse_symtree (ns->sym_root, show_symtree);
2712	gfc_current_ns = saved_ns;
2713	show_code (level: show_level, c: ns->code);
2714	--show_level;
2715	show_indent ();
2716	fprintf (stream: dumpfile, format: "END %s ", blocktype);
2717	break;
2718	}
2719
2720	case EXEC_END_BLOCK:
2721	/* Only come here when there is a label on an
2722	END ASSOCIATE construct. */
2723	break;
2724
2725	case EXEC_SELECT:
2726	case EXEC_SELECT_TYPE:
2727	case EXEC_SELECT_RANK:
2728	d = c->block;
2729	fputc (c: '\n', stream: dumpfile);
2730	code_indent (level, label: 0);
2731	if (c->op == EXEC_SELECT_RANK)
2732	fputs (s: "SELECT RANK ", stream: dumpfile);
2733	else if (c->op == EXEC_SELECT_TYPE)
2734	fputs (s: "SELECT TYPE ", stream: dumpfile);
2735	else
2736	fputs (s: "SELECT CASE ", stream: dumpfile);
2737	show_expr (p: c->expr1);
2738
2739	for (; d; d = d->block)
2740	{
2741	fputc (c: '\n', stream: dumpfile);
2742	code_indent (level, label: 0);
2743	fputs (s: "CASE ", stream: dumpfile);
2744	for (cp = d->ext.block.case_list; cp; cp = cp->next)
2745	{
2746	fputc (c: '(', stream: dumpfile);
2747	show_expr (p: cp->low);
2748	fputc (c: ' ', stream: dumpfile);
2749	show_expr (p: cp->high);
2750	fputc (c: ')', stream: dumpfile);
2751	fputc (c: ' ', stream: dumpfile);
2752	}
2753
2754	show_code (level: level + 1, c: d->next);
2755	fputc (c: '\n', stream: dumpfile);
2756	}
2757
2758	code_indent (level, label: c->label1);
2759	fputs (s: "END SELECT", stream: dumpfile);
2760	break;
2761
2762	case EXEC_WHERE:
2763	fputs (s: "WHERE ", stream: dumpfile);
2764
2765	d = c->block;
2766	show_expr (p: d->expr1);
2767	fputc (c: '\n', stream: dumpfile);
2768
2769	show_code (level: level + 1, c: d->next);
2770
2771	for (d = d->block; d; d = d->block)
2772	{
2773	code_indent (level, label: 0);
2774	fputs (s: "ELSE WHERE ", stream: dumpfile);
2775	show_expr (p: d->expr1);
2776	fputc (c: '\n', stream: dumpfile);
2777	show_code (level: level + 1, c: d->next);
2778	}
2779
2780	code_indent (level, label: 0);
2781	fputs (s: "END WHERE", stream: dumpfile);
2782	break;
2783
2784
2785	case EXEC_FORALL:
2786	fputs (s: "FORALL ", stream: dumpfile);
2787	for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2788	{
2789	show_expr (p: fa->var);
2790	fputc (c: ' ', stream: dumpfile);
2791	show_expr (p: fa->start);
2792	fputc (c: ':', stream: dumpfile);
2793	show_expr (p: fa->end);
2794	fputc (c: ':', stream: dumpfile);
2795	show_expr (p: fa->stride);
2796
2797	if (fa->next != NULL)
2798	fputc (c: ',', stream: dumpfile);
2799	}
2800
2801	if (c->expr1 != NULL)
2802	{
2803	fputc (c: ',', stream: dumpfile);
2804	show_expr (p: c->expr1);
2805	}
2806	fputc (c: '\n', stream: dumpfile);
2807
2808	show_code (level: level + 1, c: c->block->next);
2809
2810	code_indent (level, label: 0);
2811	fputs (s: "END FORALL", stream: dumpfile);
2812	break;
2813
2814	case EXEC_CRITICAL:
2815	fputs (s: "CRITICAL\n", stream: dumpfile);
2816	show_code (level: level + 1, c: c->block->next);
2817	code_indent (level, label: 0);
2818	fputs (s: "END CRITICAL", stream: dumpfile);
2819	break;
2820
2821	case EXEC_DO:
2822	fputs (s: "DO ", stream: dumpfile);
2823	if (c->label1)
2824	fprintf (stream: dumpfile, format: " %-5d ", c->label1->value);
2825
2826	show_expr (p: c->ext.iterator->var);
2827	fputc (c: '=', stream: dumpfile);
2828	show_expr (p: c->ext.iterator->start);
2829	fputc (c: ' ', stream: dumpfile);
2830	show_expr (p: c->ext.iterator->end);
2831	fputc (c: ' ', stream: dumpfile);
2832	show_expr (p: c->ext.iterator->step);
2833
2834	++show_level;
2835	show_code (level: level + 1, c: c->block->next);
2836	--show_level;
2837
2838	if (c->label1)
2839	break;
2840
2841	show_indent ();
2842	fputs (s: "END DO", stream: dumpfile);
2843	break;
2844
2845	case EXEC_DO_CONCURRENT:
2846	fputs (s: "DO CONCURRENT ", stream: dumpfile);
2847	for (fa = c->ext.forall_iterator; fa; fa = fa->next)
2848	{
2849	show_expr (p: fa->var);
2850	fputc (c: ' ', stream: dumpfile);
2851	show_expr (p: fa->start);
2852	fputc (c: ':', stream: dumpfile);
2853	show_expr (p: fa->end);
2854	fputc (c: ':', stream: dumpfile);
2855	show_expr (p: fa->stride);
2856
2857	if (fa->next != NULL)
2858	fputc (c: ',', stream: dumpfile);
2859	}
2860	show_expr (p: c->expr1);
2861	++show_level;
2862
2863	show_code (level: level + 1, c: c->block->next);
2864	--show_level;
2865	code_indent (level, label: c->label1);
2866	show_indent ();
2867	fputs (s: "END DO", stream: dumpfile);
2868	break;
2869
2870	case EXEC_DO_WHILE:
2871	fputs (s: "DO WHILE ", stream: dumpfile);
2872	show_expr (p: c->expr1);
2873	fputc (c: '\n', stream: dumpfile);
2874
2875	show_code (level: level + 1, c: c->block->next);
2876
2877	code_indent (level, label: c->label1);
2878	fputs (s: "END DO", stream: dumpfile);
2879	break;
2880
2881	case EXEC_CYCLE:
2882	fputs (s: "CYCLE", stream: dumpfile);
2883	if (c->symtree)
2884	fprintf (stream: dumpfile, format: " %s", c->symtree->n.sym->name);
2885	break;
2886
2887	case EXEC_EXIT:
2888	fputs (s: "EXIT", stream: dumpfile);
2889	if (c->symtree)
2890	fprintf (stream: dumpfile, format: " %s", c->symtree->n.sym->name);
2891	break;
2892
2893	case EXEC_ALLOCATE:
2894	fputs (s: "ALLOCATE ", stream: dumpfile);
2895	if (c->expr1)
2896	{
2897	fputs (s: " STAT=", stream: dumpfile);
2898	show_expr (p: c->expr1);
2899	}
2900
2901	if (c->expr2)
2902	{
2903	fputs (s: " ERRMSG=", stream: dumpfile);
2904	show_expr (p: c->expr2);
2905	}
2906
2907	if (c->expr3)
2908	{
2909	if (c->expr3->mold)
2910	fputs (s: " MOLD=", stream: dumpfile);
2911	else
2912	fputs (s: " SOURCE=", stream: dumpfile);
2913	show_expr (p: c->expr3);
2914	}
2915
2916	for (a = c->ext.alloc.list; a; a = a->next)
2917	{
2918	fputc (c: ' ', stream: dumpfile);
2919	show_expr (p: a->expr);
2920	}
2921
2922	break;
2923
2924	case EXEC_DEALLOCATE:
2925	fputs (s: "DEALLOCATE ", stream: dumpfile);
2926	if (c->expr1)
2927	{
2928	fputs (s: " STAT=", stream: dumpfile);
2929	show_expr (p: c->expr1);
2930	}
2931
2932	if (c->expr2)
2933	{
2934	fputs (s: " ERRMSG=", stream: dumpfile);
2935	show_expr (p: c->expr2);
2936	}
2937
2938	for (a = c->ext.alloc.list; a; a = a->next)
2939	{
2940	fputc (c: ' ', stream: dumpfile);
2941	show_expr (p: a->expr);
2942	}
2943
2944	break;
2945
2946	case EXEC_OPEN:
2947	fputs (s: "OPEN", stream: dumpfile);
2948	open = c->ext.open;
2949
2950	if (open->unit)
2951	{
2952	fputs (s: " UNIT=", stream: dumpfile);
2953	show_expr (p: open->unit);
2954	}
2955	if (open->iomsg)
2956	{
2957	fputs (s: " IOMSG=", stream: dumpfile);
2958	show_expr (p: open->iomsg);
2959	}
2960	if (open->iostat)
2961	{
2962	fputs (s: " IOSTAT=", stream: dumpfile);
2963	show_expr (p: open->iostat);
2964	}
2965	if (open->file)
2966	{
2967	fputs (s: " FILE=", stream: dumpfile);
2968	show_expr (p: open->file);
2969	}
2970	if (open->status)
2971	{
2972	fputs (s: " STATUS=", stream: dumpfile);
2973	show_expr (p: open->status);
2974	}
2975	if (open->access)
2976	{
2977	fputs (s: " ACCESS=", stream: dumpfile);
2978	show_expr (p: open->access);
2979	}
2980	if (open->form)
2981	{
2982	fputs (s: " FORM=", stream: dumpfile);
2983	show_expr (p: open->form);
2984	}
2985	if (open->recl)
2986	{
2987	fputs (s: " RECL=", stream: dumpfile);
2988	show_expr (p: open->recl);
2989	}
2990	if (open->blank)
2991	{
2992	fputs (s: " BLANK=", stream: dumpfile);
2993	show_expr (p: open->blank);
2994	}
2995	if (open->position)
2996	{
2997	fputs (s: " POSITION=", stream: dumpfile);
2998	show_expr (p: open->position);
2999	}
3000	if (open->action)
3001	{
3002	fputs (s: " ACTION=", stream: dumpfile);
3003	show_expr (p: open->action);
3004	}
3005	if (open->delim)
3006	{
3007	fputs (s: " DELIM=", stream: dumpfile);
3008	show_expr (p: open->delim);
3009	}
3010	if (open->pad)
3011	{
3012	fputs (s: " PAD=", stream: dumpfile);
3013	show_expr (p: open->pad);
3014	}
3015	if (open->decimal)
3016	{
3017	fputs (s: " DECIMAL=", stream: dumpfile);
3018	show_expr (p: open->decimal);
3019	}
3020	if (open->encoding)
3021	{
3022	fputs (s: " ENCODING=", stream: dumpfile);
3023	show_expr (p: open->encoding);
3024	}
3025	if (open->round)
3026	{
3027	fputs (s: " ROUND=", stream: dumpfile);
3028	show_expr (p: open->round);
3029	}
3030	if (open->sign)
3031	{
3032	fputs (s: " SIGN=", stream: dumpfile);
3033	show_expr (p: open->sign);
3034	}
3035	if (open->convert)
3036	{
3037	fputs (s: " CONVERT=", stream: dumpfile);
3038	show_expr (p: open->convert);
3039	}
3040	if (open->asynchronous)
3041	{
3042	fputs (s: " ASYNCHRONOUS=", stream: dumpfile);
3043	show_expr (p: open->asynchronous);
3044	}
3045	if (open->err != NULL)
3046	fprintf (stream: dumpfile, format: " ERR=%d", open->err->value);
3047
3048	break;
3049
3050	case EXEC_CLOSE:
3051	fputs (s: "CLOSE", stream: dumpfile);
3052	close = c->ext.close;
3053
3054	if (close->unit)
3055	{
3056	fputs (s: " UNIT=", stream: dumpfile);
3057	show_expr (p: close->unit);
3058	}
3059	if (close->iomsg)
3060	{
3061	fputs (s: " IOMSG=", stream: dumpfile);
3062	show_expr (p: close->iomsg);
3063	}
3064	if (close->iostat)
3065	{
3066	fputs (s: " IOSTAT=", stream: dumpfile);
3067	show_expr (p: close->iostat);
3068	}
3069	if (close->status)
3070	{
3071	fputs (s: " STATUS=", stream: dumpfile);
3072	show_expr (p: close->status);
3073	}
3074	if (close->err != NULL)
3075	fprintf (stream: dumpfile, format: " ERR=%d", close->err->value);
3076	break;
3077
3078	case EXEC_BACKSPACE:
3079	fputs (s: "BACKSPACE", stream: dumpfile);
3080	goto show_filepos;
3081
3082	case EXEC_ENDFILE:
3083	fputs (s: "ENDFILE", stream: dumpfile);
3084	goto show_filepos;
3085
3086	case EXEC_REWIND:
3087	fputs (s: "REWIND", stream: dumpfile);
3088	goto show_filepos;
3089
3090	case EXEC_FLUSH:
3091	fputs (s: "FLUSH", stream: dumpfile);
3092
3093	show_filepos:
3094	fp = c->ext.filepos;
3095
3096	if (fp->unit)
3097	{
3098	fputs (s: " UNIT=", stream: dumpfile);
3099	show_expr (p: fp->unit);
3100	}
3101	if (fp->iomsg)
3102	{
3103	fputs (s: " IOMSG=", stream: dumpfile);
3104	show_expr (p: fp->iomsg);
3105	}
3106	if (fp->iostat)
3107	{
3108	fputs (s: " IOSTAT=", stream: dumpfile);
3109	show_expr (p: fp->iostat);
3110	}
3111	if (fp->err != NULL)
3112	fprintf (stream: dumpfile, format: " ERR=%d", fp->err->value);
3113	break;
3114
3115	case EXEC_INQUIRE:
3116	fputs (s: "INQUIRE", stream: dumpfile);
3117	i = c->ext.inquire;
3118
3119	if (i->unit)
3120	{
3121	fputs (s: " UNIT=", stream: dumpfile);
3122	show_expr (p: i->unit);
3123	}
3124	if (i->file)
3125	{
3126	fputs (s: " FILE=", stream: dumpfile);
3127	show_expr (p: i->file);
3128	}
3129
3130	if (i->iomsg)
3131	{
3132	fputs (s: " IOMSG=", stream: dumpfile);
3133	show_expr (p: i->iomsg);
3134	}
3135	if (i->iostat)
3136	{
3137	fputs (s: " IOSTAT=", stream: dumpfile);
3138	show_expr (p: i->iostat);
3139	}
3140	if (i->exist)
3141	{
3142	fputs (s: " EXIST=", stream: dumpfile);
3143	show_expr (p: i->exist);
3144	}
3145	if (i->opened)
3146	{
3147	fputs (s: " OPENED=", stream: dumpfile);
3148	show_expr (p: i->opened);
3149	}
3150	if (i->number)
3151	{
3152	fputs (s: " NUMBER=", stream: dumpfile);
3153	show_expr (p: i->number);
3154	}
3155	if (i->named)
3156	{
3157	fputs (s: " NAMED=", stream: dumpfile);
3158	show_expr (p: i->named);
3159	}
3160	if (i->name)
3161	{
3162	fputs (s: " NAME=", stream: dumpfile);
3163	show_expr (p: i->name);
3164	}
3165	if (i->access)
3166	{
3167	fputs (s: " ACCESS=", stream: dumpfile);
3168	show_expr (p: i->access);
3169	}
3170	if (i->sequential)
3171	{
3172	fputs (s: " SEQUENTIAL=", stream: dumpfile);
3173	show_expr (p: i->sequential);
3174	}
3175
3176	if (i->direct)
3177	{
3178	fputs (s: " DIRECT=", stream: dumpfile);
3179	show_expr (p: i->direct);
3180	}
3181	if (i->form)
3182	{
3183	fputs (s: " FORM=", stream: dumpfile);
3184	show_expr (p: i->form);
3185	}
3186	if (i->formatted)
3187	{
3188	fputs (s: " FORMATTED", stream: dumpfile);
3189	show_expr (p: i->formatted);
3190	}
3191	if (i->unformatted)
3192	{
3193	fputs (s: " UNFORMATTED=", stream: dumpfile);
3194	show_expr (p: i->unformatted);
3195	}
3196	if (i->recl)
3197	{
3198	fputs (s: " RECL=", stream: dumpfile);
3199	show_expr (p: i->recl);
3200	}
3201	if (i->nextrec)
3202	{
3203	fputs (s: " NEXTREC=", stream: dumpfile);
3204	show_expr (p: i->nextrec);
3205	}
3206	if (i->blank)
3207	{
3208	fputs (s: " BLANK=", stream: dumpfile);
3209	show_expr (p: i->blank);
3210	}
3211	if (i->position)
3212	{
3213	fputs (s: " POSITION=", stream: dumpfile);
3214	show_expr (p: i->position);
3215	}
3216	if (i->action)
3217	{
3218	fputs (s: " ACTION=", stream: dumpfile);
3219	show_expr (p: i->action);
3220	}
3221	if (i->read)
3222	{
3223	fputs (s: " READ=", stream: dumpfile);
3224	show_expr (p: i->read);
3225	}
3226	if (i->write)
3227	{
3228	fputs (s: " WRITE=", stream: dumpfile);
3229	show_expr (p: i->write);
3230	}
3231	if (i->readwrite)
3232	{
3233	fputs (s: " READWRITE=", stream: dumpfile);
3234	show_expr (p: i->readwrite);
3235	}
3236	if (i->delim)
3237	{
3238	fputs (s: " DELIM=", stream: dumpfile);
3239	show_expr (p: i->delim);
3240	}
3241	if (i->pad)
3242	{
3243	fputs (s: " PAD=", stream: dumpfile);
3244	show_expr (p: i->pad);
3245	}
3246	if (i->convert)
3247	{
3248	fputs (s: " CONVERT=", stream: dumpfile);
3249	show_expr (p: i->convert);
3250	}
3251	if (i->asynchronous)
3252	{
3253	fputs (s: " ASYNCHRONOUS=", stream: dumpfile);
3254	show_expr (p: i->asynchronous);
3255	}
3256	if (i->decimal)
3257	{
3258	fputs (s: " DECIMAL=", stream: dumpfile);
3259	show_expr (p: i->decimal);
3260	}
3261	if (i->encoding)
3262	{
3263	fputs (s: " ENCODING=", stream: dumpfile);
3264	show_expr (p: i->encoding);
3265	}
3266	if (i->pending)
3267	{
3268	fputs (s: " PENDING=", stream: dumpfile);
3269	show_expr (p: i->pending);
3270	}
3271	if (i->round)
3272	{
3273	fputs (s: " ROUND=", stream: dumpfile);
3274	show_expr (p: i->round);
3275	}
3276	if (i->sign)
3277	{
3278	fputs (s: " SIGN=", stream: dumpfile);
3279	show_expr (p: i->sign);
3280	}
3281	if (i->size)
3282	{
3283	fputs (s: " SIZE=", stream: dumpfile);
3284	show_expr (p: i->size);
3285	}
3286	if (i->id)
3287	{
3288	fputs (s: " ID=", stream: dumpfile);
3289	show_expr (p: i->id);
3290	}
3291
3292	if (i->err != NULL)
3293	fprintf (stream: dumpfile, format: " ERR=%d", i->err->value);
3294	break;
3295
3296	case EXEC_IOLENGTH:
3297	fputs (s: "IOLENGTH ", stream: dumpfile);
3298	show_expr (p: c->expr1);
3299	goto show_dt_code;
3300	break;
3301
3302	case EXEC_READ:
3303	fputs (s: "READ", stream: dumpfile);
3304	goto show_dt;
3305
3306	case EXEC_WRITE:
3307	fputs (s: "WRITE", stream: dumpfile);
3308
3309	show_dt:
3310	dt = c->ext.dt;
3311	if (dt->io_unit)
3312	{
3313	fputs (s: " UNIT=", stream: dumpfile);
3314	show_expr (p: dt->io_unit);
3315	}
3316
3317	if (dt->format_expr)
3318	{
3319	fputs (s: " FMT=", stream: dumpfile);
3320	show_expr (p: dt->format_expr);
3321	}
3322
3323	if (dt->format_label != NULL)
3324	fprintf (stream: dumpfile, format: " FMT=%d", dt->format_label->value);
3325	if (dt->namelist)
3326	fprintf (stream: dumpfile, format: " NML=%s", dt->namelist->name);
3327
3328	if (dt->iomsg)
3329	{
3330	fputs (s: " IOMSG=", stream: dumpfile);
3331	show_expr (p: dt->iomsg);
3332	}
3333	if (dt->iostat)
3334	{
3335	fputs (s: " IOSTAT=", stream: dumpfile);
3336	show_expr (p: dt->iostat);
3337	}
3338	if (dt->size)
3339	{
3340	fputs (s: " SIZE=", stream: dumpfile);
3341	show_expr (p: dt->size);
3342	}
3343	if (dt->rec)
3344	{
3345	fputs (s: " REC=", stream: dumpfile);
3346	show_expr (p: dt->rec);
3347	}
3348	if (dt->advance)
3349	{
3350	fputs (s: " ADVANCE=", stream: dumpfile);
3351	show_expr (p: dt->advance);
3352	}
3353	if (dt->id)
3354	{
3355	fputs (s: " ID=", stream: dumpfile);
3356	show_expr (p: dt->id);
3357	}
3358	if (dt->pos)
3359	{
3360	fputs (s: " POS=", stream: dumpfile);
3361	show_expr (p: dt->pos);
3362	}
3363	if (dt->asynchronous)
3364	{
3365	fputs (s: " ASYNCHRONOUS=", stream: dumpfile);
3366	show_expr (p: dt->asynchronous);
3367	}
3368	if (dt->blank)
3369	{
3370	fputs (s: " BLANK=", stream: dumpfile);
3371	show_expr (p: dt->blank);
3372	}
3373	if (dt->decimal)
3374	{
3375	fputs (s: " DECIMAL=", stream: dumpfile);
3376	show_expr (p: dt->decimal);
3377	}
3378	if (dt->delim)
3379	{
3380	fputs (s: " DELIM=", stream: dumpfile);
3381	show_expr (p: dt->delim);
3382	}
3383	if (dt->pad)
3384	{
3385	fputs (s: " PAD=", stream: dumpfile);
3386	show_expr (p: dt->pad);
3387	}
3388	if (dt->round)
3389	{
3390	fputs (s: " ROUND=", stream: dumpfile);
3391	show_expr (p: dt->round);
3392	}
3393	if (dt->sign)
3394	{
3395	fputs (s: " SIGN=", stream: dumpfile);
3396	show_expr (p: dt->sign);
3397	}
3398
3399	show_dt_code:
3400	for (c = c->block->next; c; c = c->next)
3401	show_code_node (level: level + (c->next != NULL), c);
3402	return;
3403
3404	case EXEC_TRANSFER:
3405	fputs (s: "TRANSFER ", stream: dumpfile);
3406	show_expr (p: c->expr1);
3407	break;
3408
3409	case EXEC_DT_END:
3410	fputs (s: "DT_END", stream: dumpfile);
3411	dt = c->ext.dt;
3412
3413	if (dt->err != NULL)
3414	fprintf (stream: dumpfile, format: " ERR=%d", dt->err->value);
3415	if (dt->end != NULL)
3416	fprintf (stream: dumpfile, format: " END=%d", dt->end->value);
3417	if (dt->eor != NULL)
3418	fprintf (stream: dumpfile, format: " EOR=%d", dt->eor->value);
3419	break;
3420
3421	case EXEC_WAIT:
3422	fputs (s: "WAIT", stream: dumpfile);
3423
3424	if (c->ext.wait != NULL)
3425	{
3426	gfc_wait *wait = c->ext.wait;
3427	if (wait->unit)
3428	{
3429	fputs (s: " UNIT=", stream: dumpfile);
3430	show_expr (p: wait->unit);
3431	}
3432	if (wait->iostat)
3433	{
3434	fputs (s: " IOSTAT=", stream: dumpfile);
3435	show_expr (p: wait->iostat);
3436	}
3437	if (wait->iomsg)
3438	{
3439	fputs (s: " IOMSG=", stream: dumpfile);
3440	show_expr (p: wait->iomsg);
3441	}
3442	if (wait->id)
3443	{
3444	fputs (s: " ID=", stream: dumpfile);
3445	show_expr (p: wait->id);
3446	}
3447	if (wait->err)
3448	fprintf (stream: dumpfile, format: " ERR=%d", wait->err->value);
3449	if (wait->end)
3450	fprintf (stream: dumpfile, format: " END=%d", wait->end->value);
3451	if (wait->eor)
3452	fprintf (stream: dumpfile, format: " EOR=%d", wait->eor->value);
3453	}
3454	break;
3455
3456	case EXEC_OACC_PARALLEL_LOOP:
3457	case EXEC_OACC_PARALLEL:
3458	case EXEC_OACC_KERNELS_LOOP:
3459	case EXEC_OACC_KERNELS:
3460	case EXEC_OACC_SERIAL_LOOP:
3461	case EXEC_OACC_SERIAL:
3462	case EXEC_OACC_DATA:
3463	case EXEC_OACC_HOST_DATA:
3464	case EXEC_OACC_LOOP:
3465	case EXEC_OACC_UPDATE:
3466	case EXEC_OACC_WAIT:
3467	case EXEC_OACC_CACHE:
3468	case EXEC_OACC_ENTER_DATA:
3469	case EXEC_OACC_EXIT_DATA:
3470	case EXEC_OMP_ALLOCATE:
3471	case EXEC_OMP_ALLOCATORS:
3472	case EXEC_OMP_ASSUME:
3473	case EXEC_OMP_ATOMIC:
3474	case EXEC_OMP_CANCEL:
3475	case EXEC_OMP_CANCELLATION_POINT:
3476	case EXEC_OMP_BARRIER:
3477	case EXEC_OMP_CRITICAL:
3478	case EXEC_OMP_DEPOBJ:
3479	case EXEC_OMP_DISTRIBUTE:
3480	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3481	case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3482	case EXEC_OMP_DISTRIBUTE_SIMD:
3483	case EXEC_OMP_DO:
3484	case EXEC_OMP_DO_SIMD:
3485	case EXEC_OMP_ERROR:
3486	case EXEC_OMP_FLUSH:
3487	case EXEC_OMP_LOOP:
3488	case EXEC_OMP_MASKED:
3489	case EXEC_OMP_MASKED_TASKLOOP:
3490	case EXEC_OMP_MASKED_TASKLOOP_SIMD:
3491	case EXEC_OMP_MASTER:
3492	case EXEC_OMP_MASTER_TASKLOOP:
3493	case EXEC_OMP_MASTER_TASKLOOP_SIMD:
3494	case EXEC_OMP_ORDERED:
3495	case EXEC_OMP_PARALLEL:
3496	case EXEC_OMP_PARALLEL_DO:
3497	case EXEC_OMP_PARALLEL_DO_SIMD:
3498	case EXEC_OMP_PARALLEL_LOOP:
3499	case EXEC_OMP_PARALLEL_MASKED:
3500	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
3501	case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
3502	case EXEC_OMP_PARALLEL_MASTER:
3503	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
3504	case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
3505	case EXEC_OMP_PARALLEL_SECTIONS:
3506	case EXEC_OMP_PARALLEL_WORKSHARE:
3507	case EXEC_OMP_SCAN:
3508	case EXEC_OMP_SCOPE:
3509	case EXEC_OMP_SECTIONS:
3510	case EXEC_OMP_SIMD:
3511	case EXEC_OMP_SINGLE:
3512	case EXEC_OMP_TARGET:
3513	case EXEC_OMP_TARGET_DATA:
3514	case EXEC_OMP_TARGET_ENTER_DATA:
3515	case EXEC_OMP_TARGET_EXIT_DATA:
3516	case EXEC_OMP_TARGET_PARALLEL:
3517	case EXEC_OMP_TARGET_PARALLEL_DO:
3518	case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
3519	case EXEC_OMP_TARGET_PARALLEL_LOOP:
3520	case EXEC_OMP_TARGET_SIMD:
3521	case EXEC_OMP_TARGET_TEAMS:
3522	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3523	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3524	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3525	case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3526	case EXEC_OMP_TARGET_TEAMS_LOOP:
3527	case EXEC_OMP_TARGET_UPDATE:
3528	case EXEC_OMP_TASK:
3529	case EXEC_OMP_TASKGROUP:
3530	case EXEC_OMP_TASKLOOP:
3531	case EXEC_OMP_TASKLOOP_SIMD:
3532	case EXEC_OMP_TASKWAIT:
3533	case EXEC_OMP_TASKYIELD:
3534	case EXEC_OMP_TEAMS:
3535	case EXEC_OMP_TEAMS_DISTRIBUTE:
3536	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3537	case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3538	case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3539	case EXEC_OMP_TEAMS_LOOP:
3540	case EXEC_OMP_WORKSHARE:
3541	show_omp_node (level, c);
3542	break;
3543
3544	default:
3545	gfc_internal_error ("show_code_node(): Bad statement code");
3546	}
3547	}
3548
3549
3550	/* Show an equivalence chain. */
3551
3552	static void
3553	show_equiv (gfc_equiv *eq)
3554	{
3555	show_indent ();
3556	fputs (s: "Equivalence: ", stream: dumpfile);
3557	while (eq)
3558	{
3559	show_expr (p: eq->expr);
3560	eq = eq->eq;
3561	if (eq)
3562	fputs (s: ", ", stream: dumpfile);
3563	}
3564	}
3565
3566
3567	/* Show a freakin' whole namespace. */
3568
3569	static void
3570	show_namespace (gfc_namespace *ns)
3571	{
3572	gfc_interface *intr;
3573	gfc_namespace *save;
3574	int op;
3575	gfc_equiv *eq;
3576	int i;
3577
3578	gcc_assert (ns);
3579	save = gfc_current_ns;
3580
3581	show_indent ();
3582	fputs (s: "Namespace:", stream: dumpfile);
3583
3584	i = 0;
3585	do
3586	{
3587	int l = i;
3588	while (i < GFC_LETTERS - 1
3589	&& gfc_compare_types (&ns->default_type[i+1],
3590	&ns->default_type[l]))
3591	i++;
3592
3593	if (i > l)
3594	fprintf (stream: dumpfile, format: " %c-%c: ", l+'A', i+'A');
3595	else
3596	fprintf (stream: dumpfile, format: " %c: ", l+'A');
3597
3598	show_typespec(ts: &ns->default_type[l]);
3599	i++;
3600	} while (i < GFC_LETTERS);
3601
3602	if (ns->proc_name != NULL)
3603	{
3604	show_indent ();
3605	fprintf (stream: dumpfile, format: "procedure name = %s", ns->proc_name->name);
3606	}
3607
3608	++show_level;
3609	gfc_current_ns = ns;
3610	gfc_traverse_symtree (ns->common_root, show_common);
3611
3612	gfc_traverse_symtree (ns->sym_root, show_symtree);
3613
3614	for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
3615	{
3616	/* User operator interfaces */
3617	intr = ns->op[op];
3618	if (intr == NULL)
3619	continue;
3620
3621	show_indent ();
3622	fprintf (stream: dumpfile, format: "Operator interfaces for %s:",
3623	gfc_op2string ((gfc_intrinsic_op) op));
3624
3625	for (; intr; intr = intr->next)
3626	fprintf (stream: dumpfile, format: " %s", intr->sym->name);
3627	}
3628
3629	if (ns->uop_root != NULL)
3630	{
3631	show_indent ();
3632	fputs (s: "User operators:\n", stream: dumpfile);
3633	gfc_traverse_user_op (ns, func: show_uop);
3634	}
3635
3636	for (eq = ns->equiv; eq; eq = eq->next)
3637	show_equiv (eq);
3638
3639	if (ns->oacc_declare)
3640	{
3641	struct gfc_oacc_declare *decl;
3642	/* Dump !$ACC DECLARE clauses. */
3643	for (decl = ns->oacc_declare; decl; decl = decl->next)
3644	{
3645	show_indent ();
3646	fprintf (stream: dumpfile, format: "!$ACC DECLARE");
3647	show_omp_clauses (omp_clauses: decl->clauses);
3648	}
3649	}
3650
3651	if (ns->omp_assumes)
3652	{
3653	show_indent ();
3654	fprintf (stream: dumpfile, format: "!$OMP ASSUMES");
3655	show_omp_assumes (assume: ns->omp_assumes);
3656	}
3657
3658	fputc (c: '\n', stream: dumpfile);
3659	show_indent ();
3660	fputs (s: "code:", stream: dumpfile);
3661	show_code (level: show_level, c: ns->code);
3662	--show_level;
3663
3664	for (ns = ns->contained; ns; ns = ns->sibling)
3665	{
3666	fputs (s: "\nCONTAINS\n", stream: dumpfile);
3667	++show_level;
3668	show_namespace (ns);
3669	--show_level;
3670	}
3671
3672	fputc (c: '\n', stream: dumpfile);
3673	gfc_current_ns = save;
3674	}
3675
3676
3677	/* Main function for dumping a parse tree. */
3678
3679	void
3680	gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
3681	{
3682	dumpfile = file;
3683	show_namespace (ns);
3684	}
3685
3686	/* This part writes BIND(C) definition for use in external C programs. */
3687
3688	static void write_interop_decl (gfc_symbol *);
3689	static void write_proc (gfc_symbol *, bool);
3690
3691	void
3692	gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
3693	{
3694	int error_count;
3695	gfc_get_errors (NULL, &error_count);
3696	if (error_count != 0)
3697	return;
3698	dumpfile = file;
3699	gfc_traverse_ns (ns, write_interop_decl);
3700	}
3701
3702	/* Loop over all global symbols, writing out their declarations. */
3703
3704	void
3705	gfc_dump_external_c_prototypes (FILE * file)
3706	{
3707	dumpfile = file;
3708	fprintf (stream: dumpfile,
3709	_("/* Prototypes for external procedures generated from %s\n"
3710	" by GNU Fortran %s%s.\n\n"
3711	" Use of this interface is discouraged, consider using the\n"
3712	" BIND(C) feature of standard Fortran instead. */\n\n"),
3713	gfc_source_file, pkgversion_string, version_string);
3714
3715	for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
3716	gfc_current_ns = gfc_current_ns->sibling)
3717	{
3718	gfc_symbol *sym = gfc_current_ns->proc_name;
3719
3720	if (sym == NULL || sym->attr.flavor != FL_PROCEDURE
3721	|| sym->attr.is_bind_c)
3722	continue;
3723
3724	write_proc (sym, false);
3725	}
3726	return;
3727	}
3728
3729	enum type_return { T_OK=0, T_WARN, T_ERROR };
3730
3731	/* Return the name of the type for later output. Both function pointers and
3732	void pointers will be mapped to void *. */
3733
3734	static enum type_return
3735	get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre,
3736	const char **type_name, bool *asterisk, const char **post,
3737	bool func_ret)
3738	{
3739	static char post_buffer[40];
3740	enum type_return ret;
3741	ret = T_ERROR;
3742
3743	*pre = " ";
3744	*asterisk = false;
3745	*post = "";
3746	*type_name = "<error>";
3747	if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX)
3748	{
3749	if (ts->is_c_interop && ts->interop_kind)
3750	ret = T_OK;
3751	else
3752	ret = T_WARN;
3753
3754	for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3755	{
3756	if (c_interop_kinds_table[i].f90_type == ts->type
3757	&& c_interop_kinds_table[i].value == ts->kind)
3758	{
3759	/* Skip over 'c_'. */
3760	*type_name = c_interop_kinds_table[i].name + 2;
3761	if (strcmp (s1: *type_name, s2: "long_long") == 0)
3762	*type_name = "long long";
3763	if (strcmp (s1: *type_name, s2: "long_double") == 0)
3764	*type_name = "long double";
3765	if (strcmp (s1: *type_name, s2: "signed_char") == 0)
3766	*type_name = "signed char";
3767	else if (strcmp (s1: *type_name, s2: "size_t") == 0)
3768	*type_name = "ssize_t";
3769	else if (strcmp (s1: *type_name, s2: "float_complex") == 0)
3770	*type_name = "__GFORTRAN_FLOAT_COMPLEX";
3771	else if (strcmp (s1: *type_name, s2: "double_complex") == 0)
3772	*type_name = "__GFORTRAN_DOUBLE_COMPLEX";
3773	else if (strcmp (s1: *type_name, s2: "long_double_complex") == 0)
3774	*type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX";
3775
3776	break;
3777	}
3778	}
3779	}
3780	else if (ts->type == BT_LOGICAL)
3781	{
3782	if (ts->is_c_interop && ts->interop_kind)
3783	{
3784	*type_name = "_Bool";
3785	ret = T_OK;
3786	}
3787	else
3788	{
3789	/* Let's select an appropriate int, with a warning. */
3790	for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3791	{
3792	if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3793	&& c_interop_kinds_table[i].value == ts->kind)
3794	{
3795	*type_name = c_interop_kinds_table[i].name + 2;
3796	ret = T_WARN;
3797	}
3798	}
3799	}
3800	}
3801	else if (ts->type == BT_CHARACTER)
3802	{
3803	if (ts->is_c_interop)
3804	{
3805	*type_name = "char";
3806	ret = T_OK;
3807	}
3808	else
3809	{
3810	if (ts->kind == gfc_default_character_kind)
3811	*type_name = "char";
3812	else
3813	/* Let's select an appropriate int. */
3814	for (int i = 0; i < ISOCBINDING_NUMBER; i++)
3815	{
3816	if (c_interop_kinds_table[i].f90_type == BT_INTEGER
3817	&& c_interop_kinds_table[i].value == ts->kind)
3818	{
3819	*type_name = c_interop_kinds_table[i].name + 2;
3820	break;
3821	}
3822	}
3823	ret = T_WARN;
3824
3825	}
3826	}
3827	else if (ts->type == BT_DERIVED)
3828	{
3829	if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
3830	{
3831	if (strcmp (s1: ts->u.derived->name, s2: "c_ptr") == 0)
3832	*type_name = "void";
3833	else if (strcmp (s1: ts->u.derived->name, s2: "c_funptr") == 0)
3834	{
3835	*type_name = "int ";
3836	if (func_ret)
3837	{
3838	*pre = "(";
3839	*post = "())";
3840	}
3841	else
3842	{
3843	*pre = "(";
3844	*post = ")()";
3845	}
3846	}
3847	*asterisk = true;
3848	ret = T_OK;
3849	}
3850	else
3851	*type_name = ts->u.derived->name;
3852
3853	ret = T_OK;
3854	}
3855
3856	if (ret != T_ERROR && as)
3857	{
3858	mpz_t sz;
3859	bool size_ok;
3860	size_ok = spec_size (as, &sz);
3861	gcc_assert (size_ok == true);
3862	gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
3863	*post = post_buffer;
3864	mpz_clear (sz);
3865	}
3866	return ret;
3867	}
3868
3869	/* Write out a declaration. */
3870	static void
3871	write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
3872	bool func_ret, locus *where, bool bind_c)
3873	{
3874	const char *pre, *type_name, *post;
3875	bool asterisk;
3876	enum type_return rok;
3877
3878	rok = get_c_type_name (ts, as, pre: &pre, type_name: &type_name, asterisk: &asterisk, post: &post, func_ret);
3879	if (rok == T_ERROR)
3880	{
3881	gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3882	gfc_typename (ts), where);
3883	fprintf (stream: dumpfile, format: "/* Cannot convert '%s' to interoperable type */",
3884	gfc_typename (ts));
3885	return;
3886	}
3887	fputs (s: type_name, stream: dumpfile);
3888	fputs (s: pre, stream: dumpfile);
3889	if (asterisk)
3890	fputs (s: "*", stream: dumpfile);
3891
3892	fputs (s: sym_name, stream: dumpfile);
3893	fputs (s: post, stream: dumpfile);
3894
3895	if (rok == T_WARN && bind_c)
3896	fprintf (stream: dumpfile,format: " /* WARNING: Converting '%s' to interoperable type */",
3897	gfc_typename (ts));
3898	}
3899
3900	/* Write out an interoperable type. It will be written as a typedef
3901	for a struct. */
3902
3903	static void
3904	write_type (gfc_symbol *sym)
3905	{
3906	gfc_component *c;
3907
3908	fprintf (stream: dumpfile, format: "typedef struct %s {\n", sym->name);
3909	for (c = sym->components; c; c = c->next)
3910	{
3911	fputs (s: " ", stream: dumpfile);
3912	write_decl (ts: &(c->ts), as: c->as, sym_name: c->name, func_ret: false, where: &sym->declared_at, bind_c: true);
3913	fputs (s: ";\n", stream: dumpfile);
3914	}
3915
3916	fprintf (stream: dumpfile, format: "} %s;\n", sym->name);
3917	}
3918
3919	/* Write out a variable. */
3920
3921	static void
3922	write_variable (gfc_symbol *sym)
3923	{
3924	const char *sym_name;
3925
3926	gcc_assert (sym->attr.flavor == FL_VARIABLE);
3927
3928	if (sym->binding_label)
3929	sym_name = sym->binding_label;
3930	else
3931	sym_name = sym->name;
3932
3933	fputs (s: "extern ", stream: dumpfile);
3934	write_decl (ts: &(sym->ts), as: sym->as, sym_name, func_ret: false, where: &sym->declared_at, bind_c: true);
3935	fputs (s: ";\n", stream: dumpfile);
3936	}
3937
3938
3939	/* Write out a procedure, including its arguments. */
3940	static void
3941	write_proc (gfc_symbol *sym, bool bind_c)
3942	{
3943	const char *pre, *type_name, *post;
3944	bool asterisk;
3945	enum type_return rok;
3946	gfc_formal_arglist *f;
3947	const char *sym_name;
3948	const char *intent_in;
3949	bool external_character;
3950
3951	external_character = sym->ts.type == BT_CHARACTER && !bind_c;
3952
3953	if (sym->binding_label)
3954	sym_name = sym->binding_label;
3955	else
3956	sym_name = sym->name;
3957
3958	if (sym->ts.type == BT_UNKNOWN || external_character)
3959	{
3960	fprintf (stream: dumpfile, format: "void ");
3961	fputs (s: sym_name, stream: dumpfile);
3962	}
3963	else
3964	write_decl (ts: &(sym->ts), as: sym->as, sym_name, func_ret: true, where: &sym->declared_at, bind_c);
3965
3966	if (!bind_c)
3967	fputs (s: "_", stream: dumpfile);
3968
3969	fputs (s: " (", stream: dumpfile);
3970	if (external_character)
3971	{
3972	fprintf (stream: dumpfile, format: "char *result_%s, size_t result_%s_len",
3973	sym_name, sym_name);
3974	if (sym->formal)
3975	fputs (s: ", ", stream: dumpfile);
3976	}
3977
3978	for (f = sym->formal; f; f = f->next)
3979	{
3980	gfc_symbol *s;
3981	s = f->sym;
3982	rok = get_c_type_name (ts: &(s->ts), NULL, pre: &pre, type_name: &type_name, asterisk: &asterisk,
3983	post: &post, func_ret: false);
3984	if (rok == T_ERROR)
3985	{
3986	gfc_error_now ("Cannot convert %qs to interoperable type at %L",
3987	gfc_typename (&s->ts), &s->declared_at);
3988	fprintf (stream: dumpfile, format: "/* Cannot convert '%s' to interoperable type */",
3989	gfc_typename (&s->ts));
3990	return;
3991	}
3992
3993	if (!s->attr.value)
3994	asterisk = true;
3995
3996	if (s->attr.intent == INTENT_IN && !s->attr.value)
3997	intent_in = "const ";
3998	else
3999	intent_in = "";
4000
4001	fputs (s: intent_in, stream: dumpfile);
4002	fputs (s: type_name, stream: dumpfile);
4003	fputs (s: pre, stream: dumpfile);
4004	if (asterisk)
4005	fputs (s: "*", stream: dumpfile);
4006
4007	fputs (s: s->name, stream: dumpfile);
4008	fputs (s: post, stream: dumpfile);
4009	if (bind_c && rok == T_WARN)
4010	fputs(s: " /* WARNING: non-interoperable KIND */ ", stream: dumpfile);
4011
4012	if (f->next)
4013	fputs(s: ", ", stream: dumpfile);
4014	}
4015	if (!bind_c)
4016	for (f = sym->formal; f; f = f->next)
4017	if (f->sym->ts.type == BT_CHARACTER)
4018	fprintf (stream: dumpfile, format: ", size_t %s_len", f->sym->name);
4019
4020	fputs (s: ");\n", stream: dumpfile);
4021	}
4022
4023
4024	/* Write a C-interoperable declaration as a C prototype or extern
4025	declaration. */
4026
4027	static void
4028	write_interop_decl (gfc_symbol *sym)
4029	{
4030	/* Only dump bind(c) entities. */
4031	if (!sym->attr.is_bind_c)
4032	return;
4033
4034	/* Don't dump our iso c module. */
4035	if (sym->from_intmod == INTMOD_ISO_C_BINDING)
4036	return;
4037
4038	if (sym->attr.flavor == FL_VARIABLE)
4039	write_variable (sym);
4040	else if (sym->attr.flavor == FL_DERIVED)
4041	write_type (sym);
4042	else if (sym->attr.flavor == FL_PROCEDURE)
4043	write_proc (sym, bind_c: true);
4044	}
4045
4046	/* This section deals with dumping the global symbol tree. */
4047
4048	/* Callback function for printing out the contents of the tree. */
4049
4050	static void
4051	show_global_symbol (gfc_gsymbol *gsym, void *f_data)
4052	{
4053	FILE *out;
4054	out = (FILE *) f_data;
4055
4056	if (gsym->name)
4057	fprintf (stream: out, format: "name=%s", gsym->name);
4058
4059	if (gsym->sym_name)
4060	fprintf (stream: out, format: ", sym_name=%s", gsym->sym_name);
4061
4062	if (gsym->mod_name)
4063	fprintf (stream: out, format: ", mod_name=%s", gsym->mod_name);
4064
4065	if (gsym->binding_label)
4066	fprintf (stream: out, format: ", binding_label=%s", gsym->binding_label);
4067
4068	fputc (c: '\n', stream: out);
4069	}
4070
4071	/* Show all global symbols. */
4072
4073	void
4074	gfc_dump_global_symbols (FILE *f)
4075	{
4076	if (gfc_gsym_root == NULL)
4077	fprintf (stream: f, format: "empty\n");
4078	else
4079	gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f);
4080	}
4081
4082	/* Show an array ref. */
4083
4084	DEBUG_FUNCTION void
4085	debug (gfc_array_ref *ar)
4086	{
4087	FILE *tmp = dumpfile;
4088	dumpfile = stderr;
4089	show_array_ref (ar);
4090	fputc (c: '\n', stream: dumpfile);
4091	dumpfile = tmp;
4092	}
4093