/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/dump-parse-tree.cc

Bug Summary

File:	build/gcc/fortran/dump-parse-tree.cc
Warning:	line 3783, column 4 Value stored to 'ret' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

Show analyzer invocation

clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name dump-parse-tree.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-XkUl1s.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/dump-parse-tree.cc

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