1	/* Declaration statement matcher
2	Copyright (C) 2002-2023 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() XCNEW (gfc_data_variable)
36	#define gfc_get_data_value() XCNEW (gfc_data_value)
37	#define gfc_get_data() XCNEW (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;
88
89	/* Pointer of enum history node containing largest initializer. */
90
91	static enumerator_history *max_enum = 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;
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: p->list);
148	free (ptr: 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 (p->repeat);
164	gfc_free_expr (p->expr);
165	free (ptr: 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: p->var);
181	free_value (p: p->value);
182	free (ptr: 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 (ptr: 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 (ptr: 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 ();
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 ();
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);
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 (s: new_var, c: 0, n: sizeof (gfc_data_variable));
282
283	if (gfc_match_char ('(') == MATCH_YES)
284	return var_list (parent: 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)
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 () != COMP_BLOCK_DATA
313	&& sym->attr.in_common
314	&& !gfc_notify_std (GFC_STD_GNU, "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;
335
336	for (;;)
337	{
338	m = var_element (new_var: &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 ();
345	*new_var = var;
346	if (new_var->expr)
347	new_var->expr->where = gfc_current_locus;
348
349	if (tail == 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);
366	gfc_free_data_all (ns: 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_LEN + 1];
375	gfc_symbol *sym, *dt_sym = 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
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
427	&& (*result)->symtree->n.sym->attr.save
428	&& (*result)->symtree->n.sym->attr.target)
429	return m;
430	gfc_free_expr (*result);
431	}
432
433	gfc_current_locus = old_loc;
434
435	m = gfc_match_name (name);
436	if (m != MATCH_YES)
437	return m;
438
439	if (gfc_find_symbol (name, NULL, 1, &sym))
440	return MATCH_ERROR;
441
442	if (sym && sym->attr.generic)
443	dt_sym = gfc_find_dt_in_generic (sym);
444
445	if (sym == NULL
446	|| (sym->attr.flavor != FL_PARAMETER
447	&& (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
448	{
449	gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
450	name);
451	*result = NULL;
452	return MATCH_ERROR;
453	}
454	else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
455	return gfc_match_structure_constructor (dt_sym, result);
456
457	/* Check to see if the value is an initialization array expression. */
458	if (sym->value->expr_type == EXPR_ARRAY)
459	{
460	gfc_current_locus = old_loc;
461
462	m = gfc_match_init_expr (result);
463	if (m == MATCH_ERROR)
464	return m;
465
466	if (m == MATCH_YES)
467	{
468	if (!gfc_simplify_expr (*result, 0))
469	m = MATCH_ERROR;
470
471	if ((*result)->expr_type == EXPR_CONSTANT)
472	return m;
473	else
474	{
475	gfc_error ("Invalid initializer %s in Data statement at %C", name);
476	return MATCH_ERROR;
477	}
478	}
479	}
480
481	*result = gfc_copy_expr (sym->value);
482	return MATCH_YES;
483	}
484
485
486	/* Match a list of values in a DATA statement. The leading '/' has
487	already been seen at this point. */
488
489	static match
490	top_val_list (gfc_data *data)
491	{
492	gfc_data_value *new_val, *tail;
493	gfc_expr *expr;
494	match m;
495
496	tail = NULL;
497
498	for (;;)
499	{
500	m = match_data_constant (result: &expr);
501	if (m == MATCH_NO)
502	goto syntax;
503	if (m == MATCH_ERROR)
504	return MATCH_ERROR;
505
506	new_val = gfc_get_data_value ();
507	mpz_init (new_val->repeat);
508
509	if (tail == NULL)
510	data->value = new_val;
511	else
512	tail->next = new_val;
513
514	tail = new_val;
515
516	if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
517	{
518	tail->expr = expr;
519	mpz_set_ui (tail->repeat, 1);
520	}
521	else
522	{
523	mpz_set (tail->repeat, expr->value.integer);
524	gfc_free_expr (expr);
525
526	m = match_data_constant (result: &tail->expr);
527	if (m == MATCH_NO)
528	goto syntax;
529	if (m == MATCH_ERROR)
530	return MATCH_ERROR;
531	}
532
533	if (gfc_match_char ('/') == MATCH_YES)
534	break;
535	if (gfc_match_char (',') == MATCH_NO)
536	goto syntax;
537	}
538
539	return MATCH_YES;
540
541	syntax:
542	gfc_syntax_error (ST_DATA);
543	gfc_free_data_all (ns: gfc_current_ns);
544	return MATCH_ERROR;
545	}
546
547
548	/* Matches an old style initialization. */
549
550	static match
551	match_old_style_init (const char *name)
552	{
553	match m;
554	gfc_symtree *st;
555	gfc_symbol *sym;
556	gfc_data *newdata, *nd;
557
558	/* Set up data structure to hold initializers. */
559	gfc_find_sym_tree (name, NULL, 0, &st);
560	sym = st->n.sym;
561
562	newdata = gfc_get_data ();
563	newdata->var = gfc_get_data_variable ();
564	newdata->var->expr = gfc_get_variable_expr (st);
565	newdata->var->expr->where = sym->declared_at;
566	newdata->where = gfc_current_locus;
567
568	/* Match initial value list. This also eats the terminal '/'. */
569	m = top_val_list (data: newdata);
570	if (m != MATCH_YES)
571	{
572	free (ptr: newdata);
573	return m;
574	}
575
576	/* Check that a BOZ did not creep into an old-style initialization. */
577	for (nd = newdata; nd; nd = nd->next)
578	{
579	if (nd->value->expr->ts.type == BT_BOZ
580	&& gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
581	"initialization"), &nd->value->expr->where))
582	return MATCH_ERROR;
583
584	if (nd->var->expr->ts.type != BT_INTEGER
585	&& nd->var->expr->ts.type != BT_REAL
586	&& nd->value->expr->ts.type == BT_BOZ)
587	{
588	gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
589	"a %qs variable in an old-style initialization"),
590	&nd->value->expr->where,
591	gfc_typename (&nd->value->expr->ts));
592	return MATCH_ERROR;
593	}
594	}
595
596	if (gfc_pure (NULL))
597	{
598	gfc_error ("Initialization at %C is not allowed in a PURE procedure");
599	free (ptr: newdata);
600	return MATCH_ERROR;
601	}
602	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
603
604	/* Mark the variable as having appeared in a data statement. */
605	if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
606	{
607	free (ptr: newdata);
608	return MATCH_ERROR;
609	}
610
611	/* Chain in namespace list of DATA initializers. */
612	newdata->next = gfc_current_ns->data;
613	gfc_current_ns->data = newdata;
614
615	return m;
616	}
617
618
619	/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
620	we are matching a DATA statement and are therefore issuing an error
621	if we encounter something unexpected, if not, we're trying to match
622	an old-style initialization expression of the form INTEGER I /2/. */
623
624	match
625	gfc_match_data (void)
626	{
627	gfc_data *new_data;
628	gfc_expr *e;
629	gfc_ref *ref;
630	match m;
631	char c;
632
633	/* DATA has been matched. In free form source code, the next character
634	needs to be whitespace or '(' from an implied do-loop. Check that
635	here. */
636	c = gfc_peek_ascii_char ();
637	if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
638	return MATCH_NO;
639
640	/* Before parsing the rest of a DATA statement, check F2008:c1206. */
641	if ((gfc_current_state () == COMP_FUNCTION
642	|| gfc_current_state () == COMP_SUBROUTINE)
643	&& gfc_state_stack->previous->state == COMP_INTERFACE)
644	{
645	gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
646	return MATCH_ERROR;
647	}
648
649	set_in_match_data (true);
650
651	for (;;)
652	{
653	new_data = gfc_get_data ();
654	new_data->where = gfc_current_locus;
655
656	m = top_var_list (d: new_data);
657	if (m != MATCH_YES)
658	goto cleanup;
659
660	if (new_data->var->iter.var
661	&& new_data->var->iter.var->ts.type == BT_INTEGER
662	&& new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
663	&& new_data->var->list
664	&& new_data->var->list->expr
665	&& new_data->var->list->expr->ts.type == BT_CHARACTER
666	&& new_data->var->list->expr->ref
667	&& new_data->var->list->expr->ref->type == REF_SUBSTRING)
668	{
669	gfc_error ("Invalid substring in data-implied-do at %L in DATA "
670	"statement", &new_data->var->list->expr->where);
671	goto cleanup;
672	}
673
674	/* Check for an entity with an allocatable component, which is not
675	allowed. */
676	e = new_data->var->expr;
677	if (e)
678	{
679	bool invalid;
680
681	invalid = false;
682	for (ref = e->ref; ref; ref = ref->next)
683	if ((ref->type == REF_COMPONENT
684	&& ref->u.c.component->attr.allocatable)
685	|| (ref->type == REF_ARRAY
686	&& e->symtree->n.sym->attr.pointer != 1
687	&& ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
688	invalid = true;
689
690	if (invalid)
691	{
692	gfc_error ("Allocatable component or deferred-shaped array "
693	"near %C in DATA statement");
694	goto cleanup;
695	}
696
697	/* F2008:C567 (R536) A data-i-do-object or a variable that appears
698	as a data-stmt-object shall not be an object designator in which
699	a pointer appears other than as the entire rightmost part-ref. */
700	if (!e->ref && e->ts.type == BT_DERIVED
701	&& e->symtree->n.sym->attr.pointer)
702	goto partref;
703
704	ref = e->ref;
705	if (e->symtree->n.sym->ts.type == BT_DERIVED
706	&& e->symtree->n.sym->attr.pointer
707	&& ref->type == REF_COMPONENT)
708	goto partref;
709
710	for (; ref; ref = ref->next)
711	if (ref->type == REF_COMPONENT
712	&& ref->u.c.component->attr.pointer
713	&& ref->next)
714	goto partref;
715	}
716
717	m = top_val_list (data: new_data);
718	if (m != MATCH_YES)
719	goto cleanup;
720
721	new_data->next = gfc_current_ns->data;
722	gfc_current_ns->data = new_data;
723
724	/* A BOZ literal constant cannot appear in a structure constructor.
725	Check for that here for a data statement value. */
726	if (new_data->value->expr->ts.type == BT_DERIVED
727	&& new_data->value->expr->value.constructor)
728	{
729	gfc_constructor *c;
730	c = gfc_constructor_first (base: new_data->value->expr->value.constructor);
731	for (; c; c = gfc_constructor_next (ctor: c))
732	if (c->expr && c->expr->ts.type == BT_BOZ)
733	{
734	gfc_error ("BOZ literal constant at %L cannot appear in a "
735	"structure constructor", &c->expr->where);
736	return MATCH_ERROR;
737	}
738	}
739
740	if (gfc_match_eos () == MATCH_YES)
741	break;
742
743	gfc_match_char (','); /* Optional comma */
744	}
745
746	set_in_match_data (false);
747
748	if (gfc_pure (NULL))
749	{
750	gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
751	return MATCH_ERROR;
752	}
753	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
754
755	return MATCH_YES;
756
757	partref:
758
759	gfc_error ("part-ref with pointer attribute near %L is not "
760	"rightmost part-ref of data-stmt-object",
761	&e->where);
762
763	cleanup:
764	set_in_match_data (false);
765	gfc_free_data (p: new_data);
766	return MATCH_ERROR;
767	}
768
769
770	/************************ Declaration statements *********************/
771
772
773	/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
774	list). The difference here is the expression is a list of constants
775	and is surrounded by '/'.
776	The typespec ts must match the typespec of the variable which the
777	clist is initializing.
778	The arrayspec tells whether this should match a list of constants
779	corresponding to array elements or a scalar (as == NULL). */
780
781	static match
782	match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
783	{
784	gfc_constructor_base array_head = NULL;
785	gfc_expr *expr = NULL;
786	match m = MATCH_ERROR;
787	locus where;
788	mpz_t repeat, cons_size, as_size;
789	bool scalar;
790	int cmp;
791
792	gcc_assert (ts);
793
794	/* We have already matched '/' - now look for a constant list, as with
795	top_val_list from decl.cc, but append the result to an array. */
796	if (gfc_match ("/") == MATCH_YES)
797	{
798	gfc_error ("Empty old style initializer list at %C");
799	return MATCH_ERROR;
800	}
801
802	where = gfc_current_locus;
803	scalar = !as || !as->rank;
804
805	if (!scalar && !spec_size (as, &as_size))
806	{
807	gfc_error ("Array in initializer list at %L must have an explicit shape",
808	as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
809	/* Nothing to cleanup yet. */
810	return MATCH_ERROR;
811	}
812
813	mpz_init_set_ui (repeat, 0);
814
815	for (;;)
816	{
817	m = match_data_constant (result: &expr);
818	if (m != MATCH_YES)
819	expr = NULL; /* match_data_constant may set expr to garbage */
820	if (m == MATCH_NO)
821	goto syntax;
822	if (m == MATCH_ERROR)
823	goto cleanup;
824
825	/* Found r in repeat spec r*c; look for the constant to repeat. */
826	if ( gfc_match_char ('*') == MATCH_YES)
827	{
828	if (scalar)
829	{
830	gfc_error ("Repeat spec invalid in scalar initializer at %C");
831	goto cleanup;
832	}
833	if (expr->ts.type != BT_INTEGER)
834	{
835	gfc_error ("Repeat spec must be an integer at %C");
836	goto cleanup;
837	}
838	mpz_set (repeat, expr->value.integer);
839	gfc_free_expr (expr);
840	expr = NULL;
841
842	m = match_data_constant (result: &expr);
843	if (m == MATCH_NO)
844	{
845	m = MATCH_ERROR;
846	gfc_error ("Expected data constant after repeat spec at %C");
847	}
848	if (m != MATCH_YES)
849	goto cleanup;
850	}
851	/* No repeat spec, we matched the data constant itself. */
852	else
853	mpz_set_ui (repeat, 1);
854
855	if (!scalar)
856	{
857	/* Add the constant initializer as many times as repeated. */
858	for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
859	{
860	/* Make sure types of elements match */
861	if(ts && !gfc_compare_types (&expr->ts, ts)
862	&& !gfc_convert_type (expr, ts, 1))
863	goto cleanup;
864
865	gfc_constructor_append_expr (base: &array_head,
866	e: gfc_copy_expr (expr), where: &gfc_current_locus);
867	}
868
869	gfc_free_expr (expr);
870	expr = NULL;
871	}
872
873	/* For scalar initializers quit after one element. */
874	else
875	{
876	if(gfc_match_char ('/') != MATCH_YES)
877	{
878	gfc_error ("End of scalar initializer expected at %C");
879	goto cleanup;
880	}
881	break;
882	}
883
884	if (gfc_match_char ('/') == MATCH_YES)
885	break;
886	if (gfc_match_char (',') == MATCH_NO)
887	goto syntax;
888	}
889
890	/* If we break early from here out, we encountered an error. */
891	m = MATCH_ERROR;
892
893	/* Set up expr as an array constructor. */
894	if (!scalar)
895	{
896	expr = gfc_get_array_expr (type: ts->type, kind: ts->kind, &where);
897	expr->ts = *ts;
898	expr->value.constructor = array_head;
899
900	/* Validate sizes. We built expr ourselves, so cons_size will be
901	constant (we fail above for non-constant expressions).
902	We still need to verify that the sizes match. */
903	gcc_assert (gfc_array_size (expr, &cons_size));
904	cmp = mpz_cmp (cons_size, as_size);
905	if (cmp < 0)
906	gfc_error ("Not enough elements in array initializer at %C");
907	else if (cmp > 0)
908	gfc_error ("Too many elements in array initializer at %C");
909	mpz_clear (cons_size);
910	if (cmp)
911	goto cleanup;
912
913	/* Set the rank/shape to match the LHS as auto-reshape is implied. */
914	expr->rank = as->rank;
915	expr->shape = gfc_get_shape (as->rank);
916	for (int i = 0; i < as->rank; ++i)
917	spec_dimen_size (as, i, &expr->shape[i]);
918	}
919
920	/* Make sure scalar types match. */
921	else if (!gfc_compare_types (&expr->ts, ts)
922	&& !gfc_convert_type (expr, ts, 1))
923	goto cleanup;
924
925	if (expr->ts.u.cl)
926	expr->ts.u.cl->length_from_typespec = 1;
927
928	*result = expr;
929	m = MATCH_YES;
930	goto done;
931
932	syntax:
933	m = MATCH_ERROR;
934	gfc_error ("Syntax error in old style initializer list at %C");
935
936	cleanup:
937	if (expr)
938	expr->value.constructor = NULL;
939	gfc_free_expr (expr);
940	gfc_constructor_free (base: array_head);
941
942	done:
943	mpz_clear (repeat);
944	if (!scalar)
945	mpz_clear (as_size);
946	return m;
947	}
948
949
950	/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
951
952	static bool
953	merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
954	{
955	if ((from->type == AS_ASSUMED_RANK && to->corank)
956	|| (to->type == AS_ASSUMED_RANK && from->corank))
957	{
958	gfc_error ("The assumed-rank array at %C shall not have a codimension");
959	return false;
960	}
961
962	if (to->rank == 0 && from->rank > 0)
963	{
964	to->rank = from->rank;
965	to->type = from->type;
966	to->cray_pointee = from->cray_pointee;
967	to->cp_was_assumed = from->cp_was_assumed;
968
969	for (int i = to->corank - 1; i >= 0; i--)
970	{
971	/* Do not exceed the limits on lower[] and upper[]. gfortran
972	cleans up elsewhere. */
973	int j = from->rank + i;
974	if (j >= GFC_MAX_DIMENSIONS)
975	break;
976
977	to->lower[j] = to->lower[i];
978	to->upper[j] = to->upper[i];
979	}
980	for (int i = 0; i < from->rank; i++)
981	{
982	if (copy)
983	{
984	to->lower[i] = gfc_copy_expr (from->lower[i]);
985	to->upper[i] = gfc_copy_expr (from->upper[i]);
986	}
987	else
988	{
989	to->lower[i] = from->lower[i];
990	to->upper[i] = from->upper[i];
991	}
992	}
993	}
994	else if (to->corank == 0 && from->corank > 0)
995	{
996	to->corank = from->corank;
997	to->cotype = from->cotype;
998
999	for (int i = 0; i < from->corank; i++)
1000	{
1001	/* Do not exceed the limits on lower[] and upper[]. gfortran
1002	cleans up elsewhere. */
1003	int k = from->rank + i;
1004	int j = to->rank + i;
1005	if (j >= GFC_MAX_DIMENSIONS)
1006	break;
1007
1008	if (copy)
1009	{
1010	to->lower[j] = gfc_copy_expr (from->lower[k]);
1011	to->upper[j] = gfc_copy_expr (from->upper[k]);
1012	}
1013	else
1014	{
1015	to->lower[j] = from->lower[k];
1016	to->upper[j] = from->upper[k];
1017	}
1018	}
1019	}
1020
1021	if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1022	{
1023	gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1024	"allowed dimensions of %d",
1025	to->rank, to->corank, GFC_MAX_DIMENSIONS);
1026	to->corank = GFC_MAX_DIMENSIONS - to->rank;
1027	return false;
1028	}
1029	return true;
1030	}
1031
1032
1033	/* Match an intent specification. Since this can only happen after an
1034	INTENT word, a legal intent-spec must follow. */
1035
1036	static sym_intent
1037	match_intent_spec (void)
1038	{
1039
1040	if (gfc_match (" ( in out )") == MATCH_YES)
1041	return INTENT_INOUT;
1042	if (gfc_match (" ( in )") == MATCH_YES)
1043	return INTENT_IN;
1044	if (gfc_match (" ( out )") == MATCH_YES)
1045	return INTENT_OUT;
1046
1047	gfc_error ("Bad INTENT specification at %C");
1048	return INTENT_UNKNOWN;
1049	}
1050
1051
1052	/* Matches a character length specification, which is either a
1053	specification expression, '*', or ':'. */
1054
1055	static match
1056	char_len_param_value (gfc_expr **expr, bool *deferred)
1057	{
1058	match m;
1059	gfc_expr *p;
1060
1061	*expr = NULL;
1062	*deferred = false;
1063
1064	if (gfc_match_char ('*') == MATCH_YES)
1065	return MATCH_YES;
1066
1067	if (gfc_match_char (':') == MATCH_YES)
1068	{
1069	if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1070	return MATCH_ERROR;
1071
1072	*deferred = true;
1073
1074	return MATCH_YES;
1075	}
1076
1077	m = gfc_match_expr (expr);
1078
1079	if (m == MATCH_NO || m == MATCH_ERROR)
1080	return m;
1081
1082	if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1083	return MATCH_ERROR;
1084
1085	/* Try to simplify the expression to catch things like CHARACTER(([1])). */
1086	p = gfc_copy_expr (*expr);
1087	if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1088	gfc_replace_expr (*expr, p);
1089	else
1090	gfc_free_expr (p);
1091
1092	if ((*expr)->expr_type == EXPR_FUNCTION)
1093	{
1094	if ((*expr)->ts.type == BT_INTEGER
1095	|| ((*expr)->ts.type == BT_UNKNOWN
1096	&& strcmp(s1: (*expr)->symtree->name, s2: "null") != 0))
1097	return MATCH_YES;
1098
1099	goto syntax;
1100	}
1101	else if ((*expr)->expr_type == EXPR_CONSTANT)
1102	{
1103	/* F2008, 4.4.3.1: The length is a type parameter; its kind is
1104	processor dependent and its value is greater than or equal to zero.
1105	F2008, 4.4.3.2: If the character length parameter value evaluates
1106	to a negative value, the length of character entities declared
1107	is zero. */
1108
1109	if ((*expr)->ts.type == BT_INTEGER)
1110	{
1111	if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1112	mpz_set_si ((*expr)->value.integer, 0);
1113	}
1114	else
1115	goto syntax;
1116	}
1117	else if ((*expr)->expr_type == EXPR_ARRAY)
1118	goto syntax;
1119	else if ((*expr)->expr_type == EXPR_VARIABLE)
1120	{
1121	bool t;
1122	gfc_expr *e;
1123
1124	e = gfc_copy_expr (*expr);
1125
1126	/* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1127	which causes an ICE if gfc_reduce_init_expr() is called. */
1128	if (e->ref && e->ref->type == REF_ARRAY
1129	&& e->ref->u.ar.type == AR_UNKNOWN
1130	&& e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1131	goto syntax;
1132
1133	t = gfc_reduce_init_expr (expr: e);
1134
1135	if (!t && e->ts.type == BT_UNKNOWN
1136	&& e->symtree->n.sym->attr.untyped == 1
1137	&& (flag_implicit_none
1138	|| e->symtree->n.sym->ns->seen_implicit_none == 1
1139	|| e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1140	{
1141	gfc_free_expr (e);
1142	goto syntax;
1143	}
1144
1145	if ((e->ref && e->ref->type == REF_ARRAY
1146	&& e->ref->u.ar.type != AR_ELEMENT)
1147	|| (!e->ref && e->expr_type == EXPR_ARRAY))
1148	{
1149	gfc_free_expr (e);
1150	goto syntax;
1151	}
1152
1153	gfc_free_expr (e);
1154	}
1155
1156	if (gfc_seen_div0)
1157	m = MATCH_ERROR;
1158
1159	return m;
1160
1161	syntax:
1162	gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1163	return MATCH_ERROR;
1164	}
1165
1166
1167	/* A character length is a '*' followed by a literal integer or a
1168	char_len_param_value in parenthesis. */
1169
1170	static match
1171	match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1172	{
1173	int length;
1174	match m;
1175
1176	*deferred = false;
1177	m = gfc_match_char ('*');
1178	if (m != MATCH_YES)
1179	return m;
1180
1181	m = gfc_match_small_literal_int (&length, NULL);
1182	if (m == MATCH_ERROR)
1183	return m;
1184
1185	if (m == MATCH_YES)
1186	{
1187	if (obsolescent_check
1188	&& !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1189	return MATCH_ERROR;
1190	*expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1191	return m;
1192	}
1193
1194	if (gfc_match_char ('(') == MATCH_NO)
1195	goto syntax;
1196
1197	m = char_len_param_value (expr, deferred);
1198	if (m != MATCH_YES && gfc_matching_function)
1199	{
1200	gfc_undo_symbols ();
1201	m = MATCH_YES;
1202	}
1203
1204	if (m == MATCH_ERROR)
1205	return m;
1206	if (m == MATCH_NO)
1207	goto syntax;
1208
1209	if (gfc_match_char (')') == MATCH_NO)
1210	{
1211	gfc_free_expr (*expr);
1212	*expr = NULL;
1213	goto syntax;
1214	}
1215
1216	return MATCH_YES;
1217
1218	syntax:
1219	gfc_error ("Syntax error in character length specification at %C");
1220	return MATCH_ERROR;
1221	}
1222
1223
1224	/* Special subroutine for finding a symbol. Check if the name is found
1225	in the current name space. If not, and we're compiling a function or
1226	subroutine and the parent compilation unit is an interface, then check
1227	to see if the name we've been given is the name of the interface
1228	(located in another namespace). */
1229
1230	static int
1231	find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1232	{
1233	gfc_state_data *s;
1234	gfc_symtree *st;
1235	int i;
1236
1237	i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1238	if (i == 0)
1239	{
1240	*result = st ? st->n.sym : NULL;
1241	goto end;
1242	}
1243
1244	if (gfc_current_state () != COMP_SUBROUTINE
1245	&& gfc_current_state () != COMP_FUNCTION)
1246	goto end;
1247
1248	s = gfc_state_stack->previous;
1249	if (s == NULL)
1250	goto end;
1251
1252	if (s->state != COMP_INTERFACE)
1253	goto end;
1254	if (s->sym == NULL)
1255	goto end; /* Nameless interface. */
1256
1257	if (strcmp (s1: name, s2: s->sym->name) == 0)
1258	{
1259	*result = s->sym;
1260	return 0;
1261	}
1262
1263	end:
1264	return i;
1265	}
1266
1267
1268	/* Special subroutine for getting a symbol node associated with a
1269	procedure name, used in SUBROUTINE and FUNCTION statements. The
1270	symbol is created in the parent using with symtree node in the
1271	child unit pointing to the symbol. If the current namespace has no
1272	parent, then the symbol is just created in the current unit. */
1273
1274	static int
1275	get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1276	{
1277	gfc_symtree *st;
1278	gfc_symbol *sym;
1279	int rc = 0;
1280
1281	/* Module functions have to be left in their own namespace because
1282	they have potentially (almost certainly!) already been referenced.
1283	In this sense, they are rather like external functions. This is
1284	fixed up in resolve.cc(resolve_entries), where the symbol name-
1285	space is set to point to the master function, so that the fake
1286	result mechanism can work. */
1287	if (module_fcn_entry)
1288	{
1289	/* Present if entry is declared to be a module procedure. */
1290	rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1291
1292	if (*result == NULL)
1293	rc = gfc_get_symbol (name, NULL, result);
1294	else if (!gfc_get_symbol (name, NULL, &sym) && sym
1295	&& (*result)->ts.type == BT_UNKNOWN
1296	&& sym->attr.flavor == FL_UNKNOWN)
1297	/* Pick up the typespec for the entry, if declared in the function
1298	body. Note that this symbol is FL_UNKNOWN because it will
1299	only have appeared in a type declaration. The local symtree
1300	is set to point to the module symbol and a unique symtree
1301	to the local version. This latter ensures a correct clearing
1302	of the symbols. */
1303	{
1304	/* If the ENTRY proceeds its specification, we need to ensure
1305	that this does not raise a "has no IMPLICIT type" error. */
1306	if (sym->ts.type == BT_UNKNOWN)
1307	sym->attr.untyped = 1;
1308
1309	(*result)->ts = sym->ts;
1310
1311	/* Put the symbol in the procedure namespace so that, should
1312	the ENTRY precede its specification, the specification
1313	can be applied. */
1314	(*result)->ns = gfc_current_ns;
1315
1316	gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1317	st->n.sym = *result;
1318	st = gfc_get_unique_symtree (gfc_current_ns);
1319	sym->refs++;
1320	st->n.sym = sym;
1321	}
1322	}
1323	else
1324	rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1325
1326	if (rc)
1327	return rc;
1328
1329	sym = *result;
1330	if (sym->attr.proc == PROC_ST_FUNCTION)
1331	return rc;
1332
1333	if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1334	{
1335	/* Create a partially populated interface symbol to carry the
1336	characteristics of the procedure and the result. */
1337	sym->tlink = gfc_new_symbol (name, sym->ns);
1338	gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1339	gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1340	if (sym->attr.dimension)
1341	sym->tlink->as = gfc_copy_array_spec (sym->as);
1342
1343	/* Ideally, at this point, a copy would be made of the formal
1344	arguments and their namespace. However, this does not appear
1345	to be necessary, albeit at the expense of not being able to
1346	use gfc_compare_interfaces directly. */
1347
1348	if (sym->result && sym->result != sym)
1349	{
1350	sym->tlink->result = sym->result;
1351	sym->result = NULL;
1352	}
1353	else if (sym->result)
1354	{
1355	sym->tlink->result = sym->tlink;
1356	}
1357	}
1358	else if (sym && !sym->gfc_new
1359	&& gfc_current_state () != COMP_INTERFACE)
1360	{
1361	/* Trap another encompassed procedure with the same name. All
1362	these conditions are necessary to avoid picking up an entry
1363	whose name clashes with that of the encompassing procedure;
1364	this is handled using gsymbols to register unique, globally
1365	accessible names. */
1366	if (sym->attr.flavor != 0
1367	&& sym->attr.proc != 0
1368	&& (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1369	&& 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	if (sym->attr.flavor != 0
1376	&& sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1377	{
1378	gfc_error_now ("Procedure %qs at %C is already defined at %L",
1379	name, &sym->declared_at);
1380	return true;
1381	}
1382
1383	if (sym->attr.external && sym->attr.procedure
1384	&& gfc_current_state () == COMP_CONTAINS)
1385	{
1386	gfc_error_now ("Contained procedure %qs at %C clashes with "
1387	"procedure defined at %L",
1388	name, &sym->declared_at);
1389	return true;
1390	}
1391
1392	/* Trap a procedure with a name the same as interface in the
1393	encompassing scope. */
1394	if (sym->attr.generic != 0
1395	&& (sym->attr.subroutine || sym->attr.function)
1396	&& !sym->attr.mod_proc)
1397	{
1398	gfc_error_now ("Name %qs at %C is already defined"
1399	" as a generic interface at %L",
1400	name, &sym->declared_at);
1401	return true;
1402	}
1403
1404	/* Trap declarations of attributes in encompassing scope. The
1405	signature for this is that ts.kind is nonzero for no-CLASS
1406	entity. For a CLASS entity, ts.kind is zero. */
1407	if ((sym->ts.kind != 0
1408	|| sym->ts.type == BT_CLASS
1409	|| sym->ts.type == BT_DERIVED)
1410	&& !sym->attr.implicit_type
1411	&& sym->attr.proc == 0
1412	&& gfc_current_ns->parent != NULL
1413	&& sym->attr.access == 0
1414	&& !module_fcn_entry)
1415	{
1416	gfc_error_now ("Procedure %qs at %C has an explicit interface "
1417	"from a previous declaration", name);
1418	return true;
1419	}
1420	}
1421
1422	/* C1246 (R1225) MODULE shall appear only in the function-stmt or
1423	subroutine-stmt of a module subprogram or of a nonabstract interface
1424	body that is declared in the scoping unit of a module or submodule. */
1425	if (sym->attr.external
1426	&& (sym->attr.subroutine || sym->attr.function)
1427	&& sym->attr.if_source == IFSRC_IFBODY
1428	&& !current_attr.module_procedure
1429	&& sym->attr.proc == PROC_MODULE
1430	&& gfc_state_stack->state == COMP_CONTAINS)
1431	{
1432	gfc_error_now ("Procedure %qs defined in interface body at %L "
1433	"clashes with internal procedure defined at %C",
1434	name, &sym->declared_at);
1435	return true;
1436	}
1437
1438	if (sym && !sym->gfc_new
1439	&& sym->attr.flavor != FL_UNKNOWN
1440	&& sym->attr.referenced == 0 && sym->attr.subroutine == 1
1441	&& gfc_state_stack->state == COMP_CONTAINS
1442	&& gfc_state_stack->previous->state == COMP_SUBROUTINE)
1443	{
1444	gfc_error_now ("Procedure %qs at %C is already defined at %L",
1445	name, &sym->declared_at);
1446	return true;
1447	}
1448
1449	if (gfc_current_ns->parent == NULL || *result == NULL)
1450	return rc;
1451
1452	/* Module function entries will already have a symtree in
1453	the current namespace but will need one at module level. */
1454	if (module_fcn_entry)
1455	{
1456	/* Present if entry is declared to be a module procedure. */
1457	rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1458	if (st == NULL)
1459	st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1460	}
1461	else
1462	st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1463
1464	st->n.sym = sym;
1465	sym->refs++;
1466
1467	/* See if the procedure should be a module procedure. */
1468
1469	if (((sym->ns->proc_name != NULL
1470	&& sym->ns->proc_name->attr.flavor == FL_MODULE
1471	&& sym->attr.proc != PROC_MODULE)
1472	|| (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1473	&& !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1474	rc = 2;
1475
1476	return rc;
1477	}
1478
1479
1480	/* Verify that the given symbol representing a parameter is C
1481	interoperable, by checking to see if it was marked as such after
1482	its declaration. If the given symbol is not interoperable, a
1483	warning is reported, thus removing the need to return the status to
1484	the calling function. The standard does not require the user use
1485	one of the iso_c_binding named constants to declare an
1486	interoperable parameter, but we can't be sure if the param is C
1487	interop or not if the user doesn't. For example, integer(4) may be
1488	legal Fortran, but doesn't have meaning in C. It may interop with
1489	a number of the C types, which causes a problem because the
1490	compiler can't know which one. This code is almost certainly not
1491	portable, and the user will get what they deserve if the C type
1492	across platforms isn't always interoperable with integer(4). If
1493	the user had used something like integer(c_int) or integer(c_long),
1494	the compiler could have automatically handled the varying sizes
1495	across platforms. */
1496
1497	bool
1498	gfc_verify_c_interop_param (gfc_symbol *sym)
1499	{
1500	int is_c_interop = 0;
1501	bool retval = true;
1502
1503	/* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1504	Don't repeat the checks here. */
1505	if (sym->attr.implicit_type)
1506	return true;
1507
1508	/* For subroutines or functions that are passed to a BIND(C) procedure,
1509	they're interoperable if they're BIND(C) and their params are all
1510	interoperable. */
1511	if (sym->attr.flavor == FL_PROCEDURE)
1512	{
1513	if (sym->attr.is_bind_c == 0)
1514	{
1515	gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1516	"attribute to be C interoperable", sym->name,
1517	&(sym->declared_at));
1518	return false;
1519	}
1520	else
1521	{
1522	if (sym->attr.is_c_interop == 1)
1523	/* We've already checked this procedure; don't check it again. */
1524	return true;
1525	else
1526	return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1527	sym->common_block);
1528	}
1529	}
1530
1531	/* See if we've stored a reference to a procedure that owns sym. */
1532	if (sym->ns != NULL && sym->ns->proc_name != NULL)
1533	{
1534	if (sym->ns->proc_name->attr.is_bind_c == 1)
1535	{
1536	is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1537
1538	if (is_c_interop != 1)
1539	{
1540	/* Make personalized messages to give better feedback. */
1541	if (sym->ts.type == BT_DERIVED)
1542	gfc_error ("Variable %qs at %L is a dummy argument to the "
1543	"BIND(C) procedure %qs but is not C interoperable "
1544	"because derived type %qs is not C interoperable",
1545	sym->name, &(sym->declared_at),
1546	sym->ns->proc_name->name,
1547	sym->ts.u.derived->name);
1548	else if (sym->ts.type == BT_CLASS)
1549	gfc_error ("Variable %qs at %L is a dummy argument to the "
1550	"BIND(C) procedure %qs but is not C interoperable "
1551	"because it is polymorphic",
1552	sym->name, &(sym->declared_at),
1553	sym->ns->proc_name->name);
1554	else if (warn_c_binding_type)
1555	gfc_warning (opt: OPT_Wc_binding_type,
1556	"Variable %qs at %L is a dummy argument of the "
1557	"BIND(C) procedure %qs but may not be C "
1558	"interoperable",
1559	sym->name, &(sym->declared_at),
1560	sym->ns->proc_name->name);
1561	}
1562
1563	/* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1564	if (sym->attr.pointer && sym->attr.contiguous)
1565	gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1566	"CONTIGUOUS attribute as procedure %qs is BIND(C)",
1567	sym->name, &sym->declared_at, sym->ns->proc_name->name);
1568
1569	/* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1570	procedure that are default-initialized are not permitted. */
1571	if ((sym->attr.pointer || sym->attr.allocatable)
1572	&& sym->ts.type == BT_DERIVED
1573	&& gfc_has_default_initializer (sym->ts.u.derived))
1574	{
1575	gfc_error ("Default-initialized %s dummy argument %qs "
1576	"at %L is not permitted in BIND(C) procedure %qs",
1577	(sym->attr.pointer ? "pointer" : "allocatable"),
1578	sym->name, &sym->declared_at,
1579	sym->ns->proc_name->name);
1580	retval = false;
1581	}
1582
1583	/* Character strings are only C interoperable if they have a
1584	length of 1. However, as an argument they are also interoperable
1585	when passed as descriptor (which requires len=: or len=*). */
1586	if (sym->ts.type == BT_CHARACTER)
1587	{
1588	gfc_charlen *cl = sym->ts.u.cl;
1589
1590	if (sym->attr.allocatable || sym->attr.pointer)
1591	{
1592	/* F2018, 18.3.6 (6). */
1593	if (!sym->ts.deferred)
1594	{
1595	if (sym->attr.allocatable)
1596	gfc_error ("Allocatable character dummy argument %qs "
1597	"at %L must have deferred length as "
1598	"procedure %qs is BIND(C)", sym->name,
1599	&sym->declared_at, sym->ns->proc_name->name);
1600	else
1601	gfc_error ("Pointer character dummy argument %qs at %L "
1602	"must have deferred length as procedure %qs "
1603	"is BIND(C)", sym->name, &sym->declared_at,
1604	sym->ns->proc_name->name);
1605	retval = false;
1606	}
1607	else if (!gfc_notify_std (GFC_STD_F2018,
1608	"Deferred-length character dummy "
1609	"argument %qs at %L of procedure "
1610	"%qs with BIND(C) attribute",
1611	sym->name, &sym->declared_at,
1612	sym->ns->proc_name->name))
1613	retval = false;
1614	}
1615	else if (sym->attr.value
1616	&& (!cl || !cl->length
1617	|| cl->length->expr_type != EXPR_CONSTANT
1618	|| mpz_cmp_si (cl->length->value.integer, 1) != 0))
1619	{
1620	gfc_error ("Character dummy argument %qs at %L must be "
1621	"of length 1 as it has the VALUE attribute",
1622	sym->name, &sym->declared_at);
1623	retval = false;
1624	}
1625	else if (!cl || !cl->length)
1626	{
1627	/* Assumed length; F2018, 18.3.6 (5)(2).
1628	Uses the CFI array descriptor - also for scalars and
1629	explicit-size/assumed-size arrays. */
1630	if (!gfc_notify_std (GFC_STD_F2018,
1631	"Assumed-length character dummy argument "
1632	"%qs at %L of procedure %qs with BIND(C) "
1633	"attribute", sym->name, &sym->declared_at,
1634	sym->ns->proc_name->name))
1635	retval = false;
1636	}
1637	else if (cl->length->expr_type != EXPR_CONSTANT
1638	|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
1639	{
1640	/* F2018, 18.3.6, (5), item 4. */
1641	if (!sym->attr.dimension
1642	|| sym->as->type == AS_ASSUMED_SIZE
1643	|| sym->as->type == AS_EXPLICIT)
1644	{
1645	gfc_error ("Character dummy argument %qs at %L must be "
1646	"of constant length of one or assumed length, "
1647	"unless it has assumed shape or assumed rank, "
1648	"as procedure %qs has the BIND(C) attribute",
1649	sym->name, &sym->declared_at,
1650	sym->ns->proc_name->name);
1651	retval = false;
1652	}
1653	/* else: valid only since F2018 - and an assumed-shape/rank
1654	array; however, gfc_notify_std is already called when
1655	those array types are used. Thus, silently accept F200x. */
1656	}
1657	}
1658
1659	/* We have to make sure that any param to a bind(c) routine does
1660	not have the allocatable, pointer, or optional attributes,
1661	according to J3/04-007, section 5.1. */
1662	if (sym->attr.allocatable == 1
1663	&& !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1664	"ALLOCATABLE attribute in procedure %qs "
1665	"with BIND(C)", sym->name,
1666	&(sym->declared_at),
1667	sym->ns->proc_name->name))
1668	retval = false;
1669
1670	if (sym->attr.pointer == 1
1671	&& !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1672	"POINTER attribute in procedure %qs "
1673	"with BIND(C)", sym->name,
1674	&(sym->declared_at),
1675	sym->ns->proc_name->name))
1676	retval = false;
1677
1678	if (sym->attr.optional == 1 && sym->attr.value)
1679	{
1680	gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1681	"and the VALUE attribute because procedure %qs "
1682	"is BIND(C)", sym->name, &(sym->declared_at),
1683	sym->ns->proc_name->name);
1684	retval = false;
1685	}
1686	else if (sym->attr.optional == 1
1687	&& !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1688	"at %L with OPTIONAL attribute in "
1689	"procedure %qs which is BIND(C)",
1690	sym->name, &(sym->declared_at),
1691	sym->ns->proc_name->name))
1692	retval = false;
1693
1694	/* Make sure that if it has the dimension attribute, that it is
1695	either assumed size or explicit shape. Deferred shape is already
1696	covered by the pointer/allocatable attribute. */
1697	if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1698	&& !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1699	"at %L as dummy argument to the BIND(C) "
1700	"procedure %qs at %L", sym->name,
1701	&(sym->declared_at),
1702	sym->ns->proc_name->name,
1703	&(sym->ns->proc_name->declared_at)))
1704	retval = false;
1705	}
1706	}
1707
1708	return retval;
1709	}
1710
1711
1712
1713	/* Function called by variable_decl() that adds a name to the symbol table. */
1714
1715	static bool
1716	build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1717	gfc_array_spec **as, locus *var_locus)
1718	{
1719	symbol_attribute attr;
1720	gfc_symbol *sym;
1721	int upper;
1722	gfc_symtree *st;
1723
1724	/* Symbols in a submodule are host associated from the parent module or
1725	submodules. Therefore, they can be overridden by declarations in the
1726	submodule scope. Deal with this by attaching the existing symbol to
1727	a new symtree and recycling the old symtree with a new symbol... */
1728	st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1729	if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1730	&& st->n.sym != NULL
1731	&& st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1732	{
1733	gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1734	s->n.sym = st->n.sym;
1735	sym = gfc_new_symbol (name, gfc_current_ns);
1736
1737
1738	st->n.sym = sym;
1739	sym->refs++;
1740	gfc_set_sym_referenced (sym);
1741	}
1742	/* ...Otherwise generate a new symtree and new symbol. */
1743	else if (gfc_get_symbol (name, NULL, &sym))
1744	return false;
1745
1746	/* Check if the name has already been defined as a type. The
1747	first letter of the symtree will be in upper case then. Of
1748	course, this is only necessary if the upper case letter is
1749	actually different. */
1750
1751	upper = TOUPPER(name[0]);
1752	if (upper != name[0])
1753	{
1754	char u_name[GFC_MAX_SYMBOL_LEN + 1];
1755	gfc_symtree *st;
1756
1757	gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1758	strcpy (dest: u_name, src: name);
1759	u_name[0] = upper;
1760
1761	st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1762
1763	/* STRUCTURE types can alias symbol names */
1764	if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1765	{
1766	gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1767	&st->n.sym->declared_at);
1768	return false;
1769	}
1770	}
1771
1772	/* Start updating the symbol table. Add basic type attribute if present. */
1773	if (current_ts.type != BT_UNKNOWN
1774	&& (sym->attr.implicit_type == 0
1775	|| !gfc_compare_types (&sym->ts, &current_ts))
1776	&& !gfc_add_type (sym, &current_ts, var_locus))
1777	return false;
1778
1779	if (sym->ts.type == BT_CHARACTER)
1780	{
1781	sym->ts.u.cl = cl;
1782	sym->ts.deferred = cl_deferred;
1783	}
1784
1785	/* Add dimension attribute if present. */
1786	if (!gfc_set_array_spec (sym, *as, var_locus))
1787	return false;
1788	*as = NULL;
1789
1790	/* Add attribute to symbol. The copy is so that we can reset the
1791	dimension attribute. */
1792	attr = current_attr;
1793	attr.dimension = 0;
1794	attr.codimension = 0;
1795
1796	if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1797	return false;
1798
1799	/* Finish any work that may need to be done for the binding label,
1800	if it's a bind(c). The bind(c) attr is found before the symbol
1801	is made, and before the symbol name (for data decls), so the
1802	current_ts is holding the binding label, or nothing if the
1803	name= attr wasn't given. Therefore, test here if we're dealing
1804	with a bind(c) and make sure the binding label is set correctly. */
1805	if (sym->attr.is_bind_c == 1)
1806	{
1807	if (!sym->binding_label)
1808	{
1809	/* Set the binding label and verify that if a NAME= was specified
1810	then only one identifier was in the entity-decl-list. */
1811	if (!set_binding_label (&sym->binding_label, sym->name,
1812	num_idents_on_line))
1813	return false;
1814	}
1815	}
1816
1817	/* See if we know we're in a common block, and if it's a bind(c)
1818	common then we need to make sure we're an interoperable type. */
1819	if (sym->attr.in_common == 1)
1820	{
1821	/* Test the common block object. */
1822	if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1823	&& sym->ts.is_c_interop != 1)
1824	{
1825	gfc_error_now ("Variable %qs in common block %qs at %C "
1826	"must be declared with a C interoperable "
1827	"kind since common block %qs is BIND(C)",
1828	sym->name, sym->common_block->name,
1829	sym->common_block->name);
1830	gfc_clear_error ();
1831	}
1832	}
1833
1834	sym->attr.implied_index = 0;
1835
1836	/* Use the parameter expressions for a parameterized derived type. */
1837	if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1838	&& sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1839	sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1840
1841	if (sym->ts.type == BT_CLASS)
1842	return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1843
1844	return true;
1845	}
1846
1847
1848	/* Set character constant to the given length. The constant will be padded or
1849	truncated. If we're inside an array constructor without a typespec, we
1850	additionally check that all elements have the same length; check_len -1
1851	means no checking. */
1852
1853	void
1854	gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1855	gfc_charlen_t check_len)
1856	{
1857	gfc_char_t *s;
1858	gfc_charlen_t slen;
1859
1860	if (expr->ts.type != BT_CHARACTER)
1861	return;
1862
1863	if (expr->expr_type != EXPR_CONSTANT)
1864	{
1865	gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1866	return;
1867	}
1868
1869	slen = expr->value.character.length;
1870	if (len != slen)
1871	{
1872	s = gfc_get_wide_string (len + 1);
1873	memcpy (dest: s, src: expr->value.character.string,
1874	MIN (len, slen) * sizeof (gfc_char_t));
1875	if (len > slen)
1876	gfc_wide_memset (&s[slen], ' ', len - slen);
1877
1878	if (warn_character_truncation && slen > len)
1879	gfc_warning_now (opt: OPT_Wcharacter_truncation,
1880	"CHARACTER expression at %L is being truncated "
1881	"(%ld/%ld)", &expr->where,
1882	(long) slen, (long) len);
1883
1884	/* Apply the standard by 'hand' otherwise it gets cleared for
1885	initializers. */
1886	if (check_len != -1 && slen != check_len
1887	&& !(gfc_option.allow_std & GFC_STD_GNU))
1888	gfc_error_now ("The CHARACTER elements of the array constructor "
1889	"at %L must have the same length (%ld/%ld)",
1890	&expr->where, (long) slen,
1891	(long) check_len);
1892
1893	s[len] = '\0';
1894	free (ptr: expr->value.character.string);
1895	expr->value.character.string = s;
1896	expr->value.character.length = len;
1897	/* If explicit representation was given, clear it
1898	as it is no longer needed after padding. */
1899	if (expr->representation.length)
1900	{
1901	expr->representation.length = 0;
1902	free (ptr: expr->representation.string);
1903	expr->representation.string = NULL;
1904	}
1905	}
1906	}
1907
1908
1909	/* Function to create and update the enumerator history
1910	using the information passed as arguments.
1911	Pointer "max_enum" is also updated, to point to
1912	enum history node containing largest initializer.
1913
1914	SYM points to the symbol node of enumerator.
1915	INIT points to its enumerator value. */
1916
1917	static void
1918	create_enum_history (gfc_symbol *sym, gfc_expr *init)
1919	{
1920	enumerator_history *new_enum_history;
1921	gcc_assert (sym != NULL && init != NULL);
1922
1923	new_enum_history = XCNEW (enumerator_history);
1924
1925	new_enum_history->sym = sym;
1926	new_enum_history->initializer = init;
1927	new_enum_history->next = NULL;
1928
1929	if (enum_history == NULL)
1930	{
1931	enum_history = new_enum_history;
1932	max_enum = enum_history;
1933	}
1934	else
1935	{
1936	new_enum_history->next = enum_history;
1937	enum_history = new_enum_history;
1938
1939	if (mpz_cmp (max_enum->initializer->value.integer,
1940	new_enum_history->initializer->value.integer) < 0)
1941	max_enum = new_enum_history;
1942	}
1943	}
1944
1945
1946	/* Function to free enum kind history. */
1947
1948	void
1949	gfc_free_enum_history (void)
1950	{
1951	enumerator_history *current = enum_history;
1952	enumerator_history *next;
1953
1954	while (current != NULL)
1955	{
1956	next = current->next;
1957	free (ptr: current);
1958	current = next;
1959	}
1960	max_enum = NULL;
1961	enum_history = NULL;
1962	}
1963
1964
1965	/* Function to fix initializer character length if the length of the
1966	symbol or component is constant. */
1967
1968	static bool
1969	fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
1970	{
1971	if (!gfc_specification_expr (ts->u.cl->length))
1972	return false;
1973
1974	int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
1975
1976	/* resolve_charlen will complain later on if the length
1977	is too large. Just skip the initialization in that case. */
1978	if (mpz_cmp (ts->u.cl->length->value.integer,
1979	gfc_integer_kinds[k].huge) <= 0)
1980	{
1981	HOST_WIDE_INT len
1982	= gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
1983
1984	if (init->expr_type == EXPR_CONSTANT)
1985	gfc_set_constant_character_len (len, expr: init, check_len: -1);
1986	else if (init->expr_type == EXPR_ARRAY)
1987	{
1988	gfc_constructor *cons;
1989
1990	/* Build a new charlen to prevent simplification from
1991	deleting the length before it is resolved. */
1992	init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1993	init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
1994	cons = gfc_constructor_first (base: init->value.constructor);
1995	for (; cons; cons = gfc_constructor_next (ctor: cons))
1996	gfc_set_constant_character_len (len, expr: cons->expr, check_len: -1);
1997	}
1998	}
1999
2000	return true;
2001	}
2002
2003
2004	/* Function called by variable_decl() that adds an initialization
2005	expression to a symbol. */
2006
2007	static bool
2008	add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
2009	{
2010	symbol_attribute attr;
2011	gfc_symbol *sym;
2012	gfc_expr *init;
2013
2014	init = *initp;
2015	if (find_special (name, result: &sym, allow_subroutine: false))
2016	return false;
2017
2018	attr = sym->attr;
2019
2020	/* If this symbol is confirming an implicit parameter type,
2021	then an initialization expression is not allowed. */
2022	if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2023	{
2024	if (*initp != NULL)
2025	{
2026	gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2027	sym->name);
2028	return false;
2029	}
2030	else
2031	return true;
2032	}
2033
2034	if (init == NULL)
2035	{
2036	/* An initializer is required for PARAMETER declarations. */
2037	if (attr.flavor == FL_PARAMETER)
2038	{
2039	gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2040	return false;
2041	}
2042	}
2043	else
2044	{
2045	/* If a variable appears in a DATA block, it cannot have an
2046	initializer. */
2047	if (sym->attr.data)
2048	{
2049	gfc_error ("Variable %qs at %C with an initializer already "
2050	"appears in a DATA statement", sym->name);
2051	return false;
2052	}
2053
2054	/* Check if the assignment can happen. This has to be put off
2055	until later for derived type variables and procedure pointers. */
2056	if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2057	&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2058	&& !sym->attr.proc_pointer
2059	&& !gfc_check_assign_symbol (sym, NULL, init))
2060	return false;
2061
2062	if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2063	&& init->ts.type == BT_CHARACTER)
2064	{
2065	/* Update symbol character length according initializer. */
2066	if (!gfc_check_assign_symbol (sym, NULL, init))
2067	return false;
2068
2069	if (sym->ts.u.cl->length == NULL)
2070	{
2071	gfc_charlen_t clen;
2072	/* If there are multiple CHARACTER variables declared on the
2073	same line, we don't want them to share the same length. */
2074	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2075
2076	if (sym->attr.flavor == FL_PARAMETER)
2077	{
2078	if (init->expr_type == EXPR_CONSTANT)
2079	{
2080	clen = init->value.character.length;
2081	sym->ts.u.cl->length
2082	= gfc_get_int_expr (gfc_charlen_int_kind,
2083	NULL, clen);
2084	}
2085	else if (init->expr_type == EXPR_ARRAY)
2086	{
2087	if (init->ts.u.cl && init->ts.u.cl->length)
2088	{
2089	const gfc_expr *length = init->ts.u.cl->length;
2090	if (length->expr_type != EXPR_CONSTANT)
2091	{
2092	gfc_error ("Cannot initialize parameter array "
2093	"at %L "
2094	"with variable length elements",
2095	&sym->declared_at);
2096	return false;
2097	}
2098	clen = mpz_get_si (length->value.integer);
2099	}
2100	else if (init->value.constructor)
2101	{
2102	gfc_constructor *c;
2103	c = gfc_constructor_first (base: init->value.constructor);
2104	clen = c->expr->value.character.length;
2105	}
2106	else
2107	gcc_unreachable ();
2108	sym->ts.u.cl->length
2109	= gfc_get_int_expr (gfc_charlen_int_kind,
2110	NULL, clen);
2111	}
2112	else if (init->ts.u.cl && init->ts.u.cl->length)
2113	sym->ts.u.cl->length =
2114	gfc_copy_expr (init->ts.u.cl->length);
2115	}
2116	}
2117	/* Update initializer character length according to symbol. */
2118	else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2119	&& !fix_initializer_charlen (ts: &sym->ts, init))
2120	return false;
2121	}
2122
2123	if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2124	&& sym->as->rank && init->rank && init->rank != sym->as->rank)
2125	{
2126	gfc_error ("Rank mismatch of array at %L and its initializer "
2127	"(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2128	return false;
2129	}
2130
2131	/* If sym is implied-shape, set its upper bounds from init. */
2132	if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2133	&& sym->as->type == AS_IMPLIED_SHAPE)
2134	{
2135	int dim;
2136
2137	if (init->rank == 0)
2138	{
2139	gfc_error ("Cannot initialize implied-shape array at %L"
2140	" with scalar", &sym->declared_at);
2141	return false;
2142	}
2143
2144	/* The shape may be NULL for EXPR_ARRAY, set it. */
2145	if (init->shape == NULL)
2146	{
2147	if (init->expr_type != EXPR_ARRAY)
2148	{
2149	gfc_error ("Bad shape of initializer at %L", &init->where);
2150	return false;
2151	}
2152
2153	init->shape = gfc_get_shape (1);
2154	if (!gfc_array_size (init, &init->shape[0]))
2155	{
2156	gfc_error ("Cannot determine shape of initializer at %L",
2157	&init->where);
2158	free (ptr: init->shape);
2159	init->shape = NULL;
2160	return false;
2161	}
2162	}
2163
2164	for (dim = 0; dim < sym->as->rank; ++dim)
2165	{
2166	int k;
2167	gfc_expr *e, *lower;
2168
2169	lower = sym->as->lower[dim];
2170
2171	/* If the lower bound is an array element from another
2172	parameterized array, then it is marked with EXPR_VARIABLE and
2173	is an initialization expression. Try to reduce it. */
2174	if (lower->expr_type == EXPR_VARIABLE)
2175	gfc_reduce_init_expr (expr: lower);
2176
2177	if (lower->expr_type == EXPR_CONSTANT)
2178	{
2179	/* All dimensions must be without upper bound. */
2180	gcc_assert (!sym->as->upper[dim]);
2181
2182	k = lower->ts.kind;
2183	e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2184	mpz_add (e->value.integer, lower->value.integer,
2185	init->shape[dim]);
2186	mpz_sub_ui (e->value.integer, e->value.integer, 1);
2187	sym->as->upper[dim] = e;
2188	}
2189	else
2190	{
2191	gfc_error ("Non-constant lower bound in implied-shape"
2192	" declaration at %L", &lower->where);
2193	return false;
2194	}
2195	}
2196
2197	sym->as->type = AS_EXPLICIT;
2198	}
2199
2200	/* Ensure that explicit bounds are simplified. */
2201	if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2202	&& sym->as->type == AS_EXPLICIT)
2203	{
2204	for (int dim = 0; dim < sym->as->rank; ++dim)
2205	{
2206	gfc_expr *e;
2207
2208	e = sym->as->lower[dim];
2209	if (e->expr_type != EXPR_CONSTANT)
2210	gfc_reduce_init_expr (expr: e);
2211
2212	e = sym->as->upper[dim];
2213	if (e->expr_type != EXPR_CONSTANT)
2214	gfc_reduce_init_expr (expr: e);
2215	}
2216	}
2217
2218	/* Need to check if the expression we initialized this
2219	to was one of the iso_c_binding named constants. If so,
2220	and we're a parameter (constant), let it be iso_c.
2221	For example:
2222	integer(c_int), parameter :: my_int = c_int
2223	integer(my_int) :: my_int_2
2224	If we mark my_int as iso_c (since we can see it's value
2225	is equal to one of the named constants), then my_int_2
2226	will be considered C interoperable. */
2227	if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2228	{
2229	sym->ts.is_iso_c |= init->ts.is_iso_c;
2230	sym->ts.is_c_interop |= init->ts.is_c_interop;
2231	/* attr bits needed for module files. */
2232	sym->attr.is_iso_c |= init->ts.is_iso_c;
2233	sym->attr.is_c_interop |= init->ts.is_c_interop;
2234	if (init->ts.is_iso_c)
2235	sym->ts.f90_type = init->ts.f90_type;
2236	}
2237
2238	/* Catch the case: type(t), parameter :: x = z'1'. */
2239	if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2240	{
2241	gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2242	"literal constant", name, &sym->declared_at);
2243	return false;
2244	}
2245
2246	/* Add initializer. Make sure we keep the ranks sane. */
2247	if (sym->attr.dimension && init->rank == 0)
2248	{
2249	mpz_t size;
2250	gfc_expr *array;
2251	int n;
2252	if (sym->attr.flavor == FL_PARAMETER
2253	&& gfc_is_constant_expr (init)
2254	&& (init->expr_type == EXPR_CONSTANT
2255	|| init->expr_type == EXPR_STRUCTURE)
2256	&& spec_size (sym->as, &size))
2257	{
2258	array = gfc_get_array_expr (type: init->ts.type, kind: init->ts.kind,
2259	&init->where);
2260	if (init->ts.type == BT_DERIVED)
2261	array->ts.u.derived = init->ts.u.derived;
2262	for (n = 0; n < (int)mpz_get_si (size); n++)
2263	gfc_constructor_append_expr (base: &array->value.constructor,
2264	e: n == 0
2265	? init
2266	: gfc_copy_expr (init),
2267	where: &init->where);
2268
2269	array->shape = gfc_get_shape (sym->as->rank);
2270	for (n = 0; n < sym->as->rank; n++)
2271	spec_dimen_size (sym->as, n, &array->shape[n]);
2272
2273	init = array;
2274	mpz_clear (size);
2275	}
2276	init->rank = sym->as->rank;
2277	}
2278
2279	sym->value = init;
2280	if (sym->attr.save == SAVE_NONE)
2281	sym->attr.save = SAVE_IMPLICIT;
2282	*initp = NULL;
2283	}
2284
2285	return true;
2286	}
2287
2288
2289	/* Function called by variable_decl() that adds a name to a structure
2290	being built. */
2291
2292	static bool
2293	build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2294	gfc_array_spec **as)
2295	{
2296	gfc_state_data *s;
2297	gfc_component *c;
2298
2299	/* F03:C438/C439. If the current symbol is of the same derived type that we're
2300	constructing, it must have the pointer attribute. */
2301	if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2302	&& current_ts.u.derived == gfc_current_block ()
2303	&& current_attr.pointer == 0)
2304	{
2305	if (current_attr.allocatable
2306	&& !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2307	"must have the POINTER attribute"))
2308	{
2309	return false;
2310	}
2311	else if (current_attr.allocatable == 0)
2312	{
2313	gfc_error ("Component at %C must have the POINTER attribute");
2314	return false;
2315	}
2316	}
2317
2318	/* F03:C437. */
2319	if (current_ts.type == BT_CLASS
2320	&& !(current_attr.pointer || current_attr.allocatable))
2321	{
2322	gfc_error ("Component %qs with CLASS at %C must be allocatable "
2323	"or pointer", name);
2324	return false;
2325	}
2326
2327	if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2328	{
2329	if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2330	{
2331	gfc_error ("Array component of structure at %C must have explicit "
2332	"or deferred shape");
2333	return false;
2334	}
2335	}
2336
2337	/* If we are in a nested union/map definition, gfc_add_component will not
2338	properly find repeated components because:
2339	(i) gfc_add_component does a flat search, where components of unions
2340	and maps are implicity chained so nested components may conflict.
2341	(ii) Unions and maps are not linked as components of their parent
2342	structures until after they are parsed.
2343	For (i) we use gfc_find_component which searches recursively, and for (ii)
2344	we search each block directly from the parse stack until we find the top
2345	level structure. */
2346
2347	s = gfc_state_stack;
2348	if (s->state == COMP_UNION || s->state == COMP_MAP)
2349	{
2350	while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2351	{
2352	c = gfc_find_component (s->sym, name, true, true, NULL);
2353	if (c != NULL)
2354	{
2355	gfc_error_now ("Component %qs at %C already declared at %L",
2356	name, &c->loc);
2357	return false;
2358	}
2359	/* Break after we've searched the entire chain. */
2360	if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2361	break;
2362	s = s->previous;
2363	}
2364	}
2365
2366	if (!gfc_add_component (gfc_current_block(), name, &c))
2367	return false;
2368
2369	c->ts = current_ts;
2370	if (c->ts.type == BT_CHARACTER)
2371	c->ts.u.cl = cl;
2372
2373	if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2374	&& (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2375	&& saved_kind_expr != NULL)
2376	c->kind_expr = gfc_copy_expr (saved_kind_expr);
2377
2378	c->attr = current_attr;
2379
2380	c->initializer = *init;
2381	*init = NULL;
2382
2383	/* Update initializer character length according to component. */
2384	if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2385	&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2386	&& c->initializer && c->initializer->ts.type == BT_CHARACTER
2387	&& !fix_initializer_charlen (ts: &c->ts, init: c->initializer))
2388	return false;
2389
2390	c->as = *as;
2391	if (c->as != NULL)
2392	{
2393	if (c->as->corank)
2394	c->attr.codimension = 1;
2395	if (c->as->rank)
2396	c->attr.dimension = 1;
2397	}
2398	*as = NULL;
2399
2400	gfc_apply_init (&c->ts, &c->attr, c->initializer);
2401
2402	/* Check array components. */
2403	if (!c->attr.dimension)
2404	goto scalar;
2405
2406	if (c->attr.pointer)
2407	{
2408	if (c->as->type != AS_DEFERRED)
2409	{
2410	gfc_error ("Pointer array component of structure at %C must have a "
2411	"deferred shape");
2412	return false;
2413	}
2414	}
2415	else if (c->attr.allocatable)
2416	{
2417	if (c->as->type != AS_DEFERRED)
2418	{
2419	gfc_error ("Allocatable component of structure at %C must have a "
2420	"deferred shape");
2421	return false;
2422	}
2423	}
2424	else
2425	{
2426	if (c->as->type != AS_EXPLICIT)
2427	{
2428	gfc_error ("Array component of structure at %C must have an "
2429	"explicit shape");
2430	return false;
2431	}
2432	}
2433
2434	scalar:
2435	if (c->ts.type == BT_CLASS)
2436	return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2437
2438	if (c->attr.pdt_kind || c->attr.pdt_len)
2439	{
2440	gfc_symbol *sym;
2441	gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2442	0, &sym);
2443	if (sym == NULL)
2444	{
2445	gfc_error ("Type parameter %qs at %C has no corresponding entry "
2446	"in the type parameter name list at %L",
2447	c->name, &gfc_current_block ()->declared_at);
2448	return false;
2449	}
2450	sym->ts = c->ts;
2451	sym->attr.pdt_kind = c->attr.pdt_kind;
2452	sym->attr.pdt_len = c->attr.pdt_len;
2453	if (c->initializer)
2454	sym->value = gfc_copy_expr (c->initializer);
2455	sym->attr.flavor = FL_VARIABLE;
2456	}
2457
2458	if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2459	&& c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2460	&& decl_type_param_list)
2461	c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2462
2463	return true;
2464	}
2465
2466
2467	/* Match a 'NULL()', and possibly take care of some side effects. */
2468
2469	match
2470	gfc_match_null (gfc_expr **result)
2471	{
2472	gfc_symbol *sym;
2473	match m, m2 = MATCH_NO;
2474
2475	if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2476	return MATCH_ERROR;
2477
2478	if (m == MATCH_NO)
2479	{
2480	locus old_loc;
2481	char name[GFC_MAX_SYMBOL_LEN + 1];
2482
2483	if ((m2 = gfc_match (" null (")) != MATCH_YES)
2484	return m2;
2485
2486	old_loc = gfc_current_locus;
2487	if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2488	return MATCH_ERROR;
2489	if (m2 != MATCH_YES
2490	&& ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2491	return MATCH_ERROR;
2492	if (m2 == MATCH_NO)
2493	{
2494	gfc_current_locus = old_loc;
2495	return MATCH_NO;
2496	}
2497	}
2498
2499	/* The NULL symbol now has to be/become an intrinsic function. */
2500	if (gfc_get_symbol ("null", NULL, &sym))
2501	{
2502	gfc_error ("NULL() initialization at %C is ambiguous");
2503	return MATCH_ERROR;
2504	}
2505
2506	gfc_intrinsic_symbol (sym);
2507
2508	if (sym->attr.proc != PROC_INTRINSIC
2509	&& !(sym->attr.use_assoc && sym->attr.intrinsic)
2510	&& (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2511	|| !gfc_add_function (&sym->attr, sym->name, NULL)))
2512	return MATCH_ERROR;
2513
2514	*result = gfc_get_null_expr (&gfc_current_locus);
2515
2516	/* Invalid per F2008, C512. */
2517	if (m2 == MATCH_YES)
2518	{
2519	gfc_error ("NULL() initialization at %C may not have MOLD");
2520	return MATCH_ERROR;
2521	}
2522
2523	return MATCH_YES;
2524	}
2525
2526
2527	/* Match the initialization expr for a data pointer or procedure pointer. */
2528
2529	static match
2530	match_pointer_init (gfc_expr **init, int procptr)
2531	{
2532	match m;
2533
2534	if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2535	{
2536	gfc_error ("Initialization of pointer at %C is not allowed in "
2537	"a PURE procedure");
2538	return MATCH_ERROR;
2539	}
2540	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2541
2542	/* Match NULL() initialization. */
2543	m = gfc_match_null (result: init);
2544	if (m != MATCH_NO)
2545	return m;
2546
2547	/* Match non-NULL initialization. */
2548	gfc_matching_ptr_assignment = !procptr;
2549	gfc_matching_procptr_assignment = procptr;
2550	m = gfc_match_rvalue (init);
2551	gfc_matching_ptr_assignment = 0;
2552	gfc_matching_procptr_assignment = 0;
2553	if (m == MATCH_ERROR)
2554	return MATCH_ERROR;
2555	else if (m == MATCH_NO)
2556	{
2557	gfc_error ("Error in pointer initialization at %C");
2558	return MATCH_ERROR;
2559	}
2560
2561	if (!procptr && !gfc_resolve_expr (*init))
2562	return MATCH_ERROR;
2563
2564	if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2565	"initialization at %C"))
2566	return MATCH_ERROR;
2567
2568	return MATCH_YES;
2569	}
2570
2571
2572	static bool
2573	check_function_name (char *name)
2574	{
2575	/* In functions that have a RESULT variable defined, the function name always
2576	refers to function calls. Therefore, the name is not allowed to appear in
2577	specification statements. When checking this, be careful about
2578	'hidden' procedure pointer results ('ppr@'). */
2579
2580	if (gfc_current_state () == COMP_FUNCTION)
2581	{
2582	gfc_symbol *block = gfc_current_block ();
2583	if (block && block->result && block->result != block
2584	&& strcmp (s1: block->result->name, s2: "ppr@") != 0
2585	&& strcmp (s1: block->name, s2: name) == 0)
2586	{
2587	gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2588	"from appearing in a specification statement",
2589	block->result->name, &block->result->declared_at, name);
2590	return false;
2591	}
2592	}
2593
2594	return true;
2595	}
2596
2597
2598	/* Match a variable name with an optional initializer. When this
2599	subroutine is called, a variable is expected to be parsed next.
2600	Depending on what is happening at the moment, updates either the
2601	symbol table or the current interface. */
2602
2603	static match
2604	variable_decl (int elem)
2605	{
2606	char name[GFC_MAX_SYMBOL_LEN + 1];
2607	static unsigned int fill_id = 0;
2608	gfc_expr *initializer, *char_len;
2609	gfc_array_spec *as;
2610	gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2611	gfc_charlen *cl;
2612	bool cl_deferred;
2613	locus var_locus;
2614	match m;
2615	bool t;
2616	gfc_symbol *sym;
2617	char c;
2618
2619	initializer = NULL;
2620	as = NULL;
2621	cp_as = NULL;
2622
2623	/* When we get here, we've just matched a list of attributes and
2624	maybe a type and a double colon. The next thing we expect to see
2625	is the name of the symbol. */
2626
2627	/* If we are parsing a structure with legacy support, we allow the symbol
2628	name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2629	m = MATCH_NO;
2630	gfc_gobble_whitespace ();
2631	c = gfc_peek_ascii_char ();
2632	if (c == '%')
2633	{
2634	gfc_next_ascii_char (); /* Burn % character. */
2635	m = gfc_match ("fill");
2636	if (m == MATCH_YES)
2637	{
2638	if (gfc_current_state () != COMP_STRUCTURE)
2639	{
2640	if (flag_dec_structure)
2641	gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2642	else
2643	gfc_error ("%qs at %C is a DEC extension, enable with "
2644	"%<-fdec-structure%>", "%FILL");
2645	m = MATCH_ERROR;
2646	goto cleanup;
2647	}
2648
2649	if (attr_seen)
2650	{
2651	gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2652	m = MATCH_ERROR;
2653	goto cleanup;
2654	}
2655
2656	/* %FILL components are given invalid fortran names. */
2657	snprintf (s: name, GFC_MAX_SYMBOL_LEN + 1, format: "%%FILL%u", fill_id++);
2658	}
2659	else
2660	{
2661	gfc_error ("Invalid character %qc in variable name at %C", c);
2662	return MATCH_ERROR;
2663	}
2664	}
2665	else
2666	{
2667	m = gfc_match_name (name);
2668	if (m != MATCH_YES)
2669	goto cleanup;
2670	}
2671
2672	var_locus = gfc_current_locus;
2673
2674	/* Now we could see the optional array spec. or character length. */
2675	m = gfc_match_array_spec (&as, true, true);
2676	if (m == MATCH_ERROR)
2677	goto cleanup;
2678
2679	if (m == MATCH_NO)
2680	as = gfc_copy_array_spec (current_as);
2681	else if (current_as
2682	&& !merge_array_spec (from: current_as, to: as, copy: true))
2683	{
2684	m = MATCH_ERROR;
2685	goto cleanup;
2686	}
2687
2688	if (flag_cray_pointer)
2689	cp_as = gfc_copy_array_spec (as);
2690
2691	/* At this point, we know for sure if the symbol is PARAMETER and can thus
2692	determine (and check) whether it can be implied-shape. If it
2693	was parsed as assumed-size, change it because PARAMETERs cannot
2694	be assumed-size.
2695
2696	An explicit-shape-array cannot appear under several conditions.
2697	That check is done here as well. */
2698	if (as)
2699	{
2700	if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2701	{
2702	m = MATCH_ERROR;
2703	gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2704	name, &var_locus);
2705	goto cleanup;
2706	}
2707
2708	if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2709	&& current_attr.flavor == FL_PARAMETER)
2710	as->type = AS_IMPLIED_SHAPE;
2711
2712	if (as->type == AS_IMPLIED_SHAPE
2713	&& !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2714	&var_locus))
2715	{
2716	m = MATCH_ERROR;
2717	goto cleanup;
2718	}
2719
2720	gfc_seen_div0 = false;
2721
2722	/* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2723	constant expressions shall appear only in a subprogram, derived
2724	type definition, BLOCK construct, or interface body. */
2725	if (as->type == AS_EXPLICIT
2726	&& gfc_current_state () != COMP_BLOCK
2727	&& gfc_current_state () != COMP_DERIVED
2728	&& gfc_current_state () != COMP_FUNCTION
2729	&& gfc_current_state () != COMP_INTERFACE
2730	&& gfc_current_state () != COMP_SUBROUTINE)
2731	{
2732	gfc_expr *e;
2733	bool not_constant = false;
2734
2735	for (int i = 0; i < as->rank; i++)
2736	{
2737	e = gfc_copy_expr (as->lower[i]);
2738	if (!gfc_resolve_expr (e) && gfc_seen_div0)
2739	{
2740	m = MATCH_ERROR;
2741	goto cleanup;
2742	}
2743
2744	gfc_simplify_expr (e, 0);
2745	if (e && (e->expr_type != EXPR_CONSTANT))
2746	{
2747	not_constant = true;
2748	break;
2749	}
2750	gfc_free_expr (e);
2751
2752	e = gfc_copy_expr (as->upper[i]);
2753	if (!gfc_resolve_expr (e) && gfc_seen_div0)
2754	{
2755	m = MATCH_ERROR;
2756	goto cleanup;
2757	}
2758
2759	gfc_simplify_expr (e, 0);
2760	if (e && (e->expr_type != EXPR_CONSTANT))
2761	{
2762	not_constant = true;
2763	break;
2764	}
2765	gfc_free_expr (e);
2766	}
2767
2768	if (not_constant && e->ts.type != BT_INTEGER)
2769	{
2770	gfc_error ("Explicit array shape at %C must be constant of "
2771	"INTEGER type and not %s type",
2772	gfc_basic_typename (e->ts.type));
2773	m = MATCH_ERROR;
2774	goto cleanup;
2775	}
2776	if (not_constant)
2777	{
2778	gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2779	m = MATCH_ERROR;
2780	goto cleanup;
2781	}
2782	}
2783	if (as->type == AS_EXPLICIT)
2784	{
2785	for (int i = 0; i < as->rank; i++)
2786	{
2787	gfc_expr *e, *n;
2788	e = as->lower[i];
2789	if (e->expr_type != EXPR_CONSTANT)
2790	{
2791	n = gfc_copy_expr (e);
2792	if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2793	{
2794	m = MATCH_ERROR;
2795	goto cleanup;
2796	}
2797
2798	if (n->expr_type == EXPR_CONSTANT)
2799	gfc_replace_expr (e, n);
2800	else
2801	gfc_free_expr (n);
2802	}
2803	e = as->upper[i];
2804	if (e->expr_type != EXPR_CONSTANT)
2805	{
2806	n = gfc_copy_expr (e);
2807	if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2808	{
2809	m = MATCH_ERROR;
2810	goto cleanup;
2811	}
2812
2813	if (n->expr_type == EXPR_CONSTANT)
2814	gfc_replace_expr (e, n);
2815	else
2816	gfc_free_expr (n);
2817	}
2818	/* For an explicit-shape spec with constant bounds, ensure
2819	that the effective upper bound is not lower than the
2820	respective lower bound minus one. Otherwise adjust it so
2821	that the extent is trivially derived to be zero. */
2822	if (as->lower[i]->expr_type == EXPR_CONSTANT
2823	&& as->upper[i]->expr_type == EXPR_CONSTANT
2824	&& as->lower[i]->ts.type == BT_INTEGER
2825	&& as->upper[i]->ts.type == BT_INTEGER
2826	&& mpz_cmp (as->upper[i]->value.integer,
2827	as->lower[i]->value.integer) < 0)
2828	mpz_sub_ui (as->upper[i]->value.integer,
2829	as->lower[i]->value.integer, 1);
2830	}
2831	}
2832	}
2833
2834	char_len = NULL;
2835	cl = NULL;
2836	cl_deferred = false;
2837
2838	if (current_ts.type == BT_CHARACTER)
2839	{
2840	switch (match_char_length (expr: &char_len, deferred: &cl_deferred, obsolescent_check: false))
2841	{
2842	case MATCH_YES:
2843	cl = gfc_new_charlen (gfc_current_ns, NULL);
2844
2845	cl->length = char_len;
2846	break;
2847
2848	/* Non-constant lengths need to be copied after the first
2849	element. Also copy assumed lengths. */
2850	case MATCH_NO:
2851	if (elem > 1
2852	&& (current_ts.u.cl->length == NULL
2853	|| current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2854	{
2855	cl = gfc_new_charlen (gfc_current_ns, NULL);
2856	cl->length = gfc_copy_expr (current_ts.u.cl->length);
2857	}
2858	else
2859	cl = current_ts.u.cl;
2860
2861	cl_deferred = current_ts.deferred;
2862
2863	break;
2864
2865	case MATCH_ERROR:
2866	goto cleanup;
2867	}
2868	}
2869
2870	/* The dummy arguments and result of the abbreviated form of MODULE
2871	PROCEDUREs, used in SUBMODULES should not be redefined. */
2872	if (gfc_current_ns->proc_name
2873	&& gfc_current_ns->proc_name->abr_modproc_decl)
2874	{
2875	gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2876	if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2877	{
2878	m = MATCH_ERROR;
2879	gfc_error ("%qs at %C is a redefinition of the declaration "
2880	"in the corresponding interface for MODULE "
2881	"PROCEDURE %qs", sym->name,
2882	gfc_current_ns->proc_name->name);
2883	goto cleanup;
2884	}
2885	}
2886
2887	/* %FILL components may not have initializers. */
2888	if (startswith (str: name, prefix: "%FILL") && gfc_match_eos () != MATCH_YES)
2889	{
2890	gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2891	m = MATCH_ERROR;
2892	goto cleanup;
2893	}
2894
2895	/* If this symbol has already shown up in a Cray Pointer declaration,
2896	and this is not a component declaration,
2897	then we want to set the type & bail out. */
2898	if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2899	{
2900	gfc_find_symbol (name, gfc_current_ns, 0, &sym);
2901	if (sym != NULL && sym->attr.cray_pointee)
2902	{
2903	m = MATCH_YES;
2904	if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
2905	{
2906	m = MATCH_ERROR;
2907	goto cleanup;
2908	}
2909
2910	/* Check to see if we have an array specification. */
2911	if (cp_as != NULL)
2912	{
2913	if (sym->as != NULL)
2914	{
2915	gfc_error ("Duplicate array spec for Cray pointee at %C");
2916	gfc_free_array_spec (cp_as);
2917	m = MATCH_ERROR;
2918	goto cleanup;
2919	}
2920	else
2921	{
2922	if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2923	gfc_internal_error ("Cannot set pointee array spec.");
2924
2925	/* Fix the array spec. */
2926	m = gfc_mod_pointee_as (sym->as);
2927	if (m == MATCH_ERROR)
2928	goto cleanup;
2929	}
2930	}
2931	goto cleanup;
2932	}
2933	else
2934	{
2935	gfc_free_array_spec (cp_as);
2936	}
2937	}
2938
2939	/* Procedure pointer as function result. */
2940	if (gfc_current_state () == COMP_FUNCTION
2941	&& strcmp (s1: "ppr@", gfc_current_block ()->name) == 0
2942	&& strcmp (s1: name, gfc_current_block ()->ns->proc_name->name) == 0)
2943	strcpy (dest: name, src: "ppr@");
2944
2945	if (gfc_current_state () == COMP_FUNCTION
2946	&& strcmp (s1: name, gfc_current_block ()->name) == 0
2947	&& gfc_current_block ()->result
2948	&& strcmp (s1: "ppr@", gfc_current_block ()->result->name) == 0)
2949	strcpy (dest: name, src: "ppr@");
2950
2951	/* OK, we've successfully matched the declaration. Now put the
2952	symbol in the current namespace, because it might be used in the
2953	optional initialization expression for this symbol, e.g. this is
2954	perfectly legal:
2955
2956	integer, parameter :: i = huge(i)
2957
2958	This is only true for parameters or variables of a basic type.
2959	For components of derived types, it is not true, so we don't
2960	create a symbol for those yet. If we fail to create the symbol,
2961	bail out. */
2962	if (!gfc_comp_struct (gfc_current_state ())
2963	&& !build_sym (name, cl, cl_deferred, as: &as, var_locus: &var_locus))
2964	{
2965	m = MATCH_ERROR;
2966	goto cleanup;
2967	}
2968
2969	if (!check_function_name (name))
2970	{
2971	m = MATCH_ERROR;
2972	goto cleanup;
2973	}
2974
2975	/* We allow old-style initializations of the form
2976	integer i /2/, j(4) /3*3, 1/
2977	(if no colon has been seen). These are different from data
2978	statements in that initializers are only allowed to apply to the
2979	variable immediately preceding, i.e.
2980	integer i, j /1, 2/
2981	is not allowed. Therefore we have to do some work manually, that
2982	could otherwise be left to the matchers for DATA statements. */
2983
2984	if (!colon_seen && gfc_match (" /") == MATCH_YES)
2985	{
2986	if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2987	"initialization at %C"))
2988	return MATCH_ERROR;
2989
2990	/* Allow old style initializations for components of STRUCTUREs and MAPs
2991	but not components of derived types. */
2992	else if (gfc_current_state () == COMP_DERIVED)
2993	{
2994	gfc_error ("Invalid old style initialization for derived type "
2995	"component at %C");
2996	m = MATCH_ERROR;
2997	goto cleanup;
2998	}
2999
3000	/* For structure components, read the initializer as a special
3001	expression and let the rest of this function apply the initializer
3002	as usual. */
3003	else if (gfc_comp_struct (gfc_current_state ()))
3004	{
3005	m = match_clist_expr (result: &initializer, ts: &current_ts, as);
3006	if (m == MATCH_NO)
3007	gfc_error ("Syntax error in old style initialization of %s at %C",
3008	name);
3009	if (m != MATCH_YES)
3010	goto cleanup;
3011	}
3012
3013	/* Otherwise we treat the old style initialization just like a
3014	DATA declaration for the current variable. */
3015	else
3016	return match_old_style_init (name);
3017	}
3018
3019	/* The double colon must be present in order to have initializers.
3020	Otherwise the statement is ambiguous with an assignment statement. */
3021	if (colon_seen)
3022	{
3023	if (gfc_match (" =>") == MATCH_YES)
3024	{
3025	if (!current_attr.pointer)
3026	{
3027	gfc_error ("Initialization at %C isn't for a pointer variable");
3028	m = MATCH_ERROR;
3029	goto cleanup;
3030	}
3031
3032	m = match_pointer_init (init: &initializer, procptr: 0);
3033	if (m != MATCH_YES)
3034	goto cleanup;
3035
3036	/* The target of a pointer initialization must have the SAVE
3037	attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3038	is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3039	if (initializer->expr_type == EXPR_VARIABLE
3040	&& initializer->symtree->n.sym->attr.save == SAVE_NONE
3041	&& (gfc_current_state () == COMP_PROGRAM
3042	|| gfc_current_state () == COMP_MODULE
3043	|| gfc_current_state () == COMP_SUBMODULE))
3044	initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3045	}
3046	else if (gfc_match_char ('=') == MATCH_YES)
3047	{
3048	if (current_attr.pointer)
3049	{
3050	gfc_error ("Pointer initialization at %C requires %<=>%>, "
3051	"not %<=%>");
3052	m = MATCH_ERROR;
3053	goto cleanup;
3054	}
3055
3056	m = gfc_match_init_expr (&initializer);
3057	if (m == MATCH_NO)
3058	{
3059	gfc_error ("Expected an initialization expression at %C");
3060	m = MATCH_ERROR;
3061	}
3062
3063	if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3064	&& !gfc_comp_struct (gfc_state_stack->state))
3065	{
3066	gfc_error ("Initialization of variable at %C is not allowed in "
3067	"a PURE procedure");
3068	m = MATCH_ERROR;
3069	}
3070
3071	if (current_attr.flavor != FL_PARAMETER
3072	&& !gfc_comp_struct (gfc_state_stack->state))
3073	gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3074
3075	if (m != MATCH_YES)
3076	goto cleanup;
3077	}
3078	}
3079
3080	if (initializer != NULL && current_attr.allocatable
3081	&& gfc_comp_struct (gfc_current_state ()))
3082	{
3083	gfc_error ("Initialization of allocatable component at %C is not "
3084	"allowed");
3085	m = MATCH_ERROR;
3086	goto cleanup;
3087	}
3088
3089	if (gfc_current_state () == COMP_DERIVED
3090	&& initializer && initializer->ts.type == BT_HOLLERITH)
3091	{
3092	gfc_error ("Initialization of structure component with a HOLLERITH "
3093	"constant at %L is not allowed", &initializer->where);
3094	m = MATCH_ERROR;
3095	goto cleanup;
3096	}
3097
3098	if (gfc_current_state () == COMP_DERIVED
3099	&& gfc_current_block ()->attr.pdt_template)
3100	{
3101	gfc_symbol *param;
3102	gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3103	0, &param);
3104	if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3105	{
3106	gfc_error ("The component with KIND or LEN attribute at %C does not "
3107	"not appear in the type parameter list at %L",
3108	&gfc_current_block ()->declared_at);
3109	m = MATCH_ERROR;
3110	goto cleanup;
3111	}
3112	else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3113	{
3114	gfc_error ("The component at %C that appears in the type parameter "
3115	"list at %L has neither the KIND nor LEN attribute",
3116	&gfc_current_block ()->declared_at);
3117	m = MATCH_ERROR;
3118	goto cleanup;
3119	}
3120	else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3121	{
3122	gfc_error ("The component at %C which is a type parameter must be "
3123	"a scalar");
3124	m = MATCH_ERROR;
3125	goto cleanup;
3126	}
3127	else if (param && initializer)
3128	{
3129	if (initializer->ts.type == BT_BOZ)
3130	{
3131	gfc_error ("BOZ literal constant at %L cannot appear as an "
3132	"initializer", &initializer->where);
3133	m = MATCH_ERROR;
3134	goto cleanup;
3135	}
3136	param->value = gfc_copy_expr (initializer);
3137	}
3138	}
3139
3140	/* Before adding a possible initializer, do a simple check for compatibility
3141	of lhs and rhs types. Assigning a REAL value to a derived type is not a
3142	good thing. */
3143	if (current_ts.type == BT_DERIVED && initializer
3144	&& (gfc_numeric_ts (&initializer->ts)
3145	|| initializer->ts.type == BT_LOGICAL
3146	|| initializer->ts.type == BT_CHARACTER))
3147	{
3148	gfc_error ("Incompatible initialization between a derived type "
3149	"entity and an entity with %qs type at %C",
3150	gfc_typename (initializer));
3151	m = MATCH_ERROR;
3152	goto cleanup;
3153	}
3154
3155
3156	/* Add the initializer. Note that it is fine if initializer is
3157	NULL here, because we sometimes also need to check if a
3158	declaration *must* have an initialization expression. */
3159	if (!gfc_comp_struct (gfc_current_state ()))
3160	t = add_init_expr_to_sym (name, initp: &initializer, var_locus: &var_locus);
3161	else
3162	{
3163	if (current_ts.type == BT_DERIVED
3164	&& !current_attr.pointer && !initializer)
3165	initializer = gfc_default_initializer (&current_ts);
3166	t = build_struct (name, cl, init: &initializer, as: &as);
3167
3168	/* If we match a nested structure definition we expect to see the
3169	* body even if the variable declarations blow up, so we need to keep
3170	* the structure declaration around. */
3171	if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3172	gfc_commit_symbol (gfc_new_block);
3173	}
3174
3175	m = (t) ? MATCH_YES : MATCH_ERROR;
3176
3177	cleanup:
3178	/* Free stuff up and return. */
3179	gfc_seen_div0 = false;
3180	gfc_free_expr (initializer);
3181	gfc_free_array_spec (as);
3182
3183	return m;
3184	}
3185
3186
3187	/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3188	This assumes that the byte size is equal to the kind number for
3189	non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3190
3191	static match
3192	gfc_match_old_kind_spec (gfc_typespec *ts)
3193	{
3194	match m;
3195	int original_kind;
3196
3197	if (gfc_match_char ('*') != MATCH_YES)
3198	return MATCH_NO;
3199
3200	m = gfc_match_small_literal_int (&ts->kind, NULL);
3201	if (m != MATCH_YES)
3202	return MATCH_ERROR;
3203
3204	original_kind = ts->kind;
3205
3206	/* Massage the kind numbers for complex types. */
3207	if (ts->type == BT_COMPLEX)
3208	{
3209	if (ts->kind % 2)
3210	{
3211	gfc_error ("Old-style type declaration %s*%d not supported at %C",
3212	gfc_basic_typename (ts->type), original_kind);
3213	return MATCH_ERROR;
3214	}
3215	ts->kind /= 2;
3216
3217	}
3218
3219	if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3220	ts->kind = 8;
3221
3222	if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3223	{
3224	if (ts->kind == 4)
3225	{
3226	if (flag_real4_kind == 8)
3227	ts->kind = 8;
3228	if (flag_real4_kind == 10)
3229	ts->kind = 10;
3230	if (flag_real4_kind == 16)
3231	ts->kind = 16;
3232	}
3233	else if (ts->kind == 8)
3234	{
3235	if (flag_real8_kind == 4)
3236	ts->kind = 4;
3237	if (flag_real8_kind == 10)
3238	ts->kind = 10;
3239	if (flag_real8_kind == 16)
3240	ts->kind = 16;
3241	}
3242	}
3243
3244	if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3245	{
3246	gfc_error ("Old-style type declaration %s*%d not supported at %C",
3247	gfc_basic_typename (ts->type), original_kind);
3248	return MATCH_ERROR;
3249	}
3250
3251	if (!gfc_notify_std (GFC_STD_GNU,
3252	"Nonstandard type declaration %s*%d at %C",
3253	gfc_basic_typename(ts->type), original_kind))
3254	return MATCH_ERROR;
3255
3256	return MATCH_YES;
3257	}
3258
3259
3260	/* Match a kind specification. Since kinds are generally optional, we
3261	usually return MATCH_NO if something goes wrong. If a "kind="
3262	string is found, then we know we have an error. */
3263
3264	match
3265	gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3266	{
3267	locus where, loc;
3268	gfc_expr *e;
3269	match m, n;
3270	char c;
3271
3272	m = MATCH_NO;
3273	n = MATCH_YES;
3274	e = NULL;
3275	saved_kind_expr = NULL;
3276
3277	where = loc = gfc_current_locus;
3278
3279	if (kind_expr_only)
3280	goto kind_expr;
3281
3282	if (gfc_match_char ('(') == MATCH_NO)
3283	return MATCH_NO;
3284
3285	/* Also gobbles optional text. */
3286	if (gfc_match (" kind = ") == MATCH_YES)
3287	m = MATCH_ERROR;
3288
3289	loc = gfc_current_locus;
3290
3291	kind_expr:
3292
3293	n = gfc_match_init_expr (&e);
3294
3295	if (gfc_derived_parameter_expr (e))
3296	{
3297	ts->kind = 0;
3298	saved_kind_expr = gfc_copy_expr (e);
3299	goto close_brackets;
3300	}
3301
3302	if (n != MATCH_YES)
3303	{
3304	if (gfc_matching_function)
3305	{
3306	/* The function kind expression might include use associated or
3307	imported parameters and try again after the specification
3308	expressions..... */
3309	if (gfc_match_char (')') != MATCH_YES)
3310	{
3311	gfc_error ("Missing right parenthesis at %C");
3312	m = MATCH_ERROR;
3313	goto no_match;
3314	}
3315
3316	gfc_free_expr (e);
3317	gfc_undo_symbols ();
3318	return MATCH_YES;
3319	}
3320	else
3321	{
3322	/* ....or else, the match is real. */
3323	if (n == MATCH_NO)
3324	gfc_error ("Expected initialization expression at %C");
3325	if (n != MATCH_YES)
3326	return MATCH_ERROR;
3327	}
3328	}
3329
3330	if (e->rank != 0)
3331	{
3332	gfc_error ("Expected scalar initialization expression at %C");
3333	m = MATCH_ERROR;
3334	goto no_match;
3335	}
3336
3337	if (gfc_extract_int (e, &ts->kind, 1))
3338	{
3339	m = MATCH_ERROR;
3340	goto no_match;
3341	}
3342
3343	/* Before throwing away the expression, let's see if we had a
3344	C interoperable kind (and store the fact). */
3345	if (e->ts.is_c_interop == 1)
3346	{
3347	/* Mark this as C interoperable if being declared with one
3348	of the named constants from iso_c_binding. */
3349	ts->is_c_interop = e->ts.is_iso_c;
3350	ts->f90_type = e->ts.f90_type;
3351	if (e->symtree)
3352	ts->interop_kind = e->symtree->n.sym;
3353	}
3354
3355	gfc_free_expr (e);
3356	e = NULL;
3357
3358	/* Ignore errors to this point, if we've gotten here. This means
3359	we ignore the m=MATCH_ERROR from above. */
3360	if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3361	{
3362	gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3363	gfc_basic_typename (ts->type));
3364	gfc_current_locus = where;
3365	return MATCH_ERROR;
3366	}
3367
3368	/* Warn if, e.g., c_int is used for a REAL variable, but not
3369	if, e.g., c_double is used for COMPLEX as the standard
3370	explicitly says that the kind type parameter for complex and real
3371	variable is the same, i.e. c_float == c_float_complex. */
3372	if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3373	&& !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3374	|| (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3375	gfc_warning_now (opt: 0, "C kind type parameter is for type %s but type at %L "
3376	"is %s", gfc_basic_typename (ts->f90_type), &where,
3377	gfc_basic_typename (ts->type));
3378
3379	close_brackets:
3380
3381	gfc_gobble_whitespace ();
3382	if ((c = gfc_next_ascii_char ()) != ')'
3383	&& (ts->type != BT_CHARACTER || c != ','))
3384	{
3385	if (ts->type == BT_CHARACTER)
3386	gfc_error ("Missing right parenthesis or comma at %C");
3387	else
3388	gfc_error ("Missing right parenthesis at %C");
3389	m = MATCH_ERROR;
3390	goto no_match;
3391	}
3392	else
3393	/* All tests passed. */
3394	m = MATCH_YES;
3395
3396	if(m == MATCH_ERROR)
3397	gfc_current_locus = where;
3398
3399	if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3400	ts->kind = 8;
3401
3402	if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3403	{
3404	if (ts->kind == 4)
3405	{
3406	if (flag_real4_kind == 8)
3407	ts->kind = 8;
3408	if (flag_real4_kind == 10)
3409	ts->kind = 10;
3410	if (flag_real4_kind == 16)
3411	ts->kind = 16;
3412	}
3413	else if (ts->kind == 8)
3414	{
3415	if (flag_real8_kind == 4)
3416	ts->kind = 4;
3417	if (flag_real8_kind == 10)
3418	ts->kind = 10;
3419	if (flag_real8_kind == 16)
3420	ts->kind = 16;
3421	}
3422	}
3423
3424	/* Return what we know from the test(s). */
3425	return m;
3426
3427	no_match:
3428	gfc_free_expr (e);
3429	gfc_current_locus = where;
3430	return m;
3431	}
3432
3433
3434	static match
3435	match_char_kind (int * kind, int * is_iso_c)
3436	{
3437	locus where;
3438	gfc_expr *e;
3439	match m, n;
3440	bool fail;
3441
3442	m = MATCH_NO;
3443	e = NULL;
3444	where = gfc_current_locus;
3445
3446	n = gfc_match_init_expr (&e);
3447
3448	if (n != MATCH_YES && gfc_matching_function)
3449	{
3450	/* The expression might include use-associated or imported
3451	parameters and try again after the specification
3452	expressions. */
3453	gfc_free_expr (e);
3454	gfc_undo_symbols ();
3455	return MATCH_YES;
3456	}
3457
3458	if (n == MATCH_NO)
3459	gfc_error ("Expected initialization expression at %C");
3460	if (n != MATCH_YES)
3461	return MATCH_ERROR;
3462
3463	if (e->rank != 0)
3464	{
3465	gfc_error ("Expected scalar initialization expression at %C");
3466	m = MATCH_ERROR;
3467	goto no_match;
3468	}
3469
3470	if (gfc_derived_parameter_expr (e))
3471	{
3472	saved_kind_expr = e;
3473	*kind = 0;
3474	return MATCH_YES;
3475	}
3476
3477	fail = gfc_extract_int (e, kind, 1);
3478	*is_iso_c = e->ts.is_iso_c;
3479	if (fail)
3480	{
3481	m = MATCH_ERROR;
3482	goto no_match;
3483	}
3484
3485	gfc_free_expr (e);
3486
3487	/* Ignore errors to this point, if we've gotten here. This means
3488	we ignore the m=MATCH_ERROR from above. */
3489	if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3490	{
3491	gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3492	m = MATCH_ERROR;
3493	}
3494	else
3495	/* All tests passed. */
3496	m = MATCH_YES;
3497
3498	if (m == MATCH_ERROR)
3499	gfc_current_locus = where;
3500
3501	/* Return what we know from the test(s). */
3502	return m;
3503
3504	no_match:
3505	gfc_free_expr (e);
3506	gfc_current_locus = where;
3507	return m;
3508	}
3509
3510
3511	/* Match the various kind/length specifications in a CHARACTER
3512	declaration. We don't return MATCH_NO. */
3513
3514	match
3515	gfc_match_char_spec (gfc_typespec *ts)
3516	{
3517	int kind, seen_length, is_iso_c;
3518	gfc_charlen *cl;
3519	gfc_expr *len;
3520	match m;
3521	bool deferred;
3522
3523	len = NULL;
3524	seen_length = 0;
3525	kind = 0;
3526	is_iso_c = 0;
3527	deferred = false;
3528
3529	/* Try the old-style specification first. */
3530	old_char_selector = 0;
3531
3532	m = match_char_length (expr: &len, deferred: &deferred, obsolescent_check: true);
3533	if (m != MATCH_NO)
3534	{
3535	if (m == MATCH_YES)
3536	old_char_selector = 1;
3537	seen_length = 1;
3538	goto done;
3539	}
3540
3541	m = gfc_match_char ('(');
3542	if (m != MATCH_YES)
3543	{
3544	m = MATCH_YES; /* Character without length is a single char. */
3545	goto done;
3546	}
3547
3548	/* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3549	if (gfc_match (" kind =") == MATCH_YES)
3550	{
3551	m = match_char_kind (kind: &kind, is_iso_c: &is_iso_c);
3552
3553	if (m == MATCH_ERROR)
3554	goto done;
3555	if (m == MATCH_NO)
3556	goto syntax;
3557
3558	if (gfc_match (" , len =") == MATCH_NO)
3559	goto rparen;
3560
3561	m = char_len_param_value (expr: &len, deferred: &deferred);
3562	if (m == MATCH_NO)
3563	goto syntax;
3564	if (m == MATCH_ERROR)
3565	goto done;
3566	seen_length = 1;
3567
3568	goto rparen;
3569	}
3570
3571	/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3572	if (gfc_match (" len =") == MATCH_YES)
3573	{
3574	m = char_len_param_value (expr: &len, deferred: &deferred);
3575	if (m == MATCH_NO)
3576	goto syntax;
3577	if (m == MATCH_ERROR)
3578	goto done;
3579	seen_length = 1;
3580
3581	if (gfc_match_char (')') == MATCH_YES)
3582	goto done;
3583
3584	if (gfc_match (" , kind =") != MATCH_YES)
3585	goto syntax;
3586
3587	if (match_char_kind (kind: &kind, is_iso_c: &is_iso_c) == MATCH_ERROR)
3588	goto done;
3589
3590	goto rparen;
3591	}
3592
3593	/* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3594	m = char_len_param_value (expr: &len, deferred: &deferred);
3595	if (m == MATCH_NO)
3596	goto syntax;
3597	if (m == MATCH_ERROR)
3598	goto done;
3599	seen_length = 1;
3600
3601	m = gfc_match_char (')');
3602	if (m == MATCH_YES)
3603	goto done;
3604
3605	if (gfc_match_char (',') != MATCH_YES)
3606	goto syntax;
3607
3608	gfc_match (" kind ="); /* Gobble optional text. */
3609
3610	m = match_char_kind (kind: &kind, is_iso_c: &is_iso_c);
3611	if (m == MATCH_ERROR)
3612	goto done;
3613	if (m == MATCH_NO)
3614	goto syntax;
3615
3616	rparen:
3617	/* Require a right-paren at this point. */
3618	m = gfc_match_char (')');
3619	if (m == MATCH_YES)
3620	goto done;
3621
3622	syntax:
3623	gfc_error ("Syntax error in CHARACTER declaration at %C");
3624	m = MATCH_ERROR;
3625	gfc_free_expr (len);
3626	return m;
3627
3628	done:
3629	/* Deal with character functions after USE and IMPORT statements. */
3630	if (gfc_matching_function)
3631	{
3632	gfc_free_expr (len);
3633	gfc_undo_symbols ();
3634	return MATCH_YES;
3635	}
3636
3637	if (m != MATCH_YES)
3638	{
3639	gfc_free_expr (len);
3640	return m;
3641	}
3642
3643	/* Do some final massaging of the length values. */
3644	cl = gfc_new_charlen (gfc_current_ns, NULL);
3645
3646	if (seen_length == 0)
3647	cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3648	else
3649	{
3650	/* If gfortran ends up here, then len may be reducible to a constant.
3651	Try to do that here. If it does not reduce, simply assign len to
3652	charlen. A complication occurs with user-defined generic functions,
3653	which are not resolved. Use a private namespace to deal with
3654	generic functions. */
3655
3656	if (len && len->expr_type != EXPR_CONSTANT)
3657	{
3658	gfc_namespace *old_ns;
3659	gfc_expr *e;
3660
3661	old_ns = gfc_current_ns;
3662	gfc_current_ns = gfc_get_namespace (NULL, 0);
3663
3664	e = gfc_copy_expr (len);
3665	gfc_push_suppress_errors ();
3666	gfc_reduce_init_expr (expr: e);
3667	gfc_pop_suppress_errors ();
3668	if (e->expr_type == EXPR_CONSTANT)
3669	{
3670	gfc_replace_expr (len, e);
3671	if (mpz_cmp_si (len->value.integer, 0) < 0)
3672	mpz_set_ui (len->value.integer, 0);
3673	}
3674	else
3675	gfc_free_expr (e);
3676
3677	gfc_free_namespace (gfc_current_ns);
3678	gfc_current_ns = old_ns;
3679	}
3680
3681	cl->length = len;
3682	}
3683
3684	ts->u.cl = cl;
3685	ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3686	ts->deferred = deferred;
3687
3688	/* We have to know if it was a C interoperable kind so we can
3689	do accurate type checking of bind(c) procs, etc. */
3690	if (kind != 0)
3691	/* Mark this as C interoperable if being declared with one
3692	of the named constants from iso_c_binding. */
3693	ts->is_c_interop = is_iso_c;
3694	else if (len != NULL)
3695	/* Here, we might have parsed something such as: character(c_char)
3696	In this case, the parsing code above grabs the c_char when
3697	looking for the length (line 1690, roughly). it's the last
3698	testcase for parsing the kind params of a character variable.
3699	However, it's not actually the length. this seems like it
3700	could be an error.
3701	To see if the user used a C interop kind, test the expr
3702	of the so called length, and see if it's C interoperable. */
3703	ts->is_c_interop = len->ts.is_iso_c;
3704
3705	return MATCH_YES;
3706	}
3707
3708
3709	/* Matches a RECORD declaration. */
3710
3711	static match
3712	match_record_decl (char *name)
3713	{
3714	locus old_loc;
3715	old_loc = gfc_current_locus;
3716	match m;
3717
3718	m = gfc_match (" record /");
3719	if (m == MATCH_YES)
3720	{
3721	if (!flag_dec_structure)
3722	{
3723	gfc_current_locus = old_loc;
3724	gfc_error ("RECORD at %C is an extension, enable it with "
3725	"%<-fdec-structure%>");
3726	return MATCH_ERROR;
3727	}
3728	m = gfc_match (" %n/", name);
3729	if (m == MATCH_YES)
3730	return MATCH_YES;
3731	}
3732
3733	gfc_current_locus = old_loc;
3734	if (flag_dec_structure
3735	&& (gfc_match (" record% ") == MATCH_YES
3736	|| gfc_match (" record%t") == MATCH_YES))
3737	gfc_error ("Structure name expected after RECORD at %C");
3738	if (m == MATCH_NO)
3739	return MATCH_NO;
3740
3741	return MATCH_ERROR;
3742	}
3743
3744
3745	/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3746	of expressions to substitute into the possibly parameterized expression
3747	'e'. Using a list is inefficient but should not be too bad since the
3748	number of type parameters is not likely to be large. */
3749	static bool
3750	insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3751	int* f)
3752	{
3753	gfc_actual_arglist *param;
3754	gfc_expr *copy;
3755
3756	if (e->expr_type != EXPR_VARIABLE)
3757	return false;
3758
3759	gcc_assert (e->symtree);
3760	if (e->symtree->n.sym->attr.pdt_kind
3761	|| (*f != 0 && e->symtree->n.sym->attr.pdt_len))
3762	{
3763	for (param = type_param_spec_list; param; param = param->next)
3764	if (strcmp (s1: e->symtree->n.sym->name, s2: param->name) == 0)
3765	break;
3766
3767	if (param)
3768	{
3769	copy = gfc_copy_expr (param->expr);
3770	*e = *copy;
3771	free (ptr: copy);
3772	}
3773	}
3774
3775	return false;
3776	}
3777
3778
3779	static bool
3780	gfc_insert_kind_parameter_exprs (gfc_expr *e)
3781	{
3782	return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3783	}
3784
3785
3786	bool
3787	gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3788	{
3789	gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3790	type_param_spec_list = param_list;
3791	bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3792	type_param_spec_list = old_param_spec_list;
3793	return res;
3794	}
3795
3796	/* Determines the instance of a parameterized derived type to be used by
3797	matching determining the values of the kind parameters and using them
3798	in the name of the instance. If the instance exists, it is used, otherwise
3799	a new derived type is created. */
3800	match
3801	gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3802	gfc_actual_arglist **ext_param_list)
3803	{
3804	/* The PDT template symbol. */
3805	gfc_symbol *pdt = *sym;
3806	/* The symbol for the parameter in the template f2k_namespace. */
3807	gfc_symbol *param;
3808	/* The hoped for instance of the PDT. */
3809	gfc_symbol *instance;
3810	/* The list of parameters appearing in the PDT declaration. */
3811	gfc_formal_arglist *type_param_name_list;
3812	/* Used to store the parameter specification list during recursive calls. */
3813	gfc_actual_arglist *old_param_spec_list;
3814	/* Pointers to the parameter specification being used. */
3815	gfc_actual_arglist *actual_param;
3816	gfc_actual_arglist *tail = NULL;
3817	/* Used to build up the name of the PDT instance. The prefix uses 4
3818	characters and each KIND parameter 2 more. Allow 8 of the latter. */
3819	char name[GFC_MAX_SYMBOL_LEN + 21];
3820
3821	bool name_seen = (param_list == NULL);
3822	bool assumed_seen = false;
3823	bool deferred_seen = false;
3824	bool spec_error = false;
3825	int kind_value, i;
3826	gfc_expr *kind_expr;
3827	gfc_component *c1, *c2;
3828	match m;
3829
3830	type_param_spec_list = NULL;
3831
3832	type_param_name_list = pdt->formal;
3833	actual_param = param_list;
3834	sprintf (s: name, format: "Pdt%s", pdt->name);
3835
3836	/* Run through the parameter name list and pick up the actual
3837	parameter values or use the default values in the PDT declaration. */
3838	for (; type_param_name_list;
3839	type_param_name_list = type_param_name_list->next)
3840	{
3841	if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3842	{
3843	if (actual_param->spec_type == SPEC_ASSUMED)
3844	spec_error = deferred_seen;
3845	else
3846	spec_error = assumed_seen;
3847
3848	if (spec_error)
3849	{
3850	gfc_error ("The type parameter spec list at %C cannot contain "
3851	"both ASSUMED and DEFERRED parameters");
3852	goto error_return;
3853	}
3854	}
3855
3856	if (actual_param && actual_param->name)
3857	name_seen = true;
3858	param = type_param_name_list->sym;
3859
3860	if (!param || !param->name)
3861	continue;
3862
3863	c1 = gfc_find_component (pdt, param->name, false, true, NULL);
3864	/* An error should already have been thrown in resolve.cc
3865	(resolve_fl_derived0). */
3866	if (!pdt->attr.use_assoc && !c1)
3867	goto error_return;
3868
3869	kind_expr = NULL;
3870	if (!name_seen)
3871	{
3872	if (!actual_param && !(c1 && c1->initializer))
3873	{
3874	gfc_error ("The type parameter spec list at %C does not contain "
3875	"enough parameter expressions");
3876	goto error_return;
3877	}
3878	else if (!actual_param && c1 && c1->initializer)
3879	kind_expr = gfc_copy_expr (c1->initializer);
3880	else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3881	kind_expr = gfc_copy_expr (actual_param->expr);
3882	}
3883	else
3884	{
3885	actual_param = param_list;
3886	for (;actual_param; actual_param = actual_param->next)
3887	if (actual_param->name
3888	&& strcmp (s1: actual_param->name, s2: param->name) == 0)
3889	break;
3890	if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3891	kind_expr = gfc_copy_expr (actual_param->expr);
3892	else
3893	{
3894	if (c1->initializer)
3895	kind_expr = gfc_copy_expr (c1->initializer);
3896	else if (!(actual_param && param->attr.pdt_len))
3897	{
3898	gfc_error ("The derived parameter %qs at %C does not "
3899	"have a default value", param->name);
3900	goto error_return;
3901	}
3902	}
3903	}
3904
3905	/* Store the current parameter expressions in a temporary actual
3906	arglist 'list' so that they can be substituted in the corresponding
3907	expressions in the PDT instance. */
3908	if (type_param_spec_list == NULL)
3909	{
3910	type_param_spec_list = gfc_get_actual_arglist ();
3911	tail = type_param_spec_list;
3912	}
3913	else
3914	{
3915	tail->next = gfc_get_actual_arglist ();
3916	tail = tail->next;
3917	}
3918	tail->name = param->name;
3919
3920	if (kind_expr)
3921	{
3922	/* Try simplification even for LEN expressions. */
3923	bool ok;
3924	gfc_resolve_expr (kind_expr);
3925	ok = gfc_simplify_expr (kind_expr, 1);
3926	/* Variable expressions seem to default to BT_PROCEDURE.
3927	TODO find out why this is and fix it. */
3928	if (kind_expr->ts.type != BT_INTEGER
3929	&& kind_expr->ts.type != BT_PROCEDURE)
3930	{
3931	gfc_error ("The parameter expression at %C must be of "
3932	"INTEGER type and not %s type",
3933	gfc_basic_typename (kind_expr->ts.type));
3934	goto error_return;
3935	}
3936	if (kind_expr->ts.type == BT_INTEGER && !ok)
3937	{
3938	gfc_error ("The parameter expression at %C does not "
3939	"simplify to an INTEGER constant");
3940	goto error_return;
3941	}
3942
3943	tail->expr = gfc_copy_expr (kind_expr);
3944	}
3945
3946	if (actual_param)
3947	tail->spec_type = actual_param->spec_type;
3948
3949	if (!param->attr.pdt_kind)
3950	{
3951	if (!name_seen && actual_param)
3952	actual_param = actual_param->next;
3953	if (kind_expr)
3954	{
3955	gfc_free_expr (kind_expr);
3956	kind_expr = NULL;
3957	}
3958	continue;
3959	}
3960
3961	if (actual_param
3962	&& (actual_param->spec_type == SPEC_ASSUMED
3963	|| actual_param->spec_type == SPEC_DEFERRED))
3964	{
3965	gfc_error ("The KIND parameter %qs at %C cannot either be "
3966	"ASSUMED or DEFERRED", param->name);
3967	goto error_return;
3968	}
3969
3970	if (!kind_expr || !gfc_is_constant_expr (kind_expr))
3971	{
3972	gfc_error ("The value for the KIND parameter %qs at %C does not "
3973	"reduce to a constant expression", param->name);
3974	goto error_return;
3975	}
3976
3977	gfc_extract_int (kind_expr, &kind_value);
3978	sprintf (s: name + strlen (s: name), format: "_%d", kind_value);
3979
3980	if (!name_seen && actual_param)
3981	actual_param = actual_param->next;
3982	gfc_free_expr (kind_expr);
3983	}
3984
3985	if (!name_seen && actual_param)
3986	{
3987	gfc_error ("The type parameter spec list at %C contains too many "
3988	"parameter expressions");
3989	goto error_return;
3990	}
3991
3992	/* Now we search for the PDT instance 'name'. If it doesn't exist, we
3993	build it, using 'pdt' as a template. */
3994	if (gfc_get_symbol (name, pdt->ns, &instance))
3995	{
3996	gfc_error ("Parameterized derived type at %C is ambiguous");
3997	goto error_return;
3998	}
3999
4000	m = MATCH_YES;
4001
4002	if (instance->attr.flavor == FL_DERIVED
4003	&& instance->attr.pdt_type)
4004	{
4005	instance->refs++;
4006	if (ext_param_list)
4007	*ext_param_list = type_param_spec_list;
4008	*sym = instance;
4009	gfc_commit_symbols ();
4010	return m;
4011	}
4012
4013	/* Start building the new instance of the parameterized type. */
4014	gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4015	instance->attr.pdt_template = 0;
4016	instance->attr.pdt_type = 1;
4017	instance->declared_at = gfc_current_locus;
4018
4019	/* Add the components, replacing the parameters in all expressions
4020	with the expressions for their values in 'type_param_spec_list'. */
4021	c1 = pdt->components;
4022	tail = type_param_spec_list;
4023	for (; c1; c1 = c1->next)
4024	{
4025	gfc_add_component (instance, c1->name, &c2);
4026
4027	c2->ts = c1->ts;
4028	c2->attr = c1->attr;
4029
4030	/* The order of declaration of the type_specs might not be the
4031	same as that of the components. */
4032	if (c1->attr.pdt_kind || c1->attr.pdt_len)
4033	{
4034	for (tail = type_param_spec_list; tail; tail = tail->next)
4035	if (strcmp (s1: c1->name, s2: tail->name) == 0)
4036	break;
4037	}
4038
4039	/* Deal with type extension by recursively calling this function
4040	to obtain the instance of the extended type. */
4041	if (gfc_current_state () != COMP_DERIVED
4042	&& c1 == pdt->components
4043	&& (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4044	&& c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
4045	&& gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4046	{
4047	gfc_formal_arglist *f;
4048
4049	old_param_spec_list = type_param_spec_list;
4050
4051	/* Obtain a spec list appropriate to the extended type..*/
4052	actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4053	type_param_spec_list = actual_param;
4054	for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4055	actual_param = actual_param->next;
4056	if (actual_param)
4057	{
4058	gfc_free_actual_arglist (actual_param->next);
4059	actual_param->next = NULL;
4060	}
4061
4062	/* Now obtain the PDT instance for the extended type. */
4063	c2->param_list = type_param_spec_list;
4064	m = gfc_get_pdt_instance (param_list: type_param_spec_list, sym: &c2->ts.u.derived,
4065	NULL);
4066	type_param_spec_list = old_param_spec_list;
4067
4068	c2->ts.u.derived->refs++;
4069	gfc_set_sym_referenced (c2->ts.u.derived);
4070
4071	/* Set extension level. */
4072	if (c2->ts.u.derived->attr.extension == 255)
4073	{
4074	/* Since the extension field is 8 bit wide, we can only have
4075	up to 255 extension levels. */
4076	gfc_error ("Maximum extension level reached with type %qs at %L",
4077	c2->ts.u.derived->name,
4078	&c2->ts.u.derived->declared_at);
4079	goto error_return;
4080	}
4081	instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4082
4083	continue;
4084	}
4085
4086	/* Set the component kind using the parameterized expression. */
4087	if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4088	&& c1->kind_expr != NULL)
4089	{
4090	gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4091	gfc_insert_kind_parameter_exprs (e);
4092	gfc_simplify_expr (e, 1);
4093	gfc_extract_int (e, &c2->ts.kind);
4094	gfc_free_expr (e);
4095	if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4096	{
4097	gfc_error ("Kind %d not supported for type %s at %C",
4098	c2->ts.kind, gfc_basic_typename (c2->ts.type));
4099	goto error_return;
4100	}
4101	}
4102
4103	/* Similarly, set the string length if parameterized. */
4104	if (c1->ts.type == BT_CHARACTER
4105	&& c1->ts.u.cl->length
4106	&& gfc_derived_parameter_expr (c1->ts.u.cl->length))
4107	{
4108	gfc_expr *e;
4109	e = gfc_copy_expr (c1->ts.u.cl->length);
4110	gfc_insert_kind_parameter_exprs (e);
4111	gfc_simplify_expr (e, 1);
4112	c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4113	c2->ts.u.cl->length = e;
4114	c2->attr.pdt_string = 1;
4115	}
4116
4117	/* Set up either the KIND/LEN initializer, if constant,
4118	or the parameterized expression. Use the template
4119	initializer if one is not already set in this instance. */
4120	if (c2->attr.pdt_kind || c2->attr.pdt_len)
4121	{
4122	if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4123	c2->initializer = gfc_copy_expr (tail->expr);
4124	else if (tail && tail->expr)
4125	{
4126	c2->param_list = gfc_get_actual_arglist ();
4127	c2->param_list->name = tail->name;
4128	c2->param_list->expr = gfc_copy_expr (tail->expr);
4129	c2->param_list->next = NULL;
4130	}
4131
4132	if (!c2->initializer && c1->initializer)
4133	c2->initializer = gfc_copy_expr (c1->initializer);
4134	}
4135
4136	/* Copy the array spec. */
4137	c2->as = gfc_copy_array_spec (c1->as);
4138	if (c1->ts.type == BT_CLASS)
4139	CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4140
4141	/* Determine if an array spec is parameterized. If so, substitute
4142	in the parameter expressions for the bounds and set the pdt_array
4143	attribute. Notice that this attribute must be unconditionally set
4144	if this is an array of parameterized character length. */
4145	if (c1->as && c1->as->type == AS_EXPLICIT)
4146	{
4147	bool pdt_array = false;
4148
4149	/* Are the bounds of the array parameterized? */
4150	for (i = 0; i < c1->as->rank; i++)
4151	{
4152	if (gfc_derived_parameter_expr (c1->as->lower[i]))
4153	pdt_array = true;
4154	if (gfc_derived_parameter_expr (c1->as->upper[i]))
4155	pdt_array = true;
4156	}
4157
4158	/* If they are, free the expressions for the bounds and
4159	replace them with the template expressions with substitute
4160	values. */
4161	for (i = 0; pdt_array && i < c1->as->rank; i++)
4162	{
4163	gfc_expr *e;
4164	e = gfc_copy_expr (c1->as->lower[i]);
4165	gfc_insert_kind_parameter_exprs (e);
4166	gfc_simplify_expr (e, 1);
4167	gfc_free_expr (c2->as->lower[i]);
4168	c2->as->lower[i] = e;
4169	e = gfc_copy_expr (c1->as->upper[i]);
4170	gfc_insert_kind_parameter_exprs (e);
4171	gfc_simplify_expr (e, 1);
4172	gfc_free_expr (c2->as->upper[i]);
4173	c2->as->upper[i] = e;
4174	}
4175	c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
4176	if (c1->initializer)
4177	{
4178	c2->initializer = gfc_copy_expr (c1->initializer);
4179	gfc_insert_kind_parameter_exprs (e: c2->initializer);
4180	gfc_simplify_expr (c2->initializer, 1);
4181	}
4182	}
4183
4184	/* Recurse into this function for PDT components. */
4185	if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4186	&& c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4187	{
4188	gfc_actual_arglist *params;
4189	/* The component in the template has a list of specification
4190	expressions derived from its declaration. */
4191	params = gfc_copy_actual_arglist (c1->param_list);
4192	actual_param = params;
4193	/* Substitute the template parameters with the expressions
4194	from the specification list. */
4195	for (;actual_param; actual_param = actual_param->next)
4196	gfc_insert_parameter_exprs (e: actual_param->expr,
4197	param_list: type_param_spec_list);
4198
4199	/* Now obtain the PDT instance for the component. */
4200	old_param_spec_list = type_param_spec_list;
4201	m = gfc_get_pdt_instance (param_list: params, sym: &c2->ts.u.derived, NULL);
4202	type_param_spec_list = old_param_spec_list;
4203
4204	c2->param_list = params;
4205	if (!(c2->attr.pointer || c2->attr.allocatable))
4206	c2->initializer = gfc_default_initializer (&c2->ts);
4207
4208	if (c2->attr.allocatable)
4209	instance->attr.alloc_comp = 1;
4210	}
4211	}
4212
4213	gfc_commit_symbol (instance);
4214	if (ext_param_list)
4215	*ext_param_list = type_param_spec_list;
4216	*sym = instance;
4217	return m;
4218
4219	error_return:
4220	gfc_free_actual_arglist (type_param_spec_list);
4221	return MATCH_ERROR;
4222	}
4223
4224
4225	/* Match a legacy nonstandard BYTE type-spec. */
4226
4227	static match
4228	match_byte_typespec (gfc_typespec *ts)
4229	{
4230	if (gfc_match (" byte") == MATCH_YES)
4231	{
4232	if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4233	return MATCH_ERROR;
4234
4235	if (gfc_current_form == FORM_FREE)
4236	{
4237	char c = gfc_peek_ascii_char ();
4238	if (!gfc_is_whitespace (c) && c != ',')
4239	return MATCH_NO;
4240	}
4241
4242	if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4243	{
4244	gfc_error ("BYTE type used at %C "
4245	"is not available on the target machine");
4246	return MATCH_ERROR;
4247	}
4248
4249	ts->type = BT_INTEGER;
4250	ts->kind = 1;
4251	return MATCH_YES;
4252	}
4253	return MATCH_NO;
4254	}
4255
4256
4257	/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4258	structure to the matched specification. This is necessary for FUNCTION and
4259	IMPLICIT statements.
4260
4261	If implicit_flag is nonzero, then we don't check for the optional
4262	kind specification. Not doing so is needed for matching an IMPLICIT
4263	statement correctly. */
4264
4265	match
4266	gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4267	{
4268	/* Provide sufficient space to hold "pdtsymbol". */
4269	char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4270	gfc_symbol *sym, *dt_sym;
4271	match m;
4272	char c;
4273	bool seen_deferred_kind, matched_type;
4274	const char *dt_name;
4275
4276	decl_type_param_list = NULL;
4277
4278	/* A belt and braces check that the typespec is correctly being treated
4279	as a deferred characteristic association. */
4280	seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4281	&& (gfc_current_block ()->result->ts.kind == -1)
4282	&& (ts->kind == -1);
4283	gfc_clear_ts (ts);
4284	if (seen_deferred_kind)
4285	ts->kind = -1;
4286
4287	/* Clear the current binding label, in case one is given. */
4288	curr_binding_label = NULL;
4289
4290	/* Match BYTE type-spec. */
4291	m = match_byte_typespec (ts);
4292	if (m != MATCH_NO)
4293	return m;
4294
4295	m = gfc_match (" type (");
4296	matched_type = (m == MATCH_YES);
4297	if (matched_type)
4298	{
4299	gfc_gobble_whitespace ();
4300	if (gfc_peek_ascii_char () == '*')
4301	{
4302	if ((m = gfc_match ("* ) ")) != MATCH_YES)
4303	return m;
4304	if (gfc_comp_struct (gfc_current_state ()))
4305	{
4306	gfc_error ("Assumed type at %C is not allowed for components");
4307	return MATCH_ERROR;
4308	}
4309	if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4310	return MATCH_ERROR;
4311	ts->type = BT_ASSUMED;
4312	return MATCH_YES;
4313	}
4314
4315	m = gfc_match ("%n", name);
4316	matched_type = (m == MATCH_YES);
4317	}
4318
4319	if ((matched_type && strcmp (s1: "integer", s2: name) == 0)
4320	|| (!matched_type && gfc_match (" integer") == MATCH_YES))
4321	{
4322	ts->type = BT_INTEGER;
4323	ts->kind = gfc_default_integer_kind;
4324	goto get_kind;
4325	}
4326
4327	if ((matched_type && strcmp (s1: "character", s2: name) == 0)
4328	|| (!matched_type && gfc_match (" character") == MATCH_YES))
4329	{
4330	if (matched_type
4331	&& !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4332	"intrinsic-type-spec at %C"))
4333	return MATCH_ERROR;
4334
4335	ts->type = BT_CHARACTER;
4336	if (implicit_flag == 0)
4337	m = gfc_match_char_spec (ts);
4338	else
4339	m = MATCH_YES;
4340
4341	if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4342	{
4343	gfc_error ("Malformed type-spec at %C");
4344	return MATCH_ERROR;
4345	}
4346
4347	return m;
4348	}
4349
4350	if ((matched_type && strcmp (s1: "real", s2: name) == 0)
4351	|| (!matched_type && gfc_match (" real") == MATCH_YES))
4352	{
4353	ts->type = BT_REAL;
4354	ts->kind = gfc_default_real_kind;
4355	goto get_kind;
4356	}
4357
4358	if ((matched_type
4359	&& (strcmp (s1: "doubleprecision", s2: name) == 0
4360	|| (strcmp (s1: "double", s2: name) == 0
4361	&& gfc_match (" precision") == MATCH_YES)))
4362	|| (!matched_type && gfc_match (" double precision") == MATCH_YES))
4363	{
4364	if (matched_type
4365	&& !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4366	"intrinsic-type-spec at %C"))
4367	return MATCH_ERROR;
4368
4369	if (matched_type && gfc_match_char (')') != MATCH_YES)
4370	{
4371	gfc_error ("Malformed type-spec at %C");
4372	return MATCH_ERROR;
4373	}
4374
4375	ts->type = BT_REAL;
4376	ts->kind = gfc_default_double_kind;
4377	return MATCH_YES;
4378	}
4379
4380	if ((matched_type && strcmp (s1: "complex", s2: name) == 0)
4381	|| (!matched_type && gfc_match (" complex") == MATCH_YES))
4382	{
4383	ts->type = BT_COMPLEX;
4384	ts->kind = gfc_default_complex_kind;
4385	goto get_kind;
4386	}
4387
4388	if ((matched_type
4389	&& (strcmp (s1: "doublecomplex", s2: name) == 0
4390	|| (strcmp (s1: "double", s2: name) == 0
4391	&& gfc_match (" complex") == MATCH_YES)))
4392	|| (!matched_type && gfc_match (" double complex") == MATCH_YES))
4393	{
4394	if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4395	return MATCH_ERROR;
4396
4397	if (matched_type
4398	&& !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4399	"intrinsic-type-spec at %C"))
4400	return MATCH_ERROR;
4401
4402	if (matched_type && gfc_match_char (')') != MATCH_YES)
4403	{
4404	gfc_error ("Malformed type-spec at %C");
4405	return MATCH_ERROR;
4406	}
4407
4408	ts->type = BT_COMPLEX;
4409	ts->kind = gfc_default_double_kind;
4410	return MATCH_YES;
4411	}
4412
4413	if ((matched_type && strcmp (s1: "logical", s2: name) == 0)
4414	|| (!matched_type && gfc_match (" logical") == MATCH_YES))
4415	{
4416	ts->type = BT_LOGICAL;
4417	ts->kind = gfc_default_logical_kind;
4418	goto get_kind;
4419	}
4420
4421	if (matched_type)
4422	{
4423	m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4424	if (m == MATCH_ERROR)
4425	return m;
4426
4427	gfc_gobble_whitespace ();
4428	if (gfc_peek_ascii_char () != ')')
4429	{
4430	gfc_error ("Malformed type-spec at %C");
4431	return MATCH_ERROR;
4432	}
4433	m = gfc_match_char (')'); /* Burn closing ')'. */
4434	}
4435
4436	if (m != MATCH_YES)
4437	m = match_record_decl (name);
4438
4439	if (matched_type || m == MATCH_YES)
4440	{
4441	ts->type = BT_DERIVED;
4442	/* We accept record/s/ or type(s) where s is a structure, but we
4443	* don't need all the extra derived-type stuff for structures. */
4444	if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4445	{
4446	gfc_error ("Type name %qs at %C is ambiguous", name);
4447	return MATCH_ERROR;
4448	}
4449
4450	if (sym && sym->attr.flavor == FL_DERIVED
4451	&& sym->attr.pdt_template
4452	&& gfc_current_state () != COMP_DERIVED)
4453	{
4454	m = gfc_get_pdt_instance (param_list: decl_type_param_list, sym: &sym, NULL);
4455	if (m != MATCH_YES)
4456	return m;
4457	gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4458	ts->u.derived = sym;
4459	const char* lower = gfc_dt_lower_string (sym->name);
4460	size_t len = strlen (s: lower);
4461	/* Reallocate with sufficient size. */
4462	if (len > GFC_MAX_SYMBOL_LEN)
4463	name = XALLOCAVEC (char, len + 1);
4464	memcpy (dest: name, src: lower, n: len);
4465	name[len] = '\0';
4466	}
4467
4468	if (sym && sym->attr.flavor == FL_STRUCT)
4469	{
4470	ts->u.derived = sym;
4471	return MATCH_YES;
4472	}
4473	/* Actually a derived type. */
4474	}
4475
4476	else
4477	{
4478	/* Match nested STRUCTURE declarations; only valid within another
4479	structure declaration. */
4480	if (flag_dec_structure
4481	&& (gfc_current_state () == COMP_STRUCTURE
4482	|| gfc_current_state () == COMP_MAP))
4483	{
4484	m = gfc_match (" structure");
4485	if (m == MATCH_YES)
4486	{
4487	m = gfc_match_structure_decl ();
4488	if (m == MATCH_YES)
4489	{
4490	/* gfc_new_block is updated by match_structure_decl. */
4491	ts->type = BT_DERIVED;
4492	ts->u.derived = gfc_new_block;
4493	return MATCH_YES;
4494	}
4495	}
4496	if (m == MATCH_ERROR)
4497	return MATCH_ERROR;
4498	}
4499
4500	/* Match CLASS declarations. */
4501	m = gfc_match (" class ( * )");
4502	if (m == MATCH_ERROR)
4503	return MATCH_ERROR;
4504	else if (m == MATCH_YES)
4505	{
4506	gfc_symbol *upe;
4507	gfc_symtree *st;
4508	ts->type = BT_CLASS;
4509	gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4510	if (upe == NULL)
4511	{
4512	upe = gfc_new_symbol ("STAR", gfc_current_ns);
4513	st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4514	st->n.sym = upe;
4515	gfc_set_sym_referenced (upe);
4516	upe->refs++;
4517	upe->ts.type = BT_VOID;
4518	upe->attr.unlimited_polymorphic = 1;
4519	/* This is essential to force the construction of
4520	unlimited polymorphic component class containers. */
4521	upe->attr.zero_comp = 1;
4522	if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4523	&gfc_current_locus))
4524	return MATCH_ERROR;
4525	}
4526	else
4527	{
4528	st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4529	st->n.sym = upe;
4530	upe->refs++;
4531	}
4532	ts->u.derived = upe;
4533	return m;
4534	}
4535
4536	m = gfc_match (" class (");
4537
4538	if (m == MATCH_YES)
4539	m = gfc_match ("%n", name);
4540	else
4541	return m;
4542
4543	if (m != MATCH_YES)
4544	return m;
4545	ts->type = BT_CLASS;
4546
4547	if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4548	return MATCH_ERROR;
4549
4550	m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4551	if (m == MATCH_ERROR)
4552	return m;
4553
4554	m = gfc_match_char (')');
4555	if (m != MATCH_YES)
4556	return m;
4557	}
4558
4559	/* Defer association of the derived type until the end of the
4560	specification block. However, if the derived type can be
4561	found, add it to the typespec. */
4562	if (gfc_matching_function)
4563	{
4564	ts->u.derived = NULL;
4565	if (gfc_current_state () != COMP_INTERFACE
4566	&& !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4567	{
4568	sym = gfc_find_dt_in_generic (sym);
4569	ts->u.derived = sym;
4570	}
4571	return MATCH_YES;
4572	}
4573
4574	/* Search for the name but allow the components to be defined later. If
4575	type = -1, this typespec has been seen in a function declaration but
4576	the type could not be accessed at that point. The actual derived type is
4577	stored in a symtree with the first letter of the name capitalized; the
4578	symtree with the all lower-case name contains the associated
4579	generic function. */
4580	dt_name = gfc_dt_upper_string (name);
4581	sym = NULL;
4582	dt_sym = NULL;
4583	if (ts->kind != -1)
4584	{
4585	gfc_get_ha_symbol (name, &sym);
4586	if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4587	{
4588	gfc_error ("Type name %qs at %C is ambiguous", name);
4589	return MATCH_ERROR;
4590	}
4591	if (sym->generic && !dt_sym)
4592	dt_sym = gfc_find_dt_in_generic (sym);
4593
4594	/* Host associated PDTs can get confused with their constructors
4595	because they ar instantiated in the template's namespace. */
4596	if (!dt_sym)
4597	{
4598	if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4599	{
4600	gfc_error ("Type name %qs at %C is ambiguous", name);
4601	return MATCH_ERROR;
4602	}
4603	if (dt_sym && !dt_sym->attr.pdt_type)
4604	dt_sym = NULL;
4605	}
4606	}
4607	else if (ts->kind == -1)
4608	{
4609	int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4610	|| gfc_current_ns->has_import_set;
4611	gfc_find_symbol (name, NULL, iface, &sym);
4612	if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4613	{
4614	gfc_error ("Type name %qs at %C is ambiguous", name);
4615	return MATCH_ERROR;
4616	}
4617	if (sym && sym->generic && !dt_sym)
4618	dt_sym = gfc_find_dt_in_generic (sym);
4619
4620	ts->kind = 0;
4621	if (sym == NULL)
4622	return MATCH_NO;
4623	}
4624
4625	if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4626	&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4627	|| sym->attr.subroutine)
4628	{
4629	gfc_error ("Type name %qs at %C conflicts with previously declared "
4630	"entity at %L, which has the same name", name,
4631	&sym->declared_at);
4632	return MATCH_ERROR;
4633	}
4634
4635	if (sym && sym->attr.flavor == FL_DERIVED
4636	&& sym->attr.pdt_template
4637	&& gfc_current_state () != COMP_DERIVED)
4638	{
4639	m = gfc_get_pdt_instance (param_list: decl_type_param_list, sym: &sym, NULL);
4640	if (m != MATCH_YES)
4641	return m;
4642	gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4643	ts->u.derived = sym;
4644	strcpy (dest: name, src: gfc_dt_lower_string (sym->name));
4645	}
4646
4647	gfc_save_symbol_data (sym);
4648	gfc_set_sym_referenced (sym);
4649	if (!sym->attr.generic
4650	&& !gfc_add_generic (&sym->attr, sym->name, NULL))
4651	return MATCH_ERROR;
4652
4653	if (!sym->attr.function
4654	&& !gfc_add_function (&sym->attr, sym->name, NULL))
4655	return MATCH_ERROR;
4656
4657	if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
4658	&& dt_sym->attr.pdt_template
4659	&& gfc_current_state () != COMP_DERIVED)
4660	{
4661	m = gfc_get_pdt_instance (param_list: decl_type_param_list, sym: &dt_sym, NULL);
4662	if (m != MATCH_YES)
4663	return m;
4664	gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
4665	}
4666
4667	if (!dt_sym)
4668	{
4669	gfc_interface *intr, *head;
4670
4671	/* Use upper case to save the actual derived-type symbol. */
4672	gfc_get_symbol (dt_name, NULL, &dt_sym);
4673	dt_sym->name = gfc_get_string ("%s", sym->name);
4674	head = sym->generic;
4675	intr = gfc_get_interface ();
4676	intr->sym = dt_sym;
4677	intr->where = gfc_current_locus;
4678	intr->next = head;
4679	sym->generic = intr;
4680	sym->attr.if_source = IFSRC_DECL;
4681	}
4682	else
4683	gfc_save_symbol_data (dt_sym);
4684
4685	gfc_set_sym_referenced (dt_sym);
4686
4687	if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
4688	&& !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
4689	return MATCH_ERROR;
4690
4691	ts->u.derived = dt_sym;
4692
4693	return MATCH_YES;
4694
4695	get_kind:
4696	if (matched_type
4697	&& !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4698	"intrinsic-type-spec at %C"))
4699	return MATCH_ERROR;
4700
4701	/* For all types except double, derived and character, look for an
4702	optional kind specifier. MATCH_NO is actually OK at this point. */
4703	if (implicit_flag == 1)
4704	{
4705	if (matched_type && gfc_match_char (')') != MATCH_YES)
4706	return MATCH_ERROR;
4707
4708	return MATCH_YES;
4709	}
4710
4711	if (gfc_current_form == FORM_FREE)
4712	{
4713	c = gfc_peek_ascii_char ();
4714	if (!gfc_is_whitespace (c) && c != '*' && c != '('
4715	&& c != ':' && c != ',')
4716	{
4717	if (matched_type && c == ')')
4718	{
4719	gfc_next_ascii_char ();
4720	return MATCH_YES;
4721	}
4722	gfc_error ("Malformed type-spec at %C");
4723	return MATCH_NO;
4724	}
4725	}
4726
4727	m = gfc_match_kind_spec (ts, kind_expr_only: false);
4728	if (m == MATCH_ERROR)
4729	return MATCH_ERROR;
4730
4731	if (m == MATCH_NO && ts->type != BT_CHARACTER)
4732	{
4733	m = gfc_match_old_kind_spec (ts);
4734	if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
4735	return MATCH_ERROR;
4736	}
4737
4738	if (matched_type && gfc_match_char (')') != MATCH_YES)
4739	{
4740	gfc_error ("Malformed type-spec at %C");
4741	return MATCH_ERROR;
4742	}
4743
4744	/* Defer association of the KIND expression of function results
4745	until after USE and IMPORT statements. */
4746	if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
4747	|| gfc_matching_function)
4748	return MATCH_YES;
4749
4750	if (m == MATCH_NO)
4751	m = MATCH_YES; /* No kind specifier found. */
4752
4753	return m;
4754	}
4755
4756
4757	/* Match an IMPLICIT NONE statement. Actually, this statement is
4758	already matched in parse.cc, or we would not end up here in the
4759	first place. So the only thing we need to check, is if there is
4760	trailing garbage. If not, the match is successful. */
4761
4762	match
4763	gfc_match_implicit_none (void)
4764	{
4765	char c;
4766	match m;
4767	char name[GFC_MAX_SYMBOL_LEN + 1];
4768	bool type = false;
4769	bool external = false;
4770	locus cur_loc = gfc_current_locus;
4771
4772	if (gfc_current_ns->seen_implicit_none
4773	|| gfc_current_ns->has_implicit_none_export)
4774	{
4775	gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4776	return MATCH_ERROR;
4777	}
4778
4779	gfc_gobble_whitespace ();
4780	c = gfc_peek_ascii_char ();
4781	if (c == '(')
4782	{
4783	(void) gfc_next_ascii_char ();
4784	if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
4785	return MATCH_ERROR;
4786
4787	gfc_gobble_whitespace ();
4788	if (gfc_peek_ascii_char () == ')')
4789	{
4790	(void) gfc_next_ascii_char ();
4791	type = true;
4792	}
4793	else
4794	for(;;)
4795	{
4796	m = gfc_match (" %n", name);
4797	if (m != MATCH_YES)
4798	return MATCH_ERROR;
4799
4800	if (strcmp (s1: name, s2: "type") == 0)
4801	type = true;
4802	else if (strcmp (s1: name, s2: "external") == 0)
4803	external = true;
4804	else
4805	return MATCH_ERROR;
4806
4807	gfc_gobble_whitespace ();
4808	c = gfc_next_ascii_char ();
4809	if (c == ',')
4810	continue;
4811	if (c == ')')
4812	break;
4813	return MATCH_ERROR;
4814	}
4815	}
4816	else
4817	type = true;
4818
4819	if (gfc_match_eos () != MATCH_YES)
4820	return MATCH_ERROR;
4821
4822	gfc_set_implicit_none (type, external, &cur_loc);
4823
4824	return MATCH_YES;
4825	}
4826
4827
4828	/* Match the letter range(s) of an IMPLICIT statement. */
4829
4830	static match
4831	match_implicit_range (void)
4832	{
4833	char c, c1, c2;
4834	int inner;
4835	locus cur_loc;
4836
4837	cur_loc = gfc_current_locus;
4838
4839	gfc_gobble_whitespace ();
4840	c = gfc_next_ascii_char ();
4841	if (c != '(')
4842	{
4843	gfc_error ("Missing character range in IMPLICIT at %C");
4844	goto bad;
4845	}
4846
4847	inner = 1;
4848	while (inner)
4849	{
4850	gfc_gobble_whitespace ();
4851	c1 = gfc_next_ascii_char ();
4852	if (!ISALPHA (c1))
4853	goto bad;
4854
4855	gfc_gobble_whitespace ();
4856	c = gfc_next_ascii_char ();
4857
4858	switch (c)
4859	{
4860	case ')':
4861	inner = 0; /* Fall through. */
4862
4863	case ',':
4864	c2 = c1;
4865	break;
4866
4867	case '-':
4868	gfc_gobble_whitespace ();
4869	c2 = gfc_next_ascii_char ();
4870	if (!ISALPHA (c2))
4871	goto bad;
4872
4873	gfc_gobble_whitespace ();
4874	c = gfc_next_ascii_char ();
4875
4876	if ((c != ',') && (c != ')'))
4877	goto bad;
4878	if (c == ')')
4879	inner = 0;
4880
4881	break;
4882
4883	default:
4884	goto bad;
4885	}
4886
4887	if (c1 > c2)
4888	{
4889	gfc_error ("Letters must be in alphabetic order in "
4890	"IMPLICIT statement at %C");
4891	goto bad;
4892	}
4893
4894	/* See if we can add the newly matched range to the pending
4895	implicits from this IMPLICIT statement. We do not check for
4896	conflicts with whatever earlier IMPLICIT statements may have
4897	set. This is done when we've successfully finished matching
4898	the current one. */
4899	if (!gfc_add_new_implicit_range (c1, c2))
4900	goto bad;
4901	}
4902
4903	return MATCH_YES;
4904
4905	bad:
4906	gfc_syntax_error (ST_IMPLICIT);
4907
4908	gfc_current_locus = cur_loc;
4909	return MATCH_ERROR;
4910	}
4911
4912
4913	/* Match an IMPLICIT statement, storing the types for
4914	gfc_set_implicit() if the statement is accepted by the parser.
4915	There is a strange looking, but legal syntactic construction
4916	possible. It looks like:
4917
4918	IMPLICIT INTEGER (a-b) (c-d)
4919
4920	This is legal if "a-b" is a constant expression that happens to
4921	equal one of the legal kinds for integers. The real problem
4922	happens with an implicit specification that looks like:
4923
4924	IMPLICIT INTEGER (a-b)
4925
4926	In this case, a typespec matcher that is "greedy" (as most of the
4927	matchers are) gobbles the character range as a kindspec, leaving
4928	nothing left. We therefore have to go a bit more slowly in the
4929	matching process by inhibiting the kindspec checking during
4930	typespec matching and checking for a kind later. */
4931
4932	match
4933	gfc_match_implicit (void)
4934	{
4935	gfc_typespec ts;
4936	locus cur_loc;
4937	char c;
4938	match m;
4939
4940	if (gfc_current_ns->seen_implicit_none)
4941	{
4942	gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4943	"statement");
4944	return MATCH_ERROR;
4945	}
4946
4947	gfc_clear_ts (&ts);
4948
4949	/* We don't allow empty implicit statements. */
4950	if (gfc_match_eos () == MATCH_YES)
4951	{
4952	gfc_error ("Empty IMPLICIT statement at %C");
4953	return MATCH_ERROR;
4954	}
4955
4956	do
4957	{
4958	/* First cleanup. */
4959	gfc_clear_new_implicit ();
4960
4961	/* A basic type is mandatory here. */
4962	m = gfc_match_decl_type_spec (ts: &ts, implicit_flag: 1);
4963	if (m == MATCH_ERROR)
4964	goto error;
4965	if (m == MATCH_NO)
4966	goto syntax;
4967
4968	cur_loc = gfc_current_locus;
4969	m = match_implicit_range ();
4970
4971	if (m == MATCH_YES)
4972	{
4973	/* We may have <TYPE> (<RANGE>). */
4974	gfc_gobble_whitespace ();
4975	c = gfc_peek_ascii_char ();
4976	if (c == ',' || c == '\n' || c == ';' || c == '!')
4977	{
4978	/* Check for CHARACTER with no length parameter. */
4979	if (ts.type == BT_CHARACTER && !ts.u.cl)
4980	{
4981	ts.kind = gfc_default_character_kind;
4982	ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4983	ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4984	NULL, 1);
4985	}
4986
4987	/* Record the Successful match. */
4988	if (!gfc_merge_new_implicit (&ts))
4989	return MATCH_ERROR;
4990	if (c == ',')
4991	c = gfc_next_ascii_char ();
4992	else if (gfc_match_eos () == MATCH_ERROR)
4993	goto error;
4994	continue;
4995	}
4996
4997	gfc_current_locus = cur_loc;
4998	}
4999
5000	/* Discard the (incorrectly) matched range. */
5001	gfc_clear_new_implicit ();
5002
5003	/* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5004	if (ts.type == BT_CHARACTER)
5005	m = gfc_match_char_spec (ts: &ts);
5006	else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5007	{
5008	m = gfc_match_kind_spec (ts: &ts, kind_expr_only: false);
5009	if (m == MATCH_NO)
5010	{
5011	m = gfc_match_old_kind_spec (ts: &ts);
5012	if (m == MATCH_ERROR)
5013	goto error;
5014	if (m == MATCH_NO)
5015	goto syntax;
5016	}
5017	}
5018	if (m == MATCH_ERROR)
5019	goto error;
5020
5021	m = match_implicit_range ();
5022	if (m == MATCH_ERROR)
5023	goto error;
5024	if (m == MATCH_NO)
5025	goto syntax;
5026
5027	gfc_gobble_whitespace ();
5028	c = gfc_next_ascii_char ();
5029	if (c != ',' && gfc_match_eos () != MATCH_YES)
5030	goto syntax;
5031
5032	if (!gfc_merge_new_implicit (&ts))
5033	return MATCH_ERROR;
5034	}
5035	while (c == ',');
5036
5037	return MATCH_YES;
5038
5039	syntax:
5040	gfc_syntax_error (ST_IMPLICIT);
5041
5042	error:
5043	return MATCH_ERROR;
5044	}
5045
5046
5047	match
5048	gfc_match_import (void)
5049	{
5050	char name[GFC_MAX_SYMBOL_LEN + 1];
5051	match m;
5052	gfc_symbol *sym;
5053	gfc_symtree *st;
5054
5055	if (gfc_current_ns->proc_name == NULL
5056	|| gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
5057	{
5058	gfc_error ("IMPORT statement at %C only permitted in "
5059	"an INTERFACE body");
5060	return MATCH_ERROR;
5061	}
5062
5063	if (gfc_current_ns->proc_name->attr.module_procedure)
5064	{
5065	gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5066	"in a module procedure interface body");
5067	return MATCH_ERROR;
5068	}
5069
5070	if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5071	return MATCH_ERROR;
5072
5073	if (gfc_match_eos () == MATCH_YES)
5074	{
5075	/* All host variables should be imported. */
5076	gfc_current_ns->has_import_set = 1;
5077	return MATCH_YES;
5078	}
5079
5080	if (gfc_match (" ::") == MATCH_YES)
5081	{
5082	if (gfc_match_eos () == MATCH_YES)
5083	{
5084	gfc_error ("Expecting list of named entities at %C");
5085	return MATCH_ERROR;
5086	}
5087	}
5088
5089	for(;;)
5090	{
5091	sym = NULL;
5092	m = gfc_match (" %n", name);
5093	switch (m)
5094	{
5095	case MATCH_YES:
5096	if (gfc_current_ns->parent != NULL
5097	&& gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5098	{
5099	gfc_error ("Type name %qs at %C is ambiguous", name);
5100	return MATCH_ERROR;
5101	}
5102	else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
5103	&& gfc_find_symbol (name,
5104	gfc_current_ns->proc_name->ns->parent,
5105	1, &sym))
5106	{
5107	gfc_error ("Type name %qs at %C is ambiguous", name);
5108	return MATCH_ERROR;
5109	}
5110
5111	if (sym == NULL)
5112	{
5113	gfc_error ("Cannot IMPORT %qs from host scoping unit "
5114	"at %C - does not exist.", name);
5115	return MATCH_ERROR;
5116	}
5117
5118	if (gfc_find_symtree (gfc_current_ns->sym_root, name))
5119	{
5120	gfc_warning (opt: 0, "%qs is already IMPORTed from host scoping unit "
5121	"at %C", name);
5122	goto next_item;
5123	}
5124
5125	st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5126	st->n.sym = sym;
5127	sym->refs++;
5128	sym->attr.imported = 1;
5129
5130	if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5131	{
5132	/* The actual derived type is stored in a symtree with the first
5133	letter of the name capitalized; the symtree with the all
5134	lower-case name contains the associated generic function. */
5135	st = gfc_new_symtree (&gfc_current_ns->sym_root,
5136	gfc_dt_upper_string (name));
5137	st->n.sym = sym;
5138	sym->refs++;
5139	sym->attr.imported = 1;
5140	}
5141
5142	goto next_item;
5143
5144	case MATCH_NO:
5145	break;
5146
5147	case MATCH_ERROR:
5148	return MATCH_ERROR;
5149	}
5150
5151	next_item:
5152	if (gfc_match_eos () == MATCH_YES)
5153	break;
5154	if (gfc_match_char (',') != MATCH_YES)
5155	goto syntax;
5156	}
5157
5158	return MATCH_YES;
5159
5160	syntax:
5161	gfc_error ("Syntax error in IMPORT statement at %C");
5162	return MATCH_ERROR;
5163	}
5164
5165
5166	/* A minimal implementation of gfc_match without whitespace, escape
5167	characters or variable arguments. Returns true if the next
5168	characters match the TARGET template exactly. */
5169
5170	static bool
5171	match_string_p (const char *target)
5172	{
5173	const char *p;
5174
5175	for (p = target; *p; p++)
5176	if ((char) gfc_next_ascii_char () != *p)
5177	return false;
5178	return true;
5179	}
5180
5181	/* Matches an attribute specification including array specs. If
5182	successful, leaves the variables current_attr and current_as
5183	holding the specification. Also sets the colon_seen variable for
5184	later use by matchers associated with initializations.
5185
5186	This subroutine is a little tricky in the sense that we don't know
5187	if we really have an attr-spec until we hit the double colon.
5188	Until that time, we can only return MATCH_NO. This forces us to
5189	check for duplicate specification at this level. */
5190
5191	static match
5192	match_attr_spec (void)
5193	{
5194	/* Modifiers that can exist in a type statement. */
5195	enum
5196	{ GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5197	DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5198	DECL_DIMENSION, DECL_EXTERNAL,
5199	DECL_INTRINSIC, DECL_OPTIONAL,
5200	DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5201	DECL_STATIC, DECL_AUTOMATIC,
5202	DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5203	DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5204	DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5205	};
5206
5207	/* GFC_DECL_END is the sentinel, index starts at 0. */
5208	#define NUM_DECL GFC_DECL_END
5209
5210	/* Make sure that values from sym_intent are safe to be used here. */
5211	gcc_assert (INTENT_IN > 0);
5212
5213	locus start, seen_at[NUM_DECL];
5214	int seen[NUM_DECL];
5215	unsigned int d;
5216	const char *attr;
5217	match m;
5218	bool t;
5219
5220	gfc_clear_attr (&current_attr);
5221	start = gfc_current_locus;
5222
5223	current_as = NULL;
5224	colon_seen = 0;
5225	attr_seen = 0;
5226
5227	/* See if we get all of the keywords up to the final double colon. */
5228	for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5229	seen[d] = 0;
5230
5231	for (;;)
5232	{
5233	char ch;
5234
5235	d = DECL_NONE;
5236	gfc_gobble_whitespace ();
5237
5238	ch = gfc_next_ascii_char ();
5239	if (ch == ':')
5240	{
5241	/* This is the successful exit condition for the loop. */
5242	if (gfc_next_ascii_char () == ':')
5243	break;
5244	}
5245	else if (ch == ',')
5246	{
5247	gfc_gobble_whitespace ();
5248	switch (gfc_peek_ascii_char ())
5249	{
5250	case 'a':
5251	gfc_next_ascii_char ();
5252	switch (gfc_next_ascii_char ())
5253	{
5254	case 'l':
5255	if (match_string_p (target: "locatable"))
5256	{
5257	/* Matched "allocatable". */
5258	d = DECL_ALLOCATABLE;
5259	}
5260	break;
5261
5262	case 's':
5263	if (match_string_p (target: "ynchronous"))
5264	{
5265	/* Matched "asynchronous". */
5266	d = DECL_ASYNCHRONOUS;
5267	}
5268	break;
5269
5270	case 'u':
5271	if (match_string_p (target: "tomatic"))
5272	{
5273	/* Matched "automatic". */
5274	d = DECL_AUTOMATIC;
5275	}
5276	break;
5277	}
5278	break;
5279
5280	case 'b':
5281	/* Try and match the bind(c). */
5282	m = gfc_match_bind_c (NULL, true);
5283	if (m == MATCH_YES)
5284	d = DECL_IS_BIND_C;
5285	else if (m == MATCH_ERROR)
5286	goto cleanup;
5287	break;
5288
5289	case 'c':
5290	gfc_next_ascii_char ();
5291	if ('o' != gfc_next_ascii_char ())
5292	break;
5293	switch (gfc_next_ascii_char ())
5294	{
5295	case 'd':
5296	if (match_string_p (target: "imension"))
5297	{
5298	d = DECL_CODIMENSION;
5299	break;
5300	}
5301	/* FALLTHRU */
5302	case 'n':
5303	if (match_string_p (target: "tiguous"))
5304	{
5305	d = DECL_CONTIGUOUS;
5306	break;
5307	}
5308	}
5309	break;
5310
5311	case 'd':
5312	if (match_string_p (target: "dimension"))
5313	d = DECL_DIMENSION;
5314	break;
5315
5316	case 'e':
5317	if (match_string_p (target: "external"))
5318	d = DECL_EXTERNAL;
5319	break;
5320
5321	case 'i':
5322	if (match_string_p (target: "int"))
5323	{
5324	ch = gfc_next_ascii_char ();
5325	if (ch == 'e')
5326	{
5327	if (match_string_p (target: "nt"))
5328	{
5329	/* Matched "intent". */
5330	d = match_intent_spec ();
5331	if (d == INTENT_UNKNOWN)
5332	{
5333	m = MATCH_ERROR;
5334	goto cleanup;
5335	}
5336	}
5337	}
5338	else if (ch == 'r')
5339	{
5340	if (match_string_p (target: "insic"))
5341	{
5342	/* Matched "intrinsic". */
5343	d = DECL_INTRINSIC;
5344	}
5345	}
5346	}
5347	break;
5348
5349	case 'k':
5350	if (match_string_p (target: "kind"))
5351	d = DECL_KIND;
5352	break;
5353
5354	case 'l':
5355	if (match_string_p (target: "len"))
5356	d = DECL_LEN;
5357	break;
5358
5359	case 'o':
5360	if (match_string_p (target: "optional"))
5361	d = DECL_OPTIONAL;
5362	break;
5363
5364	case 'p':
5365	gfc_next_ascii_char ();
5366	switch (gfc_next_ascii_char ())
5367	{
5368	case 'a':
5369	if (match_string_p (target: "rameter"))
5370	{
5371	/* Matched "parameter". */
5372	d = DECL_PARAMETER;
5373	}
5374	break;
5375
5376	case 'o':
5377	if (match_string_p (target: "inter"))
5378	{
5379	/* Matched "pointer". */
5380	d = DECL_POINTER;
5381	}
5382	break;
5383
5384	case 'r':
5385	ch = gfc_next_ascii_char ();
5386	if (ch == 'i')
5387	{
5388	if (match_string_p (target: "vate"))
5389	{
5390	/* Matched "private". */
5391	d = DECL_PRIVATE;
5392	}
5393	}
5394	else if (ch == 'o')
5395	{
5396	if (match_string_p (target: "tected"))
5397	{
5398	/* Matched "protected". */
5399	d = DECL_PROTECTED;
5400	}
5401	}
5402	break;
5403
5404	case 'u':
5405	if (match_string_p (target: "blic"))
5406	{
5407	/* Matched "public". */
5408	d = DECL_PUBLIC;
5409	}
5410	break;
5411	}
5412	break;
5413
5414	case 's':
5415	gfc_next_ascii_char ();
5416	switch (gfc_next_ascii_char ())
5417	{
5418	case 'a':
5419	if (match_string_p (target: "ve"))
5420	{
5421	/* Matched "save". */
5422	d = DECL_SAVE;
5423	}
5424	break;
5425
5426	case 't':
5427	if (match_string_p (target: "atic"))
5428	{
5429	/* Matched "static". */
5430	d = DECL_STATIC;
5431	}
5432	break;
5433	}
5434	break;
5435
5436	case 't':
5437	if (match_string_p (target: "target"))
5438	d = DECL_TARGET;
5439	break;
5440
5441	case 'v':
5442	gfc_next_ascii_char ();
5443	ch = gfc_next_ascii_char ();
5444	if (ch == 'a')
5445	{
5446	if (match_string_p (target: "lue"))
5447	{
5448	/* Matched "value". */
5449	d = DECL_VALUE;
5450	}
5451	}
5452	else if (ch == 'o')
5453	{
5454	if (match_string_p (target: "latile"))
5455	{
5456	/* Matched "volatile". */
5457	d = DECL_VOLATILE;
5458	}
5459	}
5460	break;
5461	}
5462	}
5463
5464	/* No double colon and no recognizable decl_type, so assume that
5465	we've been looking at something else the whole time. */
5466	if (d == DECL_NONE)
5467	{
5468	m = MATCH_NO;
5469	goto cleanup;
5470	}
5471
5472	/* Check to make sure any parens are paired up correctly. */
5473	if (gfc_match_parens () == MATCH_ERROR)
5474	{
5475	m = MATCH_ERROR;
5476	goto cleanup;
5477	}
5478
5479	seen[d]++;
5480	seen_at[d] = gfc_current_locus;
5481
5482	if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
5483	{
5484	gfc_array_spec *as = NULL;
5485
5486	m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5487	d == DECL_CODIMENSION);
5488
5489	if (current_as == NULL)
5490	current_as = as;
5491	else if (m == MATCH_YES)
5492	{
5493	if (!merge_array_spec (from: as, to: current_as, copy: false))
5494	m = MATCH_ERROR;
5495	free (ptr: as);
5496	}
5497
5498	if (m == MATCH_NO)
5499	{
5500	if (d == DECL_CODIMENSION)
5501	gfc_error ("Missing codimension specification at %C");
5502	else
5503	gfc_error ("Missing dimension specification at %C");
5504	m = MATCH_ERROR;
5505	}
5506
5507	if (m == MATCH_ERROR)
5508	goto cleanup;
5509	}
5510	}
5511
5512	/* Since we've seen a double colon, we have to be looking at an
5513	attr-spec. This means that we can now issue errors. */
5514	for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5515	if (seen[d] > 1)
5516	{
5517	switch (d)
5518	{
5519	case DECL_ALLOCATABLE:
5520	attr = "ALLOCATABLE";
5521	break;
5522	case DECL_ASYNCHRONOUS:
5523	attr = "ASYNCHRONOUS";
5524	break;
5525	case DECL_CODIMENSION:
5526	attr = "CODIMENSION";
5527	break;
5528	case DECL_CONTIGUOUS:
5529	attr = "CONTIGUOUS";
5530	break;
5531	case DECL_DIMENSION:
5532	attr = "DIMENSION";
5533	break;
5534	case DECL_EXTERNAL:
5535	attr = "EXTERNAL";
5536	break;
5537	case DECL_IN:
5538	attr = "INTENT (IN)";
5539	break;
5540	case DECL_OUT:
5541	attr = "INTENT (OUT)";
5542	break;
5543	case DECL_INOUT:
5544	attr = "INTENT (IN OUT)";
5545	break;
5546	case DECL_INTRINSIC:
5547	attr = "INTRINSIC";
5548	break;
5549	case DECL_OPTIONAL:
5550	attr = "OPTIONAL";
5551	break;
5552	case DECL_KIND:
5553	attr = "KIND";
5554	break;
5555	case DECL_LEN:
5556	attr = "LEN";
5557	break;
5558	case DECL_PARAMETER:
5559	attr = "PARAMETER";
5560	break;
5561	case DECL_POINTER:
5562	attr = "POINTER";
5563	break;
5564	case DECL_PROTECTED:
5565	attr = "PROTECTED";
5566	break;
5567	case DECL_PRIVATE:
5568	attr = "PRIVATE";
5569	break;
5570	case DECL_PUBLIC:
5571	attr = "PUBLIC";
5572	break;
5573	case DECL_SAVE:
5574	attr = "SAVE";
5575	break;
5576	case DECL_STATIC:
5577	attr = "STATIC";
5578	break;
5579	case DECL_AUTOMATIC:
5580	attr = "AUTOMATIC";
5581	break;
5582	case DECL_TARGET:
5583	attr = "TARGET";
5584	break;
5585	case DECL_IS_BIND_C:
5586	attr = "IS_BIND_C";
5587	break;
5588	case DECL_VALUE:
5589	attr = "VALUE";
5590	break;
5591	case DECL_VOLATILE:
5592	attr = "VOLATILE";
5593	break;
5594	default:
5595	attr = NULL; /* This shouldn't happen. */
5596	}
5597
5598	gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
5599	m = MATCH_ERROR;
5600	goto cleanup;
5601	}
5602
5603	/* Now that we've dealt with duplicate attributes, add the attributes
5604	to the current attribute. */
5605	for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5606	{
5607	if (seen[d] == 0)
5608	continue;
5609	else
5610	attr_seen = 1;
5611
5612	if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
5613	&& !flag_dec_static)
5614	{
5615	gfc_error ("%s at %L is a DEC extension, enable with "
5616	"%<-fdec-static%>",
5617	d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
5618	m = MATCH_ERROR;
5619	goto cleanup;
5620	}
5621	/* Allow SAVE with STATIC, but don't complain. */
5622	if (d == DECL_STATIC && seen[DECL_SAVE])
5623	continue;
5624
5625	if (gfc_comp_struct (gfc_current_state ())
5626	&& d != DECL_DIMENSION && d != DECL_CODIMENSION
5627	&& d != DECL_POINTER && d != DECL_PRIVATE
5628	&& d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
5629	{
5630	bool is_derived = gfc_current_state () == COMP_DERIVED;
5631	if (d == DECL_ALLOCATABLE)
5632	{
5633	if (!gfc_notify_std (GFC_STD_F2003, is_derived
5634	? G_("ALLOCATABLE attribute at %C in a "
5635	"TYPE definition")
5636	: G_("ALLOCATABLE attribute at %C in a "
5637	"STRUCTURE definition")))
5638	{
5639	m = MATCH_ERROR;
5640	goto cleanup;
5641	}
5642	}
5643	else if (d == DECL_KIND)
5644	{
5645	if (!gfc_notify_std (GFC_STD_F2003, is_derived
5646	? G_("KIND attribute at %C in a "
5647	"TYPE definition")
5648	: G_("KIND attribute at %C in a "
5649	"STRUCTURE definition")))
5650	{
5651	m = MATCH_ERROR;
5652	goto cleanup;
5653	}
5654	if (current_ts.type != BT_INTEGER)
5655	{
5656	gfc_error ("Component with KIND attribute at %C must be "
5657	"INTEGER");
5658	m = MATCH_ERROR;
5659	goto cleanup;
5660	}
5661	}
5662	else if (d == DECL_LEN)
5663	{
5664	if (!gfc_notify_std (GFC_STD_F2003, is_derived
5665	? G_("LEN attribute at %C in a "
5666	"TYPE definition")
5667	: G_("LEN attribute at %C in a "
5668	"STRUCTURE definition")))
5669	{
5670	m = MATCH_ERROR;
5671	goto cleanup;
5672	}
5673	if (current_ts.type != BT_INTEGER)
5674	{
5675	gfc_error ("Component with LEN attribute at %C must be "
5676	"INTEGER");
5677	m = MATCH_ERROR;
5678	goto cleanup;
5679	}
5680	}
5681	else
5682	{
5683	gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
5684	"TYPE definition")
5685	: G_("Attribute at %L is not allowed in a "
5686	"STRUCTURE definition"), &seen_at[d]);
5687	m = MATCH_ERROR;
5688	goto cleanup;
5689	}
5690	}
5691
5692	if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
5693	&& gfc_current_state () != COMP_MODULE)
5694	{
5695	if (d == DECL_PRIVATE)
5696	attr = "PRIVATE";
5697	else
5698	attr = "PUBLIC";
5699	if (gfc_current_state () == COMP_DERIVED
5700	&& gfc_state_stack->previous
5701	&& gfc_state_stack->previous->state == COMP_MODULE)
5702	{
5703	if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
5704	"at %L in a TYPE definition", attr,
5705	&seen_at[d]))
5706	{
5707	m = MATCH_ERROR;
5708	goto cleanup;
5709	}
5710	}
5711	else
5712	{
5713	gfc_error ("%s attribute at %L is not allowed outside of the "
5714	"specification part of a module", attr, &seen_at[d]);
5715	m = MATCH_ERROR;
5716	goto cleanup;
5717	}
5718	}
5719
5720	if (gfc_current_state () != COMP_DERIVED
5721	&& (d == DECL_KIND || d == DECL_LEN))
5722	{
5723	gfc_error ("Attribute at %L is not allowed outside a TYPE "
5724	"definition", &seen_at[d]);
5725	m = MATCH_ERROR;
5726	goto cleanup;
5727	}
5728
5729	switch (d)
5730	{
5731	case DECL_ALLOCATABLE:
5732	t = gfc_add_allocatable (&current_attr, &seen_at[d]);
5733	break;
5734
5735	case DECL_ASYNCHRONOUS:
5736	if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
5737	t = false;
5738	else
5739	t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
5740	break;
5741
5742	case DECL_CODIMENSION:
5743	t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
5744	break;
5745
5746	case DECL_CONTIGUOUS:
5747	if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
5748	t = false;
5749	else
5750	t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
5751	break;
5752
5753	case DECL_DIMENSION:
5754	t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
5755	break;
5756
5757	case DECL_EXTERNAL:
5758	t = gfc_add_external (&current_attr, &seen_at[d]);
5759	break;
5760
5761	case DECL_IN:
5762	t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
5763	break;
5764
5765	case DECL_OUT:
5766	t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
5767	break;
5768
5769	case DECL_INOUT:
5770	t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
5771	break;
5772
5773	case DECL_INTRINSIC:
5774	t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
5775	break;
5776
5777	case DECL_OPTIONAL:
5778	t = gfc_add_optional (&current_attr, &seen_at[d]);
5779	break;
5780
5781	case DECL_KIND:
5782	t = gfc_add_kind (&current_attr, &seen_at[d]);
5783	break;
5784
5785	case DECL_LEN:
5786	t = gfc_add_len (&current_attr, &seen_at[d]);
5787	break;
5788
5789	case DECL_PARAMETER:
5790	t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
5791	break;
5792
5793	case DECL_POINTER:
5794	t = gfc_add_pointer (&current_attr, &seen_at[d]);
5795	break;
5796
5797	case DECL_PROTECTED:
5798	if (gfc_current_state () != COMP_MODULE
5799	|| (gfc_current_ns->proc_name
5800	&& gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5801	{
5802	gfc_error ("PROTECTED at %C only allowed in specification "
5803	"part of a module");
5804	t = false;
5805	break;
5806	}
5807
5808	if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
5809	t = false;
5810	else
5811	t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
5812	break;
5813
5814	case DECL_PRIVATE:
5815	t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
5816	&seen_at[d]);
5817	break;
5818
5819	case DECL_PUBLIC:
5820	t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
5821	&seen_at[d]);
5822	break;
5823
5824	case DECL_STATIC:
5825	case DECL_SAVE:
5826	t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
5827	break;
5828
5829	case DECL_AUTOMATIC:
5830	t = gfc_add_automatic (&current_attr, NULL, &seen_at[d]);
5831	break;
5832
5833	case DECL_TARGET:
5834	t = gfc_add_target (&current_attr, &seen_at[d]);
5835	break;
5836
5837	case DECL_IS_BIND_C:
5838	t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
5839	break;
5840
5841	case DECL_VALUE:
5842	if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
5843	t = false;
5844	else
5845	t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
5846	break;
5847
5848	case DECL_VOLATILE:
5849	if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
5850	t = false;
5851	else
5852	t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
5853	break;
5854
5855	default:
5856	gfc_internal_error ("match_attr_spec(): Bad attribute");
5857	}
5858
5859	if (!t)
5860	{
5861	m = MATCH_ERROR;
5862	goto cleanup;
5863	}
5864	}
5865
5866	/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5867	if ((gfc_current_state () == COMP_MODULE
5868	|| gfc_current_state () == COMP_SUBMODULE)
5869	&& !current_attr.save
5870	&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
5871	current_attr.save = SAVE_IMPLICIT;
5872
5873	colon_seen = 1;
5874	return MATCH_YES;
5875
5876	cleanup:
5877	gfc_current_locus = start;
5878	gfc_free_array_spec (current_as);
5879	current_as = NULL;
5880	attr_seen = 0;
5881	return m;
5882	}
5883
5884
5885	/* Set the binding label, dest_label, either with the binding label
5886	stored in the given gfc_typespec, ts, or if none was provided, it
5887	will be the symbol name in all lower case, as required by the draft
5888	(J3/04-007, section 15.4.1). If a binding label was given and
5889	there is more than one argument (num_idents), it is an error. */
5890
5891	static bool
5892	set_binding_label (const char **dest_label, const char *sym_name,
5893	int num_idents)
5894	{
5895	if (num_idents > 1 && has_name_equals)
5896	{
5897	gfc_error ("Multiple identifiers provided with "
5898	"single NAME= specifier at %C");
5899	return false;
5900	}
5901
5902	if (curr_binding_label)
5903	/* Binding label given; store in temp holder till have sym. */
5904	*dest_label = curr_binding_label;
5905	else
5906	{
5907	/* No binding label given, and the NAME= specifier did not exist,
5908	which means there was no NAME="". */
5909	if (sym_name != NULL && has_name_equals == 0)
5910	*dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
5911	}
5912
5913	return true;
5914	}
5915
5916
5917	/* Set the status of the given common block as being BIND(C) or not,
5918	depending on the given parameter, is_bind_c. */
5919
5920	static void
5921	set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5922	{
5923	com_block->is_bind_c = is_bind_c;
5924	return;
5925	}
5926
5927
5928	/* Verify that the given gfc_typespec is for a C interoperable type. */
5929
5930	bool
5931	gfc_verify_c_interop (gfc_typespec *ts)
5932	{
5933	if (ts->type == BT_DERIVED && ts->u.derived != NULL)
5934	return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
5935	? true : false;
5936	else if (ts->type == BT_CLASS)
5937	return false;
5938	else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5939	return false;
5940
5941	return true;
5942	}
5943
5944
5945	/* Verify that the variables of a given common block, which has been
5946	defined with the attribute specifier bind(c), to be of a C
5947	interoperable type. Errors will be reported here, if
5948	encountered. */
5949
5950	bool
5951	verify_com_block_vars_c_interop (gfc_common_head *com_block)
5952	{
5953	gfc_symbol *curr_sym = NULL;
5954	bool retval = true;
5955
5956	curr_sym = com_block->head;
5957
5958	/* Make sure we have at least one symbol. */
5959	if (curr_sym == NULL)
5960	return retval;
5961
5962	/* Here we know we have a symbol, so we'll execute this loop
5963	at least once. */
5964	do
5965	{
5966	/* The second to last param, 1, says this is in a common block. */
5967	retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5968	curr_sym = curr_sym->common_next;
5969	} while (curr_sym != NULL);
5970
5971	return retval;
5972	}
5973
5974
5975	/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5976	an appropriate error message is reported. */
5977
5978	bool
5979	verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
5980	int is_in_common, gfc_common_head *com_block)
5981	{
5982	bool bind_c_function = false;
5983	bool retval = true;
5984
5985	if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
5986	bind_c_function = true;
5987
5988	if (tmp_sym->attr.function && tmp_sym->result != NULL)
5989	{
5990	tmp_sym = tmp_sym->result;
5991	/* Make sure it wasn't an implicitly typed result. */
5992	if (tmp_sym->attr.implicit_type && warn_c_binding_type)
5993	{
5994	gfc_warning (opt: OPT_Wc_binding_type,
5995	"Implicitly declared BIND(C) function %qs at "
5996	"%L may not be C interoperable", tmp_sym->name,
5997	&tmp_sym->declared_at);
5998	tmp_sym->ts.f90_type = tmp_sym->ts.type;
5999	/* Mark it as C interoperable to prevent duplicate warnings. */
6000	tmp_sym->ts.is_c_interop = 1;
6001	tmp_sym->attr.is_c_interop = 1;
6002	}
6003	}
6004
6005	/* Here, we know we have the bind(c) attribute, so if we have
6006	enough type info, then verify that it's a C interop kind.
6007	The info could be in the symbol already, or possibly still in
6008	the given ts (current_ts), so look in both. */
6009	if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6010	{
6011	if (!gfc_verify_c_interop (ts: &(tmp_sym->ts)))
6012	{
6013	/* See if we're dealing with a sym in a common block or not. */
6014	if (is_in_common == 1 && warn_c_binding_type)
6015	{
6016	gfc_warning (opt: OPT_Wc_binding_type,
6017	"Variable %qs in common block %qs at %L "
6018	"may not be a C interoperable "
6019	"kind though common block %qs is BIND(C)",
6020	tmp_sym->name, com_block->name,
6021	&(tmp_sym->declared_at), com_block->name);
6022	}
6023	else
6024	{
6025	if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6026	|| tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6027	{
6028	gfc_error ("Type declaration %qs at %L is not C "
6029	"interoperable but it is BIND(C)",
6030	tmp_sym->name, &(tmp_sym->declared_at));
6031	retval = false;
6032	}
6033	else if (warn_c_binding_type)
6034	gfc_warning (opt: OPT_Wc_binding_type, "Variable %qs at %L "
6035	"may not be a C interoperable "
6036	"kind but it is BIND(C)",
6037	tmp_sym->name, &(tmp_sym->declared_at));
6038	}
6039	}
6040
6041	/* Variables declared w/in a common block can't be bind(c)
6042	since there's no way for C to see these variables, so there's
6043	semantically no reason for the attribute. */
6044	if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6045	{
6046	gfc_error ("Variable %qs in common block %qs at "
6047	"%L cannot be declared with BIND(C) "
6048	"since it is not a global",
6049	tmp_sym->name, com_block->name,
6050	&(tmp_sym->declared_at));
6051	retval = false;
6052	}
6053
6054	/* Scalar variables that are bind(c) cannot have the pointer
6055	or allocatable attributes. */
6056	if (tmp_sym->attr.is_bind_c == 1)
6057	{
6058	if (tmp_sym->attr.pointer == 1)
6059	{
6060	gfc_error ("Variable %qs at %L cannot have both the "
6061	"POINTER and BIND(C) attributes",
6062	tmp_sym->name, &(tmp_sym->declared_at));
6063	retval = false;
6064	}
6065
6066	if (tmp_sym->attr.allocatable == 1)
6067	{
6068	gfc_error ("Variable %qs at %L cannot have both the "
6069	"ALLOCATABLE and BIND(C) attributes",
6070	tmp_sym->name, &(tmp_sym->declared_at));
6071	retval = false;
6072	}
6073
6074	}
6075
6076	/* If it is a BIND(C) function, make sure the return value is a
6077	scalar value. The previous tests in this function made sure
6078	the type is interoperable. */
6079	if (bind_c_function && tmp_sym->as != NULL)
6080	gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6081	"be an array", tmp_sym->name, &(tmp_sym->declared_at));
6082
6083	/* BIND(C) functions cannot return a character string. */
6084	if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6085	if (!gfc_length_one_character_type_p (ts: &tmp_sym->ts))
6086	gfc_error ("Return type of BIND(C) function %qs of character "
6087	"type at %L must have length 1", tmp_sym->name,
6088	&(tmp_sym->declared_at));
6089	}
6090
6091	/* See if the symbol has been marked as private. If it has, make sure
6092	there is no binding label and warn the user if there is one. */
6093	if (tmp_sym->attr.access == ACCESS_PRIVATE
6094	&& tmp_sym->binding_label)
6095	/* Use gfc_warning_now because we won't say that the symbol fails
6096	just because of this. */
6097	gfc_warning_now (opt: 0, "Symbol %qs at %L is marked PRIVATE but has been "
6098	"given the binding label %qs", tmp_sym->name,
6099	&(tmp_sym->declared_at), tmp_sym->binding_label);
6100
6101	return retval;
6102	}
6103
6104
6105	/* Set the appropriate fields for a symbol that's been declared as
6106	BIND(C) (the is_bind_c flag and the binding label), and verify that
6107	the type is C interoperable. Errors are reported by the functions
6108	used to set/test these fields. */
6109
6110	static bool
6111	set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6112	{
6113	bool retval = true;
6114
6115	/* TODO: Do we need to make sure the vars aren't marked private? */
6116
6117	/* Set the is_bind_c bit in symbol_attribute. */
6118	gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6119
6120	if (!set_binding_label (dest_label: &tmp_sym->binding_label, sym_name: tmp_sym->name, num_idents))
6121	return false;
6122
6123	return retval;
6124	}
6125
6126
6127	/* Set the fields marking the given common block as BIND(C), including
6128	a binding label, and report any errors encountered. */
6129
6130	static bool
6131	set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6132	{
6133	bool retval = true;
6134
6135	/* destLabel, common name, typespec (which may have binding label). */
6136	if (!set_binding_label (dest_label: &com_block->binding_label, sym_name: com_block->name,
6137	num_idents))
6138	return false;
6139
6140	/* Set the given common block (com_block) to being bind(c) (1). */
6141	set_com_block_bind_c (com_block, is_bind_c: 1);
6142
6143	return retval;
6144	}
6145
6146
6147	/* Retrieve the list of one or more identifiers that the given bind(c)
6148	attribute applies to. */
6149
6150	static bool
6151	get_bind_c_idents (void)
6152	{
6153	char name[GFC_MAX_SYMBOL_LEN + 1];
6154	int num_idents = 0;
6155	gfc_symbol *tmp_sym = NULL;
6156	match found_id;
6157	gfc_common_head *com_block = NULL;
6158
6159	if (gfc_match_name (name) == MATCH_YES)
6160	{
6161	found_id = MATCH_YES;
6162	gfc_get_ha_symbol (name, &tmp_sym);
6163	}
6164	else if (gfc_match_common_name (name) == MATCH_YES)
6165	{
6166	found_id = MATCH_YES;
6167	com_block = gfc_get_common (name, 0);
6168	}
6169	else
6170	{
6171	gfc_error ("Need either entity or common block name for "
6172	"attribute specification statement at %C");
6173	return false;
6174	}
6175
6176	/* Save the current identifier and look for more. */
6177	do
6178	{
6179	/* Increment the number of identifiers found for this spec stmt. */
6180	num_idents++;
6181
6182	/* Make sure we have a sym or com block, and verify that it can
6183	be bind(c). Set the appropriate field(s) and look for more
6184	identifiers. */
6185	if (tmp_sym != NULL || com_block != NULL)
6186	{
6187	if (tmp_sym != NULL)
6188	{
6189	if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6190	return false;
6191	}
6192	else
6193	{
6194	if (!set_verify_bind_c_com_block (com_block, num_idents))
6195	return false;
6196	}
6197
6198	/* Look to see if we have another identifier. */
6199	tmp_sym = NULL;
6200	if (gfc_match_eos () == MATCH_YES)
6201	found_id = MATCH_NO;
6202	else if (gfc_match_char (',') != MATCH_YES)
6203	found_id = MATCH_NO;
6204	else if (gfc_match_name (name) == MATCH_YES)
6205	{
6206	found_id = MATCH_YES;
6207	gfc_get_ha_symbol (name, &tmp_sym);
6208	}
6209	else if (gfc_match_common_name (name) == MATCH_YES)
6210	{
6211	found_id = MATCH_YES;
6212	com_block = gfc_get_common (name, 0);
6213	}
6214	else
6215	{
6216	gfc_error ("Missing entity or common block name for "
6217	"attribute specification statement at %C");
6218	return false;
6219	}
6220	}
6221	else
6222	{
6223	gfc_internal_error ("Missing symbol");
6224	}
6225	} while (found_id == MATCH_YES);
6226
6227	/* if we get here we were successful */
6228	return true;
6229	}
6230
6231
6232	/* Try and match a BIND(C) attribute specification statement. */
6233
6234	match
6235	gfc_match_bind_c_stmt (void)
6236	{
6237	match found_match = MATCH_NO;
6238	gfc_typespec *ts;
6239
6240	ts = &current_ts;
6241
6242	/* This may not be necessary. */
6243	gfc_clear_ts (ts);
6244	/* Clear the temporary binding label holder. */
6245	curr_binding_label = NULL;
6246
6247	/* Look for the bind(c). */
6248	found_match = gfc_match_bind_c (NULL, true);
6249
6250	if (found_match == MATCH_YES)
6251	{
6252	if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6253	return MATCH_ERROR;
6254
6255	/* Look for the :: now, but it is not required. */
6256	gfc_match (" :: ");
6257
6258	/* Get the identifier(s) that needs to be updated. This may need to
6259	change to hand the flag(s) for the attr specified so all identifiers
6260	found can have all appropriate parts updated (assuming that the same
6261	spec stmt can have multiple attrs, such as both bind(c) and
6262	allocatable...). */
6263	if (!get_bind_c_idents ())
6264	/* Error message should have printed already. */
6265	return MATCH_ERROR;
6266	}
6267
6268	return found_match;
6269	}
6270
6271
6272	/* Match a data declaration statement. */
6273
6274	match
6275	gfc_match_data_decl (void)
6276	{
6277	gfc_symbol *sym;
6278	match m;
6279	int elem;
6280
6281	type_param_spec_list = NULL;
6282	decl_type_param_list = NULL;
6283
6284	num_idents_on_line = 0;
6285
6286	m = gfc_match_decl_type_spec (ts: &current_ts, implicit_flag: 0);
6287	if (m != MATCH_YES)
6288	return m;
6289
6290	if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6291	&& !gfc_comp_struct (gfc_current_state ()))
6292	{
6293	sym = gfc_use_derived (current_ts.u.derived);
6294
6295	if (sym == NULL)
6296	{
6297	m = MATCH_ERROR;
6298	goto cleanup;
6299	}
6300
6301	current_ts.u.derived = sym;
6302	}
6303
6304	m = match_attr_spec ();
6305	if (m == MATCH_ERROR)
6306	{
6307	m = MATCH_NO;
6308	goto cleanup;
6309	}
6310
6311	/* F2018:C708. */
6312	if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6313	{
6314	gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6315	m = MATCH_ERROR;
6316	goto cleanup;
6317	}
6318
6319	if (current_ts.type == BT_CLASS
6320	&& current_ts.u.derived->attr.unlimited_polymorphic)
6321	goto ok;
6322
6323	if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6324	&& current_ts.u.derived->components == NULL
6325	&& !current_ts.u.derived->attr.zero_comp)
6326	{
6327
6328	if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6329	goto ok;
6330
6331	if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6332	goto ok;
6333
6334	gfc_find_symbol (current_ts.u.derived->name,
6335	current_ts.u.derived->ns, 1, &sym);
6336
6337	/* Any symbol that we find had better be a type definition
6338	which has its components defined, or be a structure definition
6339	actively being parsed. */
6340	if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6341	&& (current_ts.u.derived->components != NULL
6342	|| current_ts.u.derived->attr.zero_comp
6343	|| current_ts.u.derived == gfc_new_block))
6344	goto ok;
6345
6346	gfc_error ("Derived type at %C has not been previously defined "
6347	"and so cannot appear in a derived type definition");
6348	m = MATCH_ERROR;
6349	goto cleanup;
6350	}
6351
6352	ok:
6353	/* If we have an old-style character declaration, and no new-style
6354	attribute specifications, then there a comma is optional between
6355	the type specification and the variable list. */
6356	if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6357	gfc_match_char (',');
6358
6359	/* Give the types/attributes to symbols that follow. Give the element
6360	a number so that repeat character length expressions can be copied. */
6361	elem = 1;
6362	for (;;)
6363	{
6364	num_idents_on_line++;
6365	m = variable_decl (elem: elem++);
6366	if (m == MATCH_ERROR)
6367	goto cleanup;
6368	if (m == MATCH_NO)
6369	break;
6370
6371	if (gfc_match_eos () == MATCH_YES)
6372	goto cleanup;
6373	if (gfc_match_char (',') != MATCH_YES)
6374	break;
6375	}
6376
6377	if (!gfc_error_flag_test ())
6378	{
6379	/* An anonymous structure declaration is unambiguous; if we matched one
6380	according to gfc_match_structure_decl, we need to return MATCH_YES
6381	here to avoid confusing the remaining matchers, even if there was an
6382	error during variable_decl. We must flush any such errors. Note this
6383	causes the parser to gracefully continue parsing the remaining input
6384	as a structure body, which likely follows. */
6385	if (current_ts.type == BT_DERIVED && current_ts.u.derived
6386	&& gfc_fl_struct (current_ts.u.derived->attr.flavor))
6387	{
6388	gfc_error_now ("Syntax error in anonymous structure declaration"
6389	" at %C");
6390	/* Skip the bad variable_decl and line up for the start of the
6391	structure body. */
6392	gfc_error_recovery ();
6393	m = MATCH_YES;
6394	goto cleanup;
6395	}
6396
6397	gfc_error ("Syntax error in data declaration at %C");
6398	}
6399
6400	m = MATCH_ERROR;
6401
6402	gfc_free_data_all (ns: gfc_current_ns);
6403
6404	cleanup:
6405	if (saved_kind_expr)
6406	gfc_free_expr (saved_kind_expr);
6407	if (type_param_spec_list)
6408	gfc_free_actual_arglist (type_param_spec_list);
6409	if (decl_type_param_list)
6410	gfc_free_actual_arglist (decl_type_param_list);
6411	saved_kind_expr = NULL;
6412	gfc_free_array_spec (current_as);
6413	current_as = NULL;
6414	return m;
6415	}
6416
6417	static bool
6418	in_module_or_interface(void)
6419	{
6420	if (gfc_current_state () == COMP_MODULE
6421	|| gfc_current_state () == COMP_SUBMODULE
6422	|| gfc_current_state () == COMP_INTERFACE)
6423	return true;
6424
6425	if (gfc_state_stack->state == COMP_CONTAINS
6426	|| gfc_state_stack->state == COMP_FUNCTION
6427	|| gfc_state_stack->state == COMP_SUBROUTINE)
6428	{
6429	gfc_state_data *p;
6430	for (p = gfc_state_stack->previous; p ; p = p->previous)
6431	{
6432	if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
6433	|| p->state == COMP_INTERFACE)
6434	return true;
6435	}
6436	}
6437	return false;
6438	}
6439
6440	/* Match a prefix associated with a function or subroutine
6441	declaration. If the typespec pointer is nonnull, then a typespec
6442	can be matched. Note that if nothing matches, MATCH_YES is
6443	returned (the null string was matched). */
6444
6445	match
6446	gfc_match_prefix (gfc_typespec *ts)
6447	{
6448	bool seen_type;
6449	bool seen_impure;
6450	bool found_prefix;
6451
6452	gfc_clear_attr (&current_attr);
6453	seen_type = false;
6454	seen_impure = false;
6455
6456	gcc_assert (!gfc_matching_prefix);
6457	gfc_matching_prefix = true;
6458
6459	do
6460	{
6461	found_prefix = false;
6462
6463	/* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6464	corresponding attribute seems natural and distinguishes these
6465	procedures from procedure types of PROC_MODULE, which these are
6466	as well. */
6467	if (gfc_match ("module% ") == MATCH_YES)
6468	{
6469	if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
6470	goto error;
6471
6472	if (!in_module_or_interface ())
6473	{
6474	gfc_error ("MODULE prefix at %C found outside of a module, "
6475	"submodule, or interface");
6476	goto error;
6477	}
6478
6479	current_attr.module_procedure = 1;
6480	found_prefix = true;
6481	}
6482
6483	if (!seen_type && ts != NULL)
6484	{
6485	match m;
6486	m = gfc_match_decl_type_spec (ts, implicit_flag: 0);
6487	if (m == MATCH_ERROR)
6488	goto error;
6489	if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
6490	{
6491	seen_type = true;
6492	found_prefix = true;
6493	}
6494	}
6495
6496	if (gfc_match ("elemental% ") == MATCH_YES)
6497	{
6498	if (!gfc_add_elemental (&current_attr, NULL))
6499	goto error;
6500
6501	found_prefix = true;
6502	}
6503
6504	if (gfc_match ("pure% ") == MATCH_YES)
6505	{
6506	if (!gfc_add_pure (&current_attr, NULL))
6507	goto error;
6508
6509	found_prefix = true;
6510	}
6511
6512	if (gfc_match ("recursive% ") == MATCH_YES)
6513	{
6514	if (!gfc_add_recursive (&current_attr, NULL))
6515	goto error;
6516
6517	found_prefix = true;
6518	}
6519
6520	/* IMPURE is a somewhat special case, as it needs not set an actual
6521	attribute but rather only prevents ELEMENTAL routines from being
6522	automatically PURE. */
6523	if (gfc_match ("impure% ") == MATCH_YES)
6524	{
6525	if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
6526	goto error;
6527
6528	seen_impure = true;
6529	found_prefix = true;
6530	}
6531	}
6532	while (found_prefix);
6533
6534	/* IMPURE and PURE must not both appear, of course. */
6535	if (seen_impure && current_attr.pure)
6536	{
6537	gfc_error ("PURE and IMPURE must not appear both at %C");
6538	goto error;
6539	}
6540
6541	/* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6542	if (!seen_impure && current_attr.elemental && !current_attr.pure)
6543	{
6544	if (!gfc_add_pure (&current_attr, NULL))
6545	goto error;
6546	}
6547
6548	/* At this point, the next item is not a prefix. */
6549	gcc_assert (gfc_matching_prefix);
6550
6551	gfc_matching_prefix = false;
6552	return MATCH_YES;
6553
6554	error:
6555	gcc_assert (gfc_matching_prefix);
6556	gfc_matching_prefix = false;
6557	return MATCH_ERROR;
6558	}
6559
6560
6561	/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6562
6563	static bool
6564	copy_prefix (symbol_attribute *dest, locus *where)
6565	{
6566	if (dest->module_procedure)
6567	{
6568	if (current_attr.elemental)
6569	dest->elemental = 1;
6570
6571	if (current_attr.pure)
6572	dest->pure = 1;
6573
6574	if (current_attr.recursive)
6575	dest->recursive = 1;
6576
6577	/* Module procedures are unusual in that the 'dest' is copied from
6578	the interface declaration. However, this is an oportunity to
6579	check that the submodule declaration is compliant with the
6580	interface. */
6581	if (dest->elemental && !current_attr.elemental)
6582	{
6583	gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6584	"missing at %L", where);
6585	return false;
6586	}
6587
6588	if (dest->pure && !current_attr.pure)
6589	{
6590	gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6591	"missing at %L", where);
6592	return false;
6593	}
6594
6595	if (dest->recursive && !current_attr.recursive)
6596	{
6597	gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6598	"missing at %L", where);
6599	return false;
6600	}
6601
6602	return true;
6603	}
6604
6605	if (current_attr.elemental && !gfc_add_elemental (dest, where))
6606	return false;
6607
6608	if (current_attr.pure && !gfc_add_pure (dest, where))
6609	return false;
6610
6611	if (current_attr.recursive && !gfc_add_recursive (dest, where))
6612	return false;
6613
6614	return true;
6615	}
6616
6617
6618	/* Match a formal argument list or, if typeparam is true, a
6619	type_param_name_list. */
6620
6621	match
6622	gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6623	int null_flag, bool typeparam)
6624	{
6625	gfc_formal_arglist *head, *tail, *p, *q;
6626	char name[GFC_MAX_SYMBOL_LEN + 1];
6627	gfc_symbol *sym;
6628	match m;
6629	gfc_formal_arglist *formal = NULL;
6630
6631	head = tail = NULL;
6632
6633	/* Keep the interface formal argument list and null it so that the
6634	matching for the new declaration can be done. The numbers and
6635	names of the arguments are checked here. The interface formal
6636	arguments are retained in formal_arglist and the characteristics
6637	are compared in resolve.cc(resolve_fl_procedure). See the remark
6638	in get_proc_name about the eventual need to copy the formal_arglist
6639	and populate the formal namespace of the interface symbol. */
6640	if (progname->attr.module_procedure
6641	&& progname->attr.host_assoc)
6642	{
6643	formal = progname->formal;
6644	progname->formal = NULL;
6645	}
6646
6647	if (gfc_match_char ('(') != MATCH_YES)
6648	{
6649	if (null_flag)
6650	goto ok;
6651	return MATCH_NO;
6652	}
6653
6654	if (gfc_match_char (')') == MATCH_YES)
6655	{
6656	if (typeparam)
6657	{
6658	gfc_error_now ("A type parameter list is required at %C");
6659	m = MATCH_ERROR;
6660	goto cleanup;
6661	}
6662	else
6663	goto ok;
6664	}
6665
6666	for (;;)
6667	{
6668	if (gfc_match_char ('*') == MATCH_YES)
6669	{
6670	sym = NULL;
6671	if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
6672	"Alternate-return argument at %C"))
6673	{
6674	m = MATCH_ERROR;
6675	goto cleanup;
6676	}
6677	else if (typeparam)
6678	gfc_error_now ("A parameter name is required at %C");
6679	}
6680	else
6681	{
6682	m = gfc_match_name (name);
6683	if (m != MATCH_YES)
6684	{
6685	if(typeparam)
6686	gfc_error_now ("A parameter name is required at %C");
6687	goto cleanup;
6688	}
6689
6690	if (!typeparam && gfc_get_symbol (name, NULL, &sym))
6691	goto cleanup;
6692	else if (typeparam
6693	&& gfc_get_symbol (name, progname->f2k_derived, &sym))
6694	goto cleanup;
6695	}
6696
6697	p = gfc_get_formal_arglist ();
6698
6699	if (head == NULL)
6700	head = tail = p;
6701	else
6702	{
6703	tail->next = p;
6704	tail = p;
6705	}
6706
6707	tail->sym = sym;
6708
6709	/* We don't add the VARIABLE flavor because the name could be a
6710	dummy procedure. We don't apply these attributes to formal
6711	arguments of statement functions. */
6712	if (sym != NULL && !st_flag
6713	&& (!gfc_add_dummy(&sym->attr, sym->name, NULL)
6714	|| !gfc_missing_attr (&sym->attr, NULL)))
6715	{
6716	m = MATCH_ERROR;
6717	goto cleanup;
6718	}
6719
6720	/* The name of a program unit can be in a different namespace,
6721	so check for it explicitly. After the statement is accepted,
6722	the name is checked for especially in gfc_get_symbol(). */
6723	if (gfc_new_block != NULL && sym != NULL && !typeparam
6724	&& strcmp (s1: sym->name, s2: gfc_new_block->name) == 0)
6725	{
6726	gfc_error ("Name %qs at %C is the name of the procedure",
6727	sym->name);
6728	m = MATCH_ERROR;
6729	goto cleanup;
6730	}
6731
6732	if (gfc_match_char (')') == MATCH_YES)
6733	goto ok;
6734
6735	m = gfc_match_char (',');
6736	if (m != MATCH_YES)
6737	{
6738	if (typeparam)
6739	gfc_error_now ("Expected parameter list in type declaration "
6740	"at %C");
6741	else
6742	gfc_error ("Unexpected junk in formal argument list at %C");
6743	goto cleanup;
6744	}
6745	}
6746
6747	ok:
6748	/* Check for duplicate symbols in the formal argument list. */
6749	if (head != NULL)
6750	{
6751	for (p = head; p->next; p = p->next)
6752	{
6753	if (p->sym == NULL)
6754	continue;
6755
6756	for (q = p->next; q; q = q->next)
6757	if (p->sym == q->sym)
6758	{
6759	if (typeparam)
6760	gfc_error_now ("Duplicate name %qs in parameter "
6761	"list at %C", p->sym->name);
6762	else
6763	gfc_error ("Duplicate symbol %qs in formal argument "
6764	"list at %C", p->sym->name);
6765
6766	m = MATCH_ERROR;
6767	goto cleanup;
6768	}
6769	}
6770	}
6771
6772	if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
6773	{
6774	m = MATCH_ERROR;
6775	goto cleanup;
6776	}
6777
6778	/* gfc_error_now used in following and return with MATCH_YES because
6779	doing otherwise results in a cascade of extraneous errors and in
6780	some cases an ICE in symbol.cc(gfc_release_symbol). */
6781	if (progname->attr.module_procedure && progname->attr.host_assoc)
6782	{
6783	bool arg_count_mismatch = false;
6784
6785	if (!formal && head)
6786	arg_count_mismatch = true;
6787
6788	/* Abbreviated module procedure declaration is not meant to have any
6789	formal arguments! */
6790	if (!progname->abr_modproc_decl && formal && !head)
6791	arg_count_mismatch = true;
6792
6793	for (p = formal, q = head; p && q; p = p->next, q = q->next)
6794	{
6795	if ((p->next != NULL && q->next == NULL)
6796	|| (p->next == NULL && q->next != NULL))
6797	arg_count_mismatch = true;
6798	else if ((p->sym == NULL && q->sym == NULL)
6799	|| (p->sym && q->sym
6800	&& strcmp (s1: p->sym->name, s2: q->sym->name) == 0))
6801	continue;
6802	else
6803	{
6804	if (q->sym == NULL)
6805	gfc_error_now ("MODULE PROCEDURE formal argument %qs "
6806	"conflicts with alternate return at %C",
6807	p->sym->name);
6808	else if (p->sym == NULL)
6809	gfc_error_now ("MODULE PROCEDURE formal argument is "
6810	"alternate return and conflicts with "
6811	"%qs in the separate declaration at %C",
6812	q->sym->name);
6813	else
6814	gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6815	"argument names (%s/%s) at %C",
6816	p->sym->name, q->sym->name);
6817	}
6818	}
6819
6820	if (arg_count_mismatch)
6821	gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6822	"formal arguments at %C");
6823	}
6824
6825	return MATCH_YES;
6826
6827	cleanup:
6828	gfc_free_formal_arglist (head);
6829	return m;
6830	}
6831
6832
6833	/* Match a RESULT specification following a function declaration or
6834	ENTRY statement. Also matches the end-of-statement. */
6835
6836	static match
6837	match_result (gfc_symbol *function, gfc_symbol **result)
6838	{
6839	char name[GFC_MAX_SYMBOL_LEN + 1];
6840	gfc_symbol *r;
6841	match m;
6842
6843	if (gfc_match (" result (") != MATCH_YES)
6844	return MATCH_NO;
6845
6846	m = gfc_match_name (name);
6847	if (m != MATCH_YES)
6848	return m;
6849
6850	/* Get the right paren, and that's it because there could be the
6851	bind(c) attribute after the result clause. */
6852	if (gfc_match_char (')') != MATCH_YES)
6853	{
6854	/* TODO: should report the missing right paren here. */
6855	return MATCH_ERROR;
6856	}
6857
6858	if (strcmp (s1: function->name, s2: name) == 0)
6859	{
6860	gfc_error ("RESULT variable at %C must be different than function name");
6861	return MATCH_ERROR;
6862	}
6863
6864	if (gfc_get_symbol (name, NULL, &r))
6865	return MATCH_ERROR;
6866
6867	if (!gfc_add_result (&r->attr, r->name, NULL))
6868	return MATCH_ERROR;
6869
6870	*result = r;
6871
6872	return MATCH_YES;
6873	}
6874
6875
6876	/* Match a function suffix, which could be a combination of a result
6877	clause and BIND(C), either one, or neither. The draft does not
6878	require them to come in a specific order. */
6879
6880	static match
6881	gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
6882	{
6883	match is_bind_c; /* Found bind(c). */
6884	match is_result; /* Found result clause. */
6885	match found_match; /* Status of whether we've found a good match. */
6886	char peek_char; /* Character we're going to peek at. */
6887	bool allow_binding_name;
6888
6889	/* Initialize to having found nothing. */
6890	found_match = MATCH_NO;
6891	is_bind_c = MATCH_NO;
6892	is_result = MATCH_NO;
6893
6894	/* Get the next char to narrow between result and bind(c). */
6895	gfc_gobble_whitespace ();
6896	peek_char = gfc_peek_ascii_char ();
6897
6898	/* C binding names are not allowed for internal procedures. */
6899	if (gfc_current_state () == COMP_CONTAINS
6900	&& sym->ns->proc_name->attr.flavor != FL_MODULE)
6901	allow_binding_name = false;
6902	else
6903	allow_binding_name = true;
6904
6905	switch (peek_char)
6906	{
6907	case 'r':
6908	/* Look for result clause. */
6909	is_result = match_result (function: sym, result);
6910	if (is_result == MATCH_YES)
6911	{
6912	/* Now see if there is a bind(c) after it. */
6913	is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6914	/* We've found the result clause and possibly bind(c). */
6915	found_match = MATCH_YES;
6916	}
6917	else
6918	/* This should only be MATCH_ERROR. */
6919	found_match = is_result;
6920	break;
6921	case 'b':
6922	/* Look for bind(c) first. */
6923	is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6924	if (is_bind_c == MATCH_YES)
6925	{
6926	/* Now see if a result clause followed it. */
6927	is_result = match_result (function: sym, result);
6928	found_match = MATCH_YES;
6929	}
6930	else
6931	{
6932	/* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6933	found_match = MATCH_ERROR;
6934	}
6935	break;
6936	default:
6937	gfc_error ("Unexpected junk after function declaration at %C");
6938	found_match = MATCH_ERROR;
6939	break;
6940	}
6941
6942	if (is_bind_c == MATCH_YES)
6943	{
6944	/* Fortran 2008 draft allows BIND(C) for internal procedures. */
6945	if (gfc_current_state () == COMP_CONTAINS
6946	&& sym->ns->proc_name->attr.flavor != FL_MODULE
6947	&& !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6948	"at %L may not be specified for an internal "
6949	"procedure", &gfc_current_locus))
6950	return MATCH_ERROR;
6951
6952	if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
6953	return MATCH_ERROR;
6954	}
6955
6956	return found_match;
6957	}
6958
6959
6960	/* Procedure pointer return value without RESULT statement:
6961	Add "hidden" result variable named "ppr@". */
6962
6963	static bool
6964	add_hidden_procptr_result (gfc_symbol *sym)
6965	{
6966	bool case1,case2;
6967
6968	if (gfc_notification_std (GFC_STD_F2003) == ERROR)
6969	return false;
6970
6971	/* First usage case: PROCEDURE and EXTERNAL statements. */
6972	case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
6973	&& strcmp (gfc_current_block ()->name, s2: sym->name) == 0
6974	&& sym->attr.external;
6975	/* Second usage case: INTERFACE statements. */
6976	case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
6977	&& gfc_state_stack->previous->state == COMP_FUNCTION
6978	&& strcmp (s1: gfc_state_stack->previous->sym->name, s2: sym->name) == 0;
6979
6980	if (case1 || case2)
6981	{
6982	gfc_symtree *stree;
6983	if (case1)
6984	gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
6985	else
6986	{
6987	gfc_symtree *st2;
6988	gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
6989	st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
6990	st2->n.sym = stree->n.sym;
6991	stree->n.sym->refs++;
6992	}
6993	sym->result = stree->n.sym;
6994
6995	sym->result->attr.proc_pointer = sym->attr.proc_pointer;
6996	sym->result->attr.pointer = sym->attr.pointer;
6997	sym->result->attr.external = sym->attr.external;
6998	sym->result->attr.referenced = sym->attr.referenced;
6999	sym->result->ts = sym->ts;
7000	sym->attr.proc_pointer = 0;
7001	sym->attr.pointer = 0;
7002	sym->attr.external = 0;
7003	if (sym->result->attr.external && sym->result->attr.pointer)
7004	{
7005	sym->result->attr.pointer = 0;
7006	sym->result->attr.proc_pointer = 1;
7007	}
7008
7009	return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7010	}
7011	/* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7012	else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7013	&& sym->result && sym->result != sym && sym->result->attr.external
7014	&& sym == gfc_current_ns->proc_name
7015	&& sym == sym->result->ns->proc_name
7016	&& strcmp (s1: "ppr@", s2: sym->result->name) == 0)
7017	{
7018	sym->result->attr.proc_pointer = 1;
7019	sym->attr.pointer = 0;
7020	return true;
7021	}
7022	else
7023	return false;
7024	}
7025
7026
7027	/* Match the interface for a PROCEDURE declaration,
7028	including brackets (R1212). */
7029
7030	static match
7031	match_procedure_interface (gfc_symbol **proc_if)
7032	{
7033	match m;
7034	gfc_symtree *st;
7035	locus old_loc, entry_loc;
7036	gfc_namespace *old_ns = gfc_current_ns;
7037	char name[GFC_MAX_SYMBOL_LEN + 1];
7038
7039	old_loc = entry_loc = gfc_current_locus;
7040	gfc_clear_ts (&current_ts);
7041
7042	if (gfc_match (" (") != MATCH_YES)
7043	{
7044	gfc_current_locus = entry_loc;
7045	return MATCH_NO;
7046	}
7047
7048	/* Get the type spec. for the procedure interface. */
7049	old_loc = gfc_current_locus;
7050	m = gfc_match_decl_type_spec (ts: &current_ts, implicit_flag: 0);
7051	gfc_gobble_whitespace ();
7052	if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7053	goto got_ts;
7054
7055	if (m == MATCH_ERROR)
7056	return m;
7057
7058	/* Procedure interface is itself a procedure. */
7059	gfc_current_locus = old_loc;
7060	m = gfc_match_name (name);
7061
7062	/* First look to see if it is already accessible in the current
7063	namespace because it is use associated or contained. */
7064	st = NULL;
7065	if (gfc_find_sym_tree (name, NULL, 0, &st))
7066	return MATCH_ERROR;
7067
7068	/* If it is still not found, then try the parent namespace, if it
7069	exists and create the symbol there if it is still not found. */
7070	if (gfc_current_ns->parent)
7071	gfc_current_ns = gfc_current_ns->parent;
7072	if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7073	return MATCH_ERROR;
7074
7075	gfc_current_ns = old_ns;
7076	*proc_if = st->n.sym;
7077
7078	if (*proc_if)
7079	{
7080	(*proc_if)->refs++;
7081	/* Resolve interface if possible. That way, attr.procedure is only set
7082	if it is declared by a later procedure-declaration-stmt, which is
7083	invalid per F08:C1216 (cf. resolve_procedure_interface). */
7084	while ((*proc_if)->ts.interface
7085	&& *proc_if != (*proc_if)->ts.interface)
7086	*proc_if = (*proc_if)->ts.interface;
7087
7088	if ((*proc_if)->attr.flavor == FL_UNKNOWN
7089	&& (*proc_if)->ts.type == BT_UNKNOWN
7090	&& !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7091	(*proc_if)->name, NULL))
7092	return MATCH_ERROR;
7093	}
7094
7095	got_ts:
7096	if (gfc_match (" )") != MATCH_YES)
7097	{
7098	gfc_current_locus = entry_loc;
7099	return MATCH_NO;
7100	}
7101
7102	return MATCH_YES;
7103	}
7104
7105
7106	/* Match a PROCEDURE declaration (R1211). */
7107
7108	static match
7109	match_procedure_decl (void)
7110	{
7111	match m;
7112	gfc_symbol *sym, *proc_if = NULL;
7113	int num;
7114	gfc_expr *initializer = NULL;
7115
7116	/* Parse interface (with brackets). */
7117	m = match_procedure_interface (proc_if: &proc_if);
7118	if (m != MATCH_YES)
7119	return m;
7120
7121	/* Parse attributes (with colons). */
7122	m = match_attr_spec();
7123	if (m == MATCH_ERROR)
7124	return MATCH_ERROR;
7125
7126	if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7127	{
7128	current_attr.is_bind_c = 1;
7129	has_name_equals = 0;
7130	curr_binding_label = NULL;
7131	}
7132
7133	/* Get procedure symbols. */
7134	for(num=1;;num++)
7135	{
7136	m = gfc_match_symbol (&sym, 0);
7137	if (m == MATCH_NO)
7138	goto syntax;
7139	else if (m == MATCH_ERROR)
7140	return m;
7141
7142	/* Add current_attr to the symbol attributes. */
7143	if (!gfc_copy_attr (&sym->attr, &current_attr, NULL))
7144	return MATCH_ERROR;
7145
7146	if (sym->attr.is_bind_c)
7147	{
7148	/* Check for C1218. */
7149	if (!proc_if || !proc_if->attr.is_bind_c)
7150	{
7151	gfc_error ("BIND(C) attribute at %C requires "
7152	"an interface with BIND(C)");
7153	return MATCH_ERROR;
7154	}
7155	/* Check for C1217. */
7156	if (has_name_equals && sym->attr.pointer)
7157	{
7158	gfc_error ("BIND(C) procedure with NAME may not have "
7159	"POINTER attribute at %C");
7160	return MATCH_ERROR;
7161	}
7162	if (has_name_equals && sym->attr.dummy)
7163	{
7164	gfc_error ("Dummy procedure at %C may not have "
7165	"BIND(C) attribute with NAME");
7166	return MATCH_ERROR;
7167	}
7168	/* Set binding label for BIND(C). */
7169	if (!set_binding_label (dest_label: &sym->binding_label, sym_name: sym->name, num_idents: num))
7170	return MATCH_ERROR;
7171	}
7172
7173	if (!gfc_add_external (&sym->attr, NULL))
7174	return MATCH_ERROR;
7175
7176	if (add_hidden_procptr_result (sym))
7177	sym = sym->result;
7178
7179	if (!gfc_add_proc (attr: &sym->attr, name: sym->name, NULL))
7180	return MATCH_ERROR;
7181
7182	/* Set interface. */
7183	if (proc_if != NULL)
7184	{
7185	if (sym->ts.type != BT_UNKNOWN)
7186	{
7187	gfc_error ("Procedure %qs at %L already has basic type of %s",
7188	sym->name, &gfc_current_locus,
7189	gfc_basic_typename (sym->ts.type));
7190	return MATCH_ERROR;
7191	}
7192	sym->ts.interface = proc_if;
7193	sym->attr.untyped = 1;
7194	sym->attr.if_source = IFSRC_IFBODY;
7195	}
7196	else if (current_ts.type != BT_UNKNOWN)
7197	{
7198	if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
7199	return MATCH_ERROR;
7200	sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7201	sym->ts.interface->ts = current_ts;
7202	sym->ts.interface->attr.flavor = FL_PROCEDURE;
7203	sym->ts.interface->attr.function = 1;
7204	sym->attr.function = 1;
7205	sym->attr.if_source = IFSRC_UNKNOWN;
7206	}
7207
7208	if (gfc_match (" =>") == MATCH_YES)
7209	{
7210	if (!current_attr.pointer)
7211	{
7212	gfc_error ("Initialization at %C isn't for a pointer variable");
7213	m = MATCH_ERROR;
7214	goto cleanup;
7215	}
7216
7217	m = match_pointer_init (init: &initializer, procptr: 1);
7218	if (m != MATCH_YES)
7219	goto cleanup;
7220
7221	if (!add_init_expr_to_sym (name: sym->name, initp: &initializer, var_locus: &gfc_current_locus))
7222	goto cleanup;
7223
7224	}
7225
7226	if (gfc_match_eos () == MATCH_YES)
7227	return MATCH_YES;
7228	if (gfc_match_char (',') != MATCH_YES)
7229	goto syntax;
7230	}
7231
7232	syntax:
7233	gfc_error ("Syntax error in PROCEDURE statement at %C");
7234	return MATCH_ERROR;
7235
7236	cleanup:
7237	/* Free stuff up and return. */
7238	gfc_free_expr (initializer);
7239	return m;
7240	}
7241
7242
7243	static match
7244	match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7245
7246
7247	/* Match a procedure pointer component declaration (R445). */
7248
7249	static match
7250	match_ppc_decl (void)
7251	{
7252	match m;
7253	gfc_symbol *proc_if = NULL;
7254	gfc_typespec ts;
7255	int num;
7256	gfc_component *c;
7257	gfc_expr *initializer = NULL;
7258	gfc_typebound_proc* tb;
7259	char name[GFC_MAX_SYMBOL_LEN + 1];
7260
7261	/* Parse interface (with brackets). */
7262	m = match_procedure_interface (proc_if: &proc_if);
7263	if (m != MATCH_YES)
7264	goto syntax;
7265
7266	/* Parse attributes. */
7267	tb = XCNEW (gfc_typebound_proc);
7268	tb->where = gfc_current_locus;
7269	m = match_binding_attributes (ba: tb, generic: false, ppc: true);
7270	if (m == MATCH_ERROR)
7271	return m;
7272
7273	gfc_clear_attr (&current_attr);
7274	current_attr.procedure = 1;
7275	current_attr.proc_pointer = 1;
7276	current_attr.access = tb->access;
7277	current_attr.flavor = FL_PROCEDURE;
7278
7279	/* Match the colons (required). */
7280	if (gfc_match (" ::") != MATCH_YES)
7281	{
7282	gfc_error ("Expected %<::%> after binding-attributes at %C");
7283	return MATCH_ERROR;
7284	}
7285
7286	/* Check for C450. */
7287	if (!tb->nopass && proc_if == NULL)
7288	{
7289	gfc_error("NOPASS or explicit interface required at %C");
7290	return MATCH_ERROR;
7291	}
7292
7293	if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7294	return MATCH_ERROR;
7295
7296	/* Match PPC names. */
7297	ts = current_ts;
7298	for(num=1;;num++)
7299	{
7300	m = gfc_match_name (name);
7301	if (m == MATCH_NO)
7302	goto syntax;
7303	else if (m == MATCH_ERROR)
7304	return m;
7305
7306	if (!gfc_add_component (gfc_current_block(), name, &c))
7307	return MATCH_ERROR;
7308
7309	/* Add current_attr to the symbol attributes. */
7310	if (!gfc_copy_attr (&c->attr, &current_attr, NULL))
7311	return MATCH_ERROR;
7312
7313	if (!gfc_add_external (&c->attr, NULL))
7314	return MATCH_ERROR;
7315
7316	if (!gfc_add_proc (attr: &c->attr, name, NULL))
7317	return MATCH_ERROR;
7318
7319	if (num == 1)
7320	c->tb = tb;
7321	else
7322	{
7323	c->tb = XCNEW (gfc_typebound_proc);
7324	c->tb->where = gfc_current_locus;
7325	*c->tb = *tb;
7326	}
7327
7328	/* Set interface. */
7329	if (proc_if != NULL)
7330	{
7331	c->ts.interface = proc_if;
7332	c->attr.untyped = 1;
7333	c->attr.if_source = IFSRC_IFBODY;
7334	}
7335	else if (ts.type != BT_UNKNOWN)
7336	{
7337	c->ts = ts;
7338	c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7339	c->ts.interface->result = c->ts.interface;
7340	c->ts.interface->ts = ts;
7341	c->ts.interface->attr.flavor = FL_PROCEDURE;
7342	c->ts.interface->attr.function = 1;
7343	c->attr.function = 1;
7344	c->attr.if_source = IFSRC_UNKNOWN;
7345	}
7346
7347	if (gfc_match (" =>") == MATCH_YES)
7348	{
7349	m = match_pointer_init (init: &initializer, procptr: 1);
7350	if (m != MATCH_YES)
7351	{
7352	gfc_free_expr (initializer);
7353	return m;
7354	}
7355	c->initializer = initializer;
7356	}
7357
7358	if (gfc_match_eos () == MATCH_YES)
7359	return MATCH_YES;
7360	if (gfc_match_char (',') != MATCH_YES)
7361	goto syntax;
7362	}
7363
7364	syntax:
7365	gfc_error ("Syntax error in procedure pointer component at %C");
7366	return MATCH_ERROR;
7367	}
7368
7369
7370	/* Match a PROCEDURE declaration inside an interface (R1206). */
7371
7372	static match
7373	match_procedure_in_interface (void)
7374	{
7375	match m;
7376	gfc_symbol *sym;
7377	char name[GFC_MAX_SYMBOL_LEN + 1];
7378	locus old_locus;
7379
7380	if (current_interface.type == INTERFACE_NAMELESS
7381	|| current_interface.type == INTERFACE_ABSTRACT)
7382	{
7383	gfc_error ("PROCEDURE at %C must be in a generic interface");
7384	return MATCH_ERROR;
7385	}
7386
7387	/* Check if the F2008 optional double colon appears. */
7388	gfc_gobble_whitespace ();
7389	old_locus = gfc_current_locus;
7390	if (gfc_match ("::") == MATCH_YES)
7391	{
7392	if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
7393	"MODULE PROCEDURE statement at %L", &old_locus))
7394	return MATCH_ERROR;
7395	}
7396	else
7397	gfc_current_locus = old_locus;
7398
7399	for(;;)
7400	{
7401	m = gfc_match_name (name);
7402	if (m == MATCH_NO)
7403	goto syntax;
7404	else if (m == MATCH_ERROR)
7405	return m;
7406	if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
7407	return MATCH_ERROR;
7408
7409	if (!gfc_add_interface (sym))
7410	return MATCH_ERROR;
7411
7412	if (gfc_match_eos () == MATCH_YES)
7413	break;
7414	if (gfc_match_char (',') != MATCH_YES)
7415	goto syntax;
7416	}
7417
7418	return MATCH_YES;
7419
7420	syntax:
7421	gfc_error ("Syntax error in PROCEDURE statement at %C");
7422	return MATCH_ERROR;
7423	}
7424
7425
7426	/* General matcher for PROCEDURE declarations. */
7427
7428	static match match_procedure_in_type (void);
7429
7430	match
7431	gfc_match_procedure (void)
7432	{
7433	match m;
7434
7435	switch (gfc_current_state ())
7436	{
7437	case COMP_NONE:
7438	case COMP_PROGRAM:
7439	case COMP_MODULE:
7440	case COMP_SUBMODULE:
7441	case COMP_SUBROUTINE:
7442	case COMP_FUNCTION:
7443	case COMP_BLOCK:
7444	m = match_procedure_decl ();
7445	break;
7446	case COMP_INTERFACE:
7447	m = match_procedure_in_interface ();
7448	break;
7449	case COMP_DERIVED:
7450	m = match_ppc_decl ();
7451	break;
7452	case COMP_DERIVED_CONTAINS:
7453	m = match_procedure_in_type ();
7454	break;
7455	default:
7456	return MATCH_NO;
7457	}
7458
7459	if (m != MATCH_YES)
7460	return m;
7461
7462	if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
7463	return MATCH_ERROR;
7464
7465	return m;
7466	}
7467
7468
7469	/* Warn if a matched procedure has the same name as an intrinsic; this is
7470	simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7471	parser-state-stack to find out whether we're in a module. */
7472
7473	static void
7474	do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
7475	{
7476	bool in_module;
7477
7478	in_module = (gfc_state_stack->previous
7479	&& (gfc_state_stack->previous->state == COMP_MODULE
7480	|| gfc_state_stack->previous->state == COMP_SUBMODULE));
7481
7482	gfc_warn_intrinsic_shadow (sym, in_module, func);
7483	}
7484
7485
7486	/* Match a function declaration. */
7487
7488	match
7489	gfc_match_function_decl (void)
7490	{
7491	char name[GFC_MAX_SYMBOL_LEN + 1];
7492	gfc_symbol *sym, *result;
7493	locus old_loc;
7494	match m;
7495	match suffix_match;
7496	match found_match; /* Status returned by match func. */
7497
7498	if (gfc_current_state () != COMP_NONE
7499	&& gfc_current_state () != COMP_INTERFACE
7500	&& gfc_current_state () != COMP_CONTAINS)
7501	return MATCH_NO;
7502
7503	gfc_clear_ts (&current_ts);
7504
7505	old_loc = gfc_current_locus;
7506
7507	m = gfc_match_prefix (ts: &current_ts);
7508	if (m != MATCH_YES)
7509	{
7510	gfc_current_locus = old_loc;
7511	return m;
7512	}
7513
7514	if (gfc_match ("function% %n", name) != MATCH_YES)
7515	{
7516	gfc_current_locus = old_loc;
7517	return MATCH_NO;
7518	}
7519
7520	if (get_proc_name (name, result: &sym, module_fcn_entry: false))
7521	return MATCH_ERROR;
7522
7523	if (add_hidden_procptr_result (sym))
7524	sym = sym->result;
7525
7526	if (current_attr.module_procedure)
7527	sym->attr.module_procedure = 1;
7528
7529	gfc_new_block = sym;
7530
7531	m = gfc_match_formal_arglist (progname: sym, st_flag: 0, null_flag: 0);
7532	if (m == MATCH_NO)
7533	{
7534	gfc_error ("Expected formal argument list in function "
7535	"definition at %C");
7536	m = MATCH_ERROR;
7537	goto cleanup;
7538	}
7539	else if (m == MATCH_ERROR)
7540	goto cleanup;
7541
7542	result = NULL;
7543
7544	/* According to the draft, the bind(c) and result clause can
7545	come in either order after the formal_arg_list (i.e., either
7546	can be first, both can exist together or by themselves or neither
7547	one). Therefore, the match_result can't match the end of the
7548	string, and check for the bind(c) or result clause in either order. */
7549	found_match = gfc_match_eos ();
7550
7551	/* Make sure that it isn't already declared as BIND(C). If it is, it
7552	must have been marked BIND(C) with a BIND(C) attribute and that is
7553	not allowed for procedures. */
7554	if (sym->attr.is_bind_c == 1)
7555	{
7556	sym->attr.is_bind_c = 0;
7557
7558	if (gfc_state_stack->previous
7559	&& gfc_state_stack->previous->state != COMP_SUBMODULE)
7560	{
7561	locus loc;
7562	loc = sym->old_symbol != NULL
7563	? sym->old_symbol->declared_at : gfc_current_locus;
7564	gfc_error_now ("BIND(C) attribute at %L can only be used for "
7565	"variables or common blocks", &loc);
7566	}
7567	}
7568
7569	if (found_match != MATCH_YES)
7570	{
7571	/* If we haven't found the end-of-statement, look for a suffix. */
7572	suffix_match = gfc_match_suffix (sym, result: &result);
7573	if (suffix_match == MATCH_YES)
7574	/* Need to get the eos now. */
7575	found_match = gfc_match_eos ();
7576	else
7577	found_match = suffix_match;
7578	}
7579
7580	/* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7581	subprogram and a binding label is specified, it shall be the
7582	same as the binding label specified in the corresponding module
7583	procedure interface body. */
7584	if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
7585	&& strcmp (s1: sym->name, s2: sym->old_symbol->name) == 0
7586	&& sym->binding_label && sym->old_symbol->binding_label
7587	&& strcmp (s1: sym->binding_label, s2: sym->old_symbol->binding_label) != 0)
7588	{
7589	const char *null = "NULL", *s1, *s2;
7590	s1 = sym->binding_label;
7591	if (!s1) s1 = null;
7592	s2 = sym->old_symbol->binding_label;
7593	if (!s2) s2 = null;
7594	gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
7595	sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
7596	return MATCH_ERROR;
7597	}
7598
7599	if(found_match != MATCH_YES)
7600	m = MATCH_ERROR;
7601	else
7602	{
7603	/* Make changes to the symbol. */
7604	m = MATCH_ERROR;
7605
7606	if (!gfc_add_function (&sym->attr, sym->name, NULL))
7607	goto cleanup;
7608
7609	if (!gfc_missing_attr (&sym->attr, NULL))
7610	goto cleanup;
7611
7612	if (!copy_prefix (dest: &sym->attr, where: &sym->declared_at))
7613	{
7614	if(!sym->attr.module_procedure)
7615	goto cleanup;
7616	else
7617	gfc_error_check ();
7618	}
7619
7620	/* Delay matching the function characteristics until after the
7621	specification block by signalling kind=-1. */
7622	sym->declared_at = old_loc;
7623	if (current_ts.type != BT_UNKNOWN)
7624	current_ts.kind = -1;
7625	else
7626	current_ts.kind = 0;
7627
7628	if (result == NULL)
7629	{
7630	if (current_ts.type != BT_UNKNOWN
7631	&& !gfc_add_type (sym, &current_ts, &gfc_current_locus))
7632	goto cleanup;
7633	sym->result = sym;
7634	}
7635	else
7636	{
7637	if (current_ts.type != BT_UNKNOWN
7638	&& !gfc_add_type (result, &current_ts, &gfc_current_locus))
7639	goto cleanup;
7640	sym->result = result;
7641	}
7642
7643	/* Warn if this procedure has the same name as an intrinsic. */
7644	do_warn_intrinsic_shadow (sym, func: true);
7645
7646	return MATCH_YES;
7647	}
7648
7649	cleanup:
7650	gfc_current_locus = old_loc;
7651	return m;
7652	}
7653
7654
7655	/* This is mostly a copy of parse.cc(add_global_procedure) but modified to
7656	pass the name of the entry, rather than the gfc_current_block name, and
7657	to return false upon finding an existing global entry. */
7658
7659	static bool
7660	add_global_entry (const char *name, const char *binding_label, bool sub,
7661	locus *where)
7662	{
7663	gfc_gsymbol *s;
7664	enum gfc_symbol_type type;
7665
7666	type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7667
7668	/* Only in Fortran 2003: For procedures with a binding label also the Fortran
7669	name is a global identifier. */
7670	if (!binding_label || gfc_notification_std (GFC_STD_F2008))
7671	{
7672	s = gfc_get_gsymbol (name, bind_c: false);
7673
7674	if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7675	{
7676	gfc_global_used (s, where);
7677	return false;
7678	}
7679	else
7680	{
7681	s->type = type;
7682	s->sym_name = name;
7683	s->where = *where;
7684	s->defined = 1;
7685	s->ns = gfc_current_ns;
7686	}
7687	}
7688
7689	/* Don't add the symbol multiple times. */
7690	if (binding_label
7691	&& (!gfc_notification_std (GFC_STD_F2008)
7692	|| strcmp (s1: name, s2: binding_label) != 0))
7693	{
7694	s = gfc_get_gsymbol (binding_label, bind_c: true);
7695
7696	if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7697	{
7698	gfc_global_used (s, where);
7699	return false;
7700	}
7701	else
7702	{
7703	s->type = type;
7704	s->sym_name = name;
7705	s->binding_label = binding_label;
7706	s->where = *where;
7707	s->defined = 1;
7708	s->ns = gfc_current_ns;
7709	}
7710	}
7711
7712	return true;
7713	}
7714
7715
7716	/* Match an ENTRY statement. */
7717
7718	match
7719	gfc_match_entry (void)
7720	{
7721	gfc_symbol *proc;
7722	gfc_symbol *result;
7723	gfc_symbol *entry;
7724	char name[GFC_MAX_SYMBOL_LEN + 1];
7725	gfc_compile_state state;
7726	match m;
7727	gfc_entry_list *el;
7728	locus old_loc;
7729	bool module_procedure;
7730	char peek_char;
7731	match is_bind_c;
7732
7733	m = gfc_match_name (name);
7734	if (m != MATCH_YES)
7735	return m;
7736
7737	if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
7738	return MATCH_ERROR;
7739
7740	state = gfc_current_state ();
7741	if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
7742	{
7743	switch (state)
7744	{
7745	case COMP_PROGRAM:
7746	gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7747	break;
7748	case COMP_MODULE:
7749	gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7750	break;
7751	case COMP_SUBMODULE:
7752	gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7753	break;
7754	case COMP_BLOCK_DATA:
7755	gfc_error ("ENTRY statement at %C cannot appear within "
7756	"a BLOCK DATA");
7757	break;
7758	case COMP_INTERFACE:
7759	gfc_error ("ENTRY statement at %C cannot appear within "
7760	"an INTERFACE");
7761	break;
7762	case COMP_STRUCTURE:
7763	gfc_error ("ENTRY statement at %C cannot appear within "
7764	"a STRUCTURE block");
7765	break;
7766	case COMP_DERIVED:
7767	gfc_error ("ENTRY statement at %C cannot appear within "
7768	"a DERIVED TYPE block");
7769	break;
7770	case COMP_IF:
7771	gfc_error ("ENTRY statement at %C cannot appear within "
7772	"an IF-THEN block");
7773	break;
7774	case COMP_DO:
7775	case COMP_DO_CONCURRENT:
7776	gfc_error ("ENTRY statement at %C cannot appear within "
7777	"a DO block");
7778	break;
7779	case COMP_SELECT:
7780	gfc_error ("ENTRY statement at %C cannot appear within "
7781	"a SELECT block");
7782	break;
7783	case COMP_FORALL:
7784	gfc_error ("ENTRY statement at %C cannot appear within "
7785	"a FORALL block");
7786	break;
7787	case COMP_WHERE:
7788	gfc_error ("ENTRY statement at %C cannot appear within "
7789	"a WHERE block");
7790	break;
7791	case COMP_CONTAINS:
7792	gfc_error ("ENTRY statement at %C cannot appear within "
7793	"a contained subprogram");
7794	break;
7795	default:
7796	gfc_error ("Unexpected ENTRY statement at %C");
7797	}
7798	return MATCH_ERROR;
7799	}
7800
7801	if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
7802	&& gfc_state_stack->previous->state == COMP_INTERFACE)
7803	{
7804	gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7805	return MATCH_ERROR;
7806	}
7807
7808	module_procedure = gfc_current_ns->parent != NULL
7809	&& gfc_current_ns->parent->proc_name
7810	&& gfc_current_ns->parent->proc_name->attr.flavor
7811	== FL_MODULE;
7812
7813	if (gfc_current_ns->parent != NULL
7814	&& gfc_current_ns->parent->proc_name
7815	&& !module_procedure)
7816	{
7817	gfc_error("ENTRY statement at %C cannot appear in a "
7818	"contained procedure");
7819	return MATCH_ERROR;
7820	}
7821
7822	/* Module function entries need special care in get_proc_name
7823	because previous references within the function will have
7824	created symbols attached to the current namespace. */
7825	if (get_proc_name (name, result: &entry,
7826	module_fcn_entry: gfc_current_ns->parent != NULL
7827	&& module_procedure))
7828	return MATCH_ERROR;
7829
7830	proc = gfc_current_block ();
7831
7832	/* Make sure that it isn't already declared as BIND(C). If it is, it
7833	must have been marked BIND(C) with a BIND(C) attribute and that is
7834	not allowed for procedures. */
7835	if (entry->attr.is_bind_c == 1)
7836	{
7837	locus loc;
7838
7839	entry->attr.is_bind_c = 0;
7840
7841	loc = entry->old_symbol != NULL
7842	? entry->old_symbol->declared_at : gfc_current_locus;
7843	gfc_error_now ("BIND(C) attribute at %L can only be used for "
7844	"variables or common blocks", &loc);
7845	}
7846
7847	/* Check what next non-whitespace character is so we can tell if there
7848	is the required parens if we have a BIND(C). */
7849	old_loc = gfc_current_locus;
7850	gfc_gobble_whitespace ();
7851	peek_char = gfc_peek_ascii_char ();
7852
7853	if (state == COMP_SUBROUTINE)
7854	{
7855	m = gfc_match_formal_arglist (progname: entry, st_flag: 0, null_flag: 1);
7856	if (m != MATCH_YES)
7857	return MATCH_ERROR;
7858
7859	/* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7860	never be an internal procedure. */
7861	is_bind_c = gfc_match_bind_c (entry, true);
7862	if (is_bind_c == MATCH_ERROR)
7863	return MATCH_ERROR;
7864	if (is_bind_c == MATCH_YES)
7865	{
7866	if (peek_char != '(')
7867	{
7868	gfc_error ("Missing required parentheses before BIND(C) at %C");
7869	return MATCH_ERROR;
7870	}
7871
7872	if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
7873	&(entry->declared_at), 1))
7874	return MATCH_ERROR;
7875
7876	}
7877
7878	if (!gfc_current_ns->parent
7879	&& !add_global_entry (name, binding_label: entry->binding_label, sub: true,
7880	where: &old_loc))
7881	return MATCH_ERROR;
7882
7883	/* An entry in a subroutine. */
7884	if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7885	|| !gfc_add_subroutine (&entry->attr, entry->name, NULL))
7886	return MATCH_ERROR;
7887	}
7888	else
7889	{
7890	/* An entry in a function.
7891	We need to take special care because writing
7892	ENTRY f()
7893	as
7894	ENTRY f
7895	is allowed, whereas
7896	ENTRY f() RESULT (r)
7897	can't be written as
7898	ENTRY f RESULT (r). */
7899	if (gfc_match_eos () == MATCH_YES)
7900	{
7901	gfc_current_locus = old_loc;
7902	/* Match the empty argument list, and add the interface to
7903	the symbol. */
7904	m = gfc_match_formal_arglist (progname: entry, st_flag: 0, null_flag: 1);
7905	}
7906	else
7907	m = gfc_match_formal_arglist (progname: entry, st_flag: 0, null_flag: 0);
7908
7909	if (m != MATCH_YES)
7910	return MATCH_ERROR;
7911
7912	result = NULL;
7913
7914	if (gfc_match_eos () == MATCH_YES)
7915	{
7916	if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7917	|| !gfc_add_function (&entry->attr, entry->name, NULL))
7918	return MATCH_ERROR;
7919
7920	entry->result = entry;
7921	}
7922	else
7923	{
7924	m = gfc_match_suffix (sym: entry, result: &result);
7925	if (m == MATCH_NO)
7926	gfc_syntax_error (ST_ENTRY);
7927	if (m != MATCH_YES)
7928	return MATCH_ERROR;
7929
7930	if (result)
7931	{
7932	if (!gfc_add_result (&result->attr, result->name, NULL)
7933	|| !gfc_add_entry (&entry->attr, result->name, NULL)
7934	|| !gfc_add_function (&entry->attr, result->name, NULL))
7935	return MATCH_ERROR;
7936	entry->result = result;
7937	}
7938	else
7939	{
7940	if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7941	|| !gfc_add_function (&entry->attr, entry->name, NULL))
7942	return MATCH_ERROR;
7943	entry->result = entry;
7944	}
7945	}
7946
7947	if (!gfc_current_ns->parent
7948	&& !add_global_entry (name, binding_label: entry->binding_label, sub: false,
7949	where: &old_loc))
7950	return MATCH_ERROR;
7951	}
7952
7953	if (gfc_match_eos () != MATCH_YES)
7954	{
7955	gfc_syntax_error (ST_ENTRY);
7956	return MATCH_ERROR;
7957	}
7958
7959	/* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7960	if (proc->attr.elemental && entry->attr.is_bind_c)
7961	{
7962	gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7963	"elemental procedure", &entry->declared_at);
7964	return MATCH_ERROR;
7965	}
7966
7967	entry->attr.recursive = proc->attr.recursive;
7968	entry->attr.elemental = proc->attr.elemental;
7969	entry->attr.pure = proc->attr.pure;
7970
7971	el = gfc_get_entry_list ();
7972	el->sym = entry;
7973	el->next = gfc_current_ns->entries;
7974	gfc_current_ns->entries = el;
7975	if (el->next)
7976	el->id = el->next->id + 1;
7977	else
7978	el->id = 1;
7979
7980	new_st.op = EXEC_ENTRY;
7981	new_st.ext.entry = el;
7982
7983	return MATCH_YES;
7984	}
7985
7986
7987	/* Match a subroutine statement, including optional prefixes. */
7988
7989	match
7990	gfc_match_subroutine (void)
7991	{
7992	char name[GFC_MAX_SYMBOL_LEN + 1];
7993	gfc_symbol *sym;
7994	match m;
7995	match is_bind_c;
7996	char peek_char;
7997	bool allow_binding_name;
7998	locus loc;
7999
8000	if (gfc_current_state () != COMP_NONE
8001	&& gfc_current_state () != COMP_INTERFACE
8002	&& gfc_current_state () != COMP_CONTAINS)
8003	return MATCH_NO;
8004
8005	m = gfc_match_prefix (NULL);
8006	if (m != MATCH_YES)
8007	return m;
8008
8009	m = gfc_match ("subroutine% %n", name);
8010	if (m != MATCH_YES)
8011	return m;
8012
8013	if (get_proc_name (name, result: &sym, module_fcn_entry: false))
8014	return MATCH_ERROR;
8015
8016	/* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8017	the symbol existed before. */
8018	sym->declared_at = gfc_current_locus;
8019
8020	if (current_attr.module_procedure)
8021	sym->attr.module_procedure = 1;
8022
8023	if (add_hidden_procptr_result (sym))
8024	sym = sym->result;
8025
8026	gfc_new_block = sym;
8027
8028	/* Check what next non-whitespace character is so we can tell if there
8029	is the required parens if we have a BIND(C). */
8030	gfc_gobble_whitespace ();
8031	peek_char = gfc_peek_ascii_char ();
8032
8033	if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8034	return MATCH_ERROR;
8035
8036	if (gfc_match_formal_arglist (progname: sym, st_flag: 0, null_flag: 1) != MATCH_YES)
8037	return MATCH_ERROR;
8038
8039	/* Make sure that it isn't already declared as BIND(C). If it is, it
8040	must have been marked BIND(C) with a BIND(C) attribute and that is
8041	not allowed for procedures. */
8042	if (sym->attr.is_bind_c == 1)
8043	{
8044	sym->attr.is_bind_c = 0;
8045
8046	if (gfc_state_stack->previous
8047	&& gfc_state_stack->previous->state != COMP_SUBMODULE)
8048	{
8049	locus loc;
8050	loc = sym->old_symbol != NULL
8051	? sym->old_symbol->declared_at : gfc_current_locus;
8052	gfc_error_now ("BIND(C) attribute at %L can only be used for "
8053	"variables or common blocks", &loc);
8054	}
8055	}
8056
8057	/* C binding names are not allowed for internal procedures. */
8058	if (gfc_current_state () == COMP_CONTAINS
8059	&& sym->ns->proc_name->attr.flavor != FL_MODULE)
8060	allow_binding_name = false;
8061	else
8062	allow_binding_name = true;
8063
8064	/* Here, we are just checking if it has the bind(c) attribute, and if
8065	so, then we need to make sure it's all correct. If it doesn't,
8066	we still need to continue matching the rest of the subroutine line. */
8067	gfc_gobble_whitespace ();
8068	loc = gfc_current_locus;
8069	is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8070	if (is_bind_c == MATCH_ERROR)
8071	{
8072	/* There was an attempt at the bind(c), but it was wrong. An
8073	error message should have been printed w/in the gfc_match_bind_c
8074	so here we'll just return the MATCH_ERROR. */
8075	return MATCH_ERROR;
8076	}
8077
8078	if (is_bind_c == MATCH_YES)
8079	{
8080	gfc_formal_arglist *arg;
8081
8082	/* The following is allowed in the Fortran 2008 draft. */
8083	if (gfc_current_state () == COMP_CONTAINS
8084	&& sym->ns->proc_name->attr.flavor != FL_MODULE
8085	&& !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8086	"at %L may not be specified for an internal "
8087	"procedure", &gfc_current_locus))
8088	return MATCH_ERROR;
8089
8090	if (peek_char != '(')
8091	{
8092	gfc_error ("Missing required parentheses before BIND(C) at %C");
8093	return MATCH_ERROR;
8094	}
8095
8096	/* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8097	subprogram and a binding label is specified, it shall be the
8098	same as the binding label specified in the corresponding module
8099	procedure interface body. */
8100	if (sym->attr.module_procedure && sym->old_symbol
8101	&& strcmp (s1: sym->name, s2: sym->old_symbol->name) == 0
8102	&& sym->binding_label && sym->old_symbol->binding_label
8103	&& strcmp (s1: sym->binding_label, s2: sym->old_symbol->binding_label) != 0)
8104	{
8105	const char *null = "NULL", *s1, *s2;
8106	s1 = sym->binding_label;
8107	if (!s1) s1 = null;
8108	s2 = sym->old_symbol->binding_label;
8109	if (!s2) s2 = null;
8110	gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8111	sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8112	return MATCH_ERROR;
8113	}
8114
8115	/* Scan the dummy arguments for an alternate return. */
8116	for (arg = sym->formal; arg; arg = arg->next)
8117	if (!arg->sym)
8118	{
8119	gfc_error ("Alternate return dummy argument cannot appear in a "
8120	"SUBROUTINE with the BIND(C) attribute at %L", &loc);
8121	return MATCH_ERROR;
8122	}
8123
8124	if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8125	return MATCH_ERROR;
8126	}
8127
8128	if (gfc_match_eos () != MATCH_YES)
8129	{
8130	gfc_syntax_error (ST_SUBROUTINE);
8131	return MATCH_ERROR;
8132	}
8133
8134	if (!copy_prefix (dest: &sym->attr, where: &sym->declared_at))
8135	{
8136	if(!sym->attr.module_procedure)
8137	return MATCH_ERROR;
8138	else
8139	gfc_error_check ();
8140	}
8141
8142	/* Warn if it has the same name as an intrinsic. */
8143	do_warn_intrinsic_shadow (sym, func: false);
8144
8145	return MATCH_YES;
8146	}
8147
8148
8149	/* Check that the NAME identifier in a BIND attribute or statement
8150	is conform to C identifier rules. */
8151
8152	match
8153	check_bind_name_identifier (char **name)
8154	{
8155	char *n = *name, *p;
8156
8157	/* Remove leading spaces. */
8158	while (*n == ' ')
8159	n++;
8160
8161	/* On an empty string, free memory and set name to NULL. */
8162	if (*n == '\0')
8163	{
8164	free (ptr: *name);
8165	*name = NULL;
8166	return MATCH_YES;
8167	}
8168
8169	/* Remove trailing spaces. */
8170	p = n + strlen(s: n) - 1;
8171	while (*p == ' ')
8172	*(p--) = '\0';
8173
8174	/* Insert the identifier into the symbol table. */
8175	p = xstrdup (n);
8176	free (ptr: *name);
8177	*name = p;
8178
8179	/* Now check that identifier is valid under C rules. */
8180	if (ISDIGIT (*p))
8181	{
8182	gfc_error ("Invalid C identifier in NAME= specifier at %C");
8183	return MATCH_ERROR;
8184	}
8185
8186	for (; *p; p++)
8187	if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8188	{
8189	gfc_error ("Invalid C identifier in NAME= specifier at %C");
8190	return MATCH_ERROR;
8191	}
8192
8193	return MATCH_YES;
8194	}
8195
8196
8197	/* Match a BIND(C) specifier, with the optional 'name=' specifier if
8198	given, and set the binding label in either the given symbol (if not
8199	NULL), or in the current_ts. The symbol may be NULL because we may
8200	encounter the BIND(C) before the declaration itself. Return
8201	MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8202	MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8203	or MATCH_YES if the specifier was correct and the binding label and
8204	bind(c) fields were set correctly for the given symbol or the
8205	current_ts. If allow_binding_name is false, no binding name may be
8206	given. */
8207
8208	match
8209	gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8210	{
8211	char *binding_label = NULL;
8212	gfc_expr *e = NULL;
8213
8214	/* Initialize the flag that specifies whether we encountered a NAME=
8215	specifier or not. */
8216	has_name_equals = 0;
8217
8218	/* This much we have to be able to match, in this order, if
8219	there is a bind(c) label. */
8220	if (gfc_match (" bind ( c ") != MATCH_YES)
8221	return MATCH_NO;
8222
8223	/* Now see if there is a binding label, or if we've reached the
8224	end of the bind(c) attribute without one. */
8225	if (gfc_match_char (',') == MATCH_YES)
8226	{
8227	if (gfc_match (" name = ") != MATCH_YES)
8228	{
8229	gfc_error ("Syntax error in NAME= specifier for binding label "
8230	"at %C");
8231	/* should give an error message here */
8232	return MATCH_ERROR;
8233	}
8234
8235	has_name_equals = 1;
8236
8237	if (gfc_match_init_expr (&e) != MATCH_YES)
8238	{
8239	gfc_free_expr (e);
8240	return MATCH_ERROR;
8241	}
8242
8243	if (!gfc_simplify_expr(e, 0))
8244	{
8245	gfc_error ("NAME= specifier at %C should be a constant expression");
8246	gfc_free_expr (e);
8247	return MATCH_ERROR;
8248	}
8249
8250	if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
8251	|| e->ts.kind != gfc_default_character_kind || e->rank != 0)
8252	{
8253	gfc_error ("NAME= specifier at %C should be a scalar of "
8254	"default character kind");
8255	gfc_free_expr(e);
8256	return MATCH_ERROR;
8257	}
8258
8259	// Get a C string from the Fortran string constant
8260	binding_label = gfc_widechar_to_char (e->value.character.string,
8261	e->value.character.length);
8262	gfc_free_expr(e);
8263
8264	// Check that it is valid (old gfc_match_name_C)
8265	if (check_bind_name_identifier (name: &binding_label) != MATCH_YES)
8266	return MATCH_ERROR;
8267	}
8268
8269	/* Get the required right paren. */
8270	if (gfc_match_char (')') != MATCH_YES)
8271	{
8272	gfc_error ("Missing closing paren for binding label at %C");
8273	return MATCH_ERROR;
8274	}
8275
8276	if (has_name_equals && !allow_binding_name)
8277	{
8278	gfc_error ("No binding name is allowed in BIND(C) at %C");
8279	return MATCH_ERROR;
8280	}
8281
8282	if (has_name_equals && sym != NULL && sym->attr.dummy)
8283	{
8284	gfc_error ("For dummy procedure %s, no binding name is "
8285	"allowed in BIND(C) at %C", sym->name);
8286	return MATCH_ERROR;
8287	}
8288
8289
8290	/* Save the binding label to the symbol. If sym is null, we're
8291	probably matching the typespec attributes of a declaration and
8292	haven't gotten the name yet, and therefore, no symbol yet. */
8293	if (binding_label)
8294	{
8295	if (sym != NULL)
8296	sym->binding_label = binding_label;
8297	else
8298	curr_binding_label = binding_label;
8299	}
8300	else if (allow_binding_name)
8301	{
8302	/* No binding label, but if symbol isn't null, we
8303	can set the label for it here.
8304	If name="" or allow_binding_name is false, no C binding name is
8305	created. */
8306	if (sym != NULL && sym->name != NULL && has_name_equals == 0)
8307	sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
8308	}
8309
8310	if (has_name_equals && gfc_current_state () == COMP_INTERFACE
8311	&& current_interface.type == INTERFACE_ABSTRACT)
8312	{
8313	gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8314	return MATCH_ERROR;
8315	}
8316
8317	return MATCH_YES;
8318	}
8319
8320
8321	/* Return nonzero if we're currently compiling a contained procedure. */
8322
8323	static int
8324	contained_procedure (void)
8325	{
8326	gfc_state_data *s = gfc_state_stack;
8327
8328	if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
8329	&& s->previous != NULL && s->previous->state == COMP_CONTAINS)
8330	return 1;
8331
8332	return 0;
8333	}
8334
8335	/* Set the kind of each enumerator. The kind is selected such that it is
8336	interoperable with the corresponding C enumeration type, making
8337	sure that -fshort-enums is honored. */
8338
8339	static void
8340	set_enum_kind(void)
8341	{
8342	enumerator_history *current_history = NULL;
8343	int kind;
8344	int i;
8345
8346	if (max_enum == NULL || enum_history == NULL)
8347	return;
8348
8349	if (!flag_short_enums)
8350	return;
8351
8352	i = 0;
8353	do
8354	{
8355	kind = gfc_integer_kinds[i++].kind;
8356	}
8357	while (kind < gfc_c_int_kind
8358	&& gfc_check_integer_range (p: max_enum->initializer->value.integer,
8359	kind) != ARITH_OK);
8360
8361	current_history = enum_history;
8362	while (current_history != NULL)
8363	{
8364	current_history->sym->ts.kind = kind;
8365	current_history = current_history->next;
8366	}
8367	}
8368
8369
8370	/* Match any of the various end-block statements. Returns the type of
8371	END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8372	and END BLOCK statements cannot be replaced by a single END statement. */
8373
8374	match
8375	gfc_match_end (gfc_statement *st)
8376	{
8377	char name[GFC_MAX_SYMBOL_LEN + 1];
8378	gfc_compile_state state;
8379	locus old_loc;
8380	const char *block_name;
8381	const char *target;
8382	int eos_ok;
8383	match m;
8384	gfc_namespace *parent_ns, *ns, *prev_ns;
8385	gfc_namespace **nsp;
8386	bool abbreviated_modproc_decl = false;
8387	bool got_matching_end = false;
8388
8389	old_loc = gfc_current_locus;
8390	if (gfc_match ("end") != MATCH_YES)
8391	return MATCH_NO;
8392
8393	state = gfc_current_state ();
8394	block_name = gfc_current_block () == NULL
8395	? NULL : gfc_current_block ()->name;
8396
8397	switch (state)
8398	{
8399	case COMP_ASSOCIATE:
8400	case COMP_BLOCK:
8401	if (startswith (str: block_name, prefix: "block@"))
8402	block_name = NULL;
8403	break;
8404
8405	case COMP_CONTAINS:
8406	case COMP_DERIVED_CONTAINS:
8407	state = gfc_state_stack->previous->state;
8408	block_name = gfc_state_stack->previous->sym == NULL
8409	? NULL : gfc_state_stack->previous->sym->name;
8410	abbreviated_modproc_decl = gfc_state_stack->previous->sym
8411	&& gfc_state_stack->previous->sym->abr_modproc_decl;
8412	break;
8413
8414	default:
8415	break;
8416	}
8417
8418	if (!abbreviated_modproc_decl)
8419	abbreviated_modproc_decl = gfc_current_block ()
8420	&& gfc_current_block ()->abr_modproc_decl;
8421
8422	switch (state)
8423	{
8424	case COMP_NONE:
8425	case COMP_PROGRAM:
8426	*st = ST_END_PROGRAM;
8427	target = " program";
8428	eos_ok = 1;
8429	break;
8430
8431	case COMP_SUBROUTINE:
8432	*st = ST_END_SUBROUTINE;
8433	if (!abbreviated_modproc_decl)
8434	target = " subroutine";
8435	else
8436	target = " procedure";
8437	eos_ok = !contained_procedure ();
8438	break;
8439
8440	case COMP_FUNCTION:
8441	*st = ST_END_FUNCTION;
8442	if (!abbreviated_modproc_decl)
8443	target = " function";
8444	else
8445	target = " procedure";
8446	eos_ok = !contained_procedure ();
8447	break;
8448
8449	case COMP_BLOCK_DATA:
8450	*st = ST_END_BLOCK_DATA;
8451	target = " block data";
8452	eos_ok = 1;
8453	break;
8454
8455	case COMP_MODULE:
8456	*st = ST_END_MODULE;
8457	target = " module";
8458	eos_ok = 1;
8459	break;
8460
8461	case COMP_SUBMODULE:
8462	*st = ST_END_SUBMODULE;
8463	target = " submodule";
8464	eos_ok = 1;
8465	break;
8466
8467	case COMP_INTERFACE:
8468	*st = ST_END_INTERFACE;
8469	target = " interface";
8470	eos_ok = 0;
8471	break;
8472
8473	case COMP_MAP:
8474	*st = ST_END_MAP;
8475	target = " map";
8476	eos_ok = 0;
8477	break;
8478
8479	case COMP_UNION:
8480	*st = ST_END_UNION;
8481	target = " union";
8482	eos_ok = 0;
8483	break;
8484
8485	case COMP_STRUCTURE:
8486	*st = ST_END_STRUCTURE;
8487	target = " structure";
8488	eos_ok = 0;
8489	break;
8490
8491	case COMP_DERIVED:
8492	case COMP_DERIVED_CONTAINS:
8493	*st = ST_END_TYPE;
8494	target = " type";
8495	eos_ok = 0;
8496	break;
8497
8498	case COMP_ASSOCIATE:
8499	*st = ST_END_ASSOCIATE;
8500	target = " associate";
8501	eos_ok = 0;
8502	break;
8503
8504	case COMP_BLOCK:
8505	case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
8506	*st = ST_END_BLOCK;
8507	target = " block";
8508	eos_ok = 0;
8509	break;
8510
8511	case COMP_IF:
8512	*st = ST_ENDIF;
8513	target = " if";
8514	eos_ok = 0;
8515	break;
8516
8517	case COMP_DO:
8518	case COMP_DO_CONCURRENT:
8519	*st = ST_ENDDO;
8520	target = " do";
8521	eos_ok = 0;
8522	break;
8523
8524	case COMP_CRITICAL:
8525	*st = ST_END_CRITICAL;
8526	target = " critical";
8527	eos_ok = 0;
8528	break;
8529
8530	case COMP_SELECT:
8531	case COMP_SELECT_TYPE:
8532	case COMP_SELECT_RANK:
8533	*st = ST_END_SELECT;
8534	target = " select";
8535	eos_ok = 0;
8536	break;
8537
8538	case COMP_FORALL:
8539	*st = ST_END_FORALL;
8540	target = " forall";
8541	eos_ok = 0;
8542	break;
8543
8544	case COMP_WHERE:
8545	*st = ST_END_WHERE;
8546	target = " where";
8547	eos_ok = 0;
8548	break;
8549
8550	case COMP_ENUM:
8551	*st = ST_END_ENUM;
8552	target = " enum";
8553	eos_ok = 0;
8554	last_initializer = NULL;
8555	set_enum_kind ();
8556	gfc_free_enum_history ();
8557	break;
8558
8559	default:
8560	gfc_error ("Unexpected END statement at %C");
8561	goto cleanup;
8562	}
8563
8564	old_loc = gfc_current_locus;
8565	if (gfc_match_eos () == MATCH_YES)
8566	{
8567	if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
8568	{
8569	if (!gfc_notify_std (GFC_STD_F2008, "END statement "
8570	"instead of %s statement at %L",
8571	abbreviated_modproc_decl ? "END PROCEDURE"
8572	: gfc_ascii_statement(*st), &old_loc))
8573	goto cleanup;
8574	}
8575	else if (!eos_ok)
8576	{
8577	/* We would have required END [something]. */
8578	gfc_error ("%s statement expected at %L",
8579	gfc_ascii_statement (*st), &old_loc);
8580	goto cleanup;
8581	}
8582
8583	return MATCH_YES;
8584	}
8585
8586	/* Verify that we've got the sort of end-block that we're expecting. */
8587	if (gfc_match (target) != MATCH_YES)
8588	{
8589	gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
8590	? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
8591	goto cleanup;
8592	}
8593	else
8594	got_matching_end = true;
8595
8596	old_loc = gfc_current_locus;
8597	/* If we're at the end, make sure a block name wasn't required. */
8598	if (gfc_match_eos () == MATCH_YES)
8599	{
8600
8601	if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
8602	&& *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
8603	&& *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
8604	return MATCH_YES;
8605
8606	if (!block_name)
8607	return MATCH_YES;
8608
8609	gfc_error ("Expected block name of %qs in %s statement at %L",
8610	block_name, gfc_ascii_statement (*st), &old_loc);
8611
8612	return MATCH_ERROR;
8613	}
8614
8615	/* END INTERFACE has a special handler for its several possible endings. */
8616	if (*st == ST_END_INTERFACE)
8617	return gfc_match_end_interface ();
8618
8619	/* We haven't hit the end of statement, so what is left must be an
8620	end-name. */
8621	m = gfc_match_space ();
8622	if (m == MATCH_YES)
8623	m = gfc_match_name (name);
8624
8625	if (m == MATCH_NO)
8626	gfc_error ("Expected terminating name at %C");
8627	if (m != MATCH_YES)
8628	goto cleanup;
8629
8630	if (block_name == NULL)
8631	goto syntax;
8632
8633	/* We have to pick out the declared submodule name from the composite
8634	required by F2008:11.2.3 para 2, which ends in the declared name. */
8635	if (state == COMP_SUBMODULE)
8636	block_name = strchr (s: block_name, c: '.') + 1;
8637
8638	if (strcmp (s1: name, s2: block_name) != 0 && strcmp (s1: block_name, s2: "ppr@") != 0)
8639	{
8640	gfc_error ("Expected label %qs for %s statement at %C", block_name,
8641	gfc_ascii_statement (*st));
8642	goto cleanup;
8643	}
8644	/* Procedure pointer as function result. */
8645	else if (strcmp (s1: block_name, s2: "ppr@") == 0
8646	&& strcmp (s1: name, gfc_current_block ()->ns->proc_name->name) != 0)
8647	{
8648	gfc_error ("Expected label %qs for %s statement at %C",
8649	gfc_current_block ()->ns->proc_name->name,
8650	gfc_ascii_statement (*st));
8651	goto cleanup;
8652	}
8653
8654	if (gfc_match_eos () == MATCH_YES)
8655	return MATCH_YES;
8656
8657	syntax:
8658	gfc_syntax_error (*st);
8659
8660	cleanup:
8661	gfc_current_locus = old_loc;
8662
8663	/* If we are missing an END BLOCK, we created a half-ready namespace.
8664	Remove it from the parent namespace's sibling list. */
8665
8666	while (state == COMP_BLOCK && !got_matching_end)
8667	{
8668	parent_ns = gfc_current_ns->parent;
8669
8670	nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
8671
8672	prev_ns = NULL;
8673	ns = *nsp;
8674	while (ns)
8675	{
8676	if (ns == gfc_current_ns)
8677	{
8678	if (prev_ns == NULL)
8679	*nsp = NULL;
8680	else
8681	prev_ns->sibling = ns->sibling;
8682	}
8683	prev_ns = ns;
8684	ns = ns->sibling;
8685	}
8686
8687	gfc_free_namespace (gfc_current_ns);
8688	gfc_current_ns = parent_ns;
8689	gfc_state_stack = gfc_state_stack->previous;
8690	state = gfc_current_state ();
8691	}
8692
8693	return MATCH_ERROR;
8694	}
8695
8696
8697
8698	/***************** Attribute declaration statements ****************/
8699
8700	/* Set the attribute of a single variable. */
8701
8702	static match
8703	attr_decl1 (void)
8704	{
8705	char name[GFC_MAX_SYMBOL_LEN + 1];
8706	gfc_array_spec *as;
8707
8708	/* Workaround -Wmaybe-uninitialized false positive during
8709	profiledbootstrap by initializing them. */
8710	gfc_symbol *sym = NULL;
8711	locus var_locus;
8712	match m;
8713
8714	as = NULL;
8715
8716	m = gfc_match_name (name);
8717	if (m != MATCH_YES)
8718	goto cleanup;
8719
8720	if (find_special (name, result: &sym, allow_subroutine: false))
8721	return MATCH_ERROR;
8722
8723	if (!check_function_name (name))
8724	{
8725	m = MATCH_ERROR;
8726	goto cleanup;
8727	}
8728
8729	var_locus = gfc_current_locus;
8730
8731	/* Deal with possible array specification for certain attributes. */
8732	if (current_attr.dimension
8733	|| current_attr.codimension
8734	|| current_attr.allocatable
8735	|| current_attr.pointer
8736	|| current_attr.target)
8737	{
8738	m = gfc_match_array_spec (&as, !current_attr.codimension,
8739	!current_attr.dimension
8740	&& !current_attr.pointer
8741	&& !current_attr.target);
8742	if (m == MATCH_ERROR)
8743	goto cleanup;
8744
8745	if (current_attr.dimension && m == MATCH_NO)
8746	{
8747	gfc_error ("Missing array specification at %L in DIMENSION "
8748	"statement", &var_locus);
8749	m = MATCH_ERROR;
8750	goto cleanup;
8751	}
8752
8753	if (current_attr.dimension && sym->value)
8754	{
8755	gfc_error ("Dimensions specified for %s at %L after its "
8756	"initialization", sym->name, &var_locus);
8757	m = MATCH_ERROR;
8758	goto cleanup;
8759	}
8760
8761	if (current_attr.codimension && m == MATCH_NO)
8762	{
8763	gfc_error ("Missing array specification at %L in CODIMENSION "
8764	"statement", &var_locus);
8765	m = MATCH_ERROR;
8766	goto cleanup;
8767	}
8768
8769	if ((current_attr.allocatable || current_attr.pointer)
8770	&& (m == MATCH_YES) && (as->type != AS_DEFERRED))
8771	{
8772	gfc_error ("Array specification must be deferred at %L", &var_locus);
8773	m = MATCH_ERROR;
8774	goto cleanup;
8775	}
8776	}
8777
8778	if (sym->ts.type == BT_CLASS
8779	&& sym->ts.u.derived
8780	&& sym->ts.u.derived->attr.is_class)
8781	{
8782	sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
8783	sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
8784	sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
8785	sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
8786	if (CLASS_DATA (sym)->as)
8787	sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
8788	}
8789	if (current_attr.dimension == 0 && current_attr.codimension == 0
8790	&& !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
8791	{
8792	m = MATCH_ERROR;
8793	goto cleanup;
8794	}
8795	if (!gfc_set_array_spec (sym, as, &var_locus))
8796	{
8797	m = MATCH_ERROR;
8798	goto cleanup;
8799	}
8800
8801	if (sym->attr.cray_pointee && sym->as != NULL)
8802	{
8803	/* Fix the array spec. */
8804	m = gfc_mod_pointee_as (sym->as);
8805	if (m == MATCH_ERROR)
8806	goto cleanup;
8807	}
8808
8809	if (!gfc_add_attribute (&sym->attr, &var_locus))
8810	{
8811	m = MATCH_ERROR;
8812	goto cleanup;
8813	}
8814
8815	if ((current_attr.external || current_attr.intrinsic)
8816	&& sym->attr.flavor != FL_PROCEDURE
8817	&& !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
8818	{
8819	m = MATCH_ERROR;
8820	goto cleanup;
8821	}
8822
8823	if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
8824	&& !as && !current_attr.pointer && !current_attr.allocatable
8825	&& !current_attr.external)
8826	{
8827	sym->attr.pointer = 0;
8828	sym->attr.allocatable = 0;
8829	sym->attr.dimension = 0;
8830	sym->attr.codimension = 0;
8831	gfc_free_array_spec (sym->as);
8832	sym->as = NULL;
8833	}
8834	else if (sym->ts.type == BT_CLASS
8835	&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
8836	{
8837	m = MATCH_ERROR;
8838	goto cleanup;
8839	}
8840
8841	add_hidden_procptr_result (sym);
8842
8843	return MATCH_YES;
8844
8845	cleanup:
8846	gfc_free_array_spec (as);
8847	return m;
8848	}
8849
8850
8851	/* Generic attribute declaration subroutine. Used for attributes that
8852	just have a list of names. */
8853
8854	static match
8855	attr_decl (void)
8856	{
8857	match m;
8858
8859	/* Gobble the optional double colon, by simply ignoring the result
8860	of gfc_match(). */
8861	gfc_match (" ::");
8862
8863	for (;;)
8864	{
8865	m = attr_decl1 ();
8866	if (m != MATCH_YES)
8867	break;
8868
8869	if (gfc_match_eos () == MATCH_YES)
8870	{
8871	m = MATCH_YES;
8872	break;
8873	}
8874
8875	if (gfc_match_char (',') != MATCH_YES)
8876	{
8877	gfc_error ("Unexpected character in variable list at %C");
8878	m = MATCH_ERROR;
8879	break;
8880	}
8881	}
8882
8883	return m;
8884	}
8885
8886
8887	/* This routine matches Cray Pointer declarations of the form:
8888	pointer ( <pointer>, <pointee> )
8889	or
8890	pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8891	The pointer, if already declared, should be an integer. Otherwise, we
8892	set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8893	be either a scalar, or an array declaration. No space is allocated for
8894	the pointee. For the statement
8895	pointer (ipt, ar(10))
8896	any subsequent uses of ar will be translated (in C-notation) as
8897	ar(i) => ((<type> *) ipt)(i)
8898	After gimplification, pointee variable will disappear in the code. */
8899
8900	static match
8901	cray_pointer_decl (void)
8902	{
8903	match m;
8904	gfc_array_spec *as = NULL;
8905	gfc_symbol *cptr; /* Pointer symbol. */
8906	gfc_symbol *cpte; /* Pointee symbol. */
8907	locus var_locus;
8908	bool done = false;
8909
8910	while (!done)
8911	{
8912	if (gfc_match_char ('(') != MATCH_YES)
8913	{
8914	gfc_error ("Expected %<(%> at %C");
8915	return MATCH_ERROR;
8916	}
8917
8918	/* Match pointer. */
8919	var_locus = gfc_current_locus;
8920	gfc_clear_attr (&current_attr);
8921	gfc_add_cray_pointer (&current_attr, &var_locus);
8922	current_ts.type = BT_INTEGER;
8923	current_ts.kind = gfc_index_integer_kind;
8924
8925	m = gfc_match_symbol (&cptr, 0);
8926	if (m != MATCH_YES)
8927	{
8928	gfc_error ("Expected variable name at %C");
8929	return m;
8930	}
8931
8932	if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
8933	return MATCH_ERROR;
8934
8935	gfc_set_sym_referenced (cptr);
8936
8937	if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
8938	{
8939	cptr->ts.type = BT_INTEGER;
8940	cptr->ts.kind = gfc_index_integer_kind;
8941	}
8942	else if (cptr->ts.type != BT_INTEGER)
8943	{
8944	gfc_error ("Cray pointer at %C must be an integer");
8945	return MATCH_ERROR;
8946	}
8947	else if (cptr->ts.kind < gfc_index_integer_kind)
8948	gfc_warning (opt: 0, "Cray pointer at %C has %d bytes of precision;"
8949	" memory addresses require %d bytes",
8950	cptr->ts.kind, gfc_index_integer_kind);
8951
8952	if (gfc_match_char (',') != MATCH_YES)
8953	{
8954	gfc_error ("Expected \",\" at %C");
8955	return MATCH_ERROR;
8956	}
8957
8958	/* Match Pointee. */
8959	var_locus = gfc_current_locus;
8960	gfc_clear_attr (&current_attr);
8961	gfc_add_cray_pointee (&current_attr, &var_locus);
8962	current_ts.type = BT_UNKNOWN;
8963	current_ts.kind = 0;
8964
8965	m = gfc_match_symbol (&cpte, 0);
8966	if (m != MATCH_YES)
8967	{
8968	gfc_error ("Expected variable name at %C");
8969	return m;
8970	}
8971
8972	/* Check for an optional array spec. */
8973	m = gfc_match_array_spec (&as, true, false);
8974	if (m == MATCH_ERROR)
8975	{
8976	gfc_free_array_spec (as);
8977	return m;
8978	}
8979	else if (m == MATCH_NO)
8980	{
8981	gfc_free_array_spec (as);
8982	as = NULL;
8983	}
8984
8985	if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
8986	return MATCH_ERROR;
8987
8988	gfc_set_sym_referenced (cpte);
8989
8990	if (cpte->as == NULL)
8991	{
8992	if (!gfc_set_array_spec (cpte, as, &var_locus))
8993	gfc_internal_error ("Cannot set Cray pointee array spec.");
8994	}
8995	else if (as != NULL)
8996	{
8997	gfc_error ("Duplicate array spec for Cray pointee at %C");
8998	gfc_free_array_spec (as);
8999	return MATCH_ERROR;
9000	}
9001
9002	as = NULL;
9003
9004	if (cpte->as != NULL)
9005	{
9006	/* Fix array spec. */
9007	m = gfc_mod_pointee_as (cpte->as);
9008	if (m == MATCH_ERROR)
9009	return m;
9010	}
9011
9012	/* Point the Pointee at the Pointer. */
9013	cpte->cp_pointer = cptr;
9014
9015	if (gfc_match_char (')') != MATCH_YES)
9016	{
9017	gfc_error ("Expected \")\" at %C");
9018	return MATCH_ERROR;
9019	}
9020	m = gfc_match_char (',');
9021	if (m != MATCH_YES)
9022	done = true; /* Stop searching for more declarations. */
9023
9024	}
9025
9026	if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9027	|| gfc_match_eos () != MATCH_YES)
9028	{
9029	gfc_error ("Expected %<,%> or end of statement at %C");
9030	return MATCH_ERROR;
9031	}
9032	return MATCH_YES;
9033	}
9034
9035
9036	match
9037	gfc_match_external (void)
9038	{
9039
9040	gfc_clear_attr (&current_attr);
9041	current_attr.external = 1;
9042
9043	return attr_decl ();
9044	}
9045
9046
9047	match
9048	gfc_match_intent (void)
9049	{
9050	sym_intent intent;
9051
9052	/* This is not allowed within a BLOCK construct! */
9053	if (gfc_current_state () == COMP_BLOCK)
9054	{
9055	gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9056	return MATCH_ERROR;
9057	}
9058
9059	intent = match_intent_spec ();
9060	if (intent == INTENT_UNKNOWN)
9061	return MATCH_ERROR;
9062
9063	gfc_clear_attr (&current_attr);
9064	current_attr.intent = intent;
9065
9066	return attr_decl ();
9067	}
9068
9069
9070	match
9071	gfc_match_intrinsic (void)
9072	{
9073
9074	gfc_clear_attr (&current_attr);
9075	current_attr.intrinsic = 1;
9076
9077	return attr_decl ();
9078	}
9079
9080
9081	match
9082	gfc_match_optional (void)
9083	{
9084	/* This is not allowed within a BLOCK construct! */
9085	if (gfc_current_state () == COMP_BLOCK)
9086	{
9087	gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9088	return MATCH_ERROR;
9089	}
9090
9091	gfc_clear_attr (&current_attr);
9092	current_attr.optional = 1;
9093
9094	return attr_decl ();
9095	}
9096
9097
9098	match
9099	gfc_match_pointer (void)
9100	{
9101	gfc_gobble_whitespace ();
9102	if (gfc_peek_ascii_char () == '(')
9103	{
9104	if (!flag_cray_pointer)
9105	{
9106	gfc_error ("Cray pointer declaration at %C requires "
9107	"%<-fcray-pointer%> flag");
9108	return MATCH_ERROR;
9109	}
9110	return cray_pointer_decl ();
9111	}
9112	else
9113	{
9114	gfc_clear_attr (&current_attr);
9115	current_attr.pointer = 1;
9116
9117	return attr_decl ();
9118	}
9119	}
9120
9121
9122	match
9123	gfc_match_allocatable (void)
9124	{
9125	gfc_clear_attr (&current_attr);
9126	current_attr.allocatable = 1;
9127
9128	return attr_decl ();
9129	}
9130
9131
9132	match
9133	gfc_match_codimension (void)
9134	{
9135	gfc_clear_attr (&current_attr);
9136	current_attr.codimension = 1;
9137
9138	return attr_decl ();
9139	}
9140
9141
9142	match
9143	gfc_match_contiguous (void)
9144	{
9145	if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9146	return MATCH_ERROR;
9147
9148	gfc_clear_attr (&current_attr);
9149	current_attr.contiguous = 1;
9150
9151	return attr_decl ();
9152	}
9153
9154
9155	match
9156	gfc_match_dimension (void)
9157	{
9158	gfc_clear_attr (&current_attr);
9159	current_attr.dimension = 1;
9160
9161	return attr_decl ();
9162	}
9163
9164
9165	match
9166	gfc_match_target (void)
9167	{
9168	gfc_clear_attr (&current_attr);
9169	current_attr.target = 1;
9170
9171	return attr_decl ();
9172	}
9173
9174
9175	/* Match the list of entities being specified in a PUBLIC or PRIVATE
9176	statement. */
9177
9178	static match
9179	access_attr_decl (gfc_statement st)
9180	{
9181	char name[GFC_MAX_SYMBOL_LEN + 1];
9182	interface_type type;
9183	gfc_user_op *uop;
9184	gfc_symbol *sym, *dt_sym;
9185	gfc_intrinsic_op op;
9186	match m;
9187	gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9188
9189	if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9190	goto done;
9191
9192	for (;;)
9193	{
9194	m = gfc_match_generic_spec (&type, name, &op);
9195	if (m == MATCH_NO)
9196	goto syntax;
9197	if (m == MATCH_ERROR)
9198	goto done;
9199
9200	switch (type)
9201	{
9202	case INTERFACE_NAMELESS:
9203	case INTERFACE_ABSTRACT:
9204	goto syntax;
9205
9206	case INTERFACE_GENERIC:
9207	case INTERFACE_DTIO:
9208
9209	if (gfc_get_symbol (name, NULL, &sym))
9210	goto done;
9211
9212	if (type == INTERFACE_DTIO
9213	&& gfc_current_ns->proc_name
9214	&& gfc_current_ns->proc_name->attr.flavor == FL_MODULE
9215	&& sym->attr.flavor == FL_UNKNOWN)
9216	sym->attr.flavor = FL_PROCEDURE;
9217
9218	if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
9219	goto done;
9220
9221	if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
9222	&& !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
9223	goto done;
9224
9225	break;
9226
9227	case INTERFACE_INTRINSIC_OP:
9228	if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
9229	{
9230	gfc_intrinsic_op other_op;
9231
9232	gfc_current_ns->operator_access[op] = access;
9233
9234	/* Handle the case if there is another op with the same
9235	function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9236	other_op = gfc_equivalent_op (op);
9237
9238	if (other_op != INTRINSIC_NONE)
9239	gfc_current_ns->operator_access[other_op] = access;
9240	}
9241	else
9242	{
9243	gfc_error ("Access specification of the %s operator at %C has "
9244	"already been specified", gfc_op2string (op));
9245	goto done;
9246	}
9247
9248	break;
9249
9250	case INTERFACE_USER_OP:
9251	uop = gfc_get_uop (name);
9252
9253	if (uop->access == ACCESS_UNKNOWN)
9254	{
9255	uop->access = access;
9256	}
9257	else
9258	{
9259	gfc_error ("Access specification of the .%s. operator at %C "
9260	"has already been specified", uop->name);
9261	goto done;
9262	}
9263
9264	break;
9265	}
9266
9267	if (gfc_match_char (',') == MATCH_NO)
9268	break;
9269	}
9270
9271	if (gfc_match_eos () != MATCH_YES)
9272	goto syntax;
9273	return MATCH_YES;
9274
9275	syntax:
9276	gfc_syntax_error (st);
9277
9278	done:
9279	return MATCH_ERROR;
9280	}
9281
9282
9283	match
9284	gfc_match_protected (void)
9285	{
9286	gfc_symbol *sym;
9287	match m;
9288	char c;
9289
9290	/* PROTECTED has already been seen, but must be followed by whitespace
9291	or ::. */
9292	c = gfc_peek_ascii_char ();
9293	if (!gfc_is_whitespace (c) && c != ':')
9294	return MATCH_NO;
9295
9296	if (!gfc_current_ns->proc_name
9297	|| gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
9298	{
9299	gfc_error ("PROTECTED at %C only allowed in specification "
9300	"part of a module");
9301	return MATCH_ERROR;
9302
9303	}
9304
9305	gfc_match (" ::");
9306
9307	if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
9308	return MATCH_ERROR;
9309
9310	/* PROTECTED has an entity-list. */
9311	if (gfc_match_eos () == MATCH_YES)
9312	goto syntax;
9313
9314	for(;;)
9315	{
9316	m = gfc_match_symbol (&sym, 0);
9317	switch (m)
9318	{
9319	case MATCH_YES:
9320	if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
9321	return MATCH_ERROR;
9322	goto next_item;
9323
9324	case MATCH_NO:
9325	break;
9326
9327	case MATCH_ERROR:
9328	return MATCH_ERROR;
9329	}
9330
9331	next_item:
9332	if (gfc_match_eos () == MATCH_YES)
9333	break;
9334	if (gfc_match_char (',') != MATCH_YES)
9335	goto syntax;
9336	}
9337
9338	return MATCH_YES;
9339
9340	syntax:
9341	gfc_error ("Syntax error in PROTECTED statement at %C");
9342	return MATCH_ERROR;
9343	}
9344
9345
9346	/* The PRIVATE statement is a bit weird in that it can be an attribute
9347	declaration, but also works as a standalone statement inside of a
9348	type declaration or a module. */
9349
9350	match
9351	gfc_match_private (gfc_statement *st)
9352	{
9353	gfc_state_data *prev;
9354
9355	if (gfc_match ("private") != MATCH_YES)
9356	return MATCH_NO;
9357
9358	/* Try matching PRIVATE without an access-list. */
9359	if (gfc_match_eos () == MATCH_YES)
9360	{
9361	prev = gfc_state_stack->previous;
9362	if (gfc_current_state () != COMP_MODULE
9363	&& !(gfc_current_state () == COMP_DERIVED
9364	&& prev && prev->state == COMP_MODULE)
9365	&& !(gfc_current_state () == COMP_DERIVED_CONTAINS
9366	&& prev->previous && prev->previous->state == COMP_MODULE))
9367	{
9368	gfc_error ("PRIVATE statement at %C is only allowed in the "
9369	"specification part of a module");
9370	return MATCH_ERROR;
9371	}
9372
9373	*st = ST_PRIVATE;
9374	return MATCH_YES;
9375	}
9376
9377	/* At this point in free-form source code, PRIVATE must be followed
9378	by whitespace or ::. */
9379	if (gfc_current_form == FORM_FREE)
9380	{
9381	char c = gfc_peek_ascii_char ();
9382	if (!gfc_is_whitespace (c) && c != ':')
9383	return MATCH_NO;
9384	}
9385
9386	prev = gfc_state_stack->previous;
9387	if (gfc_current_state () != COMP_MODULE
9388	&& !(gfc_current_state () == COMP_DERIVED
9389	&& prev && prev->state == COMP_MODULE)
9390	&& !(gfc_current_state () == COMP_DERIVED_CONTAINS
9391	&& prev->previous && prev->previous->state == COMP_MODULE))
9392	{
9393	gfc_error ("PRIVATE statement at %C is only allowed in the "
9394	"specification part of a module");
9395	return MATCH_ERROR;
9396	}
9397
9398	*st = ST_ATTR_DECL;
9399	return access_attr_decl (st: ST_PRIVATE);
9400	}
9401
9402
9403	match
9404	gfc_match_public (gfc_statement *st)
9405	{
9406	if (gfc_match ("public") != MATCH_YES)
9407	return MATCH_NO;
9408
9409	/* Try matching PUBLIC without an access-list. */
9410	if (gfc_match_eos () == MATCH_YES)
9411	{
9412	if (gfc_current_state () != COMP_MODULE)
9413	{
9414	gfc_error ("PUBLIC statement at %C is only allowed in the "
9415	"specification part of a module");
9416	return MATCH_ERROR;
9417	}
9418
9419	*st = ST_PUBLIC;
9420	return MATCH_YES;
9421	}
9422
9423	/* At this point in free-form source code, PUBLIC must be followed
9424	by whitespace or ::. */
9425	if (gfc_current_form == FORM_FREE)
9426	{
9427	char c = gfc_peek_ascii_char ();
9428	if (!gfc_is_whitespace (c) && c != ':')
9429	return MATCH_NO;
9430	}
9431
9432	if (gfc_current_state () != COMP_MODULE)
9433	{
9434	gfc_error ("PUBLIC statement at %C is only allowed in the "
9435	"specification part of a module");
9436	return MATCH_ERROR;
9437	}
9438
9439	*st = ST_ATTR_DECL;
9440	return access_attr_decl (st: ST_PUBLIC);
9441	}
9442
9443
9444	/* Workhorse for gfc_match_parameter. */
9445
9446	static match
9447	do_parm (void)
9448	{
9449	gfc_symbol *sym;
9450	gfc_expr *init;
9451	match m;
9452	bool t;
9453
9454	m = gfc_match_symbol (&sym, 0);
9455	if (m == MATCH_NO)
9456	gfc_error ("Expected variable name at %C in PARAMETER statement");
9457
9458	if (m != MATCH_YES)
9459	return m;
9460
9461	if (gfc_match_char ('=') == MATCH_NO)
9462	{
9463	gfc_error ("Expected = sign in PARAMETER statement at %C");
9464	return MATCH_ERROR;
9465	}
9466
9467	m = gfc_match_init_expr (&init);
9468	if (m == MATCH_NO)
9469	gfc_error ("Expected expression at %C in PARAMETER statement");
9470	if (m != MATCH_YES)
9471	return m;
9472
9473	if (sym->ts.type == BT_UNKNOWN
9474	&& !gfc_set_default_type (sym, 1, NULL))
9475	{
9476	m = MATCH_ERROR;
9477	goto cleanup;
9478	}
9479
9480	if (!gfc_check_assign_symbol (sym, NULL, init)
9481	|| !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
9482	{
9483	m = MATCH_ERROR;
9484	goto cleanup;
9485	}
9486
9487	if (sym->value)
9488	{
9489	gfc_error ("Initializing already initialized variable at %C");
9490	m = MATCH_ERROR;
9491	goto cleanup;
9492	}
9493
9494	t = add_init_expr_to_sym (name: sym->name, initp: &init, var_locus: &gfc_current_locus);
9495	return (t) ? MATCH_YES : MATCH_ERROR;
9496
9497	cleanup:
9498	gfc_free_expr (init);
9499	return m;
9500	}
9501
9502
9503	/* Match a parameter statement, with the weird syntax that these have. */
9504
9505	match
9506	gfc_match_parameter (void)
9507	{
9508	const char *term = " )%t";
9509	match m;
9510
9511	if (gfc_match_char ('(') == MATCH_NO)
9512	{
9513	/* With legacy PARAMETER statements, don't expect a terminating ')'. */
9514	if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
9515	return MATCH_NO;
9516	term = " %t";
9517	}
9518
9519	for (;;)
9520	{
9521	m = do_parm ();
9522	if (m != MATCH_YES)
9523	break;
9524
9525	if (gfc_match (term) == MATCH_YES)
9526	break;
9527
9528	if (gfc_match_char (',') != MATCH_YES)
9529	{
9530	gfc_error ("Unexpected characters in PARAMETER statement at %C");
9531	m = MATCH_ERROR;
9532	break;
9533	}
9534	}
9535
9536	return m;
9537	}
9538
9539
9540	match
9541	gfc_match_automatic (void)
9542	{
9543	gfc_symbol *sym;
9544	match m;
9545	bool seen_symbol = false;
9546
9547	if (!flag_dec_static)
9548	{
9549	gfc_error ("%s at %C is a DEC extension, enable with "
9550	"%<-fdec-static%>",
9551	"AUTOMATIC"
9552	);
9553	return MATCH_ERROR;
9554	}
9555
9556	gfc_match (" ::");
9557
9558	for (;;)
9559	{
9560	m = gfc_match_symbol (&sym, 0);
9561	switch (m)
9562	{
9563	case MATCH_NO:
9564	break;
9565
9566	case MATCH_ERROR:
9567	return MATCH_ERROR;
9568
9569	case MATCH_YES:
9570	if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
9571	return MATCH_ERROR;
9572	seen_symbol = true;
9573	break;
9574	}
9575
9576	if (gfc_match_eos () == MATCH_YES)
9577	break;
9578	if (gfc_match_char (',') != MATCH_YES)
9579	goto syntax;
9580	}
9581
9582	if (!seen_symbol)
9583	{
9584	gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9585	return MATCH_ERROR;
9586	}
9587
9588	return MATCH_YES;
9589
9590	syntax:
9591	gfc_error ("Syntax error in AUTOMATIC statement at %C");
9592	return MATCH_ERROR;
9593	}
9594
9595
9596	match
9597	gfc_match_static (void)
9598	{
9599	gfc_symbol *sym;
9600	match m;
9601	bool seen_symbol = false;
9602
9603	if (!flag_dec_static)
9604	{
9605	gfc_error ("%s at %C is a DEC extension, enable with "
9606	"%<-fdec-static%>",
9607	"STATIC");
9608	return MATCH_ERROR;
9609	}
9610
9611	gfc_match (" ::");
9612
9613	for (;;)
9614	{
9615	m = gfc_match_symbol (&sym, 0);
9616	switch (m)
9617	{
9618	case MATCH_NO:
9619	break;
9620
9621	case MATCH_ERROR:
9622	return MATCH_ERROR;
9623
9624	case MATCH_YES:
9625	if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9626	&gfc_current_locus))
9627	return MATCH_ERROR;
9628	seen_symbol = true;
9629	break;
9630	}
9631
9632	if (gfc_match_eos () == MATCH_YES)
9633	break;
9634	if (gfc_match_char (',') != MATCH_YES)
9635	goto syntax;
9636	}
9637
9638	if (!seen_symbol)
9639	{
9640	gfc_error ("Expected entity-list in STATIC statement at %C");
9641	return MATCH_ERROR;
9642	}
9643
9644	return MATCH_YES;
9645
9646	syntax:
9647	gfc_error ("Syntax error in STATIC statement at %C");
9648	return MATCH_ERROR;
9649	}
9650
9651
9652	/* Save statements have a special syntax. */
9653
9654	match
9655	gfc_match_save (void)
9656	{
9657	char n[GFC_MAX_SYMBOL_LEN+1];
9658	gfc_common_head *c;
9659	gfc_symbol *sym;
9660	match m;
9661
9662	if (gfc_match_eos () == MATCH_YES)
9663	{
9664	if (gfc_current_ns->seen_save)
9665	{
9666	if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
9667	"follows previous SAVE statement"))
9668	return MATCH_ERROR;
9669	}
9670
9671	gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
9672	return MATCH_YES;
9673	}
9674
9675	if (gfc_current_ns->save_all)
9676	{
9677	if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
9678	"blanket SAVE statement"))
9679	return MATCH_ERROR;
9680	}
9681
9682	gfc_match (" ::");
9683
9684	for (;;)
9685	{
9686	m = gfc_match_symbol (&sym, 0);
9687	switch (m)
9688	{
9689	case MATCH_YES:
9690	if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9691	&gfc_current_locus))
9692	return MATCH_ERROR;
9693	goto next_item;
9694
9695	case MATCH_NO:
9696	break;
9697
9698	case MATCH_ERROR:
9699	return MATCH_ERROR;
9700	}
9701
9702	m = gfc_match (" / %n /", &n);
9703	if (m == MATCH_ERROR)
9704	return MATCH_ERROR;
9705	if (m == MATCH_NO)
9706	goto syntax;
9707
9708	c = gfc_get_common (n, 0);
9709	c->saved = 1;
9710
9711	gfc_current_ns->seen_save = 1;
9712
9713	next_item:
9714	if (gfc_match_eos () == MATCH_YES)
9715	break;
9716	if (gfc_match_char (',') != MATCH_YES)
9717	goto syntax;
9718	}
9719
9720	return MATCH_YES;
9721
9722	syntax:
9723	if (gfc_current_ns->seen_save)
9724	{
9725	gfc_error ("Syntax error in SAVE statement at %C");
9726	return MATCH_ERROR;
9727	}
9728	else
9729	return MATCH_NO;
9730	}
9731
9732
9733	match
9734	gfc_match_value (void)
9735	{
9736	gfc_symbol *sym;
9737	match m;
9738
9739	/* This is not allowed within a BLOCK construct! */
9740	if (gfc_current_state () == COMP_BLOCK)
9741	{
9742	gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9743	return MATCH_ERROR;
9744	}
9745
9746	if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
9747	return MATCH_ERROR;
9748
9749	if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9750	{
9751	return MATCH_ERROR;
9752	}
9753
9754	if (gfc_match_eos () == MATCH_YES)
9755	goto syntax;
9756
9757	for(;;)
9758	{
9759	m = gfc_match_symbol (&sym, 0);
9760	switch (m)
9761	{
9762	case MATCH_YES:
9763	if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
9764	return MATCH_ERROR;
9765	goto next_item;
9766
9767	case MATCH_NO:
9768	break;
9769
9770	case MATCH_ERROR:
9771	return MATCH_ERROR;
9772	}
9773
9774	next_item:
9775	if (gfc_match_eos () == MATCH_YES)
9776	break;
9777	if (gfc_match_char (',') != MATCH_YES)
9778	goto syntax;
9779	}
9780
9781	return MATCH_YES;
9782
9783	syntax:
9784	gfc_error ("Syntax error in VALUE statement at %C");
9785	return MATCH_ERROR;
9786	}
9787
9788
9789	match
9790	gfc_match_volatile (void)
9791	{
9792	gfc_symbol *sym;
9793	char *name;
9794	match m;
9795
9796	if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
9797	return MATCH_ERROR;
9798
9799	if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9800	{
9801	return MATCH_ERROR;
9802	}
9803
9804	if (gfc_match_eos () == MATCH_YES)
9805	goto syntax;
9806
9807	for(;;)
9808	{
9809	/* VOLATILE is special because it can be added to host-associated
9810	symbols locally. Except for coarrays. */
9811	m = gfc_match_symbol (&sym, 1);
9812	switch (m)
9813	{
9814	case MATCH_YES:
9815	name = XCNEWVAR (char, strlen (sym->name) + 1);
9816	strcpy (dest: name, src: sym->name);
9817	if (!check_function_name (name))
9818	return MATCH_ERROR;
9819	/* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9820	for variable in a BLOCK which is defined outside of the BLOCK. */
9821	if (sym->ns != gfc_current_ns && sym->attr.codimension)
9822	{
9823	gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9824	"%C, which is use-/host-associated", sym->name);
9825	return MATCH_ERROR;
9826	}
9827	if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
9828	return MATCH_ERROR;
9829	goto next_item;
9830
9831	case MATCH_NO:
9832	break;
9833
9834	case MATCH_ERROR:
9835	return MATCH_ERROR;
9836	}
9837
9838	next_item:
9839	if (gfc_match_eos () == MATCH_YES)
9840	break;
9841	if (gfc_match_char (',') != MATCH_YES)
9842	goto syntax;
9843	}
9844
9845	return MATCH_YES;
9846
9847	syntax:
9848	gfc_error ("Syntax error in VOLATILE statement at %C");
9849	return MATCH_ERROR;
9850	}
9851
9852
9853	match
9854	gfc_match_asynchronous (void)
9855	{
9856	gfc_symbol *sym;
9857	char *name;
9858	match m;
9859
9860	if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
9861	return MATCH_ERROR;
9862
9863	if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9864	{
9865	return MATCH_ERROR;
9866	}
9867
9868	if (gfc_match_eos () == MATCH_YES)
9869	goto syntax;
9870
9871	for(;;)
9872	{
9873	/* ASYNCHRONOUS is special because it can be added to host-associated
9874	symbols locally. */
9875	m = gfc_match_symbol (&sym, 1);
9876	switch (m)
9877	{
9878	case MATCH_YES:
9879	name = XCNEWVAR (char, strlen (sym->name) + 1);
9880	strcpy (dest: name, src: sym->name);
9881	if (!check_function_name (name))
9882	return MATCH_ERROR;
9883	if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
9884	return MATCH_ERROR;
9885	goto next_item;
9886
9887	case MATCH_NO:
9888	break;
9889
9890	case MATCH_ERROR:
9891	return MATCH_ERROR;
9892	}
9893
9894	next_item:
9895	if (gfc_match_eos () == MATCH_YES)
9896	break;
9897	if (gfc_match_char (',') != MATCH_YES)
9898	goto syntax;
9899	}
9900
9901	return MATCH_YES;
9902
9903	syntax:
9904	gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9905	return MATCH_ERROR;
9906	}
9907
9908
9909	/* Match a module procedure statement in a submodule. */
9910
9911	match
9912	gfc_match_submod_proc (void)
9913	{
9914	char name[GFC_MAX_SYMBOL_LEN + 1];
9915	gfc_symbol *sym, *fsym;
9916	match m;
9917	gfc_formal_arglist *formal, *head, *tail;
9918
9919	if (gfc_current_state () != COMP_CONTAINS
9920	|| !(gfc_state_stack->previous
9921	&& (gfc_state_stack->previous->state == COMP_SUBMODULE
9922	|| gfc_state_stack->previous->state == COMP_MODULE)))
9923	return MATCH_NO;
9924
9925	m = gfc_match (" module% procedure% %n", name);
9926	if (m != MATCH_YES)
9927	return m;
9928
9929	if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
9930	"at %C"))
9931	return MATCH_ERROR;
9932
9933	if (get_proc_name (name, result: &sym, module_fcn_entry: false))
9934	return MATCH_ERROR;
9935
9936	/* Make sure that the result field is appropriately filled. */
9937	if (sym->tlink && sym->tlink->attr.function)
9938	{
9939	if (sym->tlink->result && sym->tlink->result != sym->tlink)
9940	{
9941	sym->result = sym->tlink->result;
9942	if (!sym->result->attr.use_assoc)
9943	{
9944	gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
9945	sym->result->name);
9946	st->n.sym = sym->result;
9947	sym->result->refs++;
9948	}
9949	}
9950	else
9951	sym->result = sym;
9952	}
9953
9954	/* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9955	the symbol existed before. */
9956	sym->declared_at = gfc_current_locus;
9957
9958	if (!sym->attr.module_procedure)
9959	return MATCH_ERROR;
9960
9961	/* Signal match_end to expect "end procedure". */
9962	sym->abr_modproc_decl = 1;
9963
9964	/* Change from IFSRC_IFBODY coming from the interface declaration. */
9965	sym->attr.if_source = IFSRC_DECL;
9966
9967	gfc_new_block = sym;
9968
9969	/* Make a new formal arglist with the symbols in the procedure
9970	namespace. */
9971	head = tail = NULL;
9972	for (formal = sym->formal; formal && formal->sym; formal = formal->next)
9973	{
9974	if (formal == sym->formal)
9975	head = tail = gfc_get_formal_arglist ();
9976	else
9977	{
9978	tail->next = gfc_get_formal_arglist ();
9979	tail = tail->next;
9980	}
9981
9982	if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
9983	goto cleanup;
9984
9985	tail->sym = fsym;
9986	gfc_set_sym_referenced (fsym);
9987	}
9988
9989	/* The dummy symbols get cleaned up, when the formal_namespace of the
9990	interface declaration is cleared. This allows us to add the
9991	explicit interface as is done for other type of procedure. */
9992	if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
9993	&gfc_current_locus))
9994	return MATCH_ERROR;
9995
9996	if (gfc_match_eos () != MATCH_YES)
9997	{
9998	/* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9999	undone, such that the st->n.sym->formal points to the original symbol;
10000	if now this namespace is finalized, the formal namespace is freed,
10001	but it might be still needed in the parent namespace. */
10002	gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10003	st->n.sym = NULL;
10004	gfc_free_symbol (sym->tlink);
10005	sym->tlink = NULL;
10006	sym->refs--;
10007	gfc_syntax_error (ST_MODULE_PROC);
10008	return MATCH_ERROR;
10009	}
10010
10011	return MATCH_YES;
10012
10013	cleanup:
10014	gfc_free_formal_arglist (head);
10015	return MATCH_ERROR;
10016	}
10017
10018
10019	/* Match a module procedure statement. Note that we have to modify
10020	symbols in the parent's namespace because the current one was there
10021	to receive symbols that are in an interface's formal argument list. */
10022
10023	match
10024	gfc_match_modproc (void)
10025	{
10026	char name[GFC_MAX_SYMBOL_LEN + 1];
10027	gfc_symbol *sym;
10028	match m;
10029	locus old_locus;
10030	gfc_namespace *module_ns;
10031	gfc_interface *old_interface_head, *interface;
10032
10033	if (gfc_state_stack->previous == NULL
10034	|| (gfc_state_stack->state != COMP_INTERFACE
10035	&& (gfc_state_stack->state != COMP_CONTAINS
10036	|| gfc_state_stack->previous->state != COMP_INTERFACE))
10037	|| current_interface.type == INTERFACE_NAMELESS
10038	|| current_interface.type == INTERFACE_ABSTRACT)
10039	{
10040	gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10041	"interface");
10042	return MATCH_ERROR;
10043	}
10044
10045	module_ns = gfc_current_ns->parent;
10046	for (; module_ns; module_ns = module_ns->parent)
10047	if (module_ns->proc_name->attr.flavor == FL_MODULE
10048	|| module_ns->proc_name->attr.flavor == FL_PROGRAM
10049	|| (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10050	&& !module_ns->proc_name->attr.contained))
10051	break;
10052
10053	if (module_ns == NULL)
10054	return MATCH_ERROR;
10055
10056	/* Store the current state of the interface. We will need it if we
10057	end up with a syntax error and need to recover. */
10058	old_interface_head = gfc_current_interface_head ();
10059
10060	/* Check if the F2008 optional double colon appears. */
10061	gfc_gobble_whitespace ();
10062	old_locus = gfc_current_locus;
10063	if (gfc_match ("::") == MATCH_YES)
10064	{
10065	if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10066	"MODULE PROCEDURE statement at %L", &old_locus))
10067	return MATCH_ERROR;
10068	}
10069	else
10070	gfc_current_locus = old_locus;
10071
10072	for (;;)
10073	{
10074	bool last = false;
10075	old_locus = gfc_current_locus;
10076
10077	m = gfc_match_name (name);
10078	if (m == MATCH_NO)
10079	goto syntax;
10080	if (m != MATCH_YES)
10081	return MATCH_ERROR;
10082
10083	/* Check for syntax error before starting to add symbols to the
10084	current namespace. */
10085	if (gfc_match_eos () == MATCH_YES)
10086	last = true;
10087
10088	if (!last && gfc_match_char (',') != MATCH_YES)
10089	goto syntax;
10090
10091	/* Now we're sure the syntax is valid, we process this item
10092	further. */
10093	if (gfc_get_symbol (name, module_ns, &sym))
10094	return MATCH_ERROR;
10095
10096	if (sym->attr.intrinsic)
10097	{
10098	gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10099	"PROCEDURE", &old_locus);
10100	return MATCH_ERROR;
10101	}
10102
10103	if (sym->attr.proc != PROC_MODULE
10104	&& !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10105	return MATCH_ERROR;
10106
10107	if (!gfc_add_interface (sym))
10108	return MATCH_ERROR;
10109
10110	sym->attr.mod_proc = 1;
10111	sym->declared_at = old_locus;
10112
10113	if (last)
10114	break;
10115	}
10116
10117	return MATCH_YES;
10118
10119	syntax:
10120	/* Restore the previous state of the interface. */
10121	interface = gfc_current_interface_head ();
10122	gfc_set_current_interface_head (old_interface_head);
10123
10124	/* Free the new interfaces. */
10125	while (interface != old_interface_head)
10126	{
10127	gfc_interface *i = interface->next;
10128	free (ptr: interface);
10129	interface = i;
10130	}
10131
10132	/* And issue a syntax error. */
10133	gfc_syntax_error (ST_MODULE_PROC);
10134	return MATCH_ERROR;
10135	}
10136
10137
10138	/* Check a derived type that is being extended. */
10139
10140	static gfc_symbol*
10141	check_extended_derived_type (char *name)
10142	{
10143	gfc_symbol *extended;
10144
10145	if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10146	{
10147	gfc_error ("Ambiguous symbol in TYPE definition at %C");
10148	return NULL;
10149	}
10150
10151	extended = gfc_find_dt_in_generic (extended);
10152
10153	/* F08:C428. */
10154	if (!extended)
10155	{
10156	gfc_error ("Symbol %qs at %C has not been previously defined", name);
10157	return NULL;
10158	}
10159
10160	if (extended->attr.flavor != FL_DERIVED)
10161	{
10162	gfc_error ("%qs in EXTENDS expression at %C is not a "
10163	"derived type", name);
10164	return NULL;
10165	}
10166
10167	if (extended->attr.is_bind_c)
10168	{
10169	gfc_error ("%qs cannot be extended at %C because it "
10170	"is BIND(C)", extended->name);
10171	return NULL;
10172	}
10173
10174	if (extended->attr.sequence)
10175	{
10176	gfc_error ("%qs cannot be extended at %C because it "
10177	"is a SEQUENCE type", extended->name);
10178	return NULL;
10179	}
10180
10181	return extended;
10182	}
10183
10184
10185	/* Match the optional attribute specifiers for a type declaration.
10186	Return MATCH_ERROR if an error is encountered in one of the handled
10187	attributes (public, private, bind(c)), MATCH_NO if what's found is
10188	not a handled attribute, and MATCH_YES otherwise. TODO: More error
10189	checking on attribute conflicts needs to be done. */
10190
10191	static match
10192	gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10193	{
10194	/* See if the derived type is marked as private. */
10195	if (gfc_match (" , private") == MATCH_YES)
10196	{
10197	if (gfc_current_state () != COMP_MODULE)
10198	{
10199	gfc_error ("Derived type at %C can only be PRIVATE in the "
10200	"specification part of a module");
10201	return MATCH_ERROR;
10202	}
10203
10204	if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
10205	return MATCH_ERROR;
10206	}
10207	else if (gfc_match (" , public") == MATCH_YES)
10208	{
10209	if (gfc_current_state () != COMP_MODULE)
10210	{
10211	gfc_error ("Derived type at %C can only be PUBLIC in the "
10212	"specification part of a module");
10213	return MATCH_ERROR;
10214	}
10215
10216	if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
10217	return MATCH_ERROR;
10218	}
10219	else if (gfc_match (" , bind ( c )") == MATCH_YES)
10220	{
10221	/* If the type is defined to be bind(c) it then needs to make
10222	sure that all fields are interoperable. This will
10223	need to be a semantic check on the finished derived type.
10224	See 15.2.3 (lines 9-12) of F2003 draft. */
10225	if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
10226	return MATCH_ERROR;
10227
10228	/* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10229	}
10230	else if (gfc_match (" , abstract") == MATCH_YES)
10231	{
10232	if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
10233	return MATCH_ERROR;
10234
10235	if (!gfc_add_abstract (attr, where: &gfc_current_locus))
10236	return MATCH_ERROR;
10237	}
10238	else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
10239	{
10240	if (!gfc_add_extension (attr, &gfc_current_locus))
10241	return MATCH_ERROR;
10242	}
10243	else
10244	return MATCH_NO;
10245
10246	/* If we get here, something matched. */
10247	return MATCH_YES;
10248	}
10249
10250
10251	/* Common function for type declaration blocks similar to derived types, such
10252	as STRUCTURES and MAPs. Unlike derived types, a structure type
10253	does NOT have a generic symbol matching the name given by the user.
10254	STRUCTUREs can share names with variables and PARAMETERs so we must allow
10255	for the creation of an independent symbol.
10256	Other parameters are a message to prefix errors with, the name of the new
10257	type to be created, and the flavor to add to the resulting symbol. */
10258
10259	static bool
10260	get_struct_decl (const char *name, sym_flavor fl, locus *decl,
10261	gfc_symbol **result)
10262	{
10263	gfc_symbol *sym;
10264	locus where;
10265
10266	gcc_assert (name[0] == (char) TOUPPER (name[0]));
10267
10268	if (decl)
10269	where = *decl;
10270	else
10271	where = gfc_current_locus;
10272
10273	if (gfc_get_symbol (name, NULL, &sym))
10274	return false;
10275
10276	if (!sym)
10277	{
10278	gfc_internal_error ("Failed to create structure type '%s' at %C", name);
10279	return false;
10280	}
10281
10282	if (sym->components != NULL || sym->attr.zero_comp)
10283	{
10284	gfc_error ("Type definition of %qs at %C was already defined at %L",
10285	sym->name, &sym->declared_at);
10286	return false;
10287	}
10288
10289	sym->declared_at = where;
10290
10291	if (sym->attr.flavor != fl
10292	&& !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
10293	return false;
10294
10295	if (!sym->hash_value)
10296	/* Set the hash for the compound name for this type. */
10297	sym->hash_value = gfc_hash_value (sym);
10298
10299	/* Normally the type is expected to have been completely parsed by the time
10300	a field declaration with this type is seen. For unions, maps, and nested
10301	structure declarations, we need to indicate that it is okay that we
10302	haven't seen any components yet. This will be updated after the structure
10303	is fully parsed. */
10304	sym->attr.zero_comp = 0;
10305
10306	/* Structures always act like derived-types with the SEQUENCE attribute */
10307	gfc_add_sequence (&sym->attr, sym->name, NULL);
10308
10309	if (result) *result = sym;
10310
10311	return true;
10312	}
10313
10314
10315	/* Match the opening of a MAP block. Like a struct within a union in C;
10316	behaves identical to STRUCTURE blocks. */
10317
10318	match
10319	gfc_match_map (void)
10320	{
10321	/* Counter used to give unique internal names to map structures. */
10322	static unsigned int gfc_map_id = 0;
10323	char name[GFC_MAX_SYMBOL_LEN + 1];
10324	gfc_symbol *sym;
10325	locus old_loc;
10326
10327	old_loc = gfc_current_locus;
10328
10329	if (gfc_match_eos () != MATCH_YES)
10330	{
10331	gfc_error ("Junk after MAP statement at %C");
10332	gfc_current_locus = old_loc;
10333	return MATCH_ERROR;
10334	}
10335
10336	/* Map blocks are anonymous so we make up unique names for the symbol table
10337	which are invalid Fortran identifiers. */
10338	snprintf (s: name, GFC_MAX_SYMBOL_LEN + 1, format: "MM$%u", gfc_map_id++);
10339
10340	if (!get_struct_decl (name, fl: FL_STRUCT, decl: &old_loc, result: &sym))
10341	return MATCH_ERROR;
10342
10343	gfc_new_block = sym;
10344
10345	return MATCH_YES;
10346	}
10347
10348
10349	/* Match the opening of a UNION block. */
10350
10351	match
10352	gfc_match_union (void)
10353	{
10354	/* Counter used to give unique internal names to union types. */
10355	static unsigned int gfc_union_id = 0;
10356	char name[GFC_MAX_SYMBOL_LEN + 1];
10357	gfc_symbol *sym;
10358	locus old_loc;
10359
10360	old_loc = gfc_current_locus;
10361
10362	if (gfc_match_eos () != MATCH_YES)
10363	{
10364	gfc_error ("Junk after UNION statement at %C");
10365	gfc_current_locus = old_loc;
10366	return MATCH_ERROR;
10367	}
10368
10369	/* Unions are anonymous so we make up unique names for the symbol table
10370	which are invalid Fortran identifiers. */
10371	snprintf (s: name, GFC_MAX_SYMBOL_LEN + 1, format: "UU$%u", gfc_union_id++);
10372
10373	if (!get_struct_decl (name, fl: FL_UNION, decl: &old_loc, result: &sym))
10374	return MATCH_ERROR;
10375
10376	gfc_new_block = sym;
10377
10378	return MATCH_YES;
10379	}
10380
10381
10382	/* Match the beginning of a STRUCTURE declaration. This is similar to
10383	matching the beginning of a derived type declaration with a few
10384	twists. The resulting type symbol has no access control or other
10385	interesting attributes. */
10386
10387	match
10388	gfc_match_structure_decl (void)
10389	{
10390	/* Counter used to give unique internal names to anonymous structures. */
10391	static unsigned int gfc_structure_id = 0;
10392	char name[GFC_MAX_SYMBOL_LEN + 1];
10393	gfc_symbol *sym;
10394	match m;
10395	locus where;
10396
10397	if (!flag_dec_structure)
10398	{
10399	gfc_error ("%s at %C is a DEC extension, enable with "
10400	"%<-fdec-structure%>",
10401	"STRUCTURE");
10402	return MATCH_ERROR;
10403	}
10404
10405	name[0] = '\0';
10406
10407	m = gfc_match (" /%n/", name);
10408	if (m != MATCH_YES)
10409	{
10410	/* Non-nested structure declarations require a structure name. */
10411	if (!gfc_comp_struct (gfc_current_state ()))
10412	{
10413	gfc_error ("Structure name expected in non-nested structure "
10414	"declaration at %C");
10415	return MATCH_ERROR;
10416	}
10417	/* This is an anonymous structure; make up a unique name for it
10418	(upper-case letters never make it to symbol names from the source).
10419	The important thing is initializing the type variable
10420	and setting gfc_new_symbol, which is immediately used by
10421	parse_structure () and variable_decl () to add components of
10422	this type. */
10423	snprintf (s: name, GFC_MAX_SYMBOL_LEN + 1, format: "SS$%u", gfc_structure_id++);
10424	}
10425
10426	where = gfc_current_locus;
10427	/* No field list allowed after non-nested structure declaration. */
10428	if (!gfc_comp_struct (gfc_current_state ())
10429	&& gfc_match_eos () != MATCH_YES)
10430	{
10431	gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10432	return MATCH_ERROR;
10433	}
10434
10435	/* Make sure the name is not the name of an intrinsic type. */
10436	if (gfc_is_intrinsic_typename (name))
10437	{
10438	gfc_error ("Structure name %qs at %C cannot be the same as an"
10439	" intrinsic type", name);
10440	return MATCH_ERROR;
10441	}
10442
10443	/* Store the actual type symbol for the structure with an upper-case first
10444	letter (an invalid Fortran identifier). */
10445
10446	if (!get_struct_decl (name: gfc_dt_upper_string (name), fl: FL_STRUCT, decl: &where, result: &sym))
10447	return MATCH_ERROR;
10448
10449	gfc_new_block = sym;
10450	return MATCH_YES;
10451	}
10452
10453
10454	/* This function does some work to determine which matcher should be used to
10455	* match a statement beginning with "TYPE". This is used to disambiguate TYPE
10456	* as an alias for PRINT from derived type declarations, TYPE IS statements,
10457	* and [parameterized] derived type declarations. */
10458
10459	match
10460	gfc_match_type (gfc_statement *st)
10461	{
10462	char name[GFC_MAX_SYMBOL_LEN + 1];
10463	match m;
10464	locus old_loc;
10465
10466	/* Requires -fdec. */
10467	if (!flag_dec)
10468	return MATCH_NO;
10469
10470	m = gfc_match ("type");
10471	if (m != MATCH_YES)
10472	return m;
10473	/* If we already have an error in the buffer, it is probably from failing to
10474	* match a derived type data declaration. Let it happen. */
10475	else if (gfc_error_flag_test ())
10476	return MATCH_NO;
10477
10478	old_loc = gfc_current_locus;
10479	*st = ST_NONE;
10480
10481	/* If we see an attribute list before anything else it's definitely a derived
10482	* type declaration. */
10483	if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
10484	goto derived;
10485
10486	/* By now "TYPE" has already been matched. If we do not see a name, this may
10487	* be something like "TYPE *" or "TYPE <fmt>". */
10488	m = gfc_match_name (name);
10489	if (m != MATCH_YES)
10490	{
10491	/* Let print match if it can, otherwise throw an error from
10492	* gfc_match_derived_decl. */
10493	gfc_current_locus = old_loc;
10494	if (gfc_match_print () == MATCH_YES)
10495	{
10496	*st = ST_WRITE;
10497	return MATCH_YES;
10498	}
10499	goto derived;
10500	}
10501
10502	/* Check for EOS. */
10503	if (gfc_match_eos () == MATCH_YES)
10504	{
10505	/* By now we have "TYPE <name> <EOS>". Check first if the name is an
10506	* intrinsic typename - if so let gfc_match_derived_decl dump an error.
10507	* Otherwise if gfc_match_derived_decl fails it's probably an existing
10508	* symbol which can be printed. */
10509	gfc_current_locus = old_loc;
10510	m = gfc_match_derived_decl ();
10511	if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
10512	{
10513	*st = ST_DERIVED_DECL;
10514	return m;
10515	}
10516	}
10517	else
10518	{
10519	/* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10520	like <type name(parameter)>. */
10521	gfc_gobble_whitespace ();
10522	bool paren = gfc_peek_ascii_char () == '(';
10523	if (paren)
10524	{
10525	if (strcmp (s1: "is", s2: name) == 0)
10526	goto typeis;
10527	else
10528	goto derived;
10529	}
10530	}
10531
10532	/* Treat TYPE... like PRINT... */
10533	gfc_current_locus = old_loc;
10534	*st = ST_WRITE;
10535	return gfc_match_print ();
10536
10537	derived:
10538	gfc_current_locus = old_loc;
10539	*st = ST_DERIVED_DECL;
10540	return gfc_match_derived_decl ();
10541
10542	typeis:
10543	gfc_current_locus = old_loc;
10544	*st = ST_TYPE_IS;
10545	return gfc_match_type_is ();
10546	}
10547
10548
10549	/* Match the beginning of a derived type declaration. If a type name
10550	was the result of a function, then it is possible to have a symbol
10551	already to be known as a derived type yet have no components. */
10552
10553	match
10554	gfc_match_derived_decl (void)
10555	{
10556	char name[GFC_MAX_SYMBOL_LEN + 1];
10557	char parent[GFC_MAX_SYMBOL_LEN + 1];
10558	symbol_attribute attr;
10559	gfc_symbol *sym, *gensym;
10560	gfc_symbol *extended;
10561	match m;
10562	match is_type_attr_spec = MATCH_NO;
10563	bool seen_attr = false;
10564	gfc_interface *intr = NULL, *head;
10565	bool parameterized_type = false;
10566	bool seen_colons = false;
10567
10568	if (gfc_comp_struct (gfc_current_state ()))
10569	return MATCH_NO;
10570
10571	name[0] = '\0';
10572	parent[0] = '\0';
10573	gfc_clear_attr (&attr);
10574	extended = NULL;
10575
10576	do
10577	{
10578	is_type_attr_spec = gfc_get_type_attr_spec (attr: &attr, name: parent);
10579	if (is_type_attr_spec == MATCH_ERROR)
10580	return MATCH_ERROR;
10581	if (is_type_attr_spec == MATCH_YES)
10582	seen_attr = true;
10583	} while (is_type_attr_spec == MATCH_YES);
10584
10585	/* Deal with derived type extensions. The extension attribute has
10586	been added to 'attr' but now the parent type must be found and
10587	checked. */
10588	if (parent[0])
10589	extended = check_extended_derived_type (name: parent);
10590
10591	if (parent[0] && !extended)
10592	return MATCH_ERROR;
10593
10594	m = gfc_match (" ::");
10595	if (m == MATCH_YES)
10596	{
10597	seen_colons = true;
10598	}
10599	else if (seen_attr)
10600	{
10601	gfc_error ("Expected :: in TYPE definition at %C");
10602	return MATCH_ERROR;
10603	}
10604
10605	/* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10606	But, we need to simply return for TYPE(. */
10607	if (m == MATCH_NO && gfc_current_form == FORM_FREE)
10608	{
10609	char c = gfc_peek_ascii_char ();
10610	if (c == '(')
10611	return m;
10612	if (!gfc_is_whitespace (c))
10613	{
10614	gfc_error ("Mangled derived type definition at %C");
10615	return MATCH_NO;
10616	}
10617	}
10618
10619	m = gfc_match (" %n ", name);
10620	if (m != MATCH_YES)
10621	return m;
10622
10623	/* Make sure that we don't identify TYPE IS (...) as a parameterized
10624	derived type named 'is'.
10625	TODO Expand the check, when 'name' = "is" by matching " (tname) "
10626	and checking if this is a(n intrinsic) typename. This picks up
10627	misplaced TYPE IS statements such as in select_type_1.f03. */
10628	if (gfc_peek_ascii_char () == '(')
10629	{
10630	if (gfc_current_state () == COMP_SELECT_TYPE
10631	|| (!seen_colons && !strcmp (s1: name, s2: "is")))
10632	return MATCH_NO;
10633	parameterized_type = true;
10634	}
10635
10636	m = gfc_match_eos ();
10637	if (m != MATCH_YES && !parameterized_type)
10638	return m;
10639
10640	/* Make sure the name is not the name of an intrinsic type. */
10641	if (gfc_is_intrinsic_typename (name))
10642	{
10643	gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10644	"type", name);
10645	return MATCH_ERROR;
10646	}
10647
10648	if (gfc_get_symbol (name, NULL, &gensym))
10649	return MATCH_ERROR;
10650
10651	if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
10652	{
10653	if (gensym->ts.u.derived)
10654	gfc_error ("Derived type name %qs at %C already has a basic type "
10655	"of %s", gensym->name, gfc_typename (&gensym->ts));
10656	else
10657	gfc_error ("Derived type name %qs at %C already has a basic type",
10658	gensym->name);
10659	return MATCH_ERROR;
10660	}
10661
10662	if (!gensym->attr.generic
10663	&& !gfc_add_generic (&gensym->attr, gensym->name, NULL))
10664	return MATCH_ERROR;
10665
10666	if (!gensym->attr.function
10667	&& !gfc_add_function (&gensym->attr, gensym->name, NULL))
10668	return MATCH_ERROR;
10669
10670	if (gensym->attr.dummy)
10671	{
10672	gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10673	name, &gensym->declared_at);
10674	return MATCH_ERROR;
10675	}
10676
10677	sym = gfc_find_dt_in_generic (gensym);
10678
10679	if (sym && (sym->components != NULL || sym->attr.zero_comp))
10680	{
10681	gfc_error ("Derived type definition of %qs at %C has already been "
10682	"defined", sym->name);
10683	return MATCH_ERROR;
10684	}
10685
10686	if (!sym)
10687	{
10688	/* Use upper case to save the actual derived-type symbol. */
10689	gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
10690	sym->name = gfc_get_string ("%s", gensym->name);
10691	head = gensym->generic;
10692	intr = gfc_get_interface ();
10693	intr->sym = sym;
10694	intr->where = gfc_current_locus;
10695	intr->sym->declared_at = gfc_current_locus;
10696	intr->next = head;
10697	gensym->generic = intr;
10698	gensym->attr.if_source = IFSRC_DECL;
10699	}
10700
10701	/* The symbol may already have the derived attribute without the
10702	components. The ways this can happen is via a function
10703	definition, an INTRINSIC statement or a subtype in another
10704	derived type that is a pointer. The first part of the AND clause
10705	is true if the symbol is not the return value of a function. */
10706	if (sym->attr.flavor != FL_DERIVED
10707	&& !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
10708	return MATCH_ERROR;
10709
10710	if (attr.access != ACCESS_UNKNOWN
10711	&& !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
10712	return MATCH_ERROR;
10713	else if (sym->attr.access == ACCESS_UNKNOWN
10714	&& gensym->attr.access != ACCESS_UNKNOWN
10715	&& !gfc_add_access (&sym->attr, gensym->attr.access,
10716	sym->name, NULL))
10717	return MATCH_ERROR;
10718
10719	if (sym->attr.access != ACCESS_UNKNOWN
10720	&& gensym->attr.access == ACCESS_UNKNOWN)
10721	gensym->attr.access = sym->attr.access;
10722
10723	/* See if the derived type was labeled as bind(c). */
10724	if (attr.is_bind_c != 0)
10725	sym->attr.is_bind_c = attr.is_bind_c;
10726
10727	/* Construct the f2k_derived namespace if it is not yet there. */
10728	if (!sym->f2k_derived)
10729	sym->f2k_derived = gfc_get_namespace (NULL, 0);
10730
10731	if (parameterized_type)
10732	{
10733	/* Ignore error or mismatches by going to the end of the statement
10734	in order to avoid the component declarations causing problems. */
10735	m = gfc_match_formal_arglist (progname: sym, st_flag: 0, null_flag: 0, typeparam: true);
10736	if (m != MATCH_YES)
10737	gfc_error_recovery ();
10738	else
10739	sym->attr.pdt_template = 1;
10740	m = gfc_match_eos ();
10741	if (m != MATCH_YES)
10742	{
10743	gfc_error_recovery ();
10744	gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10745	}
10746	}
10747
10748	if (extended && !sym->components)
10749	{
10750	gfc_component *p;
10751	gfc_formal_arglist *f, *g, *h;
10752
10753	/* Add the extended derived type as the first component. */
10754	gfc_add_component (sym, parent, &p);
10755	extended->refs++;
10756	gfc_set_sym_referenced (extended);
10757
10758	p->ts.type = BT_DERIVED;
10759	p->ts.u.derived = extended;
10760	p->initializer = gfc_default_initializer (&p->ts);
10761
10762	/* Set extension level. */
10763	if (extended->attr.extension == 255)
10764	{
10765	/* Since the extension field is 8 bit wide, we can only have
10766	up to 255 extension levels. */
10767	gfc_error ("Maximum extension level reached with type %qs at %L",
10768	extended->name, &extended->declared_at);
10769	return MATCH_ERROR;
10770	}
10771	sym->attr.extension = extended->attr.extension + 1;
10772
10773	/* Provide the links between the extended type and its extension. */
10774	if (!extended->f2k_derived)
10775	extended->f2k_derived = gfc_get_namespace (NULL, 0);
10776
10777	/* Copy the extended type-param-name-list from the extended type,
10778	append those of the extension and add the whole lot to the
10779	extension. */
10780	if (extended->attr.pdt_template)
10781	{
10782	g = h = NULL;
10783	sym->attr.pdt_template = 1;
10784	for (f = extended->formal; f; f = f->next)
10785	{
10786	if (f == extended->formal)
10787	{
10788	g = gfc_get_formal_arglist ();
10789	h = g;
10790	}
10791	else
10792	{
10793	g->next = gfc_get_formal_arglist ();
10794	g = g->next;
10795	}
10796	g->sym = f->sym;
10797	}
10798	g->next = sym->formal;
10799	sym->formal = h;
10800	}
10801	}
10802
10803	if (!sym->hash_value)
10804	/* Set the hash for the compound name for this type. */
10805	sym->hash_value = gfc_hash_value (sym);
10806
10807	/* Take over the ABSTRACT attribute. */
10808	sym->attr.abstract = attr.abstract;
10809
10810	gfc_new_block = sym;
10811
10812	return MATCH_YES;
10813	}
10814
10815
10816	/* Cray Pointees can be declared as:
10817	pointer (ipt, a (n,m,...,*)) */
10818
10819	match
10820	gfc_mod_pointee_as (gfc_array_spec *as)
10821	{
10822	as->cray_pointee = true; /* This will be useful to know later. */
10823	if (as->type == AS_ASSUMED_SIZE)
10824	as->cp_was_assumed = true;
10825	else if (as->type == AS_ASSUMED_SHAPE)
10826	{
10827	gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10828	return MATCH_ERROR;
10829	}
10830	return MATCH_YES;
10831	}
10832
10833
10834	/* Match the enum definition statement, here we are trying to match
10835	the first line of enum definition statement.
10836	Returns MATCH_YES if match is found. */
10837
10838	match
10839	gfc_match_enum (void)
10840	{
10841	match m;
10842
10843	m = gfc_match_eos ();
10844	if (m != MATCH_YES)
10845	return m;
10846
10847	if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
10848	return MATCH_ERROR;
10849
10850	return MATCH_YES;
10851	}
10852
10853
10854	/* Returns an initializer whose value is one higher than the value of the
10855	LAST_INITIALIZER argument. If the argument is NULL, the
10856	initializers value will be set to zero. The initializer's kind
10857	will be set to gfc_c_int_kind.
10858
10859	If -fshort-enums is given, the appropriate kind will be selected
10860	later after all enumerators have been parsed. A warning is issued
10861	here if an initializer exceeds gfc_c_int_kind. */
10862
10863	static gfc_expr *
10864	enum_initializer (gfc_expr *last_initializer, locus where)
10865	{
10866	gfc_expr *result;
10867	result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
10868
10869	mpz_init (result->value.integer);
10870
10871	if (last_initializer != NULL)
10872	{
10873	mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
10874	result->where = last_initializer->where;
10875
10876	if (gfc_check_integer_range (p: result->value.integer,
10877	kind: gfc_c_int_kind) != ARITH_OK)
10878	{
10879	gfc_error ("Enumerator exceeds the C integer type at %C");
10880	return NULL;
10881	}
10882	}
10883	else
10884	{
10885	/* Control comes here, if it's the very first enumerator and no
10886	initializer has been given. It will be initialized to zero. */
10887	mpz_set_si (result->value.integer, 0);
10888	}
10889
10890	return result;
10891	}
10892
10893
10894	/* Match a variable name with an optional initializer. When this
10895	subroutine is called, a variable is expected to be parsed next.
10896	Depending on what is happening at the moment, updates either the
10897	symbol table or the current interface. */
10898
10899	static match
10900	enumerator_decl (void)
10901	{
10902	char name[GFC_MAX_SYMBOL_LEN + 1];
10903	gfc_expr *initializer;
10904	gfc_array_spec *as = NULL;
10905	gfc_symbol *sym;
10906	locus var_locus;
10907	match m;
10908	bool t;
10909	locus old_locus;
10910
10911	initializer = NULL;
10912	old_locus = gfc_current_locus;
10913
10914	/* When we get here, we've just matched a list of attributes and
10915	maybe a type and a double colon. The next thing we expect to see
10916	is the name of the symbol. */
10917	m = gfc_match_name (name);
10918	if (m != MATCH_YES)
10919	goto cleanup;
10920
10921	var_locus = gfc_current_locus;
10922
10923	/* OK, we've successfully matched the declaration. Now put the
10924	symbol in the current namespace. If we fail to create the symbol,
10925	bail out. */
10926	if (!build_sym (name, NULL, cl_deferred: false, as: &as, var_locus: &var_locus))
10927	{
10928	m = MATCH_ERROR;
10929	goto cleanup;
10930	}
10931
10932	/* The double colon must be present in order to have initializers.
10933	Otherwise the statement is ambiguous with an assignment statement. */
10934	if (colon_seen)
10935	{
10936	if (gfc_match_char ('=') == MATCH_YES)
10937	{
10938	m = gfc_match_init_expr (&initializer);
10939	if (m == MATCH_NO)
10940	{
10941	gfc_error ("Expected an initialization expression at %C");
10942	m = MATCH_ERROR;
10943	}
10944
10945	if (m != MATCH_YES)
10946	goto cleanup;
10947	}
10948	}
10949
10950	/* If we do not have an initializer, the initialization value of the
10951	previous enumerator (stored in last_initializer) is incremented
10952	by 1 and is used to initialize the current enumerator. */
10953	if (initializer == NULL)
10954	initializer = enum_initializer (last_initializer, where: old_locus);
10955
10956	if (initializer == NULL || initializer->ts.type != BT_INTEGER)
10957	{
10958	gfc_error ("ENUMERATOR %L not initialized with integer expression",
10959	&var_locus);
10960	m = MATCH_ERROR;
10961	goto cleanup;
10962	}
10963
10964	/* Store this current initializer, for the next enumerator variable
10965	to be parsed. add_init_expr_to_sym() zeros initializer, so we
10966	use last_initializer below. */
10967	last_initializer = initializer;
10968	t = add_init_expr_to_sym (name, initp: &initializer, var_locus: &var_locus);
10969
10970	/* Maintain enumerator history. */
10971	gfc_find_symbol (name, NULL, 0, &sym);
10972	create_enum_history (sym, init: last_initializer);
10973
10974	return (t) ? MATCH_YES : MATCH_ERROR;
10975
10976	cleanup:
10977	/* Free stuff up and return. */
10978	gfc_free_expr (initializer);
10979
10980	return m;
10981	}
10982
10983
10984	/* Match the enumerator definition statement. */
10985
10986	match
10987	gfc_match_enumerator_def (void)
10988	{
10989	match m;
10990	bool t;
10991
10992	gfc_clear_ts (&current_ts);
10993
10994	m = gfc_match (" enumerator");
10995	if (m != MATCH_YES)
10996	return m;
10997
10998	m = gfc_match (" :: ");
10999	if (m == MATCH_ERROR)
11000	return m;
11001
11002	colon_seen = (m == MATCH_YES);
11003
11004	if (gfc_current_state () != COMP_ENUM)
11005	{
11006	gfc_error ("ENUM definition statement expected before %C");
11007	gfc_free_enum_history ();
11008	return MATCH_ERROR;
11009	}
11010
11011	(&current_ts)->type = BT_INTEGER;
11012	(&current_ts)->kind = gfc_c_int_kind;
11013
11014	gfc_clear_attr (&current_attr);
11015	t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
11016	if (!t)
11017	{
11018	m = MATCH_ERROR;
11019	goto cleanup;
11020	}
11021
11022	for (;;)
11023	{
11024	m = enumerator_decl ();
11025	if (m == MATCH_ERROR)
11026	{
11027	gfc_free_enum_history ();
11028	goto cleanup;
11029	}
11030	if (m == MATCH_NO)
11031	break;
11032
11033	if (gfc_match_eos () == MATCH_YES)
11034	goto cleanup;
11035	if (gfc_match_char (',') != MATCH_YES)
11036	break;
11037	}
11038
11039	if (gfc_current_state () == COMP_ENUM)
11040	{
11041	gfc_free_enum_history ();
11042	gfc_error ("Syntax error in ENUMERATOR definition at %C");
11043	m = MATCH_ERROR;
11044	}
11045
11046	cleanup:
11047	gfc_free_array_spec (current_as);
11048	current_as = NULL;
11049	return m;
11050
11051	}
11052
11053
11054	/* Match binding attributes. */
11055
11056	static match
11057	match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11058	{
11059	bool found_passing = false;
11060	bool seen_ptr = false;
11061	match m = MATCH_YES;
11062
11063	/* Initialize to defaults. Do so even before the MATCH_NO check so that in
11064	this case the defaults are in there. */
11065	ba->access = ACCESS_UNKNOWN;
11066	ba->pass_arg = NULL;
11067	ba->pass_arg_num = 0;
11068	ba->nopass = 0;
11069	ba->non_overridable = 0;
11070	ba->deferred = 0;
11071	ba->ppc = ppc;
11072
11073	/* If we find a comma, we believe there are binding attributes. */
11074	m = gfc_match_char (',');
11075	if (m == MATCH_NO)
11076	goto done;
11077
11078	do
11079	{
11080	/* Access specifier. */
11081
11082	m = gfc_match (" public");
11083	if (m == MATCH_ERROR)
11084	goto error;
11085	if (m == MATCH_YES)
11086	{
11087	if (ba->access != ACCESS_UNKNOWN)
11088	{
11089	gfc_error ("Duplicate access-specifier at %C");
11090	goto error;
11091	}
11092
11093	ba->access = ACCESS_PUBLIC;
11094	continue;
11095	}
11096
11097	m = gfc_match (" private");
11098	if (m == MATCH_ERROR)
11099	goto error;
11100	if (m == MATCH_YES)
11101	{
11102	if (ba->access != ACCESS_UNKNOWN)
11103	{
11104	gfc_error ("Duplicate access-specifier at %C");
11105	goto error;
11106	}
11107
11108	ba->access = ACCESS_PRIVATE;
11109	continue;
11110	}
11111
11112	/* If inside GENERIC, the following is not allowed. */
11113	if (!generic)
11114	{
11115
11116	/* NOPASS flag. */
11117	m = gfc_match (" nopass");
11118	if (m == MATCH_ERROR)
11119	goto error;
11120	if (m == MATCH_YES)
11121	{
11122	if (found_passing)
11123	{
11124	gfc_error ("Binding attributes already specify passing,"
11125	" illegal NOPASS at %C");
11126	goto error;
11127	}
11128
11129	found_passing = true;
11130	ba->nopass = 1;
11131	continue;
11132	}
11133
11134	/* PASS possibly including argument. */
11135	m = gfc_match (" pass");
11136	if (m == MATCH_ERROR)
11137	goto error;
11138	if (m == MATCH_YES)
11139	{
11140	char arg[GFC_MAX_SYMBOL_LEN + 1];
11141
11142	if (found_passing)
11143	{
11144	gfc_error ("Binding attributes already specify passing,"
11145	" illegal PASS at %C");
11146	goto error;
11147	}
11148
11149	m = gfc_match (" ( %n )", arg);
11150	if (m == MATCH_ERROR)
11151	goto error;
11152	if (m == MATCH_YES)
11153	ba->pass_arg = gfc_get_string ("%s", arg);
11154	gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11155
11156	found_passing = true;
11157	ba->nopass = 0;
11158	continue;
11159	}
11160
11161	if (ppc)
11162	{
11163	/* POINTER flag. */
11164	m = gfc_match (" pointer");
11165	if (m == MATCH_ERROR)
11166	goto error;
11167	if (m == MATCH_YES)
11168	{
11169	if (seen_ptr)
11170	{
11171	gfc_error ("Duplicate POINTER attribute at %C");
11172	goto error;
11173	}
11174
11175	seen_ptr = true;
11176	continue;
11177	}
11178	}
11179	else
11180	{
11181	/* NON_OVERRIDABLE flag. */
11182	m = gfc_match (" non_overridable");
11183	if (m == MATCH_ERROR)
11184	goto error;
11185	if (m == MATCH_YES)
11186	{
11187	if (ba->non_overridable)
11188	{
11189	gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11190	goto error;
11191	}
11192
11193	ba->non_overridable = 1;
11194	continue;
11195	}
11196
11197	/* DEFERRED flag. */
11198	m = gfc_match (" deferred");
11199	if (m == MATCH_ERROR)
11200	goto error;
11201	if (m == MATCH_YES)
11202	{
11203	if (ba->deferred)
11204	{
11205	gfc_error ("Duplicate DEFERRED at %C");
11206	goto error;
11207	}
11208
11209	ba->deferred = 1;
11210	continue;
11211	}
11212	}
11213
11214	}
11215
11216	/* Nothing matching found. */
11217	if (generic)
11218	gfc_error ("Expected access-specifier at %C");
11219	else
11220	gfc_error ("Expected binding attribute at %C");
11221	goto error;
11222	}
11223	while (gfc_match_char (',') == MATCH_YES);
11224
11225	/* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11226	if (ba->non_overridable && ba->deferred)
11227	{
11228	gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11229	goto error;
11230	}
11231
11232	m = MATCH_YES;
11233
11234	done:
11235	if (ba->access == ACCESS_UNKNOWN)
11236	ba->access = ppc ? gfc_current_block()->component_access
11237	: gfc_typebound_default_access;
11238
11239	if (ppc && !seen_ptr)
11240	{
11241	gfc_error ("POINTER attribute is required for procedure pointer component"
11242	" at %C");
11243	goto error;
11244	}
11245
11246	return m;
11247
11248	error:
11249	return MATCH_ERROR;
11250	}
11251
11252
11253	/* Match a PROCEDURE specific binding inside a derived type. */
11254
11255	static match
11256	match_procedure_in_type (void)
11257	{
11258	char name[GFC_MAX_SYMBOL_LEN + 1];
11259	char target_buf[GFC_MAX_SYMBOL_LEN + 1];
11260	char* target = NULL, *ifc = NULL;
11261	gfc_typebound_proc tb;
11262	bool seen_colons;
11263	bool seen_attrs;
11264	match m;
11265	gfc_symtree* stree;
11266	gfc_namespace* ns;
11267	gfc_symbol* block;
11268	int num;
11269
11270	/* Check current state. */
11271	gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
11272	block = gfc_state_stack->previous->sym;
11273	gcc_assert (block);
11274
11275	/* Try to match PROCEDURE(interface). */
11276	if (gfc_match (" (") == MATCH_YES)
11277	{
11278	m = gfc_match_name (target_buf);
11279	if (m == MATCH_ERROR)
11280	return m;
11281	if (m != MATCH_YES)
11282	{
11283	gfc_error ("Interface-name expected after %<(%> at %C");
11284	return MATCH_ERROR;
11285	}
11286
11287	if (gfc_match (" )") != MATCH_YES)
11288	{
11289	gfc_error ("%<)%> expected at %C");
11290	return MATCH_ERROR;
11291	}
11292
11293	ifc = target_buf;
11294	}
11295
11296	/* Construct the data structure. */
11297	memset (s: &tb, c: 0, n: sizeof (tb));
11298	tb.where = gfc_current_locus;
11299
11300	/* Match binding attributes. */
11301	m = match_binding_attributes (ba: &tb, generic: false, ppc: false);
11302	if (m == MATCH_ERROR)
11303	return m;
11304	seen_attrs = (m == MATCH_YES);
11305
11306	/* Check that attribute DEFERRED is given if an interface is specified. */
11307	if (tb.deferred && !ifc)
11308	{
11309	gfc_error ("Interface must be specified for DEFERRED binding at %C");
11310	return MATCH_ERROR;
11311	}
11312	if (ifc && !tb.deferred)
11313	{
11314	gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11315	return MATCH_ERROR;
11316	}
11317
11318	/* Match the colons. */
11319	m = gfc_match (" ::");
11320	if (m == MATCH_ERROR)
11321	return m;
11322	seen_colons = (m == MATCH_YES);
11323	if (seen_attrs && !seen_colons)
11324	{
11325	gfc_error ("Expected %<::%> after binding-attributes at %C");
11326	return MATCH_ERROR;
11327	}
11328
11329	/* Match the binding names. */
11330	for(num=1;;num++)
11331	{
11332	m = gfc_match_name (name);
11333	if (m == MATCH_ERROR)
11334	return m;
11335	if (m == MATCH_NO)
11336	{
11337	gfc_error ("Expected binding name at %C");
11338	return MATCH_ERROR;
11339	}
11340
11341	if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
11342	return MATCH_ERROR;
11343
11344	/* Try to match the '=> target', if it's there. */
11345	target = ifc;
11346	m = gfc_match (" =>");
11347	if (m == MATCH_ERROR)
11348	return m;
11349	if (m == MATCH_YES)
11350	{
11351	if (tb.deferred)
11352	{
11353	gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11354	return MATCH_ERROR;
11355	}
11356
11357	if (!seen_colons)
11358	{
11359	gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11360	" at %C");
11361	return MATCH_ERROR;
11362	}
11363
11364	m = gfc_match_name (target_buf);
11365	if (m == MATCH_ERROR)
11366	return m;
11367	if (m == MATCH_NO)
11368	{
11369	gfc_error ("Expected binding target after %<=>%> at %C");
11370	return MATCH_ERROR;
11371	}
11372	target = target_buf;
11373	}
11374
11375	/* If no target was found, it has the same name as the binding. */
11376	if (!target)
11377	target = name;
11378
11379	/* Get the namespace to insert the symbols into. */
11380	ns = block->f2k_derived;
11381	gcc_assert (ns);
11382
11383	/* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11384	if (tb.deferred && !block->attr.abstract)
11385	{
11386	gfc_error ("Type %qs containing DEFERRED binding at %C "
11387	"is not ABSTRACT", block->name);
11388	return MATCH_ERROR;
11389	}
11390
11391	/* See if we already have a binding with this name in the symtree which
11392	would be an error. If a GENERIC already targeted this binding, it may
11393	be already there but then typebound is still NULL. */
11394	stree = gfc_find_symtree (ns->tb_sym_root, name);
11395	if (stree && stree->n.tb)
11396	{
11397	gfc_error ("There is already a procedure with binding name %qs for "
11398	"the derived type %qs at %C", name, block->name);
11399	return MATCH_ERROR;
11400	}
11401
11402	/* Insert it and set attributes. */
11403
11404	if (!stree)
11405	{
11406	stree = gfc_new_symtree (&ns->tb_sym_root, name);
11407	gcc_assert (stree);
11408	}
11409	stree->n.tb = gfc_get_typebound_proc (&tb);
11410
11411	if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
11412	false))
11413	return MATCH_ERROR;
11414	gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
11415	gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
11416	target, &stree->n.tb->u.specific->n.sym->declared_at);
11417
11418	if (gfc_match_eos () == MATCH_YES)
11419	return MATCH_YES;
11420	if (gfc_match_char (',') != MATCH_YES)
11421	goto syntax;
11422	}
11423
11424	syntax:
11425	gfc_error ("Syntax error in PROCEDURE statement at %C");
11426	return MATCH_ERROR;
11427	}
11428
11429
11430	/* Match a GENERIC procedure binding inside a derived type. */
11431
11432	match
11433	gfc_match_generic (void)
11434	{
11435	char name[GFC_MAX_SYMBOL_LEN + 1];
11436	char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
11437	gfc_symbol* block;
11438	gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
11439	gfc_typebound_proc* tb;
11440	gfc_namespace* ns;
11441	interface_type op_type;
11442	gfc_intrinsic_op op;
11443	match m;
11444
11445	/* Check current state. */
11446	if (gfc_current_state () == COMP_DERIVED)
11447	{
11448	gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11449	return MATCH_ERROR;
11450	}
11451	if (gfc_current_state () != COMP_DERIVED_CONTAINS)
11452	return MATCH_NO;
11453	block = gfc_state_stack->previous->sym;
11454	ns = block->f2k_derived;
11455	gcc_assert (block && ns);
11456
11457	memset (s: &tbattr, c: 0, n: sizeof (tbattr));
11458	tbattr.where = gfc_current_locus;
11459
11460	/* See if we get an access-specifier. */
11461	m = match_binding_attributes (ba: &tbattr, generic: true, ppc: false);
11462	if (m == MATCH_ERROR)
11463	goto error;
11464
11465	/* Now the colons, those are required. */
11466	if (gfc_match (" ::") != MATCH_YES)
11467	{
11468	gfc_error ("Expected %<::%> at %C");
11469	goto error;
11470	}
11471
11472	/* Match the binding name; depending on type (operator / generic) format
11473	it for future error messages into bind_name. */
11474
11475	m = gfc_match_generic_spec (&op_type, name, &op);
11476	if (m == MATCH_ERROR)
11477	return MATCH_ERROR;
11478	if (m == MATCH_NO)
11479	{
11480	gfc_error ("Expected generic name or operator descriptor at %C");
11481	goto error;
11482	}
11483
11484	switch (op_type)
11485	{
11486	case INTERFACE_GENERIC:
11487	case INTERFACE_DTIO:
11488	snprintf (s: bind_name, maxlen: sizeof (bind_name), format: "%s", name);
11489	break;
11490
11491	case INTERFACE_USER_OP:
11492	snprintf (s: bind_name, maxlen: sizeof (bind_name), format: "OPERATOR(.%s.)", name);
11493	break;
11494
11495	case INTERFACE_INTRINSIC_OP:
11496	snprintf (s: bind_name, maxlen: sizeof (bind_name), format: "OPERATOR(%s)",
11497	gfc_op2string (op));
11498	break;
11499
11500	case INTERFACE_NAMELESS:
11501	gfc_error ("Malformed GENERIC statement at %C");
11502	goto error;
11503	break;
11504
11505	default:
11506	gcc_unreachable ();
11507	}
11508
11509	/* Match the required =>. */
11510	if (gfc_match (" =>") != MATCH_YES)
11511	{
11512	gfc_error ("Expected %<=>%> at %C");
11513	goto error;
11514	}
11515
11516	/* Try to find existing GENERIC binding with this name / for this operator;
11517	if there is something, check that it is another GENERIC and then extend
11518	it rather than building a new node. Otherwise, create it and put it
11519	at the right position. */
11520
11521	switch (op_type)
11522	{
11523	case INTERFACE_DTIO:
11524	case INTERFACE_USER_OP:
11525	case INTERFACE_GENERIC:
11526	{
11527	const bool is_op = (op_type == INTERFACE_USER_OP);
11528	gfc_symtree* st;
11529
11530	st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
11531	tb = st ? st->n.tb : NULL;
11532	break;
11533	}
11534
11535	case INTERFACE_INTRINSIC_OP:
11536	tb = ns->tb_op[op];
11537	break;
11538
11539	default:
11540	gcc_unreachable ();
11541	}
11542
11543	if (tb)
11544	{
11545	if (!tb->is_generic)
11546	{
11547	gcc_assert (op_type == INTERFACE_GENERIC);
11548	gfc_error ("There's already a non-generic procedure with binding name"
11549	" %qs for the derived type %qs at %C",
11550	bind_name, block->name);
11551	goto error;
11552	}
11553
11554	if (tb->access != tbattr.access)
11555	{
11556	gfc_error ("Binding at %C must have the same access as already"
11557	" defined binding %qs", bind_name);
11558	goto error;
11559	}
11560	}
11561	else
11562	{
11563	tb = gfc_get_typebound_proc (NULL);
11564	tb->where = gfc_current_locus;
11565	tb->access = tbattr.access;
11566	tb->is_generic = 1;
11567	tb->u.generic = NULL;
11568
11569	switch (op_type)
11570	{
11571	case INTERFACE_DTIO:
11572	case INTERFACE_GENERIC:
11573	case INTERFACE_USER_OP:
11574	{
11575	const bool is_op = (op_type == INTERFACE_USER_OP);
11576	gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
11577	&ns->tb_sym_root, name);
11578	gcc_assert (st);
11579	st->n.tb = tb;
11580
11581	break;
11582	}
11583
11584	case INTERFACE_INTRINSIC_OP:
11585	ns->tb_op[op] = tb;
11586	break;
11587
11588	default:
11589	gcc_unreachable ();
11590	}
11591	}
11592
11593	/* Now, match all following names as specific targets. */
11594	do
11595	{
11596	gfc_symtree* target_st;
11597	gfc_tbp_generic* target;
11598
11599	m = gfc_match_name (name);
11600	if (m == MATCH_ERROR)
11601	goto error;
11602	if (m == MATCH_NO)
11603	{
11604	gfc_error ("Expected specific binding name at %C");
11605	goto error;
11606	}
11607
11608	target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
11609
11610	/* See if this is a duplicate specification. */
11611	for (target = tb->u.generic; target; target = target->next)
11612	if (target_st == target->specific_st)
11613	{
11614	gfc_error ("%qs already defined as specific binding for the"
11615	" generic %qs at %C", name, bind_name);
11616	goto error;
11617	}
11618
11619	target = gfc_get_tbp_generic ();
11620	target->specific_st = target_st;
11621	target->specific = NULL;
11622	target->next = tb->u.generic;
11623	target->is_operator = ((op_type == INTERFACE_USER_OP)
11624	|| (op_type == INTERFACE_INTRINSIC_OP));
11625	tb->u.generic = target;
11626	}
11627	while (gfc_match (" ,") == MATCH_YES);
11628
11629	/* Here should be the end. */
11630	if (gfc_match_eos () != MATCH_YES)
11631	{
11632	gfc_error ("Junk after GENERIC binding at %C");
11633	goto error;
11634	}
11635
11636	return MATCH_YES;
11637
11638	error:
11639	return MATCH_ERROR;
11640	}
11641
11642
11643	/* Match a FINAL declaration inside a derived type. */
11644
11645	match
11646	gfc_match_final_decl (void)
11647	{
11648	char name[GFC_MAX_SYMBOL_LEN + 1];
11649	gfc_symbol* sym;
11650	match m;
11651	gfc_namespace* module_ns;
11652	bool first, last;
11653	gfc_symbol* block;
11654
11655	if (gfc_current_form == FORM_FREE)
11656	{
11657	char c = gfc_peek_ascii_char ();
11658	if (!gfc_is_whitespace (c) && c != ':')
11659	return MATCH_NO;
11660	}
11661
11662	if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
11663	{
11664	if (gfc_current_form == FORM_FIXED)
11665	return MATCH_NO;
11666
11667	gfc_error ("FINAL declaration at %C must be inside a derived type "
11668	"CONTAINS section");
11669	return MATCH_ERROR;
11670	}
11671
11672	block = gfc_state_stack->previous->sym;
11673	gcc_assert (block);
11674
11675	if (gfc_state_stack->previous->previous
11676	&& gfc_state_stack->previous->previous->state != COMP_MODULE
11677	&& gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
11678	{
11679	gfc_error ("Derived type declaration with FINAL at %C must be in the"
11680	" specification part of a MODULE");
11681	return MATCH_ERROR;
11682	}
11683
11684	module_ns = gfc_current_ns;
11685	gcc_assert (module_ns);
11686	gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
11687
11688	/* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11689	if (gfc_match (" ::") == MATCH_ERROR)
11690	return MATCH_ERROR;
11691
11692	/* Match the sequence of procedure names. */
11693	first = true;
11694	last = false;
11695	do
11696	{
11697	gfc_finalizer* f;
11698
11699	if (first && gfc_match_eos () == MATCH_YES)
11700	{
11701	gfc_error ("Empty FINAL at %C");
11702	return MATCH_ERROR;
11703	}
11704
11705	m = gfc_match_name (name);
11706	if (m == MATCH_NO)
11707	{
11708	gfc_error ("Expected module procedure name at %C");
11709	return MATCH_ERROR;
11710	}
11711	else if (m != MATCH_YES)
11712	return MATCH_ERROR;
11713
11714	if (gfc_match_eos () == MATCH_YES)
11715	last = true;
11716	if (!last && gfc_match_char (',') != MATCH_YES)
11717	{
11718	gfc_error ("Expected %<,%> at %C");
11719	return MATCH_ERROR;
11720	}
11721
11722	if (gfc_get_symbol (name, module_ns, &sym))
11723	{
11724	gfc_error ("Unknown procedure name %qs at %C", name);
11725	return MATCH_ERROR;
11726	}
11727
11728	/* Mark the symbol as module procedure. */
11729	if (sym->attr.proc != PROC_MODULE
11730	&& !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
11731	return MATCH_ERROR;
11732
11733	/* Check if we already have this symbol in the list, this is an error. */
11734	for (f = block->f2k_derived->finalizers; f; f = f->next)
11735	if (f->proc_sym == sym)
11736	{
11737	gfc_error ("%qs at %C is already defined as FINAL procedure",
11738	name);
11739	return MATCH_ERROR;
11740	}
11741
11742	/* Add this symbol to the list of finalizers. */
11743	gcc_assert (block->f2k_derived);
11744	sym->refs++;
11745	f = XCNEW (gfc_finalizer);
11746	f->proc_sym = sym;
11747	f->proc_tree = NULL;
11748	f->where = gfc_current_locus;
11749	f->next = block->f2k_derived->finalizers;
11750	block->f2k_derived->finalizers = f;
11751
11752	first = false;
11753	}
11754	while (!last);
11755
11756	return MATCH_YES;
11757	}
11758
11759
11760	const ext_attr_t ext_attr_list[] = {
11761	{ .name: "dllimport", .id: EXT_ATTR_DLLIMPORT, .middle_end_name: "dllimport" },
11762	{ .name: "dllexport", .id: EXT_ATTR_DLLEXPORT, .middle_end_name: "dllexport" },
11763	{ .name: "cdecl", .id: EXT_ATTR_CDECL, .middle_end_name: "cdecl" },
11764	{ .name: "stdcall", .id: EXT_ATTR_STDCALL, .middle_end_name: "stdcall" },
11765	{ .name: "fastcall", .id: EXT_ATTR_FASTCALL, .middle_end_name: "fastcall" },
11766	{ .name: "no_arg_check", .id: EXT_ATTR_NO_ARG_CHECK, NULL },
11767	{ .name: "deprecated", .id: EXT_ATTR_DEPRECATED, NULL },
11768	{ .name: "noinline", .id: EXT_ATTR_NOINLINE, NULL },
11769	{ .name: "noreturn", .id: EXT_ATTR_NORETURN, NULL },
11770	{ .name: "weak", .id: EXT_ATTR_WEAK, NULL },
11771	{ NULL, .id: EXT_ATTR_LAST, NULL }
11772	};
11773
11774	/* Match a !GCC$ ATTRIBUTES statement of the form:
11775	!GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11776	When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11777
11778	TODO: We should support all GCC attributes using the same syntax for
11779	the attribute list, i.e. the list in C
11780	__attributes(( attribute-list ))
11781	matches then
11782	!GCC$ ATTRIBUTES attribute-list ::
11783	Cf. c-parser.cc's c_parser_attributes; the data can then directly be
11784	saved into a TREE.
11785
11786	As there is absolutely no risk of confusion, we should never return
11787	MATCH_NO. */
11788	match
11789	gfc_match_gcc_attributes (void)
11790	{
11791	symbol_attribute attr;
11792	char name[GFC_MAX_SYMBOL_LEN + 1];
11793	unsigned id;
11794	gfc_symbol *sym;
11795	match m;
11796
11797	gfc_clear_attr (&attr);
11798	for(;;)
11799	{
11800	char ch;
11801
11802	if (gfc_match_name (name) != MATCH_YES)
11803	return MATCH_ERROR;
11804
11805	for (id = 0; id < EXT_ATTR_LAST; id++)
11806	if (strcmp (s1: name, s2: ext_attr_list[id].name) == 0)
11807	break;
11808
11809	if (id == EXT_ATTR_LAST)
11810	{
11811	gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11812	return MATCH_ERROR;
11813	}
11814
11815	if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
11816	return MATCH_ERROR;
11817
11818	gfc_gobble_whitespace ();
11819	ch = gfc_next_ascii_char ();
11820	if (ch == ':')
11821	{
11822	/* This is the successful exit condition for the loop. */
11823	if (gfc_next_ascii_char () == ':')
11824	break;
11825	}
11826
11827	if (ch == ',')
11828	continue;
11829
11830	goto syntax;
11831	}
11832
11833	if (gfc_match_eos () == MATCH_YES)
11834	goto syntax;
11835
11836	for(;;)
11837	{
11838	m = gfc_match_name (name);
11839	if (m != MATCH_YES)
11840	return m;
11841
11842	if (find_special (name, result: &sym, allow_subroutine: true))
11843	return MATCH_ERROR;
11844
11845	sym->attr.ext_attr |= attr.ext_attr;
11846
11847	if (gfc_match_eos () == MATCH_YES)
11848	break;
11849
11850	if (gfc_match_char (',') != MATCH_YES)
11851	goto syntax;
11852	}
11853
11854	return MATCH_YES;
11855
11856	syntax:
11857	gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11858	return MATCH_ERROR;
11859	}
11860
11861
11862	/* Match a !GCC$ UNROLL statement of the form:
11863	!GCC$ UNROLL n
11864
11865	The parameter n is the number of times we are supposed to unroll.
11866
11867	When we come here, we have already matched the !GCC$ UNROLL string. */
11868	match
11869	gfc_match_gcc_unroll (void)
11870	{
11871	int value;
11872
11873	/* FIXME: use gfc_match_small_literal_int instead, delete small_int */
11874	if (gfc_match_small_int (&value) == MATCH_YES)
11875	{
11876	if (value < 0 || value > USHRT_MAX)
11877	{
11878	gfc_error ("%<GCC unroll%> directive requires a"
11879	" non-negative integral constant"
11880	" less than or equal to %u at %C",
11881	USHRT_MAX
11882	);
11883	return MATCH_ERROR;
11884	}
11885	if (gfc_match_eos () == MATCH_YES)
11886	{
11887	directive_unroll = value == 0 ? 1 : value;
11888	return MATCH_YES;
11889	}
11890	}
11891
11892	gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11893	return MATCH_ERROR;
11894	}
11895
11896	/* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11897
11898	The parameter b is name of a middle-end built-in.
11899	FLAGS is optional and must be one of:
11900	- (inbranch)
11901	- (notinbranch)
11902
11903	IF('target') is optional and TARGET is a name of a multilib ABI.
11904
11905	When we come here, we have already matched the !GCC$ builtin string. */
11906
11907	match
11908	gfc_match_gcc_builtin (void)
11909	{
11910	char builtin[GFC_MAX_SYMBOL_LEN + 1];
11911	char target[GFC_MAX_SYMBOL_LEN + 1];
11912
11913	if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
11914	return MATCH_ERROR;
11915
11916	gfc_simd_clause clause = SIMD_NONE;
11917	if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
11918	clause = SIMD_NOTINBRANCH;
11919	else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
11920	clause = SIMD_INBRANCH;
11921
11922	if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
11923	{
11924	const char *abi = targetm.get_multilib_abi_name ();
11925	if (abi == NULL || strcmp (s1: abi, s2: target) != 0)
11926	return MATCH_YES;
11927	}
11928
11929	if (gfc_vectorized_builtins == NULL)
11930	gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
11931
11932	char *r = XNEWVEC (char, strlen (builtin) + 32);
11933	sprintf (s: r, format: "__builtin_%s", builtin);
11934
11935	bool existed;
11936	int &value = gfc_vectorized_builtins->get_or_insert (k: r, existed: &existed);
11937	value |= clause;
11938	if (existed)
11939	free (ptr: r);
11940
11941	return MATCH_YES;
11942	}
11943
11944	/* Match an !GCC$ IVDEP statement.
11945	When we come here, we have already matched the !GCC$ IVDEP string. */
11946
11947	match
11948	gfc_match_gcc_ivdep (void)
11949	{
11950	if (gfc_match_eos () == MATCH_YES)
11951	{
11952	directive_ivdep = true;
11953	return MATCH_YES;
11954	}
11955
11956	gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11957	return MATCH_ERROR;
11958	}
11959
11960	/* Match an !GCC$ VECTOR statement.
11961	When we come here, we have already matched the !GCC$ VECTOR string. */
11962
11963	match
11964	gfc_match_gcc_vector (void)
11965	{
11966	if (gfc_match_eos () == MATCH_YES)
11967	{
11968	directive_vector = true;
11969	directive_novector = false;
11970	return MATCH_YES;
11971	}
11972
11973	gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11974	return MATCH_ERROR;
11975	}
11976
11977	/* Match an !GCC$ NOVECTOR statement.
11978	When we come here, we have already matched the !GCC$ NOVECTOR string. */
11979
11980	match
11981	gfc_match_gcc_novector (void)
11982	{
11983	if (gfc_match_eos () == MATCH_YES)
11984	{
11985	directive_novector = true;
11986	directive_vector = false;
11987	return MATCH_YES;
11988	}
11989
11990	gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11991	return MATCH_ERROR;
11992	}
11993