/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c

Bug Summary

File:	build/gcc/fortran/decl.c
Warning:	line 2477, column 3 Value stored to 'm' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

Show analyzer invocation

clang -cc1 -cc1 -triple x86_64-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name decl.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -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 -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib64/clang/11.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/backward -internal-isystem /usr/local/include -internal-isystem /usr/lib64/clang/11.0.0/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir /home/marxin/BIG/buildbot/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 -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-01-16-135054-17580-1/report-x86KWs.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c

1	/* Declaration statement matcher
2	Copyright (C) 2002-2021 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
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	#include "config.h"
22	#include "system.h"
23	#include "coretypes.h"
24	#include "options.h"
25	#include "tree.h"
26	#include "gfortran.h"
27	#include "stringpool.h"
28	#include "match.h"
29	#include "parse.h"
30	#include "constructor.h"
31	#include "target.h"
32
33	/* Macros to access allocate memory for gfc_data_variable,
34	gfc_data_value and gfc_data. */
35	#define gfc_get_data_variable()((gfc_data_variable ) xcalloc (1, sizeof (gfc_data_variable) )) XCNEW (gfc_data_variable)((gfc_data_variable ) xcalloc (1, sizeof (gfc_data_variable) ))
36	#define gfc_get_data_value()((gfc_data_value ) xcalloc (1, sizeof (gfc_data_value))) XCNEW (gfc_data_value)((gfc_data_value ) xcalloc (1, sizeof (gfc_data_value)))
37	#define gfc_get_data()((gfc_data ) xcalloc (1, sizeof (gfc_data))) XCNEW (gfc_data)((gfc_data ) xcalloc (1, sizeof (gfc_data)))
38
39
40	static bool set_binding_label (const char *, const char , int);
41
42
43	/* This flag is set if an old-style length selector is matched
44	during a type-declaration statement. */
45
46	static int old_char_selector;
47
48	/* When variables acquire types and attributes from a declaration
49	statement, they get them from the following static variables. The
50	first part of a declaration sets these variables and the second
51	part copies these into symbol structures. */
52
53	static gfc_typespec current_ts;
54
55	static symbol_attribute current_attr;
56	static gfc_array_spec *current_as;
57	static int colon_seen;
58	static int attr_seen;
59
60	/* The current binding label (if any). */
61	static const char* curr_binding_label;
62	/* Need to know how many identifiers are on the current data declaration
63	line in case we're given the BIND(C) attribute with a NAME= specifier. */
64	static int num_idents_on_line;
65	/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
66	can supply a name if the curr_binding_label is nil and NAME= was not. */
67	static int has_name_equals = 0;
68
69	/* Initializer of the previous enumerator. */
70
71	static gfc_expr *last_initializer;
72
73	/* History of all the enumerators is maintained, so that
74	kind values of all the enumerators could be updated depending
75	upon the maximum initialized value. */
76
77	typedef struct enumerator_history
78	{
79	gfc_symbol *sym;
80	gfc_expr *initializer;
81	struct enumerator_history *next;
82	}
83	enumerator_history;
84
85	/* Header of enum history chain. */
86
87	static enumerator_history *enum_history = NULL__null;
88
89	/* Pointer of enum history node containing largest initializer. */
90
91	static enumerator_history *max_enum = NULL__null;
92
93	/* gfc_new_block points to the symbol of a newly matched block. */
94
95	gfc_symbol *gfc_new_block;
96
97	bool gfc_matching_function;
98
99	/* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
100	int directive_unroll = -1;
101
102	/* Set upon parsing supported !GCC$ pragmas for use in the next loop. */
103	bool directive_ivdep = false;
104	bool directive_vector = false;
105	bool directive_novector = false;
106
107	/* Map of middle-end built-ins that should be vectorized. */
108	hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;
109
110	/* If a kind expression of a component of a parameterized derived type is
111	parameterized, temporarily store the expression here. */
112	static gfc_expr *saved_kind_expr = NULL__null;
113
114	/* Used to store the parameter list arising in a PDT declaration and
115	in the typespec of a PDT variable or component. */
116	static gfc_actual_arglist *decl_type_param_list;
117	static gfc_actual_arglist *type_param_spec_list;
118
119	/******************* DATA statement subroutines *******************/
120
121	static bool in_match_data = false;
122
123	bool
124	gfc_in_match_data (void)
125	{
126	return in_match_data;
127	}
128
129	static void
130	set_in_match_data (bool set_value)
131	{
132	in_match_data = set_value;
133	}
134
135	/* Free a gfc_data_variable structure and everything beneath it. */
136
137	static void
138	free_variable (gfc_data_variable *p)
139	{
140	gfc_data_variable *q;
141
142	for (; p; p = q)
143	{
144	q = p->next;
145	gfc_free_expr (p->expr);
146	gfc_free_iterator (&p->iter, 0);
147	free_variable (p->list);
148	free (p);
149	}
150	}
151
152
153	/* Free a gfc_data_value structure and everything beneath it. */
154
155	static void
156	free_value (gfc_data_value *p)
157	{
158	gfc_data_value *q;
159
160	for (; p; p = q)
161	{
162	q = p->next;
163	mpz_clear__gmpz_clear (p->repeat);
164	gfc_free_expr (p->expr);
165	free (p);
166	}
167	}
168
169
170	/* Free a list of gfc_data structures. */
171
172	void
173	gfc_free_data (gfc_data *p)
174	{
175	gfc_data *q;
176
177	for (; p; p = q)
178	{
179	q = p->next;
180	free_variable (p->var);
181	free_value (p->value);
182	free (p);
183	}
184	}
185
186
187	/* Free all data in a namespace. */
188
189	static void
190	gfc_free_data_all (gfc_namespace *ns)
191	{
192	gfc_data *d;
193
194	for (;ns->data;)
195	{
196	d = ns->data->next;
197	free (ns->data);
198	ns->data = d;
199	}
200	}
201
202	/* Reject data parsed since the last restore point was marked. */
203
204	void
205	gfc_reject_data (gfc_namespace *ns)
206	{
207	gfc_data *d;
208
209	while (ns->data && ns->data != ns->old_data)
210	{
211	d = ns->data->next;
212	free (ns->data);
213	ns->data = d;
214	}
215	}
216
217	static match var_element (gfc_data_variable *);
218
219	/* Match a list of variables terminated by an iterator and a right
220	parenthesis. */
221
222	static match
223	var_list (gfc_data_variable *parent)
224	{
225	gfc_data_variable *tail, var;
226	match m;
227
228	m = var_element (&var);
229	if (m == MATCH_ERROR)
230	return MATCH_ERROR;
231	if (m == MATCH_NO)
232	goto syntax;
233
234	tail = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) ));
235	*tail = var;
236
237	parent->list = tail;
238
239	for (;;)
240	{
241	if (gfc_match_char (',') != MATCH_YES)
242	goto syntax;
243
244	m = gfc_match_iterator (&parent->iter, 1);
245	if (m == MATCH_YES)
246	break;
247	if (m == MATCH_ERROR)
248	return MATCH_ERROR;
249
250	m = var_element (&var);
251	if (m == MATCH_ERROR)
252	return MATCH_ERROR;
253	if (m == MATCH_NO)
254	goto syntax;
255
256	tail->next = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) ));
257	tail = tail->next;
258
259	*tail = var;
260	}
261
262	if (gfc_match_char (')') != MATCH_YES)
263	goto syntax;
264	return MATCH_YES;
265
266	syntax:
267	gfc_syntax_error (ST_DATA)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_DATA));;
268	return MATCH_ERROR;
269	}
270
271
272	/* Match a single element in a data variable list, which can be a
273	variable-iterator list. */
274
275	static match
276	var_element (gfc_data_variable *new_var)
277	{
278	match m;
279	gfc_symbol *sym;
280
281	memset (new_var, 0, sizeof (gfc_data_variable));
282
283	if (gfc_match_char ('(') == MATCH_YES)
284	return var_list (new_var);
285
286	m = gfc_match_variable (&new_var->expr, 0);
287	if (m != MATCH_YES)
288	return m;
289
290	if (new_var->expr->expr_type == EXPR_CONSTANT
291	&& new_var->expr->symtree == NULL__null)
292	{
293	gfc_error ("Inquiry parameter cannot appear in a "
294	"data-stmt-object-list at %C");
295	return MATCH_ERROR;
296	}
297
298	sym = new_var->expr->symtree->n.sym;
299
300	/* Symbol should already have an associated type. */
301	if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
302	return MATCH_ERROR;
303
304	if (!sym->attr.function && gfc_current_ns->parent
305	&& gfc_current_ns->parent == sym->ns)
306	{
307	gfc_error ("Host associated variable %qs may not be in the DATA "
308	"statement at %C", sym->name);
309	return MATCH_ERROR;
310	}
311
312	if (gfc_current_state ()(gfc_state_stack->state) != COMP_BLOCK_DATA
313	&& sym->attr.in_common
314	&& !gfc_notify_std (GFC_STD_GNU(1<<5), "initialization of "
315	"common block variable %qs in DATA statement at %C",
316	sym->name))
317	return MATCH_ERROR;
318
319	if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
320	return MATCH_ERROR;
321
322	return MATCH_YES;
323	}
324
325
326	/* Match the top-level list of data variables. */
327
328	static match
329	top_var_list (gfc_data *d)
330	{
331	gfc_data_variable var, tail, new_var;
332	match m;
333
334	tail = NULL__null;
335
336	for (;;)
337	{
338	m = var_element (&var);
339	if (m == MATCH_NO)
340	goto syntax;
341	if (m == MATCH_ERROR)
342	return MATCH_ERROR;
343
344	new_var = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) ));
345	*new_var = var;
346	if (new_var->expr)
347	new_var->expr->where = gfc_current_locus;
348
349	if (tail == NULL__null)
350	d->var = new_var;
351	else
352	tail->next = new_var;
353
354	tail = new_var;
355
356	if (gfc_match_char ('/') == MATCH_YES)
357	break;
358	if (gfc_match_char (',') != MATCH_YES)
359	goto syntax;
360	}
361
362	return MATCH_YES;
363
364	syntax:
365	gfc_syntax_error (ST_DATA)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_DATA));;
366	gfc_free_data_all (gfc_current_ns);
367	return MATCH_ERROR;
368	}
369
370
371	static match
372	match_data_constant (gfc_expr **result)
373	{
374	char name[GFC_MAX_SYMBOL_LEN63 + 1];
375	gfc_symbol sym, dt_sym = NULL__null;
376	gfc_expr *expr;
377	match m;
378	locus old_loc;
379
380	m = gfc_match_literal_constant (&expr, 1);
381	if (m == MATCH_YES)
382	{
383	*result = expr;
384	return MATCH_YES;
385	}
386
387	if (m == MATCH_ERROR)
388	return MATCH_ERROR;
389
390	m = gfc_match_null (result);
391	if (m != MATCH_NO)
392	return m;
393
394	old_loc = gfc_current_locus;
395
396	/* Should this be a structure component, try to match it
397	before matching a name. */
398	m = gfc_match_rvalue (result);
399	if (m == MATCH_ERROR)
400	return m;
401
402	if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
403	{
404	if (!gfc_simplify_expr (*result, 0))
405	m = MATCH_ERROR;
406	return m;
407	}
408	else if (m == MATCH_YES)
409	{
410	/* If a parameter inquiry ends up here, symtree is NULL but **result
411	contains the right constant expression. Check here. */
412	if ((*result)->symtree == NULL__null
413	&& (*result)->expr_type == EXPR_CONSTANT
414	&& ((*result)->ts.type == BT_INTEGER
415	\|\| (*result)->ts.type == BT_REAL))
416	return m;
417
418	/* F2018:R845 data-stmt-constant is initial-data-target.
419	A data-stmt-constant shall be ... initial-data-target if and
420	only if the corresponding data-stmt-object has the POINTER
421	attribute. ... If data-stmt-constant is initial-data-target
422	the corresponding data statement object shall be
423	data-pointer-initialization compatible (7.5.4.6) with the initial
424	data target; the data statement object is initially associated
425	with the target. */
426	if ((*result)->symtree->n.sym->attr.save
427	&& (*result)->symtree->n.sym->attr.target)
428	return m;
429	gfc_free_expr (*result);
430	}
431
432	gfc_current_locus = old_loc;
433
434	m = gfc_match_name (name);
435	if (m != MATCH_YES)
436	return m;
437
438	if (gfc_find_symbol (name, NULL__null, 1, &sym))
439	return MATCH_ERROR;
440
441	if (sym && sym->attr.generic)
442	dt_sym = gfc_find_dt_in_generic (sym);
443
444	if (sym == NULL__null
445	\|\| (sym->attr.flavor != FL_PARAMETER
446	&& (!dt_sym \|\| !gfc_fl_struct (dt_sym->attr.flavor)((dt_sym->attr.flavor) == FL_DERIVED \|\| (dt_sym->attr.flavor ) == FL_UNION \|\| (dt_sym->attr.flavor) == FL_STRUCT))))
447	{
448	gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
449	name);
450	*result = NULL__null;
451	return MATCH_ERROR;
452	}
453	else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)((dt_sym->attr.flavor) == FL_DERIVED \|\| (dt_sym->attr.flavor ) == FL_UNION \|\| (dt_sym->attr.flavor) == FL_STRUCT))
454	return gfc_match_structure_constructor (dt_sym, result);
455
456	/* Check to see if the value is an initialization array expression. */
457	if (sym->value->expr_type == EXPR_ARRAY)
458	{
459	gfc_current_locus = old_loc;
460
461	m = gfc_match_init_expr (result);
462	if (m == MATCH_ERROR)
463	return m;
464
465	if (m == MATCH_YES)
466	{
467	if (!gfc_simplify_expr (*result, 0))
468	m = MATCH_ERROR;
469
470	if ((*result)->expr_type == EXPR_CONSTANT)
471	return m;
472	else
473	{
474	gfc_error ("Invalid initializer %s in Data statement at %C", name);
475	return MATCH_ERROR;
476	}
477	}
478	}
479
480	*result = gfc_copy_expr (sym->value);
481	return MATCH_YES;
482	}
483
484
485	/* Match a list of values in a DATA statement. The leading '/' has
486	already been seen at this point. */
487
488	static match
489	top_val_list (gfc_data *data)
490	{
491	gfc_data_value new_val, tail;
492	gfc_expr *expr;
493	match m;
494
495	tail = NULL__null;
496
497	for (;;)
498	{
499	m = match_data_constant (&expr);
500	if (m == MATCH_NO)
501	goto syntax;
502	if (m == MATCH_ERROR)
503	return MATCH_ERROR;
504
505	new_val = gfc_get_data_value ()((gfc_data_value *) xcalloc (1, sizeof (gfc_data_value)));
506	mpz_init__gmpz_init (new_val->repeat);
507
508	if (tail == NULL__null)
509	data->value = new_val;
510	else
511	tail->next = new_val;
512
513	tail = new_val;
514
515	if (expr->ts.type != BT_INTEGER \|\| gfc_match_char ('*') != MATCH_YES)
516	{
517	tail->expr = expr;
518	mpz_set_ui__gmpz_set_ui (tail->repeat, 1);
519	}
520	else
521	{
522	mpz_set__gmpz_set (tail->repeat, expr->value.integer);
523	gfc_free_expr (expr);
524
525	m = match_data_constant (&tail->expr);
526	if (m == MATCH_NO)
527	goto syntax;
528	if (m == MATCH_ERROR)
529	return MATCH_ERROR;
530	}
531
532	if (gfc_match_char ('/') == MATCH_YES)
533	break;
534	if (gfc_match_char (',') == MATCH_NO)
535	goto syntax;
536	}
537
538	return MATCH_YES;
539
540	syntax:
541	gfc_syntax_error (ST_DATA)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_DATA));;
542	gfc_free_data_all (gfc_current_ns);
543	return MATCH_ERROR;
544	}
545
546
547	/* Matches an old style initialization. */
548
549	static match
550	match_old_style_init (const char *name)
551	{
552	match m;
553	gfc_symtree *st;
554	gfc_symbol *sym;
555	gfc_data newdata, nd;
556
557	/* Set up data structure to hold initializers. */
558	gfc_find_sym_tree (name, NULL__null, 0, &st);
559	sym = st->n.sym;
560
561	newdata = gfc_get_data ()((gfc_data *) xcalloc (1, sizeof (gfc_data)));
562	newdata->var = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) ));
563	newdata->var->expr = gfc_get_variable_expr (st);
564	newdata->var->expr->where = sym->declared_at;
565	newdata->where = gfc_current_locus;
566
567	/* Match initial value list. This also eats the terminal '/'. */
568	m = top_val_list (newdata);
569	if (m != MATCH_YES)
570	{
571	free (newdata);
572	return m;
573	}
574
575	/* Check that a BOZ did not creep into an old-style initialization. */
576	for (nd = newdata; nd; nd = nd->next)
577	{
578	if (nd->value->expr->ts.type == BT_BOZ
579	&& gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style ""BOZ at %L cannot appear in an old-style " "initialization"
580	"initialization")"BOZ at %L cannot appear in an old-style " "initialization", &nd->value->expr->where))
581	return MATCH_ERROR;
582
583	if (nd->var->expr->ts.type != BT_INTEGER
584	&& nd->var->expr->ts.type != BT_REAL
585	&& nd->value->expr->ts.type == BT_BOZ)
586	{
587	gfc_error (G_("BOZ literal constant near %L cannot be assigned to ""BOZ literal constant near %L cannot be assigned to " "a %qs variable in an old-style initialization"
588	"a %qs variable in an old-style initialization")"BOZ literal constant near %L cannot be assigned to " "a %qs variable in an old-style initialization",
589	&nd->value->expr->where,
590	gfc_typename (&nd->value->expr->ts));
591	return MATCH_ERROR;
592	}
593	}
594
595	if (gfc_pure (NULL__null))
596	{
597	gfc_error ("Initialization at %C is not allowed in a PURE procedure");
598	free (newdata);
599	return MATCH_ERROR;
600	}
601	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
602
603	/* Mark the variable as having appeared in a data statement. */
604	if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
605	{
606	free (newdata);
607	return MATCH_ERROR;
608	}
609
610	/* Chain in namespace list of DATA initializers. */
611	newdata->next = gfc_current_ns->data;
612	gfc_current_ns->data = newdata;
613
614	return m;
615	}
616
617
618	/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
619	we are matching a DATA statement and are therefore issuing an error
620	if we encounter something unexpected, if not, we're trying to match
621	an old-style initialization expression of the form INTEGER I /2/. */
622
623	match
624	gfc_match_data (void)
625	{
626	gfc_data *new_data;
627	gfc_expr *e;
628	gfc_ref *ref;
629	match m;
630	char c;
631
632	/* DATA has been matched. In free form source code, the next character
633	needs to be whitespace or '(' from an implied do-loop. Check that
634	here. */
635	c = gfc_peek_ascii_char ();
636	if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c)((c==' ') \|\| (c=='\t') \|\| (c=='\f')) && c != '(')
637	return MATCH_NO;
638
639	/* Before parsing the rest of a DATA statement, check F2008:c1206. */
640	if ((gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION
641	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_SUBROUTINE)
642	&& gfc_state_stack->previous->state == COMP_INTERFACE)
643	{
644	gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
645	return MATCH_ERROR;
646	}
647
648	set_in_match_data (true);
649
650	for (;;)
651	{
652	new_data = gfc_get_data ()((gfc_data *) xcalloc (1, sizeof (gfc_data)));
653	new_data->where = gfc_current_locus;
654
655	m = top_var_list (new_data);
656	if (m != MATCH_YES)
657	goto cleanup;
658
659	if (new_data->var->iter.var
660	&& new_data->var->iter.var->ts.type == BT_INTEGER
661	&& new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
662	&& new_data->var->list
663	&& new_data->var->list->expr
664	&& new_data->var->list->expr->ts.type == BT_CHARACTER
665	&& new_data->var->list->expr->ref
666	&& new_data->var->list->expr->ref->type == REF_SUBSTRING)
667	{
668	gfc_error ("Invalid substring in data-implied-do at %L in DATA "
669	"statement", &new_data->var->list->expr->where);
670	goto cleanup;
671	}
672
673	/* Check for an entity with an allocatable component, which is not
674	allowed. */
675	e = new_data->var->expr;
676	if (e)
677	{
678	bool invalid;
679
680	invalid = false;
681	for (ref = e->ref; ref; ref = ref->next)
682	if ((ref->type == REF_COMPONENT
683	&& ref->u.c.component->attr.allocatable)
684	\|\| (ref->type == REF_ARRAY
685	&& e->symtree->n.sym->attr.pointer != 1
686	&& ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
687	invalid = true;
688
689	if (invalid)
690	{
691	gfc_error ("Allocatable component or deferred-shaped array "
692	"near %C in DATA statement");
693	goto cleanup;
694	}
695
696	/* F2008:C567 (R536) A data-i-do-object or a variable that appears
697	as a data-stmt-object shall not be an object designator in which
698	a pointer appears other than as the entire rightmost part-ref. */
699	if (!e->ref && e->ts.type == BT_DERIVED
700	&& e->symtree->n.sym->attr.pointer)
701	goto partref;
702
703	ref = e->ref;
704	if (e->symtree->n.sym->ts.type == BT_DERIVED
705	&& e->symtree->n.sym->attr.pointer
706	&& ref->type == REF_COMPONENT)
707	goto partref;
708
709	for (; ref; ref = ref->next)
710	if (ref->type == REF_COMPONENT
711	&& ref->u.c.component->attr.pointer
712	&& ref->next)
713	goto partref;
714	}
715
716	m = top_val_list (new_data);
717	if (m != MATCH_YES)
718	goto cleanup;
719
720	new_data->next = gfc_current_ns->data;
721	gfc_current_ns->data = new_data;
722
723	/* A BOZ literal constant cannot appear in a structure constructor.
724	Check for that here for a data statement value. */
725	if (new_data->value->expr->ts.type == BT_DERIVED
726	&& new_data->value->expr->value.constructor)
727	{
728	gfc_constructor *c;
729	c = gfc_constructor_first (new_data->value->expr->value.constructor);
730	for (; c; c = gfc_constructor_next (c))
731	if (c->expr && c->expr->ts.type == BT_BOZ)
732	{
733	gfc_error ("BOZ literal constant at %L cannot appear in a "
734	"structure constructor", &c->expr->where);
735	return MATCH_ERROR;
736	}
737	}
738
739	if (gfc_match_eos () == MATCH_YES)
740	break;
741
742	gfc_match_char (','); /* Optional comma */
743	}
744
745	set_in_match_data (false);
746
747	if (gfc_pure (NULL__null))
748	{
749	gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
750	return MATCH_ERROR;
751	}
752	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
753
754	return MATCH_YES;
755
756	partref:
757
758	gfc_error ("part-ref with pointer attribute near %L is not "
759	"rightmost part-ref of data-stmt-object",
760	&e->where);
761
762	cleanup:
763	set_in_match_data (false);
764	gfc_free_data (new_data);
765	return MATCH_ERROR;
766	}
767
768
769	/********************** Declaration statements *******************/
770
771
772	/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
773	list). The difference here is the expression is a list of constants
774	and is surrounded by '/'.
775	The typespec ts must match the typespec of the variable which the
776	clist is initializing.
777	The arrayspec tells whether this should match a list of constants
778	corresponding to array elements or a scalar (as == NULL). */
779
780	static match
781	match_clist_expr (gfc_expr *result, gfc_typespec ts, gfc_array_spec *as)
782	{
783	gfc_constructor_base array_head = NULL__null;
784	gfc_expr *expr = NULL__null;
785	match m = MATCH_ERROR;
786	locus where;
787	mpz_t repeat, cons_size, as_size;
788	bool scalar;
789	int cmp;
790
791	gcc_assert (ts)((void)(!(ts) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 791, __FUNCTION__), 0 : 0));
792
793	/* We have already matched '/' - now look for a constant list, as with
794	top_val_list from decl.c, but append the result to an array. */
795	if (gfc_match ("/") == MATCH_YES)
796	{
797	gfc_error ("Empty old style initializer list at %C");
798	return MATCH_ERROR;
799	}
800
801	where = gfc_current_locus;
802	scalar = !as \|\| !as->rank;
803
804	if (!scalar && !spec_size (as, &as_size))
805	{
806	gfc_error ("Array in initializer list at %L must have an explicit shape",
807	as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
808	/* Nothing to cleanup yet. */
809	return MATCH_ERROR;
810	}
811
812	mpz_init_set_ui__gmpz_init_set_ui (repeat, 0);
813
814	for (;;)
815	{
816	m = match_data_constant (&expr);
817	if (m != MATCH_YES)
818	expr = NULL__null; /* match_data_constant may set expr to garbage */
819	if (m == MATCH_NO)
820	goto syntax;
821	if (m == MATCH_ERROR)
822	goto cleanup;
823
824	/* Found r in repeat spec rc; look for the constant to repeat. /
825	if ( gfc_match_char ('*') == MATCH_YES)
826	{
827	if (scalar)
828	{
829	gfc_error ("Repeat spec invalid in scalar initializer at %C");
830	goto cleanup;
831	}
832	if (expr->ts.type != BT_INTEGER)
833	{
834	gfc_error ("Repeat spec must be an integer at %C");
835	goto cleanup;
836	}
837	mpz_set__gmpz_set (repeat, expr->value.integer);
838	gfc_free_expr (expr);
839	expr = NULL__null;
840
841	m = match_data_constant (&expr);
842	if (m == MATCH_NO)
843	{
844	m = MATCH_ERROR;
845	gfc_error ("Expected data constant after repeat spec at %C");
846	}
847	if (m != MATCH_YES)
848	goto cleanup;
849	}
850	/* No repeat spec, we matched the data constant itself. */
851	else
852	mpz_set_ui__gmpz_set_ui (repeat, 1);
853
854	if (!scalar)
855	{
856	/* Add the constant initializer as many times as repeated. */
857	for (; mpz_cmp_ui (repeat, 0)(__builtin_constant_p (0) && (0) == 0 ? ((repeat)-> _mp_size < 0 ? -1 : (repeat)->_mp_size > 0) : __gmpz_cmp_ui (repeat,0)) > 0; mpz_sub_ui__gmpz_sub_ui (repeat, repeat, 1))
858	{
859	/* Make sure types of elements match */
860	if(ts && !gfc_compare_types (&expr->ts, ts)
861	&& !gfc_convert_type (expr, ts, 1))
862	goto cleanup;
863
864	gfc_constructor_append_expr (&array_head,
865	gfc_copy_expr (expr), &gfc_current_locus);
866	}
867
868	gfc_free_expr (expr);
869	expr = NULL__null;
870	}
871
872	/* For scalar initializers quit after one element. */
873	else
874	{
875	if(gfc_match_char ('/') != MATCH_YES)
876	{
877	gfc_error ("End of scalar initializer expected at %C");
878	goto cleanup;
879	}
880	break;
881	}
882
883	if (gfc_match_char ('/') == MATCH_YES)
884	break;
885	if (gfc_match_char (',') == MATCH_NO)
886	goto syntax;
887	}
888
889	/* If we break early from here out, we encountered an error. */
890	m = MATCH_ERROR;
891
892	/* Set up expr as an array constructor. */
893	if (!scalar)
894	{
895	expr = gfc_get_array_expr (ts->type, ts->kind, &where);
896	expr->ts = *ts;
897	expr->value.constructor = array_head;
898
899	expr->rank = as->rank;
900	expr->shape = gfc_get_shape (expr->rank)(((mpz_t *) xcalloc (((expr->rank)), sizeof (mpz_t))));
901
902	/* Validate sizes. We built expr ourselves, so cons_size will be
903	constant (we fail above for non-constant expressions).
904	We still need to verify that the sizes match. */
905	gcc_assert (gfc_array_size (expr, &cons_size))((void)(!(gfc_array_size (expr, &cons_size)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 905, __FUNCTION__), 0 : 0));
906	cmp = mpz_cmp__gmpz_cmp (cons_size, as_size);
907	if (cmp < 0)
908	gfc_error ("Not enough elements in array initializer at %C");
909	else if (cmp > 0)
910	gfc_error ("Too many elements in array initializer at %C");
911	mpz_clear__gmpz_clear (cons_size);
912	if (cmp)
913	goto cleanup;
914	}
915
916	/* Make sure scalar types match. */
917	else if (!gfc_compare_types (&expr->ts, ts)
918	&& !gfc_convert_type (expr, ts, 1))
919	goto cleanup;
920
921	if (expr->ts.u.cl)
922	expr->ts.u.cl->length_from_typespec = 1;
923
924	*result = expr;
925	m = MATCH_YES;
926	goto done;
927
928	syntax:
929	m = MATCH_ERROR;
930	gfc_error ("Syntax error in old style initializer list at %C");
931
932	cleanup:
933	if (expr)
934	expr->value.constructor = NULL__null;
935	gfc_free_expr (expr);
936	gfc_constructor_free (array_head);
937
938	done:
939	mpz_clear__gmpz_clear (repeat);
940	if (!scalar)
941	mpz_clear__gmpz_clear (as_size);
942	return m;
943	}
944
945
946	/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
947
948	static bool
949	merge_array_spec (gfc_array_spec from, gfc_array_spec to, bool copy)
950	{
951	if ((from->type == AS_ASSUMED_RANK && to->corank)
952	\|\| (to->type == AS_ASSUMED_RANK && from->corank))
953	{
954	gfc_error ("The assumed-rank array at %C shall not have a codimension");
955	return false;
956	}
957
958	if (to->rank == 0 && from->rank > 0)
959	{
960	to->rank = from->rank;
961	to->type = from->type;
962	to->cray_pointee = from->cray_pointee;
963	to->cp_was_assumed = from->cp_was_assumed;
964
965	for (int i = to->corank - 1; i >= 0; i--)
966	{
967	/* Do not exceed the limits on lower[] and upper[]. gfortran
968	cleans up elsewhere. */
969	int j = from->rank + i;
970	if (j >= GFC_MAX_DIMENSIONS15)
971	break;
972
973	to->lower[j] = to->lower[i];
974	to->upper[j] = to->upper[i];
975	}
976	for (int i = 0; i < from->rank; i++)
977	{
978	if (copy)
979	{
980	to->lower[i] = gfc_copy_expr (from->lower[i]);
981	to->upper[i] = gfc_copy_expr (from->upper[i]);
982	}
983	else
984	{
985	to->lower[i] = from->lower[i];
986	to->upper[i] = from->upper[i];
987	}
988	}
989	}
990	else if (to->corank == 0 && from->corank > 0)
991	{
992	to->corank = from->corank;
993	to->cotype = from->cotype;
994
995	for (int i = 0; i < from->corank; i++)
996	{
997	/* Do not exceed the limits on lower[] and upper[]. gfortran
998	cleans up elsewhere. */
999	int k = from->rank + i;
1000	int j = to->rank + i;
1001	if (j >= GFC_MAX_DIMENSIONS15)
1002	break;
1003
1004	if (copy)
1005	{
1006	to->lower[j] = gfc_copy_expr (from->lower[k]);
1007	to->upper[j] = gfc_copy_expr (from->upper[k]);
1008	}
1009	else
1010	{
1011	to->lower[j] = from->lower[k];
1012	to->upper[j] = from->upper[k];
1013	}
1014	}
1015	}
1016
1017	if (to->rank + to->corank > GFC_MAX_DIMENSIONS15)
1018	{
1019	gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1020	"allowed dimensions of %d",
1021	to->rank, to->corank, GFC_MAX_DIMENSIONS15);
1022	to->corank = GFC_MAX_DIMENSIONS15 - to->rank;
1023	return false;
1024	}
1025	return true;
1026	}
1027
1028
1029	/* Match an intent specification. Since this can only happen after an
1030	INTENT word, a legal intent-spec must follow. */
1031
1032	static sym_intent
1033	match_intent_spec (void)
1034	{
1035
1036	if (gfc_match (" ( in out )") == MATCH_YES)
1037	return INTENT_INOUT;
1038	if (gfc_match (" ( in )") == MATCH_YES)
1039	return INTENT_IN;
1040	if (gfc_match (" ( out )") == MATCH_YES)
1041	return INTENT_OUT;
1042
1043	gfc_error ("Bad INTENT specification at %C");
1044	return INTENT_UNKNOWN;
1045	}
1046
1047
1048	/* Matches a character length specification, which is either a
1049	specification expression, '', or ':'. /
1050
1051	static match
1052	char_len_param_value (gfc_expr *expr, bool deferred)
1053	{
1054	match m;
1055
1056	*expr = NULL__null;
1057	*deferred = false;
1058
1059	if (gfc_match_char ('*') == MATCH_YES)
1060	return MATCH_YES;
1061
1062	if (gfc_match_char (':') == MATCH_YES)
1063	{
1064	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "deferred type parameter at %C"))
1065	return MATCH_ERROR;
1066
1067	*deferred = true;
1068
1069	return MATCH_YES;
1070	}
1071
1072	m = gfc_match_expr (expr);
1073
1074	if (m == MATCH_NO \|\| m == MATCH_ERROR)
1075	return m;
1076
1077	if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1078	return MATCH_ERROR;
1079
1080	/* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things
1081	like CHARACTER(([1])). */
1082	if ((*expr)->expr_type == EXPR_OP)
1083	gfc_simplify_expr (*expr, 1);
1084
1085	if ((*expr)->expr_type == EXPR_FUNCTION)
1086	{
1087	if ((*expr)->ts.type == BT_INTEGER
1088	\|\| ((*expr)->ts.type == BT_UNKNOWN
1089	&& strcmp((*expr)->symtree->name, "null") != 0))
1090	return MATCH_YES;
1091
1092	goto syntax;
1093	}
1094	else if ((*expr)->expr_type == EXPR_CONSTANT)
1095	{
1096	/* F2008, 4.4.3.1: The length is a type parameter; its kind is
1097	processor dependent and its value is greater than or equal to zero.
1098	F2008, 4.4.3.2: If the character length parameter value evaluates
1099	to a negative value, the length of character entities declared
1100	is zero. */
1101
1102	if ((*expr)->ts.type == BT_INTEGER)
1103	{
1104	if (mpz_cmp_si ((expr)->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( ((expr)->value.integer)->_mp_size < 0 ? -1 : ((expr )->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (( expr)->value.integer,(static_cast<unsigned long> (0) ))) : __gmpz_cmp_si ((*expr)->value.integer,0)) < 0)
1105	mpz_set_si__gmpz_set_si ((*expr)->value.integer, 0);
1106	}
1107	else
1108	goto syntax;
1109	}
1110	else if ((*expr)->expr_type == EXPR_ARRAY)
1111	goto syntax;
1112	else if ((*expr)->expr_type == EXPR_VARIABLE)
1113	{
1114	bool t;
1115	gfc_expr *e;
1116
1117	e = gfc_copy_expr (*expr);
1118
1119	/* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1120	which causes an ICE if gfc_reduce_init_expr() is called. */
1121	if (e->ref && e->ref->type == REF_ARRAY
1122	&& e->ref->u.ar.type == AR_UNKNOWN
1123	&& e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1124	goto syntax;
1125
1126	t = gfc_reduce_init_expr (e);
1127
1128	if (!t && e->ts.type == BT_UNKNOWN
1129	&& e->symtree->n.sym->attr.untyped == 1
1130	&& (flag_implicit_noneglobal_options.x_flag_implicit_none
1131	\|\| e->symtree->n.sym->ns->seen_implicit_none == 1
1132	\|\| e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1133	{
1134	gfc_free_expr (e);
1135	goto syntax;
1136	}
1137
1138	if ((e->ref && e->ref->type == REF_ARRAY
1139	&& e->ref->u.ar.type != AR_ELEMENT)
1140	\|\| (!e->ref && e->expr_type == EXPR_ARRAY))
1141	{
1142	gfc_free_expr (e);
1143	goto syntax;
1144	}
1145
1146	gfc_free_expr (e);
1147	}
1148
1149	if (gfc_seen_div0)
1150	m = MATCH_ERROR;
1151
1152	return m;
1153
1154	syntax:
1155	gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1156	return MATCH_ERROR;
1157	}
1158
1159
1160	/* A character length is a '*' followed by a literal integer or a
1161	char_len_param_value in parenthesis. */
1162
1163	static match
1164	match_char_length (gfc_expr *expr, bool deferred, bool obsolescent_check)
1165	{
1166	int length;
1167	match m;
1168
1169	*deferred = false;
1170	m = gfc_match_char ('*');
1171	if (m != MATCH_YES)
1172	return m;
1173
1174	m = gfc_match_small_literal_int (&length, NULL__null);
1175	if (m == MATCH_ERROR)
1176	return m;
1177
1178	if (m == MATCH_YES)
1179	{
1180	if (obsolescent_check
1181	&& !gfc_notify_std (GFC_STD_F95_OBS(1<<1), "Old-style character length at %C"))
1182	return MATCH_ERROR;
1183	*expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, length);
1184	return m;
1185	}
1186
1187	if (gfc_match_char ('(') == MATCH_NO)
1188	goto syntax;
1189
1190	m = char_len_param_value (expr, deferred);
1191	if (m != MATCH_YES && gfc_matching_function)
1192	{
1193	gfc_undo_symbols ();
1194	m = MATCH_YES;
1195	}
1196
1197	if (m == MATCH_ERROR)
1198	return m;
1199	if (m == MATCH_NO)
1200	goto syntax;
1201
1202	if (gfc_match_char (')') == MATCH_NO)
1203	{
1204	gfc_free_expr (*expr);
1205	*expr = NULL__null;
1206	goto syntax;
1207	}
1208
1209	return MATCH_YES;
1210
1211	syntax:
1212	gfc_error ("Syntax error in character length specification at %C");
1213	return MATCH_ERROR;
1214	}
1215
1216
1217	/* Special subroutine for finding a symbol. Check if the name is found
1218	in the current name space. If not, and we're compiling a function or
1219	subroutine and the parent compilation unit is an interface, then check
1220	to see if the name we've been given is the name of the interface
1221	(located in another namespace). */
1222
1223	static int
1224	find_special (const char name, gfc_symbol *result, bool allow_subroutine)
1225	{
1226	gfc_state_data *s;
1227	gfc_symtree *st;
1228	int i;
1229
1230	i = gfc_get_sym_tree (name, NULL__null, &st, allow_subroutine);
1231	if (i == 0)
1232	{
1233	*result = st ? st->n.sym : NULL__null;
1234	goto end;
1235	}
1236
1237	if (gfc_current_state ()(gfc_state_stack->state) != COMP_SUBROUTINE
1238	&& gfc_current_state ()(gfc_state_stack->state) != COMP_FUNCTION)
1239	goto end;
1240
1241	s = gfc_state_stack->previous;
1242	if (s == NULL__null)
1243	goto end;
1244
1245	if (s->state != COMP_INTERFACE)
1246	goto end;
1247	if (s->sym == NULL__null)
1248	goto end; /* Nameless interface. */
1249
1250	if (strcmp (name, s->sym->name) == 0)
1251	{
1252	*result = s->sym;
1253	return 0;
1254	}
1255
1256	end:
1257	return i;
1258	}
1259
1260
1261	/* Special subroutine for getting a symbol node associated with a
1262	procedure name, used in SUBROUTINE and FUNCTION statements. The
1263	symbol is created in the parent using with symtree node in the
1264	child unit pointing to the symbol. If the current namespace has no
1265	parent, then the symbol is just created in the current unit. */
1266
1267	static int
1268	get_proc_name (const char name, gfc_symbol *result, bool module_fcn_entry)
1269	{
1270	gfc_symtree *st;
1271	gfc_symbol *sym;
1272	int rc = 0;
1273
1274	/* Module functions have to be left in their own namespace because
1275	they have potentially (almost certainly!) already been referenced.
1276	In this sense, they are rather like external functions. This is
1277	fixed up in resolve.c(resolve_entries), where the symbol name-
1278	space is set to point to the master function, so that the fake
1279	result mechanism can work. */
1280	if (module_fcn_entry)
1281	{
1282	/* Present if entry is declared to be a module procedure. */
1283	rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1284
1285	if (*result == NULL__null)
1286	rc = gfc_get_symbol (name, NULL__null, result);
1287	else if (!gfc_get_symbol (name, NULL__null, &sym) && sym
1288	&& (*result)->ts.type == BT_UNKNOWN
1289	&& sym->attr.flavor == FL_UNKNOWN)
1290	/* Pick up the typespec for the entry, if declared in the function
1291	body. Note that this symbol is FL_UNKNOWN because it will
1292	only have appeared in a type declaration. The local symtree
1293	is set to point to the module symbol and a unique symtree
1294	to the local version. This latter ensures a correct clearing
1295	of the symbols. */
1296	{
1297	/* If the ENTRY proceeds its specification, we need to ensure
1298	that this does not raise a "has no IMPLICIT type" error. */
1299	if (sym->ts.type == BT_UNKNOWN)
1300	sym->attr.untyped = 1;
1301
1302	(*result)->ts = sym->ts;
1303
1304	/* Put the symbol in the procedure namespace so that, should
1305	the ENTRY precede its specification, the specification
1306	can be applied. */
1307	(*result)->ns = gfc_current_ns;
1308
1309	gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1310	st->n.sym = *result;
1311	st = gfc_get_unique_symtree (gfc_current_ns);
1312	sym->refs++;
1313	st->n.sym = sym;
1314	}
1315	}
1316	else
1317	rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1318
1319	if (rc)
1320	return rc;
1321
1322	sym = *result;
1323	if (sym->attr.proc == PROC_ST_FUNCTION)
1324	return rc;
1325
1326	if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1327	{
1328	/* Create a partially populated interface symbol to carry the
1329	characteristics of the procedure and the result. */
1330	sym->tlink = gfc_new_symbol (name, sym->ns);
1331	gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1332	gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL__null);
1333	if (sym->attr.dimension)
1334	sym->tlink->as = gfc_copy_array_spec (sym->as);
1335
1336	/* Ideally, at this point, a copy would be made of the formal
1337	arguments and their namespace. However, this does not appear
1338	to be necessary, albeit at the expense of not being able to
1339	use gfc_compare_interfaces directly. */
1340
1341	if (sym->result && sym->result != sym)
1342	{
1343	sym->tlink->result = sym->result;
1344	sym->result = NULL__null;
1345	}
1346	else if (sym->result)
1347	{
1348	sym->tlink->result = sym->tlink;
1349	}
1350	}
1351	else if (sym && !sym->gfc_new
1352	&& gfc_current_state ()(gfc_state_stack->state) != COMP_INTERFACE)
1353	{
1354	/* Trap another encompassed procedure with the same name. All
1355	these conditions are necessary to avoid picking up an entry
1356	whose name clashes with that of the encompassing procedure;
1357	this is handled using gsymbols to register unique, globally
1358	accessible names. */
1359	if (sym->attr.flavor != 0
1360	&& sym->attr.proc != 0
1361	&& (sym->attr.subroutine \|\| sym->attr.function \|\| sym->attr.entry)
1362	&& sym->attr.if_source != IFSRC_UNKNOWN)
1363	{
1364	gfc_error_now ("Procedure %qs at %C is already defined at %L",
1365	name, &sym->declared_at);
1366	return true;
1367	}
1368	if (sym->attr.flavor != 0
1369	&& sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1370	{
1371	gfc_error_now ("Procedure %qs at %C is already defined at %L",
1372	name, &sym->declared_at);
1373	return true;
1374	}
1375
1376	if (sym->attr.external && sym->attr.procedure
1377	&& gfc_current_state ()(gfc_state_stack->state) == COMP_CONTAINS)
1378	{
1379	gfc_error_now ("Contained procedure %qs at %C clashes with "
1380	"procedure defined at %L",
1381	name, &sym->declared_at);
1382	return true;
1383	}
1384
1385	/* Trap a procedure with a name the same as interface in the
1386	encompassing scope. */
1387	if (sym->attr.generic != 0
1388	&& (sym->attr.subroutine \|\| sym->attr.function)
1389	&& !sym->attr.mod_proc)
1390	{
1391	gfc_error_now ("Name %qs at %C is already defined"
1392	" as a generic interface at %L",
1393	name, &sym->declared_at);
1394	return true;
1395	}
1396
1397	/* Trap declarations of attributes in encompassing scope. The
1398	signature for this is that ts.kind is nonzero for no-CLASS
1399	entity. For a CLASS entity, ts.kind is zero. */
1400	if ((sym->ts.kind != 0 \|\| sym->ts.type == BT_CLASS)
1401	&& !sym->attr.implicit_type
1402	&& sym->attr.proc == 0
1403	&& gfc_current_ns->parent != NULL__null
1404	&& sym->attr.access == 0
1405	&& !module_fcn_entry)
1406	{
1407	gfc_error_now ("Procedure %qs at %C has an explicit interface "
1408	"from a previous declaration", name);
1409	return true;
1410	}
1411	}
1412
1413	/* C1246 (R1225) MODULE shall appear only in the function-stmt or
1414	subroutine-stmt of a module subprogram or of a nonabstract interface
1415	body that is declared in the scoping unit of a module or submodule. */
1416	if (sym->attr.external
1417	&& (sym->attr.subroutine \|\| sym->attr.function)
1418	&& sym->attr.if_source == IFSRC_IFBODY
1419	&& !current_attr.module_procedure
1420	&& sym->attr.proc == PROC_MODULE
1421	&& gfc_state_stack->state == COMP_CONTAINS)
1422	{
1423	gfc_error_now ("Procedure %qs defined in interface body at %L "
1424	"clashes with internal procedure defined at %C",
1425	name, &sym->declared_at);
1426	return true;
1427	}
1428
1429	if (sym && !sym->gfc_new
1430	&& sym->attr.flavor != FL_UNKNOWN
1431	&& sym->attr.referenced == 0 && sym->attr.subroutine == 1
1432	&& gfc_state_stack->state == COMP_CONTAINS
1433	&& gfc_state_stack->previous->state == COMP_SUBROUTINE)
1434	{
1435	gfc_error_now ("Procedure %qs at %C is already defined at %L",
1436	name, &sym->declared_at);
1437	return true;
1438	}
1439
1440	if (gfc_current_ns->parent == NULL__null \|\| *result == NULL__null)
1441	return rc;
1442
1443	/* Module function entries will already have a symtree in
1444	the current namespace but will need one at module level. */
1445	if (module_fcn_entry)
1446	{
1447	/* Present if entry is declared to be a module procedure. */
1448	rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1449	if (st == NULL__null)
1450	st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1451	}
1452	else
1453	st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1454
1455	st->n.sym = sym;
1456	sym->refs++;
1457
1458	/* See if the procedure should be a module procedure. */
1459
1460	if (((sym->ns->proc_name != NULL__null
1461	&& sym->ns->proc_name->attr.flavor == FL_MODULE
1462	&& sym->attr.proc != PROC_MODULE)
1463	\|\| (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1464	&& !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL__null))
1465	rc = 2;
1466
1467	return rc;
1468	}
1469
1470
1471	/* Verify that the given symbol representing a parameter is C
1472	interoperable, by checking to see if it was marked as such after
1473	its declaration. If the given symbol is not interoperable, a
1474	warning is reported, thus removing the need to return the status to
1475	the calling function. The standard does not require the user use
1476	one of the iso_c_binding named constants to declare an
1477	interoperable parameter, but we can't be sure if the param is C
1478	interop or not if the user doesn't. For example, integer(4) may be
1479	legal Fortran, but doesn't have meaning in C. It may interop with
1480	a number of the C types, which causes a problem because the
1481	compiler can't know which one. This code is almost certainly not
1482	portable, and the user will get what they deserve if the C type
1483	across platforms isn't always interoperable with integer(4). If
1484	the user had used something like integer(c_int) or integer(c_long),
1485	the compiler could have automatically handled the varying sizes
1486	across platforms. */
1487
1488	bool
1489	gfc_verify_c_interop_param (gfc_symbol *sym)
1490	{
1491	int is_c_interop = 0;
1492	bool retval = true;
1493
1494	/* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1495	Don't repeat the checks here. */
1496	if (sym->attr.implicit_type)
1497	return true;
1498
1499	/* For subroutines or functions that are passed to a BIND(C) procedure,
1500	they're interoperable if they're BIND(C) and their params are all
1501	interoperable. */
1502	if (sym->attr.flavor == FL_PROCEDURE)
1503	{
1504	if (sym->attr.is_bind_c == 0)
1505	{
1506	gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1507	"attribute to be C interoperable", sym->name,
1508	&(sym->declared_at));
1509	return false;
1510	}
1511	else
1512	{
1513	if (sym->attr.is_c_interop == 1)
1514	/* We've already checked this procedure; don't check it again. */
1515	return true;
1516	else
1517	return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1518	sym->common_block);
1519	}
1520	}
1521
1522	/* See if we've stored a reference to a procedure that owns sym. */
1523	if (sym->ns != NULL__null && sym->ns->proc_name != NULL__null)
1524	{
1525	if (sym->ns->proc_name->attr.is_bind_c == 1)
1526	{
1527	is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1528
1529	if (is_c_interop != 1)
1530	{
1531	/* Make personalized messages to give better feedback. */
1532	if (sym->ts.type == BT_DERIVED)
1533	gfc_error ("Variable %qs at %L is a dummy argument to the "
1534	"BIND(C) procedure %qs but is not C interoperable "
1535	"because derived type %qs is not C interoperable",
1536	sym->name, &(sym->declared_at),
1537	sym->ns->proc_name->name,
1538	sym->ts.u.derived->name);
1539	else if (sym->ts.type == BT_CLASS)
1540	gfc_error ("Variable %qs at %L is a dummy argument to the "
1541	"BIND(C) procedure %qs but is not C interoperable "
1542	"because it is polymorphic",
1543	sym->name, &(sym->declared_at),
1544	sym->ns->proc_name->name);
1545	else if (warn_c_binding_typeglobal_options.x_warn_c_binding_type)
1546	gfc_warning (OPT_Wc_binding_type,
1547	"Variable %qs at %L is a dummy argument of the "
1548	"BIND(C) procedure %qs but may not be C "
1549	"interoperable",
1550	sym->name, &(sym->declared_at),
1551	sym->ns->proc_name->name);
1552	}
1553
1554	/* Character strings are only C interoperable if they have a
1555	length of 1. */
1556	if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension)
1557	{
1558	gfc_charlen *cl = sym->ts.u.cl;
1559	if (!cl \|\| !cl->length \|\| cl->length->expr_type != EXPR_CONSTANT
1560	\|\| mpz_cmp_si (cl->length->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (cl->length->value.integer)->_mp_size < 0 ? -1 : ( cl->length->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (cl->length->value.integer,(static_cast<unsigned long > (1)))) : __gmpz_cmp_si (cl->length->value.integer, 1)) != 0)
1561	{
1562	gfc_error ("Character argument %qs at %L "
1563	"must be length 1 because "
1564	"procedure %qs is BIND(C)",
1565	sym->name, &sym->declared_at,
1566	sym->ns->proc_name->name);
1567	retval = false;
1568	}
1569	}
1570
1571	/* We have to make sure that any param to a bind(c) routine does
1572	not have the allocatable, pointer, or optional attributes,
1573	according to J3/04-007, section 5.1. */
1574	if (sym->attr.allocatable == 1
1575	&& !gfc_notify_std (GFC_STD_F2018(1<<9), "Variable %qs at %L with "
1576	"ALLOCATABLE attribute in procedure %qs "
1577	"with BIND(C)", sym->name,
1578	&(sym->declared_at),
1579	sym->ns->proc_name->name))
1580	retval = false;
1581
1582	if (sym->attr.pointer == 1
1583	&& !gfc_notify_std (GFC_STD_F2018(1<<9), "Variable %qs at %L with "
1584	"POINTER attribute in procedure %qs "
1585	"with BIND(C)", sym->name,
1586	&(sym->declared_at),
1587	sym->ns->proc_name->name))
1588	retval = false;
1589
1590	if (sym->attr.optional == 1 && sym->attr.value)
1591	{
1592	gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1593	"and the VALUE attribute because procedure %qs "
1594	"is BIND(C)", sym->name, &(sym->declared_at),
1595	sym->ns->proc_name->name);
1596	retval = false;
1597	}
1598	else if (sym->attr.optional == 1
1599	&& !gfc_notify_std (GFC_STD_F2018(1<<9), "Variable %qs "
1600	"at %L with OPTIONAL attribute in "
1601	"procedure %qs which is BIND(C)",
1602	sym->name, &(sym->declared_at),
1603	sym->ns->proc_name->name))
1604	retval = false;
1605
1606	/* Make sure that if it has the dimension attribute, that it is
1607	either assumed size or explicit shape. Deferred shape is already
1608	covered by the pointer/allocatable attribute. */
1609	if (sym->as != NULL__null && sym->as->type == AS_ASSUMED_SHAPE
1610	&& !gfc_notify_std (GFC_STD_F2018(1<<9), "Assumed-shape array %qs "
1611	"at %L as dummy argument to the BIND(C) "
1612	"procedure %qs at %L", sym->name,
1613	&(sym->declared_at),
1614	sym->ns->proc_name->name,
1615	&(sym->ns->proc_name->declared_at)))
1616	retval = false;
1617	}
1618	}
1619
1620	return retval;
1621	}
1622
1623
1624
1625	/* Function called by variable_decl() that adds a name to the symbol table. */
1626
1627	static bool
1628	build_sym (const char name, gfc_charlen cl, bool cl_deferred,
1629	gfc_array_spec *as, locus var_locus)
1630	{
1631	symbol_attribute attr;
1632	gfc_symbol *sym;
1633	int upper;
1634	gfc_symtree *st;
1635
1636	/* Symbols in a submodule are host associated from the parent module or
1637	submodules. Therefore, they can be overridden by declarations in the
1638	submodule scope. Deal with this by attaching the existing symbol to
1639	a new symtree and recycling the old symtree with a new symbol... */
1640	st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1641	if (st != NULL__null && gfc_state_stack->state == COMP_SUBMODULE
1642	&& st->n.sym != NULL__null
1643	&& st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1644	{
1645	gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1646	s->n.sym = st->n.sym;
1647	sym = gfc_new_symbol (name, gfc_current_ns);
1648
1649
1650	st->n.sym = sym;
1651	sym->refs++;
1652	gfc_set_sym_referenced (sym);
1653	}
1654	/* ...Otherwise generate a new symtree and new symbol. */
1655	else if (gfc_get_symbol (name, NULL__null, &sym))
1656	return false;
1657
1658	/* Check if the name has already been defined as a type. The
1659	first letter of the symtree will be in upper case then. Of
1660	course, this is only necessary if the upper case letter is
1661	actually different. */
1662
1663	upper = TOUPPER(name[0])_sch_toupper[(name[0]) & 0xff];
1664	if (upper != name[0])
1665	{
1666	char u_name[GFC_MAX_SYMBOL_LEN63 + 1];
1667	gfc_symtree *st;
1668
1669	gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN)((void)(!(strlen(name) <= 63) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 1669, __FUNCTION__), 0 : 0));
1670	strcpy (u_name, name);
1671	u_name[0] = upper;
1672
1673	st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1674
1675	/* STRUCTURE types can alias symbol names */
1676	if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1677	{
1678	gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1679	&st->n.sym->declared_at);
1680	return false;
1681	}
1682	}
1683
1684	/* Start updating the symbol table. Add basic type attribute if present. */
1685	if (current_ts.type != BT_UNKNOWN
1686	&& (sym->attr.implicit_type == 0
1687	\|\| !gfc_compare_types (&sym->ts, &current_ts))
1688	&& !gfc_add_type (sym, &current_ts, var_locus))
1689	return false;
1690
1691	if (sym->ts.type == BT_CHARACTER)
1692	{
1693	sym->ts.u.cl = cl;
1694	sym->ts.deferred = cl_deferred;
1695	}
1696
1697	/* Add dimension attribute if present. */
1698	if (!gfc_set_array_spec (sym, *as, var_locus))
1699	return false;
1700	*as = NULL__null;
1701
1702	/* Add attribute to symbol. The copy is so that we can reset the
1703	dimension attribute. */
1704	attr = current_attr;
1705	attr.dimension = 0;
1706	attr.codimension = 0;
1707
1708	if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1709	return false;
1710
1711	/* Finish any work that may need to be done for the binding label,
1712	if it's a bind(c). The bind(c) attr is found before the symbol
1713	is made, and before the symbol name (for data decls), so the
1714	current_ts is holding the binding label, or nothing if the
1715	name= attr wasn't given. Therefore, test here if we're dealing
1716	with a bind(c) and make sure the binding label is set correctly. */
1717	if (sym->attr.is_bind_c == 1)
1718	{
1719	if (!sym->binding_label)
1720	{
1721	/* Set the binding label and verify that if a NAME= was specified
1722	then only one identifier was in the entity-decl-list. */
1723	if (!set_binding_label (&sym->binding_label, sym->name,
1724	num_idents_on_line))
1725	return false;
1726	}
1727	}
1728
1729	/* See if we know we're in a common block, and if it's a bind(c)
1730	common then we need to make sure we're an interoperable type. */
1731	if (sym->attr.in_common == 1)
1732	{
1733	/* Test the common block object. */
1734	if (sym->common_block != NULL__null && sym->common_block->is_bind_c == 1
1735	&& sym->ts.is_c_interop != 1)
1736	{
1737	gfc_error_now ("Variable %qs in common block %qs at %C "
1738	"must be declared with a C interoperable "
1739	"kind since common block %qs is BIND(C)",
1740	sym->name, sym->common_block->name,
1741	sym->common_block->name);
1742	gfc_clear_error ();
1743	}
1744	}
1745
1746	sym->attr.implied_index = 0;
1747
1748	/* Use the parameter expressions for a parameterized derived type. */
1749	if ((sym->ts.type == BT_DERIVED \|\| sym->ts.type == BT_CLASS)
1750	&& sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1751	sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1752
1753	if (sym->ts.type == BT_CLASS)
1754	return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1755
1756	return true;
1757	}
1758
1759
1760	/* Set character constant to the given length. The constant will be padded or
1761	truncated. If we're inside an array constructor without a typespec, we
1762	additionally check that all elements have the same length; check_len -1
1763	means no checking. */
1764
1765	void
1766	gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1767	gfc_charlen_t check_len)
1768	{
1769	gfc_char_t *s;
1770	gfc_charlen_t slen;
1771
1772	if (expr->ts.type != BT_CHARACTER)
1773	return;
1774
1775	if (expr->expr_type != EXPR_CONSTANT)
1776	{
1777	gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1778	return;
1779	}
1780
1781	slen = expr->value.character.length;
1782	if (len != slen)
1783	{
1784	s = gfc_get_wide_string (len + 1)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t)));
1785	memcpy (s, expr->value.character.string,
1786	MIN (len, slen)((len) < (slen) ? (len) : (slen)) * sizeof (gfc_char_t));
1787	if (len > slen)
1788	gfc_wide_memset (&s[slen], ' ', len - slen);
1789
1790	if (warn_character_truncationglobal_options.x_warn_character_truncation && slen > len)
1791	gfc_warning_now (OPT_Wcharacter_truncation,
1792	"CHARACTER expression at %L is being truncated "
1793	"(%ld/%ld)", &expr->where,
1794	(long) slen, (long) len);
1795
1796	/* Apply the standard by 'hand' otherwise it gets cleared for
1797	initializers. */
1798	if (check_len != -1 && slen != check_len
1799	&& !(gfc_option.allow_std & GFC_STD_GNU(1<<5)))
1800	gfc_error_now ("The CHARACTER elements of the array constructor "
1801	"at %L must have the same length (%ld/%ld)",
1802	&expr->where, (long) slen,
1803	(long) check_len);
1804
1805	s[len] = '\0';
1806	free (expr->value.character.string);
1807	expr->value.character.string = s;
1808	expr->value.character.length = len;
1809	/* If explicit representation was given, clear it
1810	as it is no longer needed after padding. */
1811	if (expr->representation.length)
1812	{
1813	expr->representation.length = 0;
1814	free (expr->representation.string);
1815	expr->representation.string = NULL__null;
1816	}
1817	}
1818	}
1819
1820
1821	/* Function to create and update the enumerator history
1822	using the information passed as arguments.
1823	Pointer "max_enum" is also updated, to point to
1824	enum history node containing largest initializer.
1825
1826	SYM points to the symbol node of enumerator.
1827	INIT points to its enumerator value. */
1828
1829	static void
1830	create_enum_history (gfc_symbol sym, gfc_expr init)
1831	{
1832	enumerator_history *new_enum_history;
1833	gcc_assert (sym != NULL && init != NULL)((void)(!(sym != __null && init != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 1833, __FUNCTION__), 0 : 0));
1834
1835	new_enum_history = XCNEW (enumerator_history)((enumerator_history *) xcalloc (1, sizeof (enumerator_history )));
1836
1837	new_enum_history->sym = sym;
1838	new_enum_history->initializer = init;
1839	new_enum_history->next = NULL__null;
1840
1841	if (enum_history == NULL__null)
1842	{
1843	enum_history = new_enum_history;
1844	max_enum = enum_history;
1845	}
1846	else
1847	{
1848	new_enum_history->next = enum_history;
1849	enum_history = new_enum_history;
1850
1851	if (mpz_cmp__gmpz_cmp (max_enum->initializer->value.integer,
1852	new_enum_history->initializer->value.integer) < 0)
1853	max_enum = new_enum_history;
1854	}
1855	}
1856
1857
1858	/* Function to free enum kind history. */
1859
1860	void
1861	gfc_free_enum_history (void)
1862	{
1863	enumerator_history *current = enum_history;
1864	enumerator_history *next;
1865
1866	while (current != NULL__null)
1867	{
1868	next = current->next;
1869	free (current);
1870	current = next;
1871	}
1872	max_enum = NULL__null;
1873	enum_history = NULL__null;
1874	}
1875
1876
1877	/* Function called by variable_decl() that adds an initialization
1878	expression to a symbol. */
1879
1880	static bool
1881	add_init_expr_to_sym (const char name, gfc_expr initp, locus var_locus)
1882	{
1883	symbol_attribute attr;
1884	gfc_symbol *sym;
1885	gfc_expr *init;
1886
1887	init = *initp;
1888	if (find_special (name, &sym, false))
1889	return false;
1890
1891	attr = sym->attr;
1892
1893	/* If this symbol is confirming an implicit parameter type,
1894	then an initialization expression is not allowed. */
1895	if (attr.flavor == FL_PARAMETER && sym->value != NULL__null)
1896	{
1897	if (*initp != NULL__null)
1898	{
1899	gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1900	sym->name);
1901	return false;
1902	}
1903	else
1904	return true;
1905	}
1906
1907	if (init == NULL__null)
1908	{
1909	/* An initializer is required for PARAMETER declarations. */
1910	if (attr.flavor == FL_PARAMETER)
1911	{
1912	gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1913	return false;
1914	}
1915	}
1916	else
1917	{
1918	/* If a variable appears in a DATA block, it cannot have an
1919	initializer. */
1920	if (sym->attr.data)
1921	{
1922	gfc_error ("Variable %qs at %C with an initializer already "
1923	"appears in a DATA statement", sym->name);
1924	return false;
1925	}
1926
1927	/* Check if the assignment can happen. This has to be put off
1928	until later for derived type variables and procedure pointers. */
1929	if (!gfc_bt_struct (sym->ts.type)((sym->ts.type) == BT_DERIVED \|\| (sym->ts.type) == BT_UNION ) && !gfc_bt_struct (init->ts.type)((init->ts.type) == BT_DERIVED \|\| (init->ts.type) == BT_UNION )
1930	&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1931	&& !sym->attr.proc_pointer
1932	&& !gfc_check_assign_symbol (sym, NULL__null, init))
1933	return false;
1934
1935	if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1936	&& init->ts.type == BT_CHARACTER)
1937	{
1938	/* Update symbol character length according initializer. */
1939	if (!gfc_check_assign_symbol (sym, NULL__null, init))
1940	return false;
1941
1942	if (sym->ts.u.cl->length == NULL__null)
1943	{
1944	gfc_charlen_t clen;
1945	/* If there are multiple CHARACTER variables declared on the
1946	same line, we don't want them to share the same length. */
1947	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
1948
1949	if (sym->attr.flavor == FL_PARAMETER)
1950	{
1951	if (init->expr_type == EXPR_CONSTANT)
1952	{
1953	clen = init->value.character.length;
1954	sym->ts.u.cl->length
1955	= gfc_get_int_expr (gfc_charlen_int_kind,
1956	NULL__null, clen);
1957	}
1958	else if (init->expr_type == EXPR_ARRAY)
1959	{
1960	if (init->ts.u.cl && init->ts.u.cl->length)
1961	{
1962	const gfc_expr *length = init->ts.u.cl->length;
1963	if (length->expr_type != EXPR_CONSTANT)
1964	{
1965	gfc_error ("Cannot initialize parameter array "
1966	"at %L "
1967	"with variable length elements",
1968	&sym->declared_at);
1969	return false;
1970	}
1971	clen = mpz_get_si__gmpz_get_si (length->value.integer);
1972	}
1973	else if (init->value.constructor)
1974	{
1975	gfc_constructor *c;
1976	c = gfc_constructor_first (init->value.constructor);
1977	clen = c->expr->value.character.length;
1978	}
1979	else
1980	gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 1980, __FUNCTION__));
1981	sym->ts.u.cl->length
1982	= gfc_get_int_expr (gfc_charlen_int_kind,
1983	NULL__null, clen);
1984	}
1985	else if (init->ts.u.cl && init->ts.u.cl->length)
1986	sym->ts.u.cl->length =
1987	gfc_copy_expr (init->ts.u.cl->length);
1988	}
1989	}
1990	/* Update initializer character length according symbol. */
1991	else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1992	{
1993	if (!gfc_specification_expr (sym->ts.u.cl->length))
1994	return false;
1995
1996	int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
1997	false);
1998	/* resolve_charlen will complain later on if the length
1999	is too large. Just skeep the initialization in that case. */
2000	if (mpz_cmp__gmpz_cmp (sym->ts.u.cl->length->value.integer,
2001	gfc_integer_kinds[k].huge) <= 0)
2002	{
2003	HOST_WIDE_INTlong len
2004	= gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);
2005
2006	if (init->expr_type == EXPR_CONSTANT)
2007	gfc_set_constant_character_len (len, init, -1);
2008	else if (init->expr_type == EXPR_ARRAY)
2009	{
2010	gfc_constructor *c;
2011
2012	/* Build a new charlen to prevent simplification from
2013	deleting the length before it is resolved. */
2014	init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
2015	init->ts.u.cl->length
2016	= gfc_copy_expr (sym->ts.u.cl->length);
2017
2018	for (c = gfc_constructor_first (init->value.constructor);
2019	c; c = gfc_constructor_next (c))
2020	gfc_set_constant_character_len (len, c->expr, -1);
2021	}
2022	}
2023	}
2024	}
2025
2026	/* If sym is implied-shape, set its upper bounds from init. */
2027	if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2028	&& sym->as->type == AS_IMPLIED_SHAPE)
2029	{
2030	int dim;
2031
2032	if (init->rank == 0)
2033	{
2034	gfc_error ("Cannot initialize implied-shape array at %L"
2035	" with scalar", &sym->declared_at);
2036	return false;
2037	}
2038
2039	/* The shape may be NULL for EXPR_ARRAY, set it. */
2040	if (init->shape == NULL__null)
2041	{
2042	gcc_assert (init->expr_type == EXPR_ARRAY)((void)(!(init->expr_type == EXPR_ARRAY) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 2042, __FUNCTION__), 0 : 0));
2043	init->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
2044	if (!gfc_array_size (init, &init->shape[0]))
2045	gfc_internal_error ("gfc_array_size failed");
2046	}
2047
2048	for (dim = 0; dim < sym->as->rank; ++dim)
2049	{
2050	int k;
2051	gfc_expr e, lower;
2052
2053	lower = sym->as->lower[dim];
2054
2055	/* If the lower bound is an array element from another
2056	parameterized array, then it is marked with EXPR_VARIABLE and
2057	is an initialization expression. Try to reduce it. */
2058	if (lower->expr_type == EXPR_VARIABLE)
2059	gfc_reduce_init_expr (lower);
2060
2061	if (lower->expr_type == EXPR_CONSTANT)
2062	{
2063	/* All dimensions must be without upper bound. */
2064	gcc_assert (!sym->as->upper[dim])((void)(!(!sym->as->upper[dim]) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 2064, __FUNCTION__), 0 : 0));
2065
2066	k = lower->ts.kind;
2067	e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2068	mpz_add__gmpz_add (e->value.integer, lower->value.integer,
2069	init->shape[dim]);
2070	mpz_sub_ui__gmpz_sub_ui (e->value.integer, e->value.integer, 1);
2071	sym->as->upper[dim] = e;
2072	}
2073	else
2074	{
2075	gfc_error ("Non-constant lower bound in implied-shape"
2076	" declaration at %L", &lower->where);
2077	return false;
2078	}
2079	}
2080
2081	sym->as->type = AS_EXPLICIT;
2082	}
2083
2084	/* Need to check if the expression we initialized this
2085	to was one of the iso_c_binding named constants. If so,
2086	and we're a parameter (constant), let it be iso_c.
2087	For example:
2088	integer(c_int), parameter :: my_int = c_int
2089	integer(my_int) :: my_int_2
2090	If we mark my_int as iso_c (since we can see it's value
2091	is equal to one of the named constants), then my_int_2
2092	will be considered C interoperable. */
2093	if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type)((sym->ts.type) == BT_DERIVED \|\| (sym->ts.type) == BT_UNION ))
2094	{
2095	sym->ts.is_iso_c \|= init->ts.is_iso_c;
2096	sym->ts.is_c_interop \|= init->ts.is_c_interop;
2097	/* attr bits needed for module files. */
2098	sym->attr.is_iso_c \|= init->ts.is_iso_c;
2099	sym->attr.is_c_interop \|= init->ts.is_c_interop;
2100	if (init->ts.is_iso_c)
2101	sym->ts.f90_type = init->ts.f90_type;
2102	}
2103
2104	/* Add initializer. Make sure we keep the ranks sane. */
2105	if (sym->attr.dimension && init->rank == 0)
2106	{
2107	mpz_t size;
2108	gfc_expr *array;
2109	int n;
2110	if (sym->attr.flavor == FL_PARAMETER
2111	&& init->expr_type == EXPR_CONSTANT
2112	&& spec_size (sym->as, &size)
2113	&& mpz_cmp_si (size, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (size)->_mp_size < 0 ? -1 : (size)->_mp_size > 0) : __gmpz_cmp_ui (size,(static_cast<unsigned long> (0)) )) : __gmpz_cmp_si (size,0)) > 0)
2114	{
2115	array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2116	&init->where);
2117	for (n = 0; n < (int)mpz_get_si__gmpz_get_si (size); n++)
2118	gfc_constructor_append_expr (&array->value.constructor,
2119	n == 0
2120	? init
2121	: gfc_copy_expr (init),
2122	&init->where);
2123
2124	array->shape = gfc_get_shape (sym->as->rank)(((mpz_t *) xcalloc (((sym->as->rank)), sizeof (mpz_t)) ));
2125	for (n = 0; n < sym->as->rank; n++)
2126	spec_dimen_size (sym->as, n, &array->shape[n]);
2127
2128	init = array;
2129	mpz_clear__gmpz_clear (size);
2130	}
2131	init->rank = sym->as->rank;
2132	}
2133
2134	sym->value = init;
2135	if (sym->attr.save == SAVE_NONE)
2136	sym->attr.save = SAVE_IMPLICIT;
2137	*initp = NULL__null;
2138	}
2139
2140	return true;
2141	}
2142
2143
2144	/* Function called by variable_decl() that adds a name to a structure
2145	being built. */
2146
2147	static bool
2148	build_struct (const char name, gfc_charlen cl, gfc_expr **init,
2149	gfc_array_spec **as)
2150	{
2151	gfc_state_data *s;
2152	gfc_component *c;
2153
2154	/* F03:C438/C439. If the current symbol is of the same derived type that we're
2155	constructing, it must have the pointer attribute. */
2156	if ((current_ts.type == BT_DERIVED \|\| current_ts.type == BT_CLASS)
2157	&& current_ts.u.derived == gfc_current_block ()(gfc_state_stack->sym)
2158	&& current_attr.pointer == 0)
2159	{
2160	if (current_attr.allocatable
2161	&& !gfc_notify_std(GFC_STD_F2008(1<<7), "Component at %C "
2162	"must have the POINTER attribute"))
2163	{
2164	return false;
2165	}
2166	else if (current_attr.allocatable == 0)
2167	{
2168	gfc_error ("Component at %C must have the POINTER attribute");
2169	return false;
2170	}
2171	}
2172
2173	/* F03:C437. */
2174	if (current_ts.type == BT_CLASS
2175	&& !(current_attr.pointer \|\| current_attr.allocatable))
2176	{
2177	gfc_error ("Component %qs with CLASS at %C must be allocatable "
2178	"or pointer", name);
2179	return false;
2180	}
2181
2182	if (gfc_current_block ()(gfc_state_stack->sym)->attr.pointer && (*as)->rank != 0)
2183	{
2184	if ((as)->type != AS_DEFERRED && (as)->type != AS_EXPLICIT)
2185	{
2186	gfc_error ("Array component of structure at %C must have explicit "
2187	"or deferred shape");
2188	return false;
2189	}
2190	}
2191
2192	/* If we are in a nested union/map definition, gfc_add_component will not
2193	properly find repeated components because:
2194	(i) gfc_add_component does a flat search, where components of unions
2195	and maps are implicity chained so nested components may conflict.
2196	(ii) Unions and maps are not linked as components of their parent
2197	structures until after they are parsed.
2198	For (i) we use gfc_find_component which searches recursively, and for (ii)
2199	we search each block directly from the parse stack until we find the top
2200	level structure. */
2201
2202	s = gfc_state_stack;
2203	if (s->state == COMP_UNION \|\| s->state == COMP_MAP)
2204	{
2205	while (s->state == COMP_UNION \|\| gfc_comp_struct (s->state)((s->state) == COMP_DERIVED \|\| (s->state) == COMP_STRUCTURE \|\| (s->state) == COMP_MAP))
2206	{
2207	c = gfc_find_component (s->sym, name, true, true, NULL__null);
2208	if (c != NULL__null)
2209	{
2210	gfc_error_now ("Component %qs at %C already declared at %L",
2211	name, &c->loc);
2212	return false;
2213	}
2214	/* Break after we've searched the entire chain. */
2215	if (s->state == COMP_DERIVED \|\| s->state == COMP_STRUCTURE)
2216	break;
2217	s = s->previous;
2218	}
2219	}
2220
2221	if (!gfc_add_component (gfc_current_block()(gfc_state_stack->sym), name, &c))
2222	return false;
2223
2224	c->ts = current_ts;
2225	if (c->ts.type == BT_CHARACTER)
2226	c->ts.u.cl = cl;
2227
2228	if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2229	&& (c->ts.kind == 0 \|\| c->ts.type == BT_CHARACTER)
2230	&& saved_kind_expr != NULL__null)
2231	c->kind_expr = gfc_copy_expr (saved_kind_expr);
2232
2233	c->attr = current_attr;
2234
2235	c->initializer = *init;
2236	*init = NULL__null;
2237
2238	c->as = *as;
2239	if (c->as != NULL__null)
2240	{
2241	if (c->as->corank)
2242	c->attr.codimension = 1;
2243	if (c->as->rank)
2244	c->attr.dimension = 1;
2245	}
2246	*as = NULL__null;
2247
2248	gfc_apply_init (&c->ts, &c->attr, c->initializer);
2249
2250	/* Check array components. */
2251	if (!c->attr.dimension)
2252	goto scalar;
2253
2254	if (c->attr.pointer)
2255	{
2256	if (c->as->type != AS_DEFERRED)
2257	{
2258	gfc_error ("Pointer array component of structure at %C must have a "
2259	"deferred shape");
2260	return false;
2261	}
2262	}
2263	else if (c->attr.allocatable)
2264	{
2265	if (c->as->type != AS_DEFERRED)
2266	{
2267	gfc_error ("Allocatable component of structure at %C must have a "
2268	"deferred shape");
2269	return false;
2270	}
2271	}
2272	else
2273	{
2274	if (c->as->type != AS_EXPLICIT)
2275	{
2276	gfc_error ("Array component of structure at %C must have an "
2277	"explicit shape");
2278	return false;
2279	}
2280	}
2281
2282	scalar:
2283	if (c->ts.type == BT_CLASS)
2284	return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2285
2286	if (c->attr.pdt_kind \|\| c->attr.pdt_len)
2287	{
2288	gfc_symbol *sym;
2289	gfc_find_symbol (c->name, gfc_current_block ()(gfc_state_stack->sym)->f2k_derived,
2290	0, &sym);
2291	if (sym == NULL__null)
2292	{
2293	gfc_error ("Type parameter %qs at %C has no corresponding entry "
2294	"in the type parameter name list at %L",
2295	c->name, &gfc_current_block ()(gfc_state_stack->sym)->declared_at);
2296	return false;
2297	}
2298	sym->ts = c->ts;
2299	sym->attr.pdt_kind = c->attr.pdt_kind;
2300	sym->attr.pdt_len = c->attr.pdt_len;
2301	if (c->initializer)
2302	sym->value = gfc_copy_expr (c->initializer);
2303	sym->attr.flavor = FL_VARIABLE;
2304	}
2305
2306	if ((c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
2307	&& c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2308	&& decl_type_param_list)
2309	c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2310
2311	return true;
2312	}
2313
2314
2315	/* Match a 'NULL()', and possibly take care of some side effects. */
2316
2317	match
2318	gfc_match_null (gfc_expr **result)
2319	{
2320	gfc_symbol *sym;
2321	match m, m2 = MATCH_NO;
2322
2323	if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2324	return MATCH_ERROR;
2325
2326	if (m == MATCH_NO)
2327	{
2328	locus old_loc;
2329	char name[GFC_MAX_SYMBOL_LEN63 + 1];
2330
2331	if ((m2 = gfc_match (" null (")) != MATCH_YES)
2332	return m2;
2333
2334	old_loc = gfc_current_locus;
2335	if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2336	return MATCH_ERROR;
2337	if (m2 != MATCH_YES
2338	&& ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2339	return MATCH_ERROR;
2340	if (m2 == MATCH_NO)
2341	{
2342	gfc_current_locus = old_loc;
2343	return MATCH_NO;
2344	}
2345	}
2346
2347	/* The NULL symbol now has to be/become an intrinsic function. */
2348	if (gfc_get_symbol ("null", NULL__null, &sym))
2349	{
2350	gfc_error ("NULL() initialization at %C is ambiguous");
2351	return MATCH_ERROR;
2352	}
2353
2354	gfc_intrinsic_symbol (sym)sym->module = gfc_get_string ("(intrinsic)");
2355
2356	if (sym->attr.proc != PROC_INTRINSIC
2357	&& !(sym->attr.use_assoc && sym->attr.intrinsic)
2358	&& (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL__null)
2359	\|\| !gfc_add_function (&sym->attr, sym->name, NULL__null)))
2360	return MATCH_ERROR;
2361
2362	*result = gfc_get_null_expr (&gfc_current_locus);
2363
2364	/* Invalid per F2008, C512. */
2365	if (m2 == MATCH_YES)
2366	{
2367	gfc_error ("NULL() initialization at %C may not have MOLD");
2368	return MATCH_ERROR;
2369	}
2370
2371	return MATCH_YES;
2372	}
2373
2374
2375	/* Match the initialization expr for a data pointer or procedure pointer. */
2376
2377	static match
2378	match_pointer_init (gfc_expr **init, int procptr)
2379	{
2380	match m;
2381
2382	if (gfc_pure (NULL__null) && !gfc_comp_struct (gfc_state_stack->state)((gfc_state_stack->state) == COMP_DERIVED \|\| (gfc_state_stack ->state) == COMP_STRUCTURE \|\| (gfc_state_stack->state) == COMP_MAP))
2383	{
2384	gfc_error ("Initialization of pointer at %C is not allowed in "
2385	"a PURE procedure");
2386	return MATCH_ERROR;
2387	}
2388	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2389
2390	/* Match NULL() initialization. */
2391	m = gfc_match_null (init);
2392	if (m != MATCH_NO)
2393	return m;
2394
2395	/* Match non-NULL initialization. */
2396	gfc_matching_ptr_assignment = !procptr;
2397	gfc_matching_procptr_assignment = procptr;
2398	m = gfc_match_rvalue (init);
2399	gfc_matching_ptr_assignment = 0;
2400	gfc_matching_procptr_assignment = 0;
2401	if (m == MATCH_ERROR)
2402	return MATCH_ERROR;
2403	else if (m == MATCH_NO)
2404	{
2405	gfc_error ("Error in pointer initialization at %C");
2406	return MATCH_ERROR;
2407	}
2408
2409	if (!procptr && !gfc_resolve_expr (*init))
2410	return MATCH_ERROR;
2411
2412	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "non-NULL pointer "
2413	"initialization at %C"))
2414	return MATCH_ERROR;
2415
2416	return MATCH_YES;
2417	}
2418
2419
2420	static bool
2421	check_function_name (char *name)
2422	{
2423	/* In functions that have a RESULT variable defined, the function name always
2424	refers to function calls. Therefore, the name is not allowed to appear in
2425	specification statements. When checking this, be careful about
2426	'hidden' procedure pointer results ('ppr@'). */
2427
2428	if (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION)
2429	{
2430	gfc_symbol *block = gfc_current_block ()(gfc_state_stack->sym);
2431	if (block && block->result && block->result != block
2432	&& strcmp (block->result->name, "ppr@") != 0
2433	&& strcmp (block->name, name) == 0)
2434	{
2435	gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2436	"from appearing in a specification statement",
2437	block->result->name, &block->result->declared_at, name);
2438	return false;
2439	}
2440	}
2441
2442	return true;
2443	}
2444
2445
2446	/* Match a variable name with an optional initializer. When this
2447	subroutine is called, a variable is expected to be parsed next.
2448	Depending on what is happening at the moment, updates either the
2449	symbol table or the current interface. */
2450
2451	static match
2452	variable_decl (int elem)
2453	{
2454	char name[GFC_MAX_SYMBOL_LEN63 + 1];
2455	static unsigned int fill_id = 0;
2456	gfc_expr initializer, char_len;
2457	gfc_array_spec *as;
2458	gfc_array_spec cp_as; / Extra copy for Cray Pointees. */
2459	gfc_charlen *cl;
2460	bool cl_deferred;
2461	locus var_locus;
2462	match m;
2463	bool t;
2464	gfc_symbol *sym;
2465	char c;
2466
2467	initializer = NULL__null;
2468	as = NULL__null;
2469	cp_as = NULL__null;
2470
2471	/* When we get here, we've just matched a list of attributes and
2472	maybe a type and a double colon. The next thing we expect to see
2473	is the name of the symbol. */
2474
2475	/* If we are parsing a structure with legacy support, we allow the symbol
2476	name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2477	m = MATCH_NO;
	Value stored to 'm' is never read
2478	gfc_gobble_whitespace ();
2479	c = gfc_peek_ascii_char ();
2480	if (c == '%')
2481	{
2482	gfc_next_ascii_char (); /* Burn % character. */
2483	m = gfc_match ("fill");
2484	if (m == MATCH_YES)
2485	{
2486	if (gfc_current_state ()(gfc_state_stack->state) != COMP_STRUCTURE)
2487	{
2488	if (flag_dec_structureglobal_options.x_flag_dec_structure)
2489	gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2490	else
2491	gfc_error ("%qs at %C is a DEC extension, enable with "
2492	"%<-fdec-structure%>", "%FILL");
2493	m = MATCH_ERROR;
2494	goto cleanup;
2495	}
2496
2497	if (attr_seen)
2498	{
2499	gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2500	m = MATCH_ERROR;
2501	goto cleanup;
2502	}
2503
2504	/* %FILL components are given invalid fortran names. */
2505	snprintf (name, GFC_MAX_SYMBOL_LEN63 + 1, "%%FILL%u", fill_id++);
2506	}
2507	else
2508	{
2509	gfc_error ("Invalid character %qc in variable name at %C", c);
2510	return MATCH_ERROR;
2511	}
2512	}
2513	else
2514	{
2515	m = gfc_match_name (name);
2516	if (m != MATCH_YES)
2517	goto cleanup;
2518	}
2519
2520	var_locus = gfc_current_locus;
2521
2522	/* Now we could see the optional array spec. or character length. */
2523	m = gfc_match_array_spec (&as, true, true);
2524	if (m == MATCH_ERROR)
2525	goto cleanup;
2526
2527	if (m == MATCH_NO)
2528	as = gfc_copy_array_spec (current_as);
2529	else if (current_as
2530	&& !merge_array_spec (current_as, as, true))
2531	{
2532	m = MATCH_ERROR;
2533	goto cleanup;
2534	}
2535
2536	if (flag_cray_pointerglobal_options.x_flag_cray_pointer)
2537	cp_as = gfc_copy_array_spec (as);
2538
2539	/* At this point, we know for sure if the symbol is PARAMETER and can thus
2540	determine (and check) whether it can be implied-shape. If it
2541	was parsed as assumed-size, change it because PARAMETERs cannot
2542	be assumed-size.
2543
2544	An explicit-shape-array cannot appear under several conditions.
2545	That check is done here as well. */
2546	if (as)
2547	{
2548	if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2549	{
2550	m = MATCH_ERROR;
2551	gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2552	name, &var_locus);
2553	goto cleanup;
2554	}
2555
2556	if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2557	&& current_attr.flavor == FL_PARAMETER)
2558	as->type = AS_IMPLIED_SHAPE;
2559
2560	if (as->type == AS_IMPLIED_SHAPE
2561	&& !gfc_notify_std (GFC_STD_F2008(1<<7), "Implied-shape array at %L",
2562	&var_locus))
2563	{
2564	m = MATCH_ERROR;
2565	goto cleanup;
2566	}
2567
2568	gfc_seen_div0 = false;
2569
2570	/* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2571	constant expressions shall appear only in a subprogram, derived
2572	type definition, BLOCK construct, or interface body. */
2573	if (as->type == AS_EXPLICIT
2574	&& gfc_current_state ()(gfc_state_stack->state) != COMP_BLOCK
2575	&& gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED
2576	&& gfc_current_state ()(gfc_state_stack->state) != COMP_FUNCTION
2577	&& gfc_current_state ()(gfc_state_stack->state) != COMP_INTERFACE
2578	&& gfc_current_state ()(gfc_state_stack->state) != COMP_SUBROUTINE)
2579	{
2580	gfc_expr *e;
2581	bool not_constant = false;
2582
2583	for (int i = 0; i < as->rank; i++)
2584	{
2585	e = gfc_copy_expr (as->lower[i]);
2586	if (!gfc_resolve_expr (e) && gfc_seen_div0)
2587	{
2588	m = MATCH_ERROR;
2589	goto cleanup;
2590	}
2591
2592	gfc_simplify_expr (e, 0);
2593	if (e && (e->expr_type != EXPR_CONSTANT))
2594	{
2595	not_constant = true;
2596	break;
2597	}
2598	gfc_free_expr (e);
2599
2600	e = gfc_copy_expr (as->upper[i]);
2601	if (!gfc_resolve_expr (e) && gfc_seen_div0)
2602	{
2603	m = MATCH_ERROR;
2604	goto cleanup;
2605	}
2606
2607	gfc_simplify_expr (e, 0);
2608	if (e && (e->expr_type != EXPR_CONSTANT))
2609	{
2610	not_constant = true;
2611	break;
2612	}
2613	gfc_free_expr (e);
2614	}
2615
2616	if (not_constant && e->ts.type != BT_INTEGER)
2617	{
2618	gfc_error ("Explicit array shape at %C must be constant of "
2619	"INTEGER type and not %s type",
2620	gfc_basic_typename (e->ts.type));
2621	m = MATCH_ERROR;
2622	goto cleanup;
2623	}
2624	if (not_constant)
2625	{
2626	gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2627	m = MATCH_ERROR;
2628	goto cleanup;
2629	}
2630	}
2631	if (as->type == AS_EXPLICIT)
2632	{
2633	for (int i = 0; i < as->rank; i++)
2634	{
2635	gfc_expr e, n;
2636	e = as->lower[i];
2637	if (e->expr_type != EXPR_CONSTANT)
2638	{
2639	n = gfc_copy_expr (e);
2640	if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2641	{
2642	m = MATCH_ERROR;
2643	goto cleanup;
2644	}
2645
2646	if (n->expr_type == EXPR_CONSTANT)
2647	gfc_replace_expr (e, n);
2648	else
2649	gfc_free_expr (n);
2650	}
2651	e = as->upper[i];
2652	if (e->expr_type != EXPR_CONSTANT)
2653	{
2654	n = gfc_copy_expr (e);
2655	if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2656	{
2657	m = MATCH_ERROR;
2658	goto cleanup;
2659	}
2660
2661	if (n->expr_type == EXPR_CONSTANT)
2662	gfc_replace_expr (e, n);
2663	else
2664	gfc_free_expr (n);
2665	}
2666	}
2667	}
2668	}
2669
2670	char_len = NULL__null;
2671	cl = NULL__null;
2672	cl_deferred = false;
2673
2674	if (current_ts.type == BT_CHARACTER)
2675	{
2676	switch (match_char_length (&char_len, &cl_deferred, false))
2677	{
2678	case MATCH_YES:
2679	cl = gfc_new_charlen (gfc_current_ns, NULL__null);
2680
2681	cl->length = char_len;
2682	break;
2683
2684	/* Non-constant lengths need to be copied after the first
2685	element. Also copy assumed lengths. */
2686	case MATCH_NO:
2687	if (elem > 1
2688	&& (current_ts.u.cl->length == NULL__null
2689	\|\| current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2690	{
2691	cl = gfc_new_charlen (gfc_current_ns, NULL__null);
2692	cl->length = gfc_copy_expr (current_ts.u.cl->length);
2693	}
2694	else
2695	cl = current_ts.u.cl;
2696
2697	cl_deferred = current_ts.deferred;
2698
2699	break;
2700
2701	case MATCH_ERROR:
2702	goto cleanup;
2703	}
2704	}
2705
2706	/* The dummy arguments and result of the abreviated form of MODULE
2707	PROCEDUREs, used in SUBMODULES should not be redefined. */
2708	if (gfc_current_ns->proc_name
2709	&& gfc_current_ns->proc_name->abr_modproc_decl)
2710	{
2711	gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2712	if (sym != NULL__null && (sym->attr.dummy \|\| sym->attr.result))
2713	{
2714	m = MATCH_ERROR;
2715	gfc_error ("%qs at %C is a redefinition of the declaration "
2716	"in the corresponding interface for MODULE "
2717	"PROCEDURE %qs", sym->name,
2718	gfc_current_ns->proc_name->name);
2719	goto cleanup;
2720	}
2721	}
2722
2723	/* %FILL components may not have initializers. */
2724	if (gfc_str_startswith (name, "%FILL")(strncmp ((name), ("%FILL"), strlen ("%FILL")) == 0) && gfc_match_eos () != MATCH_YES)
2725	{
2726	gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2727	m = MATCH_ERROR;
2728	goto cleanup;
2729	}
2730
2731	/* If this symbol has already shown up in a Cray Pointer declaration,
2732	and this is not a component declaration,
2733	then we want to set the type & bail out. */
2734	if (flag_cray_pointerglobal_options.x_flag_cray_pointer && !gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
2735	{
2736	gfc_find_symbol (name, gfc_current_ns, 0, &sym);
2737	if (sym != NULL__null && sym->attr.cray_pointee)
2738	{
2739	m = MATCH_YES;
2740	if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
2741	{
2742	m = MATCH_ERROR;
2743	goto cleanup;
2744	}
2745
2746	/* Check to see if we have an array specification. */
2747	if (cp_as != NULL__null)
2748	{
2749	if (sym->as != NULL__null)
2750	{
2751	gfc_error ("Duplicate array spec for Cray pointee at %C");
2752	gfc_free_array_spec (cp_as);
2753	m = MATCH_ERROR;
2754	goto cleanup;
2755	}
2756	else
2757	{
2758	if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2759	gfc_internal_error ("Cannot set pointee array spec.");
2760
2761	/* Fix the array spec. */
2762	m = gfc_mod_pointee_as (sym->as);
2763	if (m == MATCH_ERROR)
2764	goto cleanup;
2765	}
2766	}
2767	goto cleanup;
2768	}
2769	else
2770	{
2771	gfc_free_array_spec (cp_as);
2772	}
2773	}
2774
2775	/* Procedure pointer as function result. */
2776	if (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION
2777	&& strcmp ("ppr@", gfc_current_block ()(gfc_state_stack->sym)->name) == 0
2778	&& strcmp (name, gfc_current_block ()(gfc_state_stack->sym)->ns->proc_name->name) == 0)
2779	strcpy (name, "ppr@");
2780
2781	if (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION
2782	&& strcmp (name, gfc_current_block ()(gfc_state_stack->sym)->name) == 0
2783	&& gfc_current_block ()(gfc_state_stack->sym)->result
2784	&& strcmp ("ppr@", gfc_current_block ()(gfc_state_stack->sym)->result->name) == 0)
2785	strcpy (name, "ppr@");
2786
2787	/* OK, we've successfully matched the declaration. Now put the
2788	symbol in the current namespace, because it might be used in the
2789	optional initialization expression for this symbol, e.g. this is
2790	perfectly legal:
2791
2792	integer, parameter :: i = huge(i)
2793
2794	This is only true for parameters or variables of a basic type.
2795	For components of derived types, it is not true, so we don't
2796	create a symbol for those yet. If we fail to create the symbol,
2797	bail out. */
2798	if (!gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP)
2799	&& !build_sym (name, cl, cl_deferred, &as, &var_locus))
2800	{
2801	m = MATCH_ERROR;
2802	goto cleanup;
2803	}
2804
2805	if (!check_function_name (name))
2806	{
2807	m = MATCH_ERROR;
2808	goto cleanup;
2809	}
2810
2811	/* We allow old-style initializations of the form
2812	integer i /2/, j(4) /3*3, 1/
2813	(if no colon has been seen). These are different from data
2814	statements in that initializers are only allowed to apply to the
2815	variable immediately preceding, i.e.
2816	integer i, j /1, 2/
2817	is not allowed. Therefore we have to do some work manually, that
2818	could otherwise be left to the matchers for DATA statements. */
2819
2820	if (!colon_seen && gfc_match (" /") == MATCH_YES)
2821	{
2822	if (!gfc_notify_std (GFC_STD_GNU(1<<5), "Old-style "
2823	"initialization at %C"))
2824	return MATCH_ERROR;
2825
2826	/* Allow old style initializations for components of STRUCTUREs and MAPs
2827	but not components of derived types. */
2828	else if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED)
2829	{
2830	gfc_error ("Invalid old style initialization for derived type "
2831	"component at %C");
2832	m = MATCH_ERROR;
2833	goto cleanup;
2834	}
2835
2836	/* For structure components, read the initializer as a special
2837	expression and let the rest of this function apply the initializer
2838	as usual. */
2839	else if (gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
2840	{
2841	m = match_clist_expr (&initializer, &current_ts, as);
2842	if (m == MATCH_NO)
2843	gfc_error ("Syntax error in old style initialization of %s at %C",
2844	name);
2845	if (m != MATCH_YES)
2846	goto cleanup;
2847	}
2848
2849	/* Otherwise we treat the old style initialization just like a
2850	DATA declaration for the current variable. */
2851	else
2852	return match_old_style_init (name);
2853	}
2854
2855	/* The double colon must be present in order to have initializers.
2856	Otherwise the statement is ambiguous with an assignment statement. */
2857	if (colon_seen)
2858	{
2859	if (gfc_match (" =>") == MATCH_YES)
2860	{
2861	if (!current_attr.pointer)
2862	{
2863	gfc_error ("Initialization at %C isn't for a pointer variable");
2864	m = MATCH_ERROR;
2865	goto cleanup;
2866	}
2867
2868	m = match_pointer_init (&initializer, 0);
2869	if (m != MATCH_YES)
2870	goto cleanup;
2871
2872	/* The target of a pointer initialization must have the SAVE
2873	attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
2874	is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
2875	if (initializer->expr_type == EXPR_VARIABLE
2876	&& initializer->symtree->n.sym->attr.save == SAVE_NONE
2877	&& (gfc_current_state ()(gfc_state_stack->state) == COMP_PROGRAM
2878	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_MODULE
2879	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_SUBMODULE))
2880	initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
2881	}
2882	else if (gfc_match_char ('=') == MATCH_YES)
2883	{
2884	if (current_attr.pointer)
2885	{
2886	gfc_error ("Pointer initialization at %C requires %<=>%>, "
2887	"not %<=%>");
2888	m = MATCH_ERROR;
2889	goto cleanup;
2890	}
2891
2892	m = gfc_match_init_expr (&initializer);
2893	if (m == MATCH_NO)
2894	{
2895	gfc_error ("Expected an initialization expression at %C");
2896	m = MATCH_ERROR;
2897	}
2898
2899	if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL__null)
2900	&& !gfc_comp_struct (gfc_state_stack->state)((gfc_state_stack->state) == COMP_DERIVED \|\| (gfc_state_stack ->state) == COMP_STRUCTURE \|\| (gfc_state_stack->state) == COMP_MAP))
2901	{
2902	gfc_error ("Initialization of variable at %C is not allowed in "
2903	"a PURE procedure");
2904	m = MATCH_ERROR;
2905	}
2906
2907	if (current_attr.flavor != FL_PARAMETER
2908	&& !gfc_comp_struct (gfc_state_stack->state)((gfc_state_stack->state) == COMP_DERIVED \|\| (gfc_state_stack ->state) == COMP_STRUCTURE \|\| (gfc_state_stack->state) == COMP_MAP))
2909	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2910
2911	if (m != MATCH_YES)
2912	goto cleanup;
2913	}
2914	}
2915
2916	if (initializer != NULL__null && current_attr.allocatable
2917	&& gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
2918	{
2919	gfc_error ("Initialization of allocatable component at %C is not "
2920	"allowed");
2921	m = MATCH_ERROR;
2922	goto cleanup;
2923	}
2924
2925	if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED
2926	&& initializer && initializer->ts.type == BT_HOLLERITH)
2927	{
2928	gfc_error ("Initialization of structure component with a HOLLERITH "
2929	"constant at %L is not allowed", &initializer->where);
2930	m = MATCH_ERROR;
2931	goto cleanup;
2932	}
2933
2934	if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED
2935	&& gfc_current_block ()(gfc_state_stack->sym)->attr.pdt_template)
2936	{
2937	gfc_symbol *param;
2938	gfc_find_symbol (name, gfc_current_block ()(gfc_state_stack->sym)->f2k_derived,
2939	0, &param);
2940	if (!param && (current_attr.pdt_kind \|\| current_attr.pdt_len))
2941	{
2942	gfc_error ("The component with KIND or LEN attribute at %C does not "
2943	"not appear in the type parameter list at %L",
2944	&gfc_current_block ()(gfc_state_stack->sym)->declared_at);
2945	m = MATCH_ERROR;
2946	goto cleanup;
2947	}
2948	else if (param && !(current_attr.pdt_kind \|\| current_attr.pdt_len))
2949	{
2950	gfc_error ("The component at %C that appears in the type parameter "
2951	"list at %L has neither the KIND nor LEN attribute",
2952	&gfc_current_block ()(gfc_state_stack->sym)->declared_at);
2953	m = MATCH_ERROR;
2954	goto cleanup;
2955	}
2956	else if (as && (current_attr.pdt_kind \|\| current_attr.pdt_len))
2957	{
2958	gfc_error ("The component at %C which is a type parameter must be "
2959	"a scalar");
2960	m = MATCH_ERROR;
2961	goto cleanup;
2962	}
2963	else if (param && initializer)
2964	{
2965	if (initializer->ts.type == BT_BOZ)
2966	{
2967	gfc_error ("BOZ literal constant at %L cannot appear as an "
2968	"initializer", &initializer->where);
2969	m = MATCH_ERROR;
2970	goto cleanup;
2971	}
2972	param->value = gfc_copy_expr (initializer);
2973	}
2974	}
2975
2976	/* Before adding a possible initilizer, do a simple check for compatibility
2977	of lhs and rhs types. Assigning a REAL value to a derived type is not a
2978	good thing. */
2979	if (current_ts.type == BT_DERIVED && initializer
2980	&& (gfc_numeric_ts (&initializer->ts)
2981	\|\| initializer->ts.type == BT_LOGICAL
2982	\|\| initializer->ts.type == BT_CHARACTER))
2983	{
2984	gfc_error ("Incompatible initialization between a derived type "
2985	"entity and an entity with %qs type at %C",
2986	gfc_typename (initializer));
2987	m = MATCH_ERROR;
2988	goto cleanup;
2989	}
2990
2991
2992	/* Add the initializer. Note that it is fine if initializer is
2993	NULL here, because we sometimes also need to check if a
2994	declaration must have an initialization expression. */
2995	if (!gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
2996	t = add_init_expr_to_sym (name, &initializer, &var_locus);
2997	else
2998	{
2999	if (current_ts.type == BT_DERIVED
3000	&& !current_attr.pointer && !initializer)
3001	initializer = gfc_default_initializer (&current_ts);
3002	t = build_struct (name, cl, &initializer, &as);
3003
3004	/* If we match a nested structure definition we expect to see the
3005	* body even if the variable declarations blow up, so we need to keep
3006	* the structure declaration around. */
3007	if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3008	gfc_commit_symbol (gfc_new_block);
3009	}
3010
3011	m = (t) ? MATCH_YES : MATCH_ERROR;
3012
3013	cleanup:
3014	/* Free stuff up and return. */
3015	gfc_seen_div0 = false;
3016	gfc_free_expr (initializer);
3017	gfc_free_array_spec (as);
3018
3019	return m;
3020	}
3021
3022
3023	/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3024	This assumes that the byte size is equal to the kind number for
3025	non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3026
3027	match
3028	gfc_match_old_kind_spec (gfc_typespec *ts)
3029	{
3030	match m;
3031	int original_kind;
3032
3033	if (gfc_match_char ('*') != MATCH_YES)
3034	return MATCH_NO;
3035
3036	m = gfc_match_small_literal_int (&ts->kind, NULL__null);
3037	if (m != MATCH_YES)
3038	return MATCH_ERROR;
3039
3040	original_kind = ts->kind;
3041
3042	/* Massage the kind numbers for complex types. */
3043	if (ts->type == BT_COMPLEX)
3044	{
3045	if (ts->kind % 2)
3046	{
3047	gfc_error ("Old-style type declaration %s*%d not supported at %C",
3048	gfc_basic_typename (ts->type), original_kind);
3049	return MATCH_ERROR;
3050	}
3051	ts->kind /= 2;
3052
3053	}
3054
3055	if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kindglobal_options.x_flag_integer4_kind == 8)
3056	ts->kind = 8;
3057
3058	if (ts->type == BT_REAL \|\| ts->type == BT_COMPLEX)
3059	{
3060	if (ts->kind == 4)
3061	{
3062	if (flag_real4_kindglobal_options.x_flag_real4_kind == 8)
3063	ts->kind = 8;
3064	if (flag_real4_kindglobal_options.x_flag_real4_kind == 10)
3065	ts->kind = 10;
3066	if (flag_real4_kindglobal_options.x_flag_real4_kind == 16)
3067	ts->kind = 16;
3068	}
3069
3070	if (ts->kind == 8)
3071	{
3072	if (flag_real8_kindglobal_options.x_flag_real8_kind == 4)
3073	ts->kind = 4;
3074	if (flag_real8_kindglobal_options.x_flag_real8_kind == 10)
3075	ts->kind = 10;
3076	if (flag_real8_kindglobal_options.x_flag_real8_kind == 16)
3077	ts->kind = 16;
3078	}
3079	}
3080
3081	if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3082	{
3083	gfc_error ("Old-style type declaration %s*%d not supported at %C",
3084	gfc_basic_typename (ts->type), original_kind);
3085	return MATCH_ERROR;
3086	}
3087
3088	if (!gfc_notify_std (GFC_STD_GNU(1<<5),
3089	"Nonstandard type declaration %s*%d at %C",
3090	gfc_basic_typename(ts->type), original_kind))
3091	return MATCH_ERROR;
3092
3093	return MATCH_YES;
3094	}
3095
3096
3097	/* Match a kind specification. Since kinds are generally optional, we
3098	usually return MATCH_NO if something goes wrong. If a "kind="
3099	string is found, then we know we have an error. */
3100
3101	match
3102	gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3103	{
3104	locus where, loc;
3105	gfc_expr *e;
3106	match m, n;
3107	char c;
3108
3109	m = MATCH_NO;
3110	n = MATCH_YES;
3111	e = NULL__null;
3112	saved_kind_expr = NULL__null;
3113
3114	where = loc = gfc_current_locus;
3115
3116	if (kind_expr_only)
3117	goto kind_expr;
3118
3119	if (gfc_match_char ('(') == MATCH_NO)
3120	return MATCH_NO;
3121
3122	/* Also gobbles optional text. */
3123	if (gfc_match (" kind = ") == MATCH_YES)
3124	m = MATCH_ERROR;
3125
3126	loc = gfc_current_locus;
3127
3128	kind_expr:
3129
3130	n = gfc_match_init_expr (&e);
3131
3132	if (gfc_derived_parameter_expr (e))
3133	{
3134	ts->kind = 0;
3135	saved_kind_expr = gfc_copy_expr (e);
3136	goto close_brackets;
3137	}
3138
3139	if (n != MATCH_YES)
3140	{
3141	if (gfc_matching_function)
3142	{
3143	/* The function kind expression might include use associated or
3144	imported parameters and try again after the specification
3145	expressions..... */
3146	if (gfc_match_char (')') != MATCH_YES)
3147	{
3148	gfc_error ("Missing right parenthesis at %C");
3149	m = MATCH_ERROR;
3150	goto no_match;
3151	}
3152
3153	gfc_free_expr (e);
3154	gfc_undo_symbols ();
3155	return MATCH_YES;
3156	}
3157	else
3158	{
3159	/* ....or else, the match is real. */
3160	if (n == MATCH_NO)
3161	gfc_error ("Expected initialization expression at %C");
3162	if (n != MATCH_YES)
3163	return MATCH_ERROR;
3164	}
3165	}
3166
3167	if (e->rank != 0)
3168	{
3169	gfc_error ("Expected scalar initialization expression at %C");
3170	m = MATCH_ERROR;
3171	goto no_match;
3172	}
3173
3174	if (gfc_extract_int (e, &ts->kind, 1))
3175	{
3176	m = MATCH_ERROR;
3177	goto no_match;
3178	}
3179
3180	/* Before throwing away the expression, let's see if we had a
3181	C interoperable kind (and store the fact). */
3182	if (e->ts.is_c_interop == 1)
3183	{
3184	/* Mark this as C interoperable if being declared with one
3185	of the named constants from iso_c_binding. */
3186	ts->is_c_interop = e->ts.is_iso_c;
3187	ts->f90_type = e->ts.f90_type;
3188	if (e->symtree)
3189	ts->interop_kind = e->symtree->n.sym;
3190	}
3191
3192	gfc_free_expr (e);
3193	e = NULL__null;
3194
3195	/* Ignore errors to this point, if we've gotten here. This means
3196	we ignore the m=MATCH_ERROR from above. */
3197	if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3198	{
3199	gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3200	gfc_basic_typename (ts->type));
3201	gfc_current_locus = where;
3202	return MATCH_ERROR;
3203	}
3204
3205	/* Warn if, e.g., c_int is used for a REAL variable, but not
3206	if, e.g., c_double is used for COMPLEX as the standard
3207	explicitly says that the kind type parameter for complex and real
3208	variable is the same, i.e. c_float == c_float_complex. */
3209	if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3210	&& !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3211	\|\| (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3212	gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3213	"is %s", gfc_basic_typename (ts->f90_type), &where,
3214	gfc_basic_typename (ts->type));
3215
3216	close_brackets:
3217
3218	gfc_gobble_whitespace ();
3219	if ((c = gfc_next_ascii_char ()) != ')'
3220	&& (ts->type != BT_CHARACTER \|\| c != ','))
3221	{
3222	if (ts->type == BT_CHARACTER)
3223	gfc_error ("Missing right parenthesis or comma at %C");
3224	else
3225	gfc_error ("Missing right parenthesis at %C");
3226	m = MATCH_ERROR;
3227	}
3228	else
3229	/* All tests passed. */
3230	m = MATCH_YES;
3231
3232	if(m == MATCH_ERROR)
3233	gfc_current_locus = where;
3234
3235	if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kindglobal_options.x_flag_integer4_kind == 8)
3236	ts->kind = 8;
3237
3238	if (ts->type == BT_REAL \|\| ts->type == BT_COMPLEX)
3239	{
3240	if (ts->kind == 4)
3241	{
3242	if (flag_real4_kindglobal_options.x_flag_real4_kind == 8)
3243	ts->kind = 8;
3244	if (flag_real4_kindglobal_options.x_flag_real4_kind == 10)
3245	ts->kind = 10;
3246	if (flag_real4_kindglobal_options.x_flag_real4_kind == 16)
3247	ts->kind = 16;
3248	}
3249
3250	if (ts->kind == 8)
3251	{
3252	if (flag_real8_kindglobal_options.x_flag_real8_kind == 4)
3253	ts->kind = 4;
3254	if (flag_real8_kindglobal_options.x_flag_real8_kind == 10)
3255	ts->kind = 10;
3256	if (flag_real8_kindglobal_options.x_flag_real8_kind == 16)
3257	ts->kind = 16;
3258	}
3259	}
3260
3261	/* Return what we know from the test(s). */
3262	return m;
3263
3264	no_match:
3265	gfc_free_expr (e);
3266	gfc_current_locus = where;
3267	return m;
3268	}
3269
3270
3271	static match
3272	match_char_kind (int * kind, int * is_iso_c)
3273	{
3274	locus where;
3275	gfc_expr *e;
3276	match m, n;
3277	bool fail;
3278
3279	m = MATCH_NO;
3280	e = NULL__null;
3281	where = gfc_current_locus;
3282
3283	n = gfc_match_init_expr (&e);
3284
3285	if (n != MATCH_YES && gfc_matching_function)
3286	{
3287	/* The expression might include use-associated or imported
3288	parameters and try again after the specification
3289	expressions. */
3290	gfc_free_expr (e);
3291	gfc_undo_symbols ();
3292	return MATCH_YES;
3293	}
3294
3295	if (n == MATCH_NO)
3296	gfc_error ("Expected initialization expression at %C");
3297	if (n != MATCH_YES)
3298	return MATCH_ERROR;
3299
3300	if (e->rank != 0)
3301	{
3302	gfc_error ("Expected scalar initialization expression at %C");
3303	m = MATCH_ERROR;
3304	goto no_match;
3305	}
3306
3307	if (gfc_derived_parameter_expr (e))
3308	{
3309	saved_kind_expr = e;
3310	*kind = 0;
3311	return MATCH_YES;
3312	}
3313
3314	fail = gfc_extract_int (e, kind, 1);
3315	*is_iso_c = e->ts.is_iso_c;
3316	if (fail)
3317	{
3318	m = MATCH_ERROR;
3319	goto no_match;
3320	}
3321
3322	gfc_free_expr (e);
3323
3324	/* Ignore errors to this point, if we've gotten here. This means
3325	we ignore the m=MATCH_ERROR from above. */
3326	if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3327	{
3328	gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3329	m = MATCH_ERROR;
3330	}
3331	else
3332	/* All tests passed. */
3333	m = MATCH_YES;
3334
3335	if (m == MATCH_ERROR)
3336	gfc_current_locus = where;
3337
3338	/* Return what we know from the test(s). */
3339	return m;
3340
3341	no_match:
3342	gfc_free_expr (e);
3343	gfc_current_locus = where;
3344	return m;
3345	}
3346
3347
3348	/* Match the various kind/length specifications in a CHARACTER
3349	declaration. We don't return MATCH_NO. */
3350
3351	match
3352	gfc_match_char_spec (gfc_typespec *ts)
3353	{
3354	int kind, seen_length, is_iso_c;
3355	gfc_charlen *cl;
3356	gfc_expr *len;
3357	match m;
3358	bool deferred;
3359
3360	len = NULL__null;
3361	seen_length = 0;
3362	kind = 0;
3363	is_iso_c = 0;
3364	deferred = false;
3365
3366	/* Try the old-style specification first. */
3367	old_char_selector = 0;
3368
3369	m = match_char_length (&len, &deferred, true);
3370	if (m != MATCH_NO)
3371	{
3372	if (m == MATCH_YES)
3373	old_char_selector = 1;
3374	seen_length = 1;
3375	goto done;
3376	}
3377
3378	m = gfc_match_char ('(');
3379	if (m != MATCH_YES)
3380	{
3381	m = MATCH_YES; /* Character without length is a single char. */
3382	goto done;
3383	}
3384
3385	/* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3386	if (gfc_match (" kind =") == MATCH_YES)
3387	{
3388	m = match_char_kind (&kind, &is_iso_c);
3389
3390	if (m == MATCH_ERROR)
3391	goto done;
3392	if (m == MATCH_NO)
3393	goto syntax;
3394
3395	if (gfc_match (" , len =") == MATCH_NO)
3396	goto rparen;
3397
3398	m = char_len_param_value (&len, &deferred);
3399	if (m == MATCH_NO)
3400	goto syntax;
3401	if (m == MATCH_ERROR)
3402	goto done;
3403	seen_length = 1;
3404
3405	goto rparen;
3406	}
3407
3408	/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3409	if (gfc_match (" len =") == MATCH_YES)
3410	{
3411	m = char_len_param_value (&len, &deferred);
3412	if (m == MATCH_NO)
3413	goto syntax;
3414	if (m == MATCH_ERROR)
3415	goto done;
3416	seen_length = 1;
3417
3418	if (gfc_match_char (')') == MATCH_YES)
3419	goto done;
3420
3421	if (gfc_match (" , kind =") != MATCH_YES)
3422	goto syntax;
3423
3424	if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3425	goto done;
3426
3427	goto rparen;
3428	}
3429
3430	/* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3431	m = char_len_param_value (&len, &deferred);
3432	if (m == MATCH_NO)
3433	goto syntax;
3434	if (m == MATCH_ERROR)
3435	goto done;
3436	seen_length = 1;
3437
3438	m = gfc_match_char (')');
3439	if (m == MATCH_YES)
3440	goto done;
3441
3442	if (gfc_match_char (',') != MATCH_YES)
3443	goto syntax;
3444
3445	gfc_match (" kind ="); /* Gobble optional text. */
3446
3447	m = match_char_kind (&kind, &is_iso_c);
3448	if (m == MATCH_ERROR)
3449	goto done;
3450	if (m == MATCH_NO)
3451	goto syntax;
3452
3453	rparen:
3454	/* Require a right-paren at this point. */
3455	m = gfc_match_char (')');
3456	if (m == MATCH_YES)
3457	goto done;
3458
3459	syntax:
3460	gfc_error ("Syntax error in CHARACTER declaration at %C");
3461	m = MATCH_ERROR;
3462	gfc_free_expr (len);
3463	return m;
3464
3465	done:
3466	/* Deal with character functions after USE and IMPORT statements. */
3467	if (gfc_matching_function)
3468	{
3469	gfc_free_expr (len);
3470	gfc_undo_symbols ();
3471	return MATCH_YES;
3472	}
3473
3474	if (m != MATCH_YES)
3475	{
3476	gfc_free_expr (len);
3477	return m;
3478	}
3479
3480	/* Do some final massaging of the length values. */
3481	cl = gfc_new_charlen (gfc_current_ns, NULL__null);
3482
3483	if (seen_length == 0)
3484	cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, 1);
3485	else
3486	{
3487	/* If gfortran ends up here, then len may be reducible to a constant.
3488	Try to do that here. If it does not reduce, simply assign len to
3489	charlen. A complication occurs with user-defined generic functions,
3490	which are not resolved. Use a private namespace to deal with
3491	generic functions. */
3492
3493	if (len && len->expr_type != EXPR_CONSTANT)
3494	{
3495	gfc_namespace *old_ns;
3496	gfc_expr *e;
3497
3498	old_ns = gfc_current_ns;
3499	gfc_current_ns = gfc_get_namespace (NULL__null, 0);
3500
3501	e = gfc_copy_expr (len);
3502	gfc_reduce_init_expr (e);
3503	if (e->expr_type == EXPR_CONSTANT)
3504	{
3505	gfc_replace_expr (len, e);
3506	if (mpz_cmp_si (len->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (len->value.integer)->_mp_size < 0 ? -1 : (len->value .integer)->_mp_size > 0) : __gmpz_cmp_ui (len->value .integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (len->value.integer,0)) < 0)
3507	mpz_set_ui__gmpz_set_ui (len->value.integer, 0);
3508	}
3509	else
3510	gfc_free_expr (e);
3511
3512	gfc_free_namespace (gfc_current_ns);
3513	gfc_current_ns = old_ns;
3514	}
3515
3516	cl->length = len;
3517	}
3518
3519	ts->u.cl = cl;
3520	ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3521	ts->deferred = deferred;
3522
3523	/* We have to know if it was a C interoperable kind so we can
3524	do accurate type checking of bind(c) procs, etc. */
3525	if (kind != 0)
3526	/* Mark this as C interoperable if being declared with one
3527	of the named constants from iso_c_binding. */
3528	ts->is_c_interop = is_iso_c;
3529	else if (len != NULL__null)
3530	/* Here, we might have parsed something such as: character(c_char)
3531	In this case, the parsing code above grabs the c_char when
3532	looking for the length (line 1690, roughly). it's the last
3533	testcase for parsing the kind params of a character variable.
3534	However, it's not actually the length. this seems like it
3535	could be an error.
3536	To see if the user used a C interop kind, test the expr
3537	of the so called length, and see if it's C interoperable. */
3538	ts->is_c_interop = len->ts.is_iso_c;
3539
3540	return MATCH_YES;
3541	}
3542
3543
3544	/* Matches a RECORD declaration. */
3545
3546	static match
3547	match_record_decl (char *name)
3548	{
3549	locus old_loc;
3550	old_loc = gfc_current_locus;
3551	match m;
3552
3553	m = gfc_match (" record /");
3554	if (m == MATCH_YES)
3555	{
3556	if (!flag_dec_structureglobal_options.x_flag_dec_structure)
3557	{
3558	gfc_current_locus = old_loc;
3559	gfc_error ("RECORD at %C is an extension, enable it with "
3560	"%<-fdec-structure%>");
3561	return MATCH_ERROR;
3562	}
3563	m = gfc_match (" %n/", name);
3564	if (m == MATCH_YES)
3565	return MATCH_YES;
3566	}
3567
3568	gfc_current_locus = old_loc;
3569	if (flag_dec_structureglobal_options.x_flag_dec_structure
3570	&& (gfc_match (" record% ") == MATCH_YES
3571	\|\| gfc_match (" record%t") == MATCH_YES))
3572	gfc_error ("Structure name expected after RECORD at %C");
3573	if (m == MATCH_NO)
3574	return MATCH_NO;
3575
3576	return MATCH_ERROR;
3577	}
3578
3579
3580	/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3581	of expressions to substitute into the possibly parameterized expression
3582	'e'. Using a list is inefficient but should not be too bad since the
3583	number of type parameters is not likely to be large. */
3584	static bool
3585	insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
3586	int* f)
3587	{
3588	gfc_actual_arglist *param;
3589	gfc_expr *copy;
3590
3591	if (e->expr_type != EXPR_VARIABLE)
3592	return false;
3593
3594	gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 3594, __FUNCTION__), 0 : 0));
3595	if (e->symtree->n.sym->attr.pdt_kind
3596	\|\| (*f != 0 && e->symtree->n.sym->attr.pdt_len))
3597	{
3598	for (param = type_param_spec_list; param; param = param->next)
3599	if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3600	break;
3601
3602	if (param)
3603	{
3604	copy = gfc_copy_expr (param->expr);
3605	e = copy;
3606	free (copy);
3607	}
3608	}
3609
3610	return false;
3611	}
3612
3613
3614	bool
3615	gfc_insert_kind_parameter_exprs (gfc_expr *e)
3616	{
3617	return gfc_traverse_expr (e, NULL__null, &insert_parameter_exprs, 0);
3618	}
3619
3620
3621	bool
3622	gfc_insert_parameter_exprs (gfc_expr e, gfc_actual_arglist param_list)
3623	{
3624	gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3625	type_param_spec_list = param_list;
3626	return gfc_traverse_expr (e, NULL__null, &insert_parameter_exprs, 1);
3627	type_param_spec_list = NULL__null;
3628	type_param_spec_list = old_param_spec_list;
3629	}
3630
3631	/* Determines the instance of a parameterized derived type to be used by
3632	matching determining the values of the kind parameters and using them
3633	in the name of the instance. If the instance exists, it is used, otherwise
3634	a new derived type is created. */
3635	match
3636	gfc_get_pdt_instance (gfc_actual_arglist param_list, gfc_symbol *sym,
3637	gfc_actual_arglist **ext_param_list)
3638	{
3639	/* The PDT template symbol. */
3640	gfc_symbol pdt = sym;
3641	/* The symbol for the parameter in the template f2k_namespace. */
3642	gfc_symbol *param;
3643	/* The hoped for instance of the PDT. */
3644	gfc_symbol *instance;
3645	/* The list of parameters appearing in the PDT declaration. */
3646	gfc_formal_arglist *type_param_name_list;
3647	/* Used to store the parameter specification list during recursive calls. */
3648	gfc_actual_arglist *old_param_spec_list;
3649	/* Pointers to the parameter specification being used. */
3650	gfc_actual_arglist *actual_param;
3651	gfc_actual_arglist *tail = NULL__null;
3652	/* Used to build up the name of the PDT instance. The prefix uses 4
3653	characters and each KIND parameter 2 more. Allow 8 of the latter. */
3654	char name[GFC_MAX_SYMBOL_LEN63 + 21];
3655
3656	bool name_seen = (param_list == NULL__null);
3657	bool assumed_seen = false;
3658	bool deferred_seen = false;
3659	bool spec_error = false;
3660	int kind_value, i;
3661	gfc_expr *kind_expr;
3662	gfc_component c1, c2;
3663	match m;
3664
3665	type_param_spec_list = NULL__null;
3666
3667	type_param_name_list = pdt->formal;
3668	actual_param = param_list;
3669	sprintf (name, "Pdt%s", pdt->name);
3670
3671	/* Run through the parameter name list and pick up the actual
3672	parameter values or use the default values in the PDT declaration. */
3673	for (; type_param_name_list;
3674	type_param_name_list = type_param_name_list->next)
3675	{
3676	if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3677	{
3678	if (actual_param->spec_type == SPEC_ASSUMED)
3679	spec_error = deferred_seen;
3680	else
3681	spec_error = assumed_seen;
3682
3683	if (spec_error)
3684	{
3685	gfc_error ("The type parameter spec list at %C cannot contain "
3686	"both ASSUMED and DEFERRED parameters");
3687	goto error_return;
3688	}
3689	}
3690
3691	if (actual_param && actual_param->name)
3692	name_seen = true;
3693	param = type_param_name_list->sym;
3694
3695	if (!param \|\| !param->name)
3696	continue;
3697
3698	c1 = gfc_find_component (pdt, param->name, false, true, NULL__null);
3699	/* An error should already have been thrown in resolve.c
3700	(resolve_fl_derived0). */
3701	if (!pdt->attr.use_assoc && !c1)
3702	goto error_return;
3703
3704	kind_expr = NULL__null;
3705	if (!name_seen)
3706	{
3707	if (!actual_param && !(c1 && c1->initializer))
3708	{
3709	gfc_error ("The type parameter spec list at %C does not contain "
3710	"enough parameter expressions");
3711	goto error_return;
3712	}
3713	else if (!actual_param && c1 && c1->initializer)
3714	kind_expr = gfc_copy_expr (c1->initializer);
3715	else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3716	kind_expr = gfc_copy_expr (actual_param->expr);
3717	}
3718	else
3719	{
3720	actual_param = param_list;
3721	for (;actual_param; actual_param = actual_param->next)
3722	if (actual_param->name
3723	&& strcmp (actual_param->name, param->name) == 0)
3724	break;
3725	if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3726	kind_expr = gfc_copy_expr (actual_param->expr);
3727	else
3728	{
3729	if (c1->initializer)
3730	kind_expr = gfc_copy_expr (c1->initializer);
3731	else if (!(actual_param && param->attr.pdt_len))
3732	{
3733	gfc_error ("The derived parameter %qs at %C does not "
3734	"have a default value", param->name);
3735	goto error_return;
3736	}
3737	}
3738	}
3739
3740	/* Store the current parameter expressions in a temporary actual
3741	arglist 'list' so that they can be substituted in the corresponding
3742	expressions in the PDT instance. */
3743	if (type_param_spec_list == NULL__null)
3744	{
3745	type_param_spec_list = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
3746	tail = type_param_spec_list;
3747	}
3748	else
3749	{
3750	tail->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
3751	tail = tail->next;
3752	}
3753	tail->name = param->name;
3754
3755	if (kind_expr)
3756	{
3757	/* Try simplification even for LEN expressions. */
3758	bool ok;
3759	gfc_resolve_expr (kind_expr);
3760	ok = gfc_simplify_expr (kind_expr, 1);
3761	/* Variable expressions seem to default to BT_PROCEDURE.
3762	TODO find out why this is and fix it. */
3763	if (kind_expr->ts.type != BT_INTEGER
3764	&& kind_expr->ts.type != BT_PROCEDURE)
3765	{
3766	gfc_error ("The parameter expression at %C must be of "
3767	"INTEGER type and not %s type",
3768	gfc_basic_typename (kind_expr->ts.type));
3769	goto error_return;
3770	}
3771	if (kind_expr->ts.type == BT_INTEGER && !ok)
3772	{
3773	gfc_error ("The parameter expression at %C does not "
3774	"simplify to an INTEGER constant");
3775	goto error_return;
3776	}
3777
3778	tail->expr = gfc_copy_expr (kind_expr);
3779	}
3780
3781	if (actual_param)
3782	tail->spec_type = actual_param->spec_type;
3783
3784	if (!param->attr.pdt_kind)
3785	{
3786	if (!name_seen && actual_param)
3787	actual_param = actual_param->next;
3788	if (kind_expr)
3789	{
3790	gfc_free_expr (kind_expr);
3791	kind_expr = NULL__null;
3792	}
3793	continue;
3794	}
3795
3796	if (actual_param
3797	&& (actual_param->spec_type == SPEC_ASSUMED
3798	\|\| actual_param->spec_type == SPEC_DEFERRED))
3799	{
3800	gfc_error ("The KIND parameter %qs at %C cannot either be "
3801	"ASSUMED or DEFERRED", param->name);
3802	goto error_return;
3803	}
3804
3805	if (!kind_expr \|\| !gfc_is_constant_expr (kind_expr))
3806	{
3807	gfc_error ("The value for the KIND parameter %qs at %C does not "
3808	"reduce to a constant expression", param->name);
3809	goto error_return;
3810	}
3811
3812	gfc_extract_int (kind_expr, &kind_value);
3813	sprintf (name + strlen (name), "_%d", kind_value);
3814
3815	if (!name_seen && actual_param)
3816	actual_param = actual_param->next;
3817	gfc_free_expr (kind_expr);
3818	}
3819
3820	if (!name_seen && actual_param)
3821	{
3822	gfc_error ("The type parameter spec list at %C contains too many "
3823	"parameter expressions");
3824	goto error_return;
3825	}
3826
3827	/* Now we search for the PDT instance 'name'. If it doesn't exist, we
3828	build it, using 'pdt' as a template. */
3829	if (gfc_get_symbol (name, pdt->ns, &instance))
3830	{
3831	gfc_error ("Parameterized derived type at %C is ambiguous");
3832	goto error_return;
3833	}
3834
3835	m = MATCH_YES;
3836
3837	if (instance->attr.flavor == FL_DERIVED
3838	&& instance->attr.pdt_type)
3839	{
3840	instance->refs++;
3841	if (ext_param_list)
3842	*ext_param_list = type_param_spec_list;
3843	*sym = instance;
3844	gfc_commit_symbols ();
3845	return m;
3846	}
3847
3848	/* Start building the new instance of the parameterized type. */
3849	gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
3850	instance->attr.pdt_template = 0;
3851	instance->attr.pdt_type = 1;
3852	instance->declared_at = gfc_current_locus;
3853
3854	/* Add the components, replacing the parameters in all expressions
3855	with the expressions for their values in 'type_param_spec_list'. */
3856	c1 = pdt->components;
3857	tail = type_param_spec_list;
3858	for (; c1; c1 = c1->next)
3859	{
3860	gfc_add_component (instance, c1->name, &c2);
3861
3862	c2->ts = c1->ts;
3863	c2->attr = c1->attr;
3864
3865	/* The order of declaration of the type_specs might not be the
3866	same as that of the components. */
3867	if (c1->attr.pdt_kind \|\| c1->attr.pdt_len)
3868	{
3869	for (tail = type_param_spec_list; tail; tail = tail->next)
3870	if (strcmp (c1->name, tail->name) == 0)
3871	break;
3872	}
3873
3874	/* Deal with type extension by recursively calling this function
3875	to obtain the instance of the extended type. */
3876	if (gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED
3877	&& c1 == pdt->components
3878	&& (c1->ts.type == BT_DERIVED \|\| c1->ts.type == BT_CLASS)
3879	&& c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
3880	&& gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
3881	{
3882	gfc_formal_arglist *f;
3883
3884	old_param_spec_list = type_param_spec_list;
3885
3886	/* Obtain a spec list appropriate to the extended type..*/
3887	actual_param = gfc_copy_actual_arglist (type_param_spec_list);
3888	type_param_spec_list = actual_param;
3889	for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
3890	actual_param = actual_param->next;
3891	if (actual_param)
3892	{
3893	gfc_free_actual_arglist (actual_param->next);
3894	actual_param->next = NULL__null;
3895	}
3896
3897	/* Now obtain the PDT instance for the extended type. */
3898	c2->param_list = type_param_spec_list;
3899	m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
3900	NULL__null);
3901	type_param_spec_list = old_param_spec_list;
3902
3903	c2->ts.u.derived->refs++;
3904	gfc_set_sym_referenced (c2->ts.u.derived);
3905
3906	/* Set extension level. */
3907	if (c2->ts.u.derived->attr.extension == 255)
3908	{
3909	/* Since the extension field is 8 bit wide, we can only have
3910	up to 255 extension levels. */
3911	gfc_error ("Maximum extension level reached with type %qs at %L",
3912	c2->ts.u.derived->name,
3913	&c2->ts.u.derived->declared_at);
3914	goto error_return;
3915	}
3916	instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
3917
3918	continue;
3919	}
3920
3921	/* Set the component kind using the parameterized expression. */
3922	if ((c1->ts.kind == 0 \|\| c1->ts.type == BT_CHARACTER)
3923	&& c1->kind_expr != NULL__null)
3924	{
3925	gfc_expr *e = gfc_copy_expr (c1->kind_expr);
3926	gfc_insert_kind_parameter_exprs (e);
3927	gfc_simplify_expr (e, 1);
3928	gfc_extract_int (e, &c2->ts.kind);
3929	gfc_free_expr (e);
3930	if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
3931	{
3932	gfc_error ("Kind %d not supported for type %s at %C",
3933	c2->ts.kind, gfc_basic_typename (c2->ts.type));
3934	goto error_return;
3935	}
3936	}
3937
3938	/* Similarly, set the string length if parameterized. */
3939	if (c1->ts.type == BT_CHARACTER
3940	&& c1->ts.u.cl->length
3941	&& gfc_derived_parameter_expr (c1->ts.u.cl->length))
3942	{
3943	gfc_expr *e;
3944	e = gfc_copy_expr (c1->ts.u.cl->length);
3945	gfc_insert_kind_parameter_exprs (e);
3946	gfc_simplify_expr (e, 1);
3947	c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
3948	c2->ts.u.cl->length = e;
3949	c2->attr.pdt_string = 1;
3950	}
3951
3952	/* Set up either the KIND/LEN initializer, if constant,
3953	or the parameterized expression. Use the template
3954	initializer if one is not already set in this instance. */
3955	if (c2->attr.pdt_kind \|\| c2->attr.pdt_len)
3956	{
3957	if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
3958	c2->initializer = gfc_copy_expr (tail->expr);
3959	else if (tail && tail->expr)
3960	{
3961	c2->param_list = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist )));
3962	c2->param_list->name = tail->name;
3963	c2->param_list->expr = gfc_copy_expr (tail->expr);
3964	c2->param_list->next = NULL__null;
3965	}
3966
3967	if (!c2->initializer && c1->initializer)
3968	c2->initializer = gfc_copy_expr (c1->initializer);
3969	}
3970
3971	/* Copy the array spec. */
3972	c2->as = gfc_copy_array_spec (c1->as);
3973	if (c1->ts.type == BT_CLASS)
3974	CLASS_DATA (c2)c2->ts.u.derived->components->as = gfc_copy_array_spec (CLASS_DATA (c1)c1->ts.u.derived->components->as);
3975
3976	/* Determine if an array spec is parameterized. If so, substitute
3977	in the parameter expressions for the bounds and set the pdt_array
3978	attribute. Notice that this attribute must be unconditionally set
3979	if this is an array of parameterized character length. */
3980	if (c1->as && c1->as->type == AS_EXPLICIT)
3981	{
3982	bool pdt_array = false;
3983
3984	/* Are the bounds of the array parameterized? */
3985	for (i = 0; i < c1->as->rank; i++)
3986	{
3987	if (gfc_derived_parameter_expr (c1->as->lower[i]))
3988	pdt_array = true;
3989	if (gfc_derived_parameter_expr (c1->as->upper[i]))
3990	pdt_array = true;
3991	}
3992
3993	/* If they are, free the expressions for the bounds and
3994	replace them with the template expressions with substitute
3995	values. */
3996	for (i = 0; pdt_array && i < c1->as->rank; i++)
3997	{
3998	gfc_expr *e;
3999	e = gfc_copy_expr (c1->as->lower[i]);
4000	gfc_insert_kind_parameter_exprs (e);
4001	gfc_simplify_expr (e, 1);
4002	gfc_free_expr (c2->as->lower[i]);
4003	c2->as->lower[i] = e;
4004	e = gfc_copy_expr (c1->as->upper[i]);
4005	gfc_insert_kind_parameter_exprs (e);
4006	gfc_simplify_expr (e, 1);
4007	gfc_free_expr (c2->as->upper[i]);
4008	c2->as->upper[i] = e;
4009	}
4010	c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
4011	if (c1->initializer)
4012	{
4013	c2->initializer = gfc_copy_expr (c1->initializer);
4014	gfc_insert_kind_parameter_exprs (c2->initializer);
4015	gfc_simplify_expr (c2->initializer, 1);
4016	}
4017	}
4018
4019	/* Recurse into this function for PDT components. */
4020	if ((c1->ts.type == BT_DERIVED \|\| c1->ts.type == BT_CLASS)
4021	&& c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4022	{
4023	gfc_actual_arglist *params;
4024	/* The component in the template has a list of specification
4025	expressions derived from its declaration. */
4026	params = gfc_copy_actual_arglist (c1->param_list);
4027	actual_param = params;
4028	/* Substitute the template parameters with the expressions
4029	from the specification list. */
4030	for (;actual_param; actual_param = actual_param->next)
4031	gfc_insert_parameter_exprs (actual_param->expr,
4032	type_param_spec_list);
4033
4034	/* Now obtain the PDT instance for the component. */
4035	old_param_spec_list = type_param_spec_list;
4036	m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL__null);
4037	type_param_spec_list = old_param_spec_list;
4038
4039	c2->param_list = params;
4040	if (!(c2->attr.pointer \|\| c2->attr.allocatable))
4041	c2->initializer = gfc_default_initializer (&c2->ts);
4042
4043	if (c2->attr.allocatable)
4044	instance->attr.alloc_comp = 1;
4045	}
4046	}
4047
4048	gfc_commit_symbol (instance);
4049	if (ext_param_list)
4050	*ext_param_list = type_param_spec_list;
4051	*sym = instance;
4052	return m;
4053
4054	error_return:
4055	gfc_free_actual_arglist (type_param_spec_list);
4056	return MATCH_ERROR;
4057	}
4058
4059
4060	/* Match a legacy nonstandard BYTE type-spec. */
4061
4062	static match
4063	match_byte_typespec (gfc_typespec *ts)
4064	{
4065	if (gfc_match (" byte") == MATCH_YES)
4066	{
4067	if (!gfc_notify_std (GFC_STD_GNU(1<<5), "BYTE type at %C"))
4068	return MATCH_ERROR;
4069
4070	if (gfc_current_form == FORM_FREE)
4071	{
4072	char c = gfc_peek_ascii_char ();
4073	if (!gfc_is_whitespace (c)((c==' ') \|\| (c=='\t') \|\| (c=='\f')) && c != ',')
4074	return MATCH_NO;
4075	}
4076
4077	if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4078	{
4079	gfc_error ("BYTE type used at %C "
4080	"is not available on the target machine");
4081	return MATCH_ERROR;
4082	}
4083
4084	ts->type = BT_INTEGER;
4085	ts->kind = 1;
4086	return MATCH_YES;
4087	}
4088	return MATCH_NO;
4089	}
4090
4091
4092	/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4093	structure to the matched specification. This is necessary for FUNCTION and
4094	IMPLICIT statements.
4095
4096	If implicit_flag is nonzero, then we don't check for the optional
4097	kind specification. Not doing so is needed for matching an IMPLICIT
4098	statement correctly. */
4099
4100	match
4101	gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4102	{
4103	/* Provide sufficient space to hold "pdtsymbol". */
4104	char name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1)((char ) __builtin_alloca(sizeof (char) * (63 + 1)));
4105	gfc_symbol sym, dt_sym;
4106	match m;
4107	char c;
4108	bool seen_deferred_kind, matched_type;
4109	const char *dt_name;
4110
4111	decl_type_param_list = NULL__null;
4112
4113	/* A belt and braces check that the typespec is correctly being treated
4114	as a deferred characteristic association. */
4115	seen_deferred_kind = (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION)
4116	&& (gfc_current_block ()(gfc_state_stack->sym)->result->ts.kind == -1)
4117	&& (ts->kind == -1);
4118	gfc_clear_ts (ts);
4119	if (seen_deferred_kind)
4120	ts->kind = -1;
4121
4122	/* Clear the current binding label, in case one is given. */
4123	curr_binding_label = NULL__null;
4124
4125	/* Match BYTE type-spec. */
4126	m = match_byte_typespec (ts);
4127	if (m != MATCH_NO)
4128	return m;
4129
4130	m = gfc_match (" type (");
4131	matched_type = (m == MATCH_YES);
4132	if (matched_type)
4133	{
4134	gfc_gobble_whitespace ();
4135	if (gfc_peek_ascii_char () == '*')
4136	{
4137	if ((m = gfc_match ("* ) ")) != MATCH_YES)
4138	return m;
4139	if (gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
4140	{
4141	gfc_error ("Assumed type at %C is not allowed for components");
4142	return MATCH_ERROR;
4143	}
4144	if (!gfc_notify_std (GFC_STD_F2018(1<<9), "Assumed type at %C"))
4145	return MATCH_ERROR;
4146	ts->type = BT_ASSUMED;
4147	return MATCH_YES;
4148	}
4149
4150	m = gfc_match ("%n", name);
4151	matched_type = (m == MATCH_YES);
4152	}
4153
4154	if ((matched_type && strcmp ("integer", name) == 0)
4155	\|\| (!matched_type && gfc_match (" integer") == MATCH_YES))
4156	{
4157	ts->type = BT_INTEGER;
4158	ts->kind = gfc_default_integer_kind;
4159	goto get_kind;
4160	}
4161
4162	if ((matched_type && strcmp ("character", name) == 0)
4163	\|\| (!matched_type && gfc_match (" character") == MATCH_YES))
4164	{
4165	if (matched_type
4166	&& !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with "
4167	"intrinsic-type-spec at %C"))
4168	return MATCH_ERROR;
4169
4170	ts->type = BT_CHARACTER;
4171	if (implicit_flag == 0)
4172	m = gfc_match_char_spec (ts);
4173	else
4174	m = MATCH_YES;
4175
4176	if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4177	{
4178	gfc_error ("Malformed type-spec at %C");
4179	return MATCH_ERROR;
4180	}
4181
4182	return m;
4183	}
4184
4185	if ((matched_type && strcmp ("real", name) == 0)
4186	\|\| (!matched_type && gfc_match (" real") == MATCH_YES))
4187	{
4188	ts->type = BT_REAL;
4189	ts->kind = gfc_default_real_kind;
4190	goto get_kind;
4191	}
4192
4193	if ((matched_type
4194	&& (strcmp ("doubleprecision", name) == 0
4195	\|\| (strcmp ("double", name) == 0
4196	&& gfc_match (" precision") == MATCH_YES)))
4197	\|\| (!matched_type && gfc_match (" double precision") == MATCH_YES))
4198	{
4199	if (matched_type
4200	&& !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with "
4201	"intrinsic-type-spec at %C"))
4202	return MATCH_ERROR;
4203
4204	if (matched_type && gfc_match_char (')') != MATCH_YES)
4205	{
4206	gfc_error ("Malformed type-spec at %C");
4207	return MATCH_ERROR;
4208	}
4209
4210	ts->type = BT_REAL;
4211	ts->kind = gfc_default_double_kind;
4212	return MATCH_YES;
4213	}
4214
4215	if ((matched_type && strcmp ("complex", name) == 0)
4216	\|\| (!matched_type && gfc_match (" complex") == MATCH_YES))
4217	{
4218	ts->type = BT_COMPLEX;
4219	ts->kind = gfc_default_complex_kind;
4220	goto get_kind;
4221	}
4222
4223	if ((matched_type
4224	&& (strcmp ("doublecomplex", name) == 0
4225	\|\| (strcmp ("double", name) == 0
4226	&& gfc_match (" complex") == MATCH_YES)))
4227	\|\| (!matched_type && gfc_match (" double complex") == MATCH_YES))
4228	{
4229	if (!gfc_notify_std (GFC_STD_GNU(1<<5), "DOUBLE COMPLEX at %C"))
4230	return MATCH_ERROR;
4231
4232	if (matched_type
4233	&& !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with "
4234	"intrinsic-type-spec at %C"))
4235	return MATCH_ERROR;
4236
4237	if (matched_type && gfc_match_char (')') != MATCH_YES)
4238	{
4239	gfc_error ("Malformed type-spec at %C");
4240	return MATCH_ERROR;
4241	}
4242
4243	ts->type = BT_COMPLEX;
4244	ts->kind = gfc_default_double_kind;
4245	return MATCH_YES;
4246	}
4247
4248	if ((matched_type && strcmp ("logical", name) == 0)
4249	\|\| (!matched_type && gfc_match (" logical") == MATCH_YES))
4250	{
4251	ts->type = BT_LOGICAL;
4252	ts->kind = gfc_default_logical_kind;
4253	goto get_kind;
4254	}
4255
4256	if (matched_type)
4257	{
4258	m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4259	if (m == MATCH_ERROR)
4260	return m;
4261
4262	gfc_gobble_whitespace ();
4263	if (gfc_peek_ascii_char () != ')')
4264	{
4265	gfc_error ("Malformed type-spec at %C");
4266	return MATCH_ERROR;
4267	}
4268	m = gfc_match_char (')'); /* Burn closing ')'. */
4269	}
4270
4271	if (m != MATCH_YES)
4272	m = match_record_decl (name);
4273
4274	if (matched_type \|\| m == MATCH_YES)
4275	{
4276	ts->type = BT_DERIVED;
4277	/* We accept record/s/ or type(s) where s is a structure, but we
4278	* don't need all the extra derived-type stuff for structures. */
4279	if (gfc_find_symbol (gfc_dt_upper_string (name), NULL__null, 1, &sym))
4280	{
4281	gfc_error ("Type name %qs at %C is ambiguous", name);
4282	return MATCH_ERROR;
4283	}
4284
4285	if (sym && sym->attr.flavor == FL_DERIVED
4286	&& sym->attr.pdt_template
4287	&& gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED)
4288	{
4289	m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL__null);
4290	if (m != MATCH_YES)
4291	return m;
4292	gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type)((void)(!(!sym->attr.pdt_template && sym->attr. pdt_type) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 4292, __FUNCTION__), 0 : 0));
4293	ts->u.derived = sym;
4294	const char* lower = gfc_dt_lower_string (sym->name);
4295	size_t len = strlen (lower);
4296	/* Reallocate with sufficient size. */
4297	if (len > GFC_MAX_SYMBOL_LEN63)
4298	name = XALLOCAVEC (char, len + 1)((char ) __builtin_alloca(sizeof (char) (len + 1)));
4299	memcpy (name, lower, len);
4300	name[len] = '\0';
4301	}
4302
4303	if (sym && sym->attr.flavor == FL_STRUCT)
4304	{
4305	ts->u.derived = sym;
4306	return MATCH_YES;
4307	}
4308	/* Actually a derived type. */
4309	}
4310
4311	else
4312	{
4313	/* Match nested STRUCTURE declarations; only valid within another
4314	structure declaration. */
4315	if (flag_dec_structureglobal_options.x_flag_dec_structure
4316	&& (gfc_current_state ()(gfc_state_stack->state) == COMP_STRUCTURE
4317	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_MAP))
4318	{
4319	m = gfc_match (" structure");
4320	if (m == MATCH_YES)
4321	{
4322	m = gfc_match_structure_decl ();
4323	if (m == MATCH_YES)
4324	{
4325	/* gfc_new_block is updated by match_structure_decl. */
4326	ts->type = BT_DERIVED;
4327	ts->u.derived = gfc_new_block;
4328	return MATCH_YES;
4329	}
4330	}
4331	if (m == MATCH_ERROR)
4332	return MATCH_ERROR;
4333	}
4334
4335	/* Match CLASS declarations. */
4336	m = gfc_match (" class ( * )");
4337	if (m == MATCH_ERROR)
4338	return MATCH_ERROR;
4339	else if (m == MATCH_YES)
4340	{
4341	gfc_symbol *upe;
4342	gfc_symtree *st;
4343	ts->type = BT_CLASS;
4344	gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4345	if (upe == NULL__null)
4346	{
4347	upe = gfc_new_symbol ("STAR", gfc_current_ns);
4348	st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4349	st->n.sym = upe;
4350	gfc_set_sym_referenced (upe);
4351	upe->refs++;
4352	upe->ts.type = BT_VOID;
4353	upe->attr.unlimited_polymorphic = 1;
4354	/* This is essential to force the construction of
4355	unlimited polymorphic component class containers. */
4356	upe->attr.zero_comp = 1;
4357	if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL__null,
4358	&gfc_current_locus))
4359	return MATCH_ERROR;
4360	}
4361	else
4362	{
4363	st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4364	st->n.sym = upe;
4365	upe->refs++;
4366	}
4367	ts->u.derived = upe;
4368	return m;
4369	}
4370
4371	m = gfc_match (" class (");
4372
4373	if (m == MATCH_YES)
4374	m = gfc_match ("%n", name);
4375	else
4376	return m;
4377
4378	if (m != MATCH_YES)
4379	return m;
4380	ts->type = BT_CLASS;
4381
4382	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "CLASS statement at %C"))
4383	return MATCH_ERROR;
4384
4385	m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4386	if (m == MATCH_ERROR)
4387	return m;
4388
4389	m = gfc_match_char (')');
4390	if (m != MATCH_YES)
4391	return m;
4392	}
4393
4394	/* Defer association of the derived type until the end of the
4395	specification block. However, if the derived type can be
4396	found, add it to the typespec. */
4397	if (gfc_matching_function)
4398	{
4399	ts->u.derived = NULL__null;
4400	if (gfc_current_state ()(gfc_state_stack->state) != COMP_INTERFACE
4401	&& !gfc_find_symbol (name, NULL__null, 1, &sym) && sym)
4402	{
4403	sym = gfc_find_dt_in_generic (sym);
4404	ts->u.derived = sym;
4405	}
4406	return MATCH_YES;
4407	}
4408
4409	/* Search for the name but allow the components to be defined later. If
4410	type = -1, this typespec has been seen in a function declaration but
4411	the type could not be accessed at that point. The actual derived type is
4412	stored in a symtree with the first letter of the name capitalized; the
4413	symtree with the all lower-case name contains the associated
4414	generic function. */
4415	dt_name = gfc_dt_upper_string (name);
4416	sym = NULL__null;
4417	dt_sym = NULL__null;
4418	if (ts->kind != -1)
4419	{
4420	gfc_get_ha_symbol (name, &sym);
4421	if (sym->generic && gfc_find_symbol (dt_name, NULL__null, 0, &dt_sym))
4422	{
4423	gfc_error ("Type name %qs at %C is ambiguous", name);
4424	return MATCH_ERROR;
4425	}
4426	if (sym->generic && !dt_sym)
4427	dt_sym = gfc_find_dt_in_generic (sym);
4428
4429	/* Host associated PDTs can get confused with their constructors
4430	because they ar instantiated in the template's namespace. */
4431	if (!dt_sym)
4432	{
4433	if (gfc_find_symbol (dt_name, NULL__null, 1, &dt_sym))
4434	{
4435	gfc_error ("Type name %qs at %C is ambiguous", name);
4436	return MATCH_ERROR;
4437	}
4438	if (dt_sym && !dt_sym->attr.pdt_type)
4439	dt_sym = NULL__null;
4440	}
4441	}
4442	else if (ts->kind == -1)
4443	{
4444	int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4445	\|\| gfc_current_ns->has_import_set;
4446	gfc_find_symbol (name, NULL__null, iface, &sym);
4447	if (sym && sym->generic && gfc_find_symbol (dt_name, NULL__null, 1, &dt_sym))
4448	{
4449	gfc_error ("Type name %qs at %C is ambiguous", name);
4450	return MATCH_ERROR;
4451	}
4452	if (sym && sym->generic && !dt_sym)
4453	dt_sym = gfc_find_dt_in_generic (sym);
4454
4455	ts->kind = 0;
4456	if (sym == NULL__null)
4457	return MATCH_NO;
4458	}
4459
4460	if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4461	&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4462	\|\| sym->attr.subroutine)
4463	{
4464	gfc_error ("Type name %qs at %C conflicts with previously declared "
4465	"entity at %L, which has the same name", name,
4466	&sym->declared_at);
4467	return MATCH_ERROR;
4468	}
4469
4470	if (sym && sym->attr.flavor == FL_DERIVED
4471	&& sym->attr.pdt_template
4472	&& gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED)
4473	{
4474	m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL__null);
4475	if (m != MATCH_YES)
4476	return m;
4477	gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type)((void)(!(!sym->attr.pdt_template && sym->attr. pdt_type) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 4477, __FUNCTION__), 0 : 0));
4478	ts->u.derived = sym;
4479	strcpy (name, gfc_dt_lower_string (sym->name));
4480	}
4481
4482	gfc_save_symbol_data (sym);
4483	gfc_set_sym_referenced (sym);
4484	if (!sym->attr.generic
4485	&& !gfc_add_generic (&sym->attr, sym->name, NULL__null))
4486	return MATCH_ERROR;
4487
4488	if (!sym->attr.function
4489	&& !gfc_add_function (&sym->attr, sym->name, NULL__null))
4490	return MATCH_ERROR;
4491
4492	if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
4493	&& dt_sym->attr.pdt_template
4494	&& gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED)
4495	{
4496	m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL__null);
4497	if (m != MATCH_YES)
4498	return m;
4499	gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type)((void)(!(!dt_sym->attr.pdt_template && dt_sym-> attr.pdt_type) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 4499, __FUNCTION__), 0 : 0));
4500	}
4501
4502	if (!dt_sym)
4503	{
4504	gfc_interface intr, head;
4505
4506	/* Use upper case to save the actual derived-type symbol. */
4507	gfc_get_symbol (dt_name, NULL__null, &dt_sym);
4508	dt_sym->name = gfc_get_string ("%s", sym->name);
4509	head = sym->generic;
4510	intr = gfc_get_interface ()((gfc_interface *) xcalloc (1, sizeof (gfc_interface)));
4511	intr->sym = dt_sym;
4512	intr->where = gfc_current_locus;
4513	intr->next = head;
4514	sym->generic = intr;
4515	sym->attr.if_source = IFSRC_DECL;
4516	}
4517	else
4518	gfc_save_symbol_data (dt_sym);
4519
4520	gfc_set_sym_referenced (dt_sym);
4521
4522	if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
4523	&& !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL__null))
4524	return MATCH_ERROR;
4525
4526	ts->u.derived = dt_sym;
4527
4528	return MATCH_YES;
4529
4530	get_kind:
4531	if (matched_type
4532	&& !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with "
4533	"intrinsic-type-spec at %C"))
4534	return MATCH_ERROR;
4535
4536	/* For all types except double, derived and character, look for an
4537	optional kind specifier. MATCH_NO is actually OK at this point. */
4538	if (implicit_flag == 1)
4539	{
4540	if (matched_type && gfc_match_char (')') != MATCH_YES)
4541	return MATCH_ERROR;
4542
4543	return MATCH_YES;
4544	}
4545
4546	if (gfc_current_form == FORM_FREE)
4547	{
4548	c = gfc_peek_ascii_char ();
4549	if (!gfc_is_whitespace (c)((c==' ') \|\| (c=='\t') \|\| (c=='\f')) && c != '*' && c != '('
4550	&& c != ':' && c != ',')
4551	{
4552	if (matched_type && c == ')')
4553	{
4554	gfc_next_ascii_char ();
4555	return MATCH_YES;
4556	}
4557	gfc_error ("Malformed type-spec at %C");
4558	return MATCH_NO;
4559	}
4560	}
4561
4562	m = gfc_match_kind_spec (ts, false);
4563	if (m == MATCH_NO && ts->type != BT_CHARACTER)
4564	{
4565	m = gfc_match_old_kind_spec (ts);
4566	if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
4567	return MATCH_ERROR;
4568	}
4569
4570	if (matched_type && gfc_match_char (')') != MATCH_YES)
4571	{
4572	gfc_error ("Malformed type-spec at %C");
4573	return MATCH_ERROR;
4574	}
4575
4576	/* Defer association of the KIND expression of function results
4577	until after USE and IMPORT statements. */
4578	if ((gfc_current_state ()(gfc_state_stack->state) == COMP_NONE && gfc_error_flag_test ())
4579	\|\| gfc_matching_function)
4580	return MATCH_YES;
4581
4582	if (m == MATCH_NO)
4583	m = MATCH_YES; /* No kind specifier found. */
4584
4585	return m;
4586	}
4587
4588
4589	/* Match an IMPLICIT NONE statement. Actually, this statement is
4590	already matched in parse.c, or we would not end up here in the
4591	first place. So the only thing we need to check, is if there is
4592	trailing garbage. If not, the match is successful. */
4593
4594	match
4595	gfc_match_implicit_none (void)
4596	{
4597	char c;
4598	match m;
4599	char name[GFC_MAX_SYMBOL_LEN63 + 1];
4600	bool type = false;
4601	bool external = false;
4602	locus cur_loc = gfc_current_locus;
4603
4604	if (gfc_current_ns->seen_implicit_none
4605	\|\| gfc_current_ns->has_implicit_none_export)
4606	{
4607	gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4608	return MATCH_ERROR;
4609	}
4610
4611	gfc_gobble_whitespace ();
4612	c = gfc_peek_ascii_char ();
4613	if (c == '(')
4614	{
4615	(void) gfc_next_ascii_char ();
4616	if (!gfc_notify_std (GFC_STD_F2018(1<<9), "IMPORT NONE with spec list at %C"))
4617	return MATCH_ERROR;
4618
4619	gfc_gobble_whitespace ();
4620	if (gfc_peek_ascii_char () == ')')
4621	{
4622	(void) gfc_next_ascii_char ();
4623	type = true;
4624	}
4625	else
4626	for(;;)
4627	{
4628	m = gfc_match (" %n", name);
4629	if (m != MATCH_YES)
4630	return MATCH_ERROR;
4631
4632	if (strcmp (name, "type") == 0)
4633	type = true;
4634	else if (strcmp (name, "external") == 0)
4635	external = true;
4636	else
4637	return MATCH_ERROR;
4638
4639	gfc_gobble_whitespace ();
4640	c = gfc_next_ascii_char ();
4641	if (c == ',')
4642	continue;
4643	if (c == ')')
4644	break;
4645	return MATCH_ERROR;
4646	}
4647	}
4648	else
4649	type = true;
4650
4651	if (gfc_match_eos () != MATCH_YES)
4652	return MATCH_ERROR;
4653
4654	gfc_set_implicit_none (type, external, &cur_loc);
4655
4656	return MATCH_YES;
4657	}
4658
4659
4660	/* Match the letter range(s) of an IMPLICIT statement. */
4661
4662	static match
4663	match_implicit_range (void)
4664	{
4665	char c, c1, c2;
4666	int inner;
4667	locus cur_loc;
4668
4669	cur_loc = gfc_current_locus;
4670
4671	gfc_gobble_whitespace ();
4672	c = gfc_next_ascii_char ();
4673	if (c != '(')
4674	{
4675	gfc_error ("Missing character range in IMPLICIT at %C");
4676	goto bad;
4677	}
4678
4679	inner = 1;
4680	while (inner)
4681	{
4682	gfc_gobble_whitespace ();
4683	c1 = gfc_next_ascii_char ();
4684	if (!ISALPHA (c1)(_sch_istable[(c1) & 0xff] & (unsigned short)(_sch_isalpha )))
4685	goto bad;
4686
4687	gfc_gobble_whitespace ();
4688	c = gfc_next_ascii_char ();
4689
4690	switch (c)
4691	{
4692	case ')':
4693	inner = 0; /* Fall through. */
4694
4695	case ',':
4696	c2 = c1;
4697	break;
4698
4699	case '-':
4700	gfc_gobble_whitespace ();
4701	c2 = gfc_next_ascii_char ();
4702	if (!ISALPHA (c2)(_sch_istable[(c2) & 0xff] & (unsigned short)(_sch_isalpha )))
4703	goto bad;
4704
4705	gfc_gobble_whitespace ();
4706	c = gfc_next_ascii_char ();
4707
4708	if ((c != ',') && (c != ')'))
4709	goto bad;
4710	if (c == ')')
4711	inner = 0;
4712
4713	break;
4714
4715	default:
4716	goto bad;
4717	}
4718
4719	if (c1 > c2)
4720	{
4721	gfc_error ("Letters must be in alphabetic order in "
4722	"IMPLICIT statement at %C");
4723	goto bad;
4724	}
4725
4726	/* See if we can add the newly matched range to the pending
4727	implicits from this IMPLICIT statement. We do not check for
4728	conflicts with whatever earlier IMPLICIT statements may have
4729	set. This is done when we've successfully finished matching
4730	the current one. */
4731	if (!gfc_add_new_implicit_range (c1, c2))
4732	goto bad;
4733	}
4734
4735	return MATCH_YES;
4736
4737	bad:
4738	gfc_syntax_error (ST_IMPLICIT)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_IMPLICIT));;
4739
4740	gfc_current_locus = cur_loc;
4741	return MATCH_ERROR;
4742	}
4743
4744
4745	/* Match an IMPLICIT statement, storing the types for
4746	gfc_set_implicit() if the statement is accepted by the parser.
4747	There is a strange looking, but legal syntactic construction
4748	possible. It looks like:
4749
4750	IMPLICIT INTEGER (a-b) (c-d)
4751
4752	This is legal if "a-b" is a constant expression that happens to
4753	equal one of the legal kinds for integers. The real problem
4754	happens with an implicit specification that looks like:
4755
4756	IMPLICIT INTEGER (a-b)
4757
4758	In this case, a typespec matcher that is "greedy" (as most of the
4759	matchers are) gobbles the character range as a kindspec, leaving
4760	nothing left. We therefore have to go a bit more slowly in the
4761	matching process by inhibiting the kindspec checking during
4762	typespec matching and checking for a kind later. */
4763
4764	match
4765	gfc_match_implicit (void)
4766	{
4767	gfc_typespec ts;
4768	locus cur_loc;
4769	char c;
4770	match m;
4771
4772	if (gfc_current_ns->seen_implicit_none)
4773	{
4774	gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4775	"statement");
4776	return MATCH_ERROR;
4777	}
4778
4779	gfc_clear_ts (&ts);
4780
4781	/* We don't allow empty implicit statements. */
4782	if (gfc_match_eos () == MATCH_YES)
4783	{
4784	gfc_error ("Empty IMPLICIT statement at %C");
4785	return MATCH_ERROR;
4786	}
4787
4788	do
4789	{
4790	/* First cleanup. */
4791	gfc_clear_new_implicit ();
4792
4793	/* A basic type is mandatory here. */
4794	m = gfc_match_decl_type_spec (&ts, 1);
4795	if (m == MATCH_ERROR)
4796	goto error;
4797	if (m == MATCH_NO)
4798	goto syntax;
4799
4800	cur_loc = gfc_current_locus;
4801	m = match_implicit_range ();
4802
4803	if (m == MATCH_YES)
4804	{
4805	/* We may have <TYPE> (<RANGE>). */
4806	gfc_gobble_whitespace ();
4807	c = gfc_peek_ascii_char ();
4808	if (c == ',' \|\| c == '\n' \|\| c == ';' \|\| c == '!')
4809	{
4810	/* Check for CHARACTER with no length parameter. */
4811	if (ts.type == BT_CHARACTER && !ts.u.cl)
4812	{
4813	ts.kind = gfc_default_character_kind;
4814	ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
4815	ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4816	NULL__null, 1);
4817	}
4818
4819	/* Record the Successful match. */
4820	if (!gfc_merge_new_implicit (&ts))
4821	return MATCH_ERROR;
4822	if (c == ',')
4823	c = gfc_next_ascii_char ();
4824	else if (gfc_match_eos () == MATCH_ERROR)
4825	goto error;
4826	continue;
4827	}
4828
4829	gfc_current_locus = cur_loc;
4830	}
4831
4832	/* Discard the (incorrectly) matched range. */
4833	gfc_clear_new_implicit ();
4834
4835	/* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4836	if (ts.type == BT_CHARACTER)
4837	m = gfc_match_char_spec (&ts);
4838	else if (gfc_numeric_ts(&ts) \|\| ts.type == BT_LOGICAL)
4839	{
4840	m = gfc_match_kind_spec (&ts, false);
4841	if (m == MATCH_NO)
4842	{
4843	m = gfc_match_old_kind_spec (&ts);
4844	if (m == MATCH_ERROR)
4845	goto error;
4846	if (m == MATCH_NO)
4847	goto syntax;
4848	}
4849	}
4850	if (m == MATCH_ERROR)
4851	goto error;
4852
4853	m = match_implicit_range ();
4854	if (m == MATCH_ERROR)
4855	goto error;
4856	if (m == MATCH_NO)
4857	goto syntax;
4858
4859	gfc_gobble_whitespace ();
4860	c = gfc_next_ascii_char ();
4861	if (c != ',' && gfc_match_eos () != MATCH_YES)
4862	goto syntax;
4863
4864	if (!gfc_merge_new_implicit (&ts))
4865	return MATCH_ERROR;
4866	}
4867	while (c == ',');
4868
4869	return MATCH_YES;
4870
4871	syntax:
4872	gfc_syntax_error (ST_IMPLICIT)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_IMPLICIT));;
4873
4874	error:
4875	return MATCH_ERROR;
4876	}
4877
4878
4879	match
4880	gfc_match_import (void)
4881	{
4882	char name[GFC_MAX_SYMBOL_LEN63 + 1];
4883	match m;
4884	gfc_symbol *sym;
4885	gfc_symtree *st;
4886
4887	if (gfc_current_ns->proc_name == NULL__null
4888	\|\| gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
4889	{
4890	gfc_error ("IMPORT statement at %C only permitted in "
4891	"an INTERFACE body");
4892	return MATCH_ERROR;
4893	}
4894
4895	if (gfc_current_ns->proc_name->attr.module_procedure)
4896	{
4897	gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4898	"in a module procedure interface body");
4899	return MATCH_ERROR;
4900	}
4901
4902	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "IMPORT statement at %C"))
4903	return MATCH_ERROR;
4904
4905	if (gfc_match_eos () == MATCH_YES)
4906	{
4907	/* All host variables should be imported. */
4908	gfc_current_ns->has_import_set = 1;
4909	return MATCH_YES;
4910	}
4911
4912	if (gfc_match (" ::") == MATCH_YES)
4913	{
4914	if (gfc_match_eos () == MATCH_YES)
4915	{
4916	gfc_error ("Expecting list of named entities at %C");
4917	return MATCH_ERROR;
4918	}
4919	}
4920
4921	for(;;)
4922	{
4923	sym = NULL__null;
4924	m = gfc_match (" %n", name);
4925	switch (m)
4926	{
4927	case MATCH_YES:
4928	if (gfc_current_ns->parent != NULL__null
4929	&& gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
4930	{
4931	gfc_error ("Type name %qs at %C is ambiguous", name);
4932	return MATCH_ERROR;
4933	}
4934	else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL__null
4935	&& gfc_find_symbol (name,
4936	gfc_current_ns->proc_name->ns->parent,
4937	1, &sym))
4938	{
4939	gfc_error ("Type name %qs at %C is ambiguous", name);
4940	return MATCH_ERROR;
4941	}
4942
4943	if (sym == NULL__null)
4944	{
4945	gfc_error ("Cannot IMPORT %qs from host scoping unit "
4946	"at %C - does not exist.", name);
4947	return MATCH_ERROR;
4948	}
4949
4950	if (gfc_find_symtree (gfc_current_ns->sym_root, name))
4951	{
4952	gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4953	"at %C", name);
4954	goto next_item;
4955	}
4956
4957	st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
4958	st->n.sym = sym;
4959	sym->refs++;
4960	sym->attr.imported = 1;
4961
4962	if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
4963	{
4964	/* The actual derived type is stored in a symtree with the first
4965	letter of the name capitalized; the symtree with the all
4966	lower-case name contains the associated generic function. */
4967	st = gfc_new_symtree (&gfc_current_ns->sym_root,
4968	gfc_dt_upper_string (name));
4969	st->n.sym = sym;
4970	sym->refs++;
4971	sym->attr.imported = 1;
4972	}
4973
4974	goto next_item;
4975
4976	case MATCH_NO:
4977	break;
4978
4979	case MATCH_ERROR:
4980	return MATCH_ERROR;
4981	}
4982
4983	next_item:
4984	if (gfc_match_eos () == MATCH_YES)
4985	break;
4986	if (gfc_match_char (',') != MATCH_YES)
4987	goto syntax;
4988	}
4989
4990	return MATCH_YES;
4991
4992	syntax:
4993	gfc_error ("Syntax error in IMPORT statement at %C");
4994	return MATCH_ERROR;
4995	}
4996
4997
4998	/* A minimal implementation of gfc_match without whitespace, escape
4999	characters or variable arguments. Returns true if the next
5000	characters match the TARGET template exactly. */
5001
5002	static bool
5003	match_string_p (const char *target)
5004	{
5005	const char *p;
5006
5007	for (p = target; *p; p++)
5008	if ((char) gfc_next_ascii_char () != *p)
5009	return false;
5010	return true;
5011	}
5012
5013	/* Matches an attribute specification including array specs. If
5014	successful, leaves the variables current_attr and current_as
5015	holding the specification. Also sets the colon_seen variable for
5016	later use by matchers associated with initializations.
5017
5018	This subroutine is a little tricky in the sense that we don't know
5019	if we really have an attr-spec until we hit the double colon.
5020	Until that time, we can only return MATCH_NO. This forces us to
5021	check for duplicate specification at this level. */
5022
5023	static match
5024	match_attr_spec (void)
5025	{
5026	/* Modifiers that can exist in a type statement. */
5027	enum
5028	{ GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5029	DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5030	DECL_DIMENSION, DECL_EXTERNAL,
5031	DECL_INTRINSIC, DECL_OPTIONAL,
5032	DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5033	DECL_STATIC, DECL_AUTOMATIC,
5034	DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5035	DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5036	DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5037	};
5038
5039	/* GFC_DECL_END is the sentinel, index starts at 0. */
5040	#define NUM_DECLGFC_DECL_END GFC_DECL_END
5041
5042	/* Make sure that values from sym_intent are safe to be used here. */
5043	gcc_assert (INTENT_IN > 0)((void)(!(INTENT_IN > 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 5043, __FUNCTION__), 0 : 0));
5044
5045	locus start, seen_at[NUM_DECLGFC_DECL_END];
5046	int seen[NUM_DECLGFC_DECL_END];
5047	unsigned int d;
5048	const char *attr;
5049	match m;
5050	bool t;
5051
5052	gfc_clear_attr (&current_attr);
5053	start = gfc_current_locus;
5054
5055	current_as = NULL__null;
5056	colon_seen = 0;
5057	attr_seen = 0;
5058
5059	/* See if we get all of the keywords up to the final double colon. */
5060	for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5061	seen[d] = 0;
5062
5063	for (;;)
5064	{
5065	char ch;
5066
5067	d = DECL_NONE;
5068	gfc_gobble_whitespace ();
5069
5070	ch = gfc_next_ascii_char ();
5071	if (ch == ':')
5072	{
5073	/* This is the successful exit condition for the loop. */
5074	if (gfc_next_ascii_char () == ':')
5075	break;
5076	}
5077	else if (ch == ',')
5078	{
5079	gfc_gobble_whitespace ();
5080	switch (gfc_peek_ascii_char ())
5081	{
5082	case 'a':
5083	gfc_next_ascii_char ();
5084	switch (gfc_next_ascii_char ())
5085	{
5086	case 'l':
5087	if (match_string_p ("locatable"))
5088	{
5089	/* Matched "allocatable". */
5090	d = DECL_ALLOCATABLE;
5091	}
5092	break;
5093
5094	case 's':
5095	if (match_string_p ("ynchronous"))
5096	{
5097	/* Matched "asynchronous". */
5098	d = DECL_ASYNCHRONOUS;
5099	}
5100	break;
5101
5102	case 'u':
5103	if (match_string_p ("tomatic"))
5104	{
5105	/* Matched "automatic". */
5106	d = DECL_AUTOMATIC;
5107	}
5108	break;
5109	}
5110	break;
5111
5112	case 'b':
5113	/* Try and match the bind(c). */
5114	m = gfc_match_bind_c (NULL__null, true);
5115	if (m == MATCH_YES)
5116	d = DECL_IS_BIND_C;
5117	else if (m == MATCH_ERROR)
5118	goto cleanup;
5119	break;
5120
5121	case 'c':
5122	gfc_next_ascii_char ();
5123	if ('o' != gfc_next_ascii_char ())
5124	break;
5125	switch (gfc_next_ascii_char ())
5126	{
5127	case 'd':
5128	if (match_string_p ("imension"))
5129	{
5130	d = DECL_CODIMENSION;
5131	break;
5132	}
5133	/* FALLTHRU */
5134	case 'n':
5135	if (match_string_p ("tiguous"))
5136	{
5137	d = DECL_CONTIGUOUS;
5138	break;
5139	}
5140	}
5141	break;
5142
5143	case 'd':
5144	if (match_string_p ("dimension"))
5145	d = DECL_DIMENSION;
5146	break;
5147
5148	case 'e':
5149	if (match_string_p ("external"))
5150	d = DECL_EXTERNAL;
5151	break;
5152
5153	case 'i':
5154	if (match_string_p ("int"))
5155	{
5156	ch = gfc_next_ascii_char ();
5157	if (ch == 'e')
5158	{
5159	if (match_string_p ("nt"))
5160	{
5161	/* Matched "intent". */
5162	d = match_intent_spec ();
5163	if (d == INTENT_UNKNOWN)
5164	{
5165	m = MATCH_ERROR;
5166	goto cleanup;
5167	}
5168	}
5169	}
5170	else if (ch == 'r')
5171	{
5172	if (match_string_p ("insic"))
5173	{
5174	/* Matched "intrinsic". */
5175	d = DECL_INTRINSIC;
5176	}
5177	}
5178	}
5179	break;
5180
5181	case 'k':
5182	if (match_string_p ("kind"))
5183	d = DECL_KIND;
5184	break;
5185
5186	case 'l':
5187	if (match_string_p ("len"))
5188	d = DECL_LEN;
5189	break;
5190
5191	case 'o':
5192	if (match_string_p ("optional"))
5193	d = DECL_OPTIONAL;
5194	break;
5195
5196	case 'p':
5197	gfc_next_ascii_char ();
5198	switch (gfc_next_ascii_char ())
5199	{
5200	case 'a':
5201	if (match_string_p ("rameter"))
5202	{
5203	/* Matched "parameter". */
5204	d = DECL_PARAMETER;
5205	}
5206	break;
5207
5208	case 'o':
5209	if (match_string_p ("inter"))
5210	{
5211	/* Matched "pointer". */
5212	d = DECL_POINTER;
5213	}
5214	break;
5215
5216	case 'r':
5217	ch = gfc_next_ascii_char ();
5218	if (ch == 'i')
5219	{
5220	if (match_string_p ("vate"))
5221	{
5222	/* Matched "private". */
5223	d = DECL_PRIVATE;
5224	}
5225	}
5226	else if (ch == 'o')
5227	{
5228	if (match_string_p ("tected"))
5229	{
5230	/* Matched "protected". */
5231	d = DECL_PROTECTED;
5232	}
5233	}
5234	break;
5235
5236	case 'u':
5237	if (match_string_p ("blic"))
5238	{
5239	/* Matched "public". */
5240	d = DECL_PUBLIC;
5241	}
5242	break;
5243	}
5244	break;
5245
5246	case 's':
5247	gfc_next_ascii_char ();
5248	switch (gfc_next_ascii_char ())
5249	{
5250	case 'a':
5251	if (match_string_p ("ve"))
5252	{
5253	/* Matched "save". */
5254	d = DECL_SAVE;
5255	}
5256	break;
5257
5258	case 't':
5259	if (match_string_p ("atic"))
5260	{
5261	/* Matched "static". */
5262	d = DECL_STATIC;
5263	}
5264	break;
5265	}
5266	break;
5267
5268	case 't':
5269	if (match_string_p ("target"))
5270	d = DECL_TARGET;
5271	break;
5272
5273	case 'v':
5274	gfc_next_ascii_char ();
5275	ch = gfc_next_ascii_char ();
5276	if (ch == 'a')
5277	{
5278	if (match_string_p ("lue"))
5279	{
5280	/* Matched "value". */
5281	d = DECL_VALUE;
5282	}
5283	}
5284	else if (ch == 'o')
5285	{
5286	if (match_string_p ("latile"))
5287	{
5288	/* Matched "volatile". */
5289	d = DECL_VOLATILE;
5290	}
5291	}
5292	break;
5293	}
5294	}
5295
5296	/* No double colon and no recognizable decl_type, so assume that
5297	we've been looking at something else the whole time. */
5298	if (d == DECL_NONE)
5299	{
5300	m = MATCH_NO;
5301	goto cleanup;
5302	}
5303
5304	/* Check to make sure any parens are paired up correctly. */
5305	if (gfc_match_parens () == MATCH_ERROR)
5306	{
5307	m = MATCH_ERROR;
5308	goto cleanup;
5309	}
5310
5311	seen[d]++;
5312	seen_at[d] = gfc_current_locus;
5313
5314	if (d == DECL_DIMENSION \|\| d == DECL_CODIMENSION)
5315	{
5316	gfc_array_spec *as = NULL__null;
5317
5318	m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5319	d == DECL_CODIMENSION);
5320
5321	if (current_as == NULL__null)
5322	current_as = as;
5323	else if (m == MATCH_YES)
5324	{
5325	if (!merge_array_spec (as, current_as, false))
5326	m = MATCH_ERROR;
5327	free (as);
5328	}
5329
5330	if (m == MATCH_NO)
5331	{
5332	if (d == DECL_CODIMENSION)
5333	gfc_error ("Missing codimension specification at %C");
5334	else
5335	gfc_error ("Missing dimension specification at %C");
5336	m = MATCH_ERROR;
5337	}
5338
5339	if (m == MATCH_ERROR)
5340	goto cleanup;
5341	}
5342	}
5343
5344	/* Since we've seen a double colon, we have to be looking at an
5345	attr-spec. This means that we can now issue errors. */
5346	for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5347	if (seen[d] > 1)
5348	{
5349	switch (d)
5350	{
5351	case DECL_ALLOCATABLE:
5352	attr = "ALLOCATABLE";
5353	break;
5354	case DECL_ASYNCHRONOUS:
5355	attr = "ASYNCHRONOUS";
5356	break;
5357	case DECL_CODIMENSION:
5358	attr = "CODIMENSION";
5359	break;
5360	case DECL_CONTIGUOUS:
5361	attr = "CONTIGUOUS";
5362	break;
5363	case DECL_DIMENSION:
5364	attr = "DIMENSION";
5365	break;
5366	case DECL_EXTERNAL:
5367	attr = "EXTERNAL";
5368	break;
5369	case DECL_IN:
5370	attr = "INTENT (IN)";
5371	break;
5372	case DECL_OUT:
5373	attr = "INTENT (OUT)";
5374	break;
5375	case DECL_INOUT:
5376	attr = "INTENT (IN OUT)";
5377	break;
5378	case DECL_INTRINSIC:
5379	attr = "INTRINSIC";
5380	break;
5381	case DECL_OPTIONAL:
5382	attr = "OPTIONAL";
5383	break;
5384	case DECL_KIND:
5385	attr = "KIND";
5386	break;
5387	case DECL_LEN:
5388	attr = "LEN";
5389	break;
5390	case DECL_PARAMETER:
5391	attr = "PARAMETER";
5392	break;
5393	case DECL_POINTER:
5394	attr = "POINTER";
5395	break;
5396	case DECL_PROTECTED:
5397	attr = "PROTECTED";
5398	break;
5399	case DECL_PRIVATE:
5400	attr = "PRIVATE";
5401	break;
5402	case DECL_PUBLIC:
5403	attr = "PUBLIC";
5404	break;
5405	case DECL_SAVE:
5406	attr = "SAVE";
5407	break;
5408	case DECL_STATIC:
5409	attr = "STATIC";
5410	break;
5411	case DECL_AUTOMATIC:
5412	attr = "AUTOMATIC";
5413	break;
5414	case DECL_TARGET:
5415	attr = "TARGET";
5416	break;
5417	case DECL_IS_BIND_C:
5418	attr = "IS_BIND_C";
5419	break;
5420	case DECL_VALUE:
5421	attr = "VALUE";
5422	break;
5423	case DECL_VOLATILE:
5424	attr = "VOLATILE";
5425	break;
5426	default:
5427	attr = NULL__null; /* This shouldn't happen. */
5428	}
5429
5430	gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
5431	m = MATCH_ERROR;
5432	goto cleanup;
5433	}
5434
5435	/* Now that we've dealt with duplicate attributes, add the attributes
5436	to the current attribute. */
5437	for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5438	{
5439	if (seen[d] == 0)
5440	continue;
5441	else
5442	attr_seen = 1;
5443
5444	if ((d == DECL_STATIC \|\| d == DECL_AUTOMATIC)
5445	&& !flag_dec_staticglobal_options.x_flag_dec_static)
5446	{
5447	gfc_error ("%s at %L is a DEC extension, enable with "
5448	"%<-fdec-static%>",
5449	d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
5450	m = MATCH_ERROR;
5451	goto cleanup;
5452	}
5453	/* Allow SAVE with STATIC, but don't complain. */
5454	if (d == DECL_STATIC && seen[DECL_SAVE])
5455	continue;
5456
5457	if (gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP)
5458	&& d != DECL_DIMENSION && d != DECL_CODIMENSION
5459	&& d != DECL_POINTER && d != DECL_PRIVATE
5460	&& d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
5461	{
5462	bool is_derived = gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED;
5463	if (d == DECL_ALLOCATABLE)
5464	{
5465	if (!gfc_notify_std (GFC_STD_F2003(1<<4), is_derived
5466	? G_("ALLOCATABLE attribute at %C in a ""ALLOCATABLE attribute at %C in a " "TYPE definition"
5467	"TYPE definition")"ALLOCATABLE attribute at %C in a " "TYPE definition"
5468	: G_("ALLOCATABLE attribute at %C in a ""ALLOCATABLE attribute at %C in a " "STRUCTURE definition"
5469	"STRUCTURE definition")"ALLOCATABLE attribute at %C in a " "STRUCTURE definition"))
5470	{
5471	m = MATCH_ERROR;
5472	goto cleanup;
5473	}
5474	}
5475	else if (d == DECL_KIND)
5476	{
5477	if (!gfc_notify_std (GFC_STD_F2003(1<<4), is_derived
5478	? G_("KIND attribute at %C in a ""KIND attribute at %C in a " "TYPE definition"
5479	"TYPE definition")"KIND attribute at %C in a " "TYPE definition"
5480	: G_("KIND attribute at %C in a ""KIND attribute at %C in a " "STRUCTURE definition"
5481	"STRUCTURE definition")"KIND attribute at %C in a " "STRUCTURE definition"))
5482	{
5483	m = MATCH_ERROR;
5484	goto cleanup;
5485	}
5486	if (current_ts.type != BT_INTEGER)
5487	{
5488	gfc_error ("Component with KIND attribute at %C must be "
5489	"INTEGER");
5490	m = MATCH_ERROR;
5491	goto cleanup;
5492	}
5493	if (current_ts.kind != gfc_default_integer_kind)
5494	{
5495	gfc_error ("Component with KIND attribute at %C must be "
5496	"default integer kind (%d)",
5497	gfc_default_integer_kind);
5498	m = MATCH_ERROR;
5499	goto cleanup;
5500	}
5501	}
5502	else if (d == DECL_LEN)
5503	{
5504	if (!gfc_notify_std (GFC_STD_F2003(1<<4), is_derived
5505	? G_("LEN attribute at %C in a ""LEN attribute at %C in a " "TYPE definition"
5506	"TYPE definition")"LEN attribute at %C in a " "TYPE definition"
5507	: G_("LEN attribute at %C in a ""LEN attribute at %C in a " "STRUCTURE definition"
5508	"STRUCTURE definition")"LEN attribute at %C in a " "STRUCTURE definition"))
5509	{
5510	m = MATCH_ERROR;
5511	goto cleanup;
5512	}
5513	if (current_ts.type != BT_INTEGER)
5514	{
5515	gfc_error ("Component with LEN attribute at %C must be "
5516	"INTEGER");
5517	m = MATCH_ERROR;
5518	goto cleanup;
5519	}
5520	if (current_ts.kind != gfc_default_integer_kind)
5521	{
5522	gfc_error ("Component with LEN attribute at %C must be "
5523	"default integer kind (%d)",
5524	gfc_default_integer_kind);
5525	m = MATCH_ERROR;
5526	goto cleanup;
5527	}
5528	}
5529	else
5530	{
5531	gfc_error (is_derived ? G_("Attribute at %L is not allowed in a ""Attribute at %L is not allowed in a " "TYPE definition"
5532	"TYPE definition")"Attribute at %L is not allowed in a " "TYPE definition"
5533	: G_("Attribute at %L is not allowed in a ""Attribute at %L is not allowed in a " "STRUCTURE definition"
5534	"STRUCTURE definition")"Attribute at %L is not allowed in a " "STRUCTURE definition", &seen_at[d]);
5535	m = MATCH_ERROR;
5536	goto cleanup;
5537	}
5538	}
5539
5540	if ((d == DECL_PRIVATE \|\| d == DECL_PUBLIC)
5541	&& gfc_current_state ()(gfc_state_stack->state) != COMP_MODULE)
5542	{
5543	if (d == DECL_PRIVATE)
5544	attr = "PRIVATE";
5545	else
5546	attr = "PUBLIC";
5547	if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED
5548	&& gfc_state_stack->previous
5549	&& gfc_state_stack->previous->state == COMP_MODULE)
5550	{
5551	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Attribute %s "
5552	"at %L in a TYPE definition", attr,
5553	&seen_at[d]))
5554	{
5555	m = MATCH_ERROR;
5556	goto cleanup;
5557	}
5558	}
5559	else
5560	{
5561	gfc_error ("%s attribute at %L is not allowed outside of the "
5562	"specification part of a module", attr, &seen_at[d]);
5563	m = MATCH_ERROR;
5564	goto cleanup;
5565	}
5566	}
5567
5568	if (gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED
5569	&& (d == DECL_KIND \|\| d == DECL_LEN))
5570	{
5571	gfc_error ("Attribute at %L is not allowed outside a TYPE "
5572	"definition", &seen_at[d]);
5573	m = MATCH_ERROR;
5574	goto cleanup;
5575	}
5576
5577	switch (d)
5578	{
5579	case DECL_ALLOCATABLE:
5580	t = gfc_add_allocatable (&current_attr, &seen_at[d]);
5581	break;
5582
5583	case DECL_ASYNCHRONOUS:
5584	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "ASYNCHRONOUS attribute at %C"))
5585	t = false;
5586	else
5587	t = gfc_add_asynchronous (&current_attr, NULL__null, &seen_at[d]);
5588	break;
5589
5590	case DECL_CODIMENSION:
5591	t = gfc_add_codimension (&current_attr, NULL__null, &seen_at[d]);
5592	break;
5593
5594	case DECL_CONTIGUOUS:
5595	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "CONTIGUOUS attribute at %C"))
5596	t = false;
5597	else
5598	t = gfc_add_contiguous (&current_attr, NULL__null, &seen_at[d]);
5599	break;
5600
5601	case DECL_DIMENSION:
5602	t = gfc_add_dimension (&current_attr, NULL__null, &seen_at[d]);
5603	break;
5604
5605	case DECL_EXTERNAL:
5606	t = gfc_add_external (&current_attr, &seen_at[d]);
5607	break;
5608
5609	case DECL_IN:
5610	t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
5611	break;
5612
5613	case DECL_OUT:
5614	t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
5615	break;
5616
5617	case DECL_INOUT:
5618	t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
5619	break;
5620
5621	case DECL_INTRINSIC:
5622	t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
5623	break;
5624
5625	case DECL_OPTIONAL:
5626	t = gfc_add_optional (&current_attr, &seen_at[d]);
5627	break;
5628
5629	case DECL_KIND:
5630	t = gfc_add_kind (&current_attr, &seen_at[d]);
5631	break;
5632
5633	case DECL_LEN:
5634	t = gfc_add_len (&current_attr, &seen_at[d]);
5635	break;
5636
5637	case DECL_PARAMETER:
5638	t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL__null, &seen_at[d]);
5639	break;
5640
5641	case DECL_POINTER:
5642	t = gfc_add_pointer (&current_attr, &seen_at[d]);
5643	break;
5644
5645	case DECL_PROTECTED:
5646	if (gfc_current_state ()(gfc_state_stack->state) != COMP_MODULE
5647	\|\| (gfc_current_ns->proc_name
5648	&& gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5649	{
5650	gfc_error ("PROTECTED at %C only allowed in specification "
5651	"part of a module");
5652	t = false;
5653	break;
5654	}
5655
5656	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "PROTECTED attribute at %C"))
5657	t = false;
5658	else
5659	t = gfc_add_protected (&current_attr, NULL__null, &seen_at[d]);
5660	break;
5661
5662	case DECL_PRIVATE:
5663	t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL__null,
5664	&seen_at[d]);
5665	break;
5666
5667	case DECL_PUBLIC:
5668	t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL__null,
5669	&seen_at[d]);
5670	break;
5671
5672	case DECL_STATIC:
5673	case DECL_SAVE:
5674	t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL__null, &seen_at[d]);
5675	break;
5676
5677	case DECL_AUTOMATIC:
5678	t = gfc_add_automatic (&current_attr, NULL__null, &seen_at[d]);
5679	break;
5680
5681	case DECL_TARGET:
5682	t = gfc_add_target (&current_attr, &seen_at[d]);
5683	break;
5684
5685	case DECL_IS_BIND_C:
5686	t = gfc_add_is_bind_c(&current_attr, NULL__null, &seen_at[d], 0);
5687	break;
5688
5689	case DECL_VALUE:
5690	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "VALUE attribute at %C"))
5691	t = false;
5692	else
5693	t = gfc_add_value (&current_attr, NULL__null, &seen_at[d]);
5694	break;
5695
5696	case DECL_VOLATILE:
5697	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "VOLATILE attribute at %C"))
5698	t = false;
5699	else
5700	t = gfc_add_volatile (&current_attr, NULL__null, &seen_at[d]);
5701	break;
5702
5703	default:
5704	gfc_internal_error ("match_attr_spec(): Bad attribute");
5705	}
5706
5707	if (!t)
5708	{
5709	m = MATCH_ERROR;
5710	goto cleanup;
5711	}
5712	}
5713
5714	/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5715	if ((gfc_current_state ()(gfc_state_stack->state) == COMP_MODULE
5716	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_SUBMODULE)
5717	&& !current_attr.save
5718	&& (gfc_option.allow_std & GFC_STD_F2008(1<<7)) != 0)
5719	current_attr.save = SAVE_IMPLICIT;
5720
5721	colon_seen = 1;
5722	return MATCH_YES;
5723
5724	cleanup:
5725	gfc_current_locus = start;
5726	gfc_free_array_spec (current_as);
5727	current_as = NULL__null;
5728	attr_seen = 0;
5729	return m;
5730	}
5731
5732
5733	/* Set the binding label, dest_label, either with the binding label
5734	stored in the given gfc_typespec, ts, or if none was provided, it
5735	will be the symbol name in all lower case, as required by the draft
5736	(J3/04-007, section 15.4.1). If a binding label was given and
5737	there is more than one argument (num_idents), it is an error. */
5738
5739	static bool
5740	set_binding_label (const char *dest_label, const char sym_name,
5741	int num_idents)
5742	{
5743	if (num_idents > 1 && has_name_equals)
5744	{
5745	gfc_error ("Multiple identifiers provided with "
5746	"single NAME= specifier at %C");
5747	return false;
5748	}
5749
5750	if (curr_binding_label)
5751	/* Binding label given; store in temp holder till have sym. */
5752	*dest_label = curr_binding_label;
5753	else
5754	{
5755	/* No binding label given, and the NAME= specifier did not exist,
5756	which means there was no NAME="". */
5757	if (sym_name != NULL__null && has_name_equals == 0)
5758	dest_label = IDENTIFIER_POINTER (get_identifier (sym_name))((const char ) (tree_check (((__builtin_constant_p (sym_name ) ? get_identifier_with_length ((sym_name), strlen (sym_name) ) : get_identifier (sym_name))), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 5758, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str );
5759	}
5760
5761	return true;
5762	}
5763
5764
5765	/* Set the status of the given common block as being BIND(C) or not,
5766	depending on the given parameter, is_bind_c. */
5767
5768	void
5769	set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5770	{
5771	com_block->is_bind_c = is_bind_c;
5772	return;
5773	}
5774
5775
5776	/* Verify that the given gfc_typespec is for a C interoperable type. */
5777
5778	bool
5779	gfc_verify_c_interop (gfc_typespec *ts)
5780	{
5781	if (ts->type == BT_DERIVED && ts->u.derived != NULL__null)
5782	return (ts->u.derived->ts.is_c_interop \|\| ts->u.derived->attr.is_bind_c)
5783	? true : false;
5784	else if (ts->type == BT_CLASS)
5785	return false;
5786	else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5787	return false;
5788
5789	return true;
5790	}
5791
5792
5793	/* Verify that the variables of a given common block, which has been
5794	defined with the attribute specifier bind(c), to be of a C
5795	interoperable type. Errors will be reported here, if
5796	encountered. */
5797
5798	bool
5799	verify_com_block_vars_c_interop (gfc_common_head *com_block)
5800	{
5801	gfc_symbol *curr_sym = NULL__null;
5802	bool retval = true;
5803
5804	curr_sym = com_block->head;
5805
5806	/* Make sure we have at least one symbol. */
5807	if (curr_sym == NULL__null)
5808	return retval;
5809
5810	/* Here we know we have a symbol, so we'll execute this loop
5811	at least once. */
5812	do
5813	{
5814	/* The second to last param, 1, says this is in a common block. */
5815	retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5816	curr_sym = curr_sym->common_next;
5817	} while (curr_sym != NULL__null);
5818
5819	return retval;
5820	}
5821
5822
5823	/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5824	an appropriate error message is reported. */
5825
5826	bool
5827	verify_bind_c_sym (gfc_symbol tmp_sym, gfc_typespec ts,
5828	int is_in_common, gfc_common_head *com_block)
5829	{
5830	bool bind_c_function = false;
5831	bool retval = true;
5832
5833	if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
5834	bind_c_function = true;
5835
5836	if (tmp_sym->attr.function && tmp_sym->result != NULL__null)
5837	{
5838	tmp_sym = tmp_sym->result;
5839	/* Make sure it wasn't an implicitly typed result. */
5840	if (tmp_sym->attr.implicit_type && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
5841	{
5842	gfc_warning (OPT_Wc_binding_type,
5843	"Implicitly declared BIND(C) function %qs at "
5844	"%L may not be C interoperable", tmp_sym->name,
5845	&tmp_sym->declared_at);
5846	tmp_sym->ts.f90_type = tmp_sym->ts.type;
5847	/* Mark it as C interoperable to prevent duplicate warnings. */
5848	tmp_sym->ts.is_c_interop = 1;
5849	tmp_sym->attr.is_c_interop = 1;
5850	}
5851	}
5852
5853	/* Here, we know we have the bind(c) attribute, so if we have
5854	enough type info, then verify that it's a C interop kind.
5855	The info could be in the symbol already, or possibly still in
5856	the given ts (current_ts), so look in both. */
5857	if (tmp_sym->ts.type != BT_UNKNOWN \|\| ts->type != BT_UNKNOWN)
5858	{
5859	if (!gfc_verify_c_interop (&(tmp_sym->ts)))
5860	{
5861	/* See if we're dealing with a sym in a common block or not. */
5862	if (is_in_common == 1 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
5863	{
5864	gfc_warning (OPT_Wc_binding_type,
5865	"Variable %qs in common block %qs at %L "
5866	"may not be a C interoperable "
5867	"kind though common block %qs is BIND(C)",
5868	tmp_sym->name, com_block->name,
5869	&(tmp_sym->declared_at), com_block->name);
5870	}
5871	else
5872	{
5873	if (tmp_sym->ts.type == BT_DERIVED \|\| ts->type == BT_DERIVED)
5874	gfc_error ("Type declaration %qs at %L is not C "
5875	"interoperable but it is BIND(C)",
5876	tmp_sym->name, &(tmp_sym->declared_at));
5877	else if (warn_c_binding_typeglobal_options.x_warn_c_binding_type)
5878	gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
5879	"may not be a C interoperable "
5880	"kind but it is BIND(C)",
5881	tmp_sym->name, &(tmp_sym->declared_at));
5882	}
5883	}
5884
5885	/* Variables declared w/in a common block can't be bind(c)
5886	since there's no way for C to see these variables, so there's
5887	semantically no reason for the attribute. */
5888	if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
5889	{
5890	gfc_error ("Variable %qs in common block %qs at "
5891	"%L cannot be declared with BIND(C) "
5892	"since it is not a global",
5893	tmp_sym->name, com_block->name,
5894	&(tmp_sym->declared_at));
5895	retval = false;
5896	}
5897
5898	/* Scalar variables that are bind(c) cannot have the pointer
5899	or allocatable attributes. */
5900	if (tmp_sym->attr.is_bind_c == 1)
5901	{
5902	if (tmp_sym->attr.pointer == 1)
5903	{
5904	gfc_error ("Variable %qs at %L cannot have both the "
5905	"POINTER and BIND(C) attributes",
5906	tmp_sym->name, &(tmp_sym->declared_at));
5907	retval = false;
5908	}
5909
5910	if (tmp_sym->attr.allocatable == 1)
5911	{
5912	gfc_error ("Variable %qs at %L cannot have both the "
5913	"ALLOCATABLE and BIND(C) attributes",
5914	tmp_sym->name, &(tmp_sym->declared_at));
5915	retval = false;
5916	}
5917
5918	}
5919
5920	/* If it is a BIND(C) function, make sure the return value is a
5921	scalar value. The previous tests in this function made sure
5922	the type is interoperable. */
5923	if (bind_c_function && tmp_sym->as != NULL__null)
5924	gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5925	"be an array", tmp_sym->name, &(tmp_sym->declared_at));
5926
5927	/* BIND(C) functions cannot return a character string. */
5928	if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
5929	if (tmp_sym->ts.u.cl == NULL__null \|\| tmp_sym->ts.u.cl->length == NULL__null
5930	\|\| tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5931	\|\| mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (tmp_sym->ts.u.cl->length->value.integer)->_mp_size < 0 ? -1 : (tmp_sym->ts.u.cl->length->value.integer )->_mp_size > 0) : __gmpz_cmp_ui (tmp_sym->ts.u.cl-> length->value.integer,(static_cast<unsigned long> (1 )))) : __gmpz_cmp_si (tmp_sym->ts.u.cl->length->value .integer,1)) != 0)
5932	gfc_error ("Return type of BIND(C) function %qs of character "
5933	"type at %L must have length 1", tmp_sym->name,
5934	&(tmp_sym->declared_at));
5935	}
5936
5937	/* See if the symbol has been marked as private. If it has, make sure
5938	there is no binding label and warn the user if there is one. */
5939	if (tmp_sym->attr.access == ACCESS_PRIVATE
5940	&& tmp_sym->binding_label)
5941	/* Use gfc_warning_now because we won't say that the symbol fails
5942	just because of this. */
5943	gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5944	"given the binding label %qs", tmp_sym->name,
5945	&(tmp_sym->declared_at), tmp_sym->binding_label);
5946
5947	return retval;
5948	}
5949
5950
5951	/* Set the appropriate fields for a symbol that's been declared as
5952	BIND(C) (the is_bind_c flag and the binding label), and verify that
5953	the type is C interoperable. Errors are reported by the functions
5954	used to set/test these fields. */
5955
5956	bool
5957	set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
5958	{
5959	bool retval = true;
5960
5961	/* TODO: Do we need to make sure the vars aren't marked private? */
5962
5963	/* Set the is_bind_c bit in symbol_attribute. */
5964	gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
5965
5966	if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
5967	return false;
5968
5969	return retval;
5970	}
5971
5972
5973	/* Set the fields marking the given common block as BIND(C), including
5974	a binding label, and report any errors encountered. */
5975
5976	bool
5977	set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
5978	{
5979	bool retval = true;
5980
5981	/* destLabel, common name, typespec (which may have binding label). */
5982	if (!set_binding_label (&com_block->binding_label, com_block->name,
5983	num_idents))
5984	return false;
5985
5986	/* Set the given common block (com_block) to being bind(c) (1). */
5987	set_com_block_bind_c (com_block, 1);
5988
5989	return retval;
5990	}
5991
5992
5993	/* Retrieve the list of one or more identifiers that the given bind(c)
5994	attribute applies to. */
5995
5996	bool
5997	get_bind_c_idents (void)
5998	{
5999	char name[GFC_MAX_SYMBOL_LEN63 + 1];
6000	int num_idents = 0;
6001	gfc_symbol *tmp_sym = NULL__null;
6002	match found_id;
6003	gfc_common_head *com_block = NULL__null;
6004
6005	if (gfc_match_name (name) == MATCH_YES)
6006	{
6007	found_id = MATCH_YES;
6008	gfc_get_ha_symbol (name, &tmp_sym);
6009	}
6010	else if (gfc_match_common_name (name) == MATCH_YES)
6011	{
6012	found_id = MATCH_YES;
6013	com_block = gfc_get_common (name, 0);
6014	}
6015	else
6016	{
6017	gfc_error ("Need either entity or common block name for "
6018	"attribute specification statement at %C");
6019	return false;
6020	}
6021
6022	/* Save the current identifier and look for more. */
6023	do
6024	{
6025	/* Increment the number of identifiers found for this spec stmt. */
6026	num_idents++;
6027
6028	/* Make sure we have a sym or com block, and verify that it can
6029	be bind(c). Set the appropriate field(s) and look for more
6030	identifiers. */
6031	if (tmp_sym != NULL__null \|\| com_block != NULL__null)
6032	{
6033	if (tmp_sym != NULL__null)
6034	{
6035	if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6036	return false;
6037	}
6038	else
6039	{
6040	if (!set_verify_bind_c_com_block (com_block, num_idents))
6041	return false;
6042	}
6043
6044	/* Look to see if we have another identifier. */
6045	tmp_sym = NULL__null;
6046	if (gfc_match_eos () == MATCH_YES)
6047	found_id = MATCH_NO;
6048	else if (gfc_match_char (',') != MATCH_YES)
6049	found_id = MATCH_NO;
6050	else if (gfc_match_name (name) == MATCH_YES)
6051	{
6052	found_id = MATCH_YES;
6053	gfc_get_ha_symbol (name, &tmp_sym);
6054	}
6055	else if (gfc_match_common_name (name) == MATCH_YES)
6056	{
6057	found_id = MATCH_YES;
6058	com_block = gfc_get_common (name, 0);
6059	}
6060	else
6061	{
6062	gfc_error ("Missing entity or common block name for "
6063	"attribute specification statement at %C");
6064	return false;
6065	}
6066	}
6067	else
6068	{
6069	gfc_internal_error ("Missing symbol");
6070	}
6071	} while (found_id == MATCH_YES);
6072
6073	/* if we get here we were successful */
6074	return true;
6075	}
6076
6077
6078	/* Try and match a BIND(C) attribute specification statement. */
6079
6080	match
6081	gfc_match_bind_c_stmt (void)
6082	{
6083	match found_match = MATCH_NO;
6084	gfc_typespec *ts;
6085
6086	ts = &current_ts;
6087
6088	/* This may not be necessary. */
6089	gfc_clear_ts (ts);
6090	/* Clear the temporary binding label holder. */
6091	curr_binding_label = NULL__null;
6092
6093	/* Look for the bind(c). */
6094	found_match = gfc_match_bind_c (NULL__null, true);
6095
6096	if (found_match == MATCH_YES)
6097	{
6098	if (!gfc_notify_std (GFC_STD_F2003(1<<4), "BIND(C) statement at %C"))
6099	return MATCH_ERROR;
6100
6101	/* Look for the :: now, but it is not required. */
6102	gfc_match (" :: ");
6103
6104	/* Get the identifier(s) that needs to be updated. This may need to
6105	change to hand the flag(s) for the attr specified so all identifiers
6106	found can have all appropriate parts updated (assuming that the same
6107	spec stmt can have multiple attrs, such as both bind(c) and
6108	allocatable...). */
6109	if (!get_bind_c_idents ())
6110	/* Error message should have printed already. */
6111	return MATCH_ERROR;
6112	}
6113
6114	return found_match;
6115	}
6116
6117
6118	/* Match a data declaration statement. */
6119
6120	match
6121	gfc_match_data_decl (void)
6122	{
6123	gfc_symbol *sym;
6124	match m;
6125	int elem;
6126
6127	type_param_spec_list = NULL__null;
6128	decl_type_param_list = NULL__null;
6129
6130	num_idents_on_line = 0;
6131
6132	m = gfc_match_decl_type_spec (&current_ts, 0);
6133	if (m != MATCH_YES)
6134	return m;
6135
6136	if ((current_ts.type == BT_DERIVED \|\| current_ts.type == BT_CLASS)
6137	&& !gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
6138	{
6139	sym = gfc_use_derived (current_ts.u.derived);
6140
6141	if (sym == NULL__null)
6142	{
6143	m = MATCH_ERROR;
6144	goto cleanup;
6145	}
6146
6147	current_ts.u.derived = sym;
6148	}
6149
6150	m = match_attr_spec ();
6151	if (m == MATCH_ERROR)
6152	{
6153	m = MATCH_NO;
6154	goto cleanup;
6155	}
6156
6157	if (current_ts.type == BT_CLASS
6158	&& current_ts.u.derived->attr.unlimited_polymorphic)
6159	goto ok;
6160
6161	if ((current_ts.type == BT_DERIVED \|\| current_ts.type == BT_CLASS)
6162	&& current_ts.u.derived->components == NULL__null
6163	&& !current_ts.u.derived->attr.zero_comp)
6164	{
6165
6166	if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED \|\| ((gfc_state_stack ->state)) == COMP_STRUCTURE \|\| ((gfc_state_stack->state )) == COMP_MAP))
6167	goto ok;
6168
6169	if (current_attr.allocatable && gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED)
6170	goto ok;
6171
6172	gfc_find_symbol (current_ts.u.derived->name,
6173	current_ts.u.derived->ns, 1, &sym);
6174
6175	/* Any symbol that we find had better be a type definition
6176	which has its components defined, or be a structure definition
6177	actively being parsed. */
6178	if (sym != NULL__null && gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED \|\| (sym->attr.flavor) == FL_UNION \|\| (sym->attr.flavor) == FL_STRUCT)
6179	&& (current_ts.u.derived->components != NULL__null
6180	\|\| current_ts.u.derived->attr.zero_comp
6181	\|\| current_ts.u.derived == gfc_new_block))
6182	goto ok;
6183
6184	gfc_error ("Derived type at %C has not been previously defined "
6185	"and so cannot appear in a derived type definition");
6186	m = MATCH_ERROR;
6187	goto cleanup;
6188	}
6189
6190	ok:
6191	/* If we have an old-style character declaration, and no new-style
6192	attribute specifications, then there a comma is optional between
6193	the type specification and the variable list. */
6194	if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6195	gfc_match_char (',');
6196
6197	/* Give the types/attributes to symbols that follow. Give the element
6198	a number so that repeat character length expressions can be copied. */
6199	elem = 1;
6200	for (;;)
6201	{
6202	num_idents_on_line++;
6203	m = variable_decl (elem++);
6204	if (m == MATCH_ERROR)
6205	goto cleanup;
6206	if (m == MATCH_NO)
6207	break;
6208
6209	if (gfc_match_eos () == MATCH_YES)
6210	goto cleanup;
6211	if (gfc_match_char (',') != MATCH_YES)
6212	break;
6213	}
6214
6215	if (!gfc_error_flag_test ())
6216	{
6217	/* An anonymous structure declaration is unambiguous; if we matched one
6218	according to gfc_match_structure_decl, we need to return MATCH_YES
6219	here to avoid confusing the remaining matchers, even if there was an
6220	error during variable_decl. We must flush any such errors. Note this
6221	causes the parser to gracefully continue parsing the remaining input
6222	as a structure body, which likely follows. */
6223	if (current_ts.type == BT_DERIVED && current_ts.u.derived
6224	&& gfc_fl_struct (current_ts.u.derived->attr.flavor)((current_ts.u.derived->attr.flavor) == FL_DERIVED \|\| (current_ts .u.derived->attr.flavor) == FL_UNION \|\| (current_ts.u.derived ->attr.flavor) == FL_STRUCT))
6225	{
6226	gfc_error_now ("Syntax error in anonymous structure declaration"
6227	" at %C");
6228	/* Skip the bad variable_decl and line up for the start of the
6229	structure body. */
6230	gfc_error_recovery ();
6231	m = MATCH_YES;
6232	goto cleanup;
6233	}
6234
6235	gfc_error ("Syntax error in data declaration at %C");
6236	}
6237
6238	m = MATCH_ERROR;
6239
6240	gfc_free_data_all (gfc_current_ns);
6241
6242	cleanup:
6243	if (saved_kind_expr)
6244	gfc_free_expr (saved_kind_expr);
6245	if (type_param_spec_list)
6246	gfc_free_actual_arglist (type_param_spec_list);
6247	if (decl_type_param_list)
6248	gfc_free_actual_arglist (decl_type_param_list);
6249	saved_kind_expr = NULL__null;
6250	gfc_free_array_spec (current_as);
6251	current_as = NULL__null;
6252	return m;
6253	}
6254
6255	static bool
6256	in_module_or_interface(void)
6257	{
6258	if (gfc_current_state ()(gfc_state_stack->state) == COMP_MODULE
6259	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_SUBMODULE
6260	\|\| gfc_current_state ()(gfc_state_stack->state) == COMP_INTERFACE)
6261	return true;
6262
6263	if (gfc_state_stack->state == COMP_CONTAINS
6264	\|\| gfc_state_stack->state == COMP_FUNCTION
6265	\|\| gfc_state_stack->state == COMP_SUBROUTINE)
6266	{
6267	gfc_state_data *p;
6268	for (p = gfc_state_stack->previous; p ; p = p->previous)
6269	{
6270	if (p->state == COMP_MODULE \|\| p->state == COMP_SUBMODULE
6271	\|\| p->state == COMP_INTERFACE)
6272	return true;
6273	}
6274	}
6275	return false;
6276	}
6277
6278	/* Match a prefix associated with a function or subroutine
6279	declaration. If the typespec pointer is nonnull, then a typespec
6280	can be matched. Note that if nothing matches, MATCH_YES is
6281	returned (the null string was matched). */
6282
6283	match
6284	gfc_match_prefix (gfc_typespec *ts)
6285	{
6286	bool seen_type;
6287	bool seen_impure;
6288	bool found_prefix;
6289
6290	gfc_clear_attr (&current_attr);
6291	seen_type = false;
6292	seen_impure = false;
6293
6294	gcc_assert (!gfc_matching_prefix)((void)(!(!gfc_matching_prefix) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 6294, __FUNCTION__), 0 : 0));
6295	gfc_matching_prefix = true;
6296
6297	do
6298	{
6299	found_prefix = false;
6300
6301	/* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6302	corresponding attribute seems natural and distinguishes these
6303	procedures from procedure types of PROC_MODULE, which these are
6304	as well. */
6305	if (gfc_match ("module% ") == MATCH_YES)
6306	{
6307	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "MODULE prefix at %C"))
6308	goto error;
6309
6310	if (!in_module_or_interface ())
6311	{
6312	gfc_error ("MODULE prefix at %C found outside of a module, "
6313	"submodule, or interface");
6314	goto error;
6315	}
6316
6317	current_attr.module_procedure = 1;
6318	found_prefix = true;
6319	}
6320
6321	if (!seen_type && ts != NULL__null)
6322	{
6323	match m;
6324	m = gfc_match_decl_type_spec (ts, 0);
6325	if (m == MATCH_ERROR)
6326	goto error;
6327	if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
6328	{
6329	seen_type = true;
6330	found_prefix = true;
6331	}
6332	}
6333
6334	if (gfc_match ("elemental% ") == MATCH_YES)
6335	{
6336	if (!gfc_add_elemental (&current_attr, NULL__null))
6337	goto error;
6338
6339	found_prefix = true;
6340	}
6341
6342	if (gfc_match ("pure% ") == MATCH_YES)
6343	{
6344	if (!gfc_add_pure (&current_attr, NULL__null))
6345	goto error;
6346
6347	found_prefix = true;
6348	}
6349
6350	if (gfc_match ("recursive% ") == MATCH_YES)
6351	{
6352	if (!gfc_add_recursive (&current_attr, NULL__null))
6353	goto error;
6354
6355	found_prefix = true;
6356	}
6357
6358	/* IMPURE is a somewhat special case, as it needs not set an actual
6359	attribute but rather only prevents ELEMENTAL routines from being
6360	automatically PURE. */
6361	if (gfc_match ("impure% ") == MATCH_YES)
6362	{
6363	if (!gfc_notify_std (GFC_STD_F2008(1<<7), "IMPURE procedure at %C"))
6364	goto error;
6365
6366	seen_impure = true;
6367	found_prefix = true;
6368	}
6369	}
6370	while (found_prefix);
6371
6372	/* IMPURE and PURE must not both appear, of course. */
6373	if (seen_impure && current_attr.pure)
6374	{
6375	gfc_error ("PURE and IMPURE must not appear both at %C");
6376	goto error;
6377	}
6378
6379	/* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6380	if (!seen_impure && current_attr.elemental && !current_attr.pure)
6381	{
6382	if (!gfc_add_pure (&current_attr, NULL__null))
6383	goto error;
6384	}
6385
6386	/* At this point, the next item is not a prefix. */
6387	gcc_assert (gfc_matching_prefix)((void)(!(gfc_matching_prefix) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 6387, __FUNCTION__), 0 : 0));
6388
6389	gfc_matching_prefix = false;
6390	return MATCH_YES;
6391
6392	error:
6393	gcc_assert (gfc_matching_prefix)((void)(!(gfc_matching_prefix) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.c" , 6393, __FUNCTION__), 0 : 0));
6394	gfc_matching_prefix = false;
6395	return MATCH_ERROR;
6396	}
6397
6398
6399	/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6400
6401	static bool
6402	copy_prefix (symbol_attribute dest, locus where)
6403	{
6404	if (dest->module_procedure)
6405	{
6406	if (current_attr.elemental)
6407	dest->elemental = 1;
6408
6409	if (current_attr.pure)
6410	dest->pure = 1;
6411
6412	if (current_attr.recursive)
6413	dest->recursive = 1;
6414
6415	/* Module procedures are unusual in that the 'dest' is copied from
6416	the interface declaration. However, this is an oportunity to
6417	check that the submodule declaration is compliant with the
6418	interface. */
6419	if (dest->elemental && !current_attr.elemental)
6420	{
6421	gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6422	"missing at %L", where);
6423	return false;
6424	}
6425
6426	if (dest->pure && !current_attr.pure)
6427	{
6428	gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6429	"missing at %L", where);
6430	return false;
6431	}
6432
6433	if (dest->recursive && !current_attr.recursive)
6434	{
6435	gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6436	"missing at %L", where);
6437	return false;
6438	}
6439
6440	return true;
6441	}
6442
6443	if (current_attr.elemental && !gfc_add_elemental (dest, where))
6444	return false;
6445
6446	if (current_attr.pure && !gfc_add_pure (dest, where))
6447	return false;
6448
6449	if (current_attr.recursive && !gfc_add_recursive (dest, where))
6450	return false;
6451
6452	return true;
6453	}
6454
6455
6456	/* Match a formal argument list or, if typeparam is true, a
6457	type_param_name_list. */
6458
6459	match
6460	gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6461	int null_flag, bool typeparam)
6462	{
6463	gfc_formal_arglist head, tail, p, q;
6464	char name[GFC_MAX_SYMBOL_LEN63 + 1];
6465	gfc_symbol *sym;
6466	match m;
6467	gfc_formal_arglist *formal = NULL__null;
6468
6469	head = tail = NULL__null;
6470
6471	/* Keep the interface formal argument list and null it so that the
6472	matching for the new declaration can be done. The numbers and
6473	names of the arguments are checked here. The interface formal
6474	arguments are retained in formal_arglist and the characteristics
6475	are compared in resolve.c(resolve_fl_procedure). See the remark
6476	in get_proc_name about the eventual need to copy the formal_arglist
6477	and populate the formal namespace of the interface symbol. */
6478	if (progname->attr.module_procedure
6479	&& progname->attr.host_assoc)
6480	{
6481	formal = progname->formal;
6482	progname->formal = NULL__null;
6483	}
6484
6485	if (gfc_match_char ('(') != MATCH_YES)
6486	{
6487	if (null_flag)
6488	goto ok;
6489	return MATCH_NO;
6490	}
6491
6492	if (gfc_match_char (')') == MATCH_YES)
6493	{
6494	if (typeparam)
6495	{
6496	gfc_error_now ("A type parameter list is required at %C");
6497	m = MATCH_ERROR;
6498	goto cleanup;
6499	}
6500	else
6501	goto ok;
6502	}
6503
6504	for (;;)
6505	{
6506	if (gfc_match_char ('*') == MATCH_YES)
6507	{
6508	sym = NULL__null;
6509	if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS(1<<1),
6510	"Alternate-return argument at %C"))
6511	{
6512	m = MATCH_ERROR;
6513	goto cleanup;
6514	}
6515	else if (typeparam)
6516	gfc_error_now ("A parameter name is required at %C");
6517	}
6518	else
6519	{
6520	m = gfc_match_name (name);
6521	if (m != MATCH_YES)
6522	{
6523	if(typeparam)
6524	gfc_error_now ("A parameter name is required at %C");
6525	goto cleanup;
6526	}
6527
6528	if (!typeparam && gfc_get_symbol (name, NULL__null, &sym))
6529	goto cleanup;
6530	else if (typeparam
6531	&& gfc_get_symbol (name, progname->f2k_derived, &sym))
6532	goto cleanup;
6533	}
6534
6535	p = gfc_get_formal_arglist ()((gfc_formal_arglist *) xcalloc (1, sizeof (gfc_formal_arglist )));
6536
6537	if (head == NULL__null)
6538	head = tail = p;
6539	else
6540	{
6541	tail->next = p;
6542	tail = p;
6543	}
6544
6545	tail->sym = sym;
6546
6547	/* We don't add the VARIABLE flavor because the name could be a
6548	dummy procedure. We don't apply these attributes to formal
6549	arguments of statement functions. */
6550	if (sym != NULL__null && !st_flag
6551	&& (!gfc_add_dummy(&sym->attr, sym->name, NULL__null)
6552	\|\| !gfc_missing_attr (&sym->attr, NULL__null)))
6553	{
6554	m = MATCH_ERROR;
6555	goto cleanup;
6556	}
6557
6558	/* The name of a program unit can be in a different namespace,
6559	so check for it explicitly. After the statement is accepted,
6560	the name is checked for especially in gfc_get_symbol(). */
6561	if (gfc_new_block != NULL__null && sym != NULL__null && !typeparam