1	/* Deal with interfaces.
2	Copyright (C) 2000-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
22	/* Deal with interfaces. An explicit interface is represented as a
23	singly linked list of formal argument structures attached to the
24	relevant symbols. For an implicit interface, the arguments don't
25	point to symbols. Explicit interfaces point to namespaces that
26	contain the symbols within that interface.
27
28	Implicit interfaces are linked together in a singly linked list
29	along the next_if member of symbol nodes. Since a particular
30	symbol can only have a single explicit interface, the symbol cannot
31	be part of multiple lists and a single next-member suffices.
32
33	This is not the case for general classes, though. An operator
34	definition is independent of just about all other uses and has it's
35	own head pointer.
36
37	Nameless interfaces:
38	Nameless interfaces create symbols with explicit interfaces within
39	the current namespace. They are otherwise unlinked.
40
41	Generic interfaces:
42	The generic name points to a linked list of symbols. Each symbol
43	has an explicit interface. Each explicit interface has its own
44	namespace containing the arguments. Module procedures are symbols in
45	which the interface is added later when the module procedure is parsed.
46
47	User operators:
48	User-defined operators are stored in a their own set of symtrees
49	separate from regular symbols. The symtrees point to gfc_user_op
50	structures which in turn head up a list of relevant interfaces.
51
52	Extended intrinsics and assignment:
53	The head of these interface lists are stored in the containing namespace.
54
55	Implicit interfaces:
56	An implicit interface is represented as a singly linked list of
57	formal argument list structures that don't point to any symbol
58	nodes -- they just contain types.
59
60
61	When a subprogram is defined, the program unit's name points to an
62	interface as usual, but the link to the namespace is NULL and the
63	formal argument list points to symbols within the same namespace as
64	the program unit name. */
65
66	#include "config.h"
67	#include "system.h"
68	#include "coretypes.h"
69	#include "options.h"
70	#include "gfortran.h"
71	#include "match.h"
72	#include "arith.h"
73
74	/* The current_interface structure holds information about the
75	interface currently being parsed. This structure is saved and
76	restored during recursive interfaces. */
77
78	gfc_interface_info current_interface;
79
80
81	/* Free the leading members of the gfc_interface linked list given in INTR
82	up to the END element (exclusive: the END element is not freed).
83	If END is not nullptr, it is assumed that END is in the linked list starting
84	with INTR. */
85
86	static void
87	free_interface_elements_until (gfc_interface *intr, gfc_interface *end)
88	{
89	gfc_interface *next;
90
91	for (; intr != end; intr = next)
92	{
93	next = intr->next;
94	free (ptr: intr);
95	}
96	}
97
98
99	/* Free a singly linked list of gfc_interface structures. */
100
101	void
102	gfc_free_interface (gfc_interface *intr)
103	{
104	free_interface_elements_until (intr, end: nullptr);
105	}
106
107
108	/* Update the interface pointer given by IFC_PTR to make it point to TAIL.
109	It is expected that TAIL (if non-null) is in the list pointed to by
110	IFC_PTR, hence the tail of it. The members of the list before TAIL are
111	freed before the pointer reassignment. */
112
113	void
114	gfc_drop_interface_elements_before (gfc_interface **ifc_ptr,
115	gfc_interface *tail)
116	{
117	if (ifc_ptr == nullptr)
118	return;
119
120	free_interface_elements_until (intr: *ifc_ptr, end: tail);
121	*ifc_ptr = tail;
122	}
123
124
125	/* Change the operators unary plus and minus into binary plus and
126	minus respectively, leaving the rest unchanged. */
127
128	static gfc_intrinsic_op
129	fold_unary_intrinsic (gfc_intrinsic_op op)
130	{
131	switch (op)
132	{
133	case INTRINSIC_UPLUS:
134	op = INTRINSIC_PLUS;
135	break;
136	case INTRINSIC_UMINUS:
137	op = INTRINSIC_MINUS;
138	break;
139	default:
140	break;
141	}
142
143	return op;
144	}
145
146
147	/* Return the operator depending on the DTIO moded string. Note that
148	these are not operators in the normal sense and so have been placed
149	beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
150
151	static gfc_intrinsic_op
152	dtio_op (char* mode)
153	{
154	if (strcmp (s1: mode, s2: "formatted") == 0)
155	return INTRINSIC_FORMATTED;
156	if (strcmp (s1: mode, s2: "unformatted") == 0)
157	return INTRINSIC_UNFORMATTED;
158	return INTRINSIC_NONE;
159	}
160
161
162	/* Match a generic specification. Depending on which type of
163	interface is found, the 'name' or 'op' pointers may be set.
164	This subroutine doesn't return MATCH_NO. */
165
166	match
167	gfc_match_generic_spec (interface_type *type,
168	char *name,
169	gfc_intrinsic_op *op)
170	{
171	char buffer[GFC_MAX_SYMBOL_LEN + 1];
172	match m;
173	gfc_intrinsic_op i;
174
175	if (gfc_match (" assignment ( = )") == MATCH_YES)
176	{
177	*type = INTERFACE_INTRINSIC_OP;
178	*op = INTRINSIC_ASSIGN;
179	return MATCH_YES;
180	}
181
182	if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
183	{ /* Operator i/f */
184	*type = INTERFACE_INTRINSIC_OP;
185	*op = fold_unary_intrinsic (op: i);
186	return MATCH_YES;
187	}
188
189	*op = INTRINSIC_NONE;
190	if (gfc_match (" operator ( ") == MATCH_YES)
191	{
192	m = gfc_match_defined_op_name (buffer, 1);
193	if (m == MATCH_NO)
194	goto syntax;
195	if (m != MATCH_YES)
196	return MATCH_ERROR;
197
198	m = gfc_match_char (')');
199	if (m == MATCH_NO)
200	goto syntax;
201	if (m != MATCH_YES)
202	return MATCH_ERROR;
203
204	strcpy (dest: name, src: buffer);
205	*type = INTERFACE_USER_OP;
206	return MATCH_YES;
207	}
208
209	if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
210	{
211	*op = dtio_op (mode: buffer);
212	if (*op == INTRINSIC_FORMATTED)
213	{
214	strcpy (dest: name, src: gfc_code2string (dtio_procs, DTIO_RF));
215	*type = INTERFACE_DTIO;
216	}
217	if (*op == INTRINSIC_UNFORMATTED)
218	{
219	strcpy (dest: name, src: gfc_code2string (dtio_procs, DTIO_RUF));
220	*type = INTERFACE_DTIO;
221	}
222	if (*op != INTRINSIC_NONE)
223	return MATCH_YES;
224	}
225
226	if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
227	{
228	*op = dtio_op (mode: buffer);
229	if (*op == INTRINSIC_FORMATTED)
230	{
231	strcpy (dest: name, src: gfc_code2string (dtio_procs, DTIO_WF));
232	*type = INTERFACE_DTIO;
233	}
234	if (*op == INTRINSIC_UNFORMATTED)
235	{
236	strcpy (dest: name, src: gfc_code2string (dtio_procs, DTIO_WUF));
237	*type = INTERFACE_DTIO;
238	}
239	if (*op != INTRINSIC_NONE)
240	return MATCH_YES;
241	}
242
243	if (gfc_match_name (buffer) == MATCH_YES)
244	{
245	strcpy (dest: name, src: buffer);
246	*type = INTERFACE_GENERIC;
247	return MATCH_YES;
248	}
249
250	*type = INTERFACE_NAMELESS;
251	return MATCH_YES;
252
253	syntax:
254	gfc_error ("Syntax error in generic specification at %C");
255	return MATCH_ERROR;
256	}
257
258
259	/* Match one of the five F95 forms of an interface statement. The
260	matcher for the abstract interface follows. */
261
262	match
263	gfc_match_interface (void)
264	{
265	char name[GFC_MAX_SYMBOL_LEN + 1];
266	interface_type type;
267	gfc_symbol *sym;
268	gfc_intrinsic_op op;
269	match m;
270
271	m = gfc_match_space ();
272
273	if (gfc_match_generic_spec (type: &type, name, op: &op) == MATCH_ERROR)
274	return MATCH_ERROR;
275
276	/* If we're not looking at the end of the statement now, or if this
277	is not a nameless interface but we did not see a space, punt. */
278	if (gfc_match_eos () != MATCH_YES
279	|| (type != INTERFACE_NAMELESS && m != MATCH_YES))
280	{
281	gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
282	"at %C");
283	return MATCH_ERROR;
284	}
285
286	current_interface.type = type;
287
288	switch (type)
289	{
290	case INTERFACE_DTIO:
291	case INTERFACE_GENERIC:
292	if (gfc_get_symbol (name, NULL, &sym))
293	return MATCH_ERROR;
294
295	if (!sym->attr.generic
296	&& !gfc_add_generic (&sym->attr, sym->name, NULL))
297	return MATCH_ERROR;
298
299	if (sym->attr.dummy)
300	{
301	gfc_error ("Dummy procedure %qs at %C cannot have a "
302	"generic interface", sym->name);
303	return MATCH_ERROR;
304	}
305
306	current_interface.sym = gfc_new_block = sym;
307	break;
308
309	case INTERFACE_USER_OP:
310	current_interface.uop = gfc_get_uop (name);
311	break;
312
313	case INTERFACE_INTRINSIC_OP:
314	current_interface.op = op;
315	break;
316
317	case INTERFACE_NAMELESS:
318	case INTERFACE_ABSTRACT:
319	break;
320	}
321
322	return MATCH_YES;
323	}
324
325
326
327	/* Match a F2003 abstract interface. */
328
329	match
330	gfc_match_abstract_interface (void)
331	{
332	match m;
333
334	if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
335	return MATCH_ERROR;
336
337	m = gfc_match_eos ();
338
339	if (m != MATCH_YES)
340	{
341	gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
342	return MATCH_ERROR;
343	}
344
345	current_interface.type = INTERFACE_ABSTRACT;
346
347	return m;
348	}
349
350
351	/* Match the different sort of generic-specs that can be present after
352	the END INTERFACE itself. */
353
354	match
355	gfc_match_end_interface (void)
356	{
357	char name[GFC_MAX_SYMBOL_LEN + 1];
358	interface_type type;
359	gfc_intrinsic_op op;
360	match m;
361
362	m = gfc_match_space ();
363
364	if (gfc_match_generic_spec (type: &type, name, op: &op) == MATCH_ERROR)
365	return MATCH_ERROR;
366
367	/* If we're not looking at the end of the statement now, or if this
368	is not a nameless interface but we did not see a space, punt. */
369	if (gfc_match_eos () != MATCH_YES
370	|| (type != INTERFACE_NAMELESS && m != MATCH_YES))
371	{
372	gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
373	"statement at %C");
374	return MATCH_ERROR;
375	}
376
377	m = MATCH_YES;
378
379	switch (current_interface.type)
380	{
381	case INTERFACE_NAMELESS:
382	case INTERFACE_ABSTRACT:
383	if (type != INTERFACE_NAMELESS)
384	{
385	gfc_error ("Expected a nameless interface at %C");
386	m = MATCH_ERROR;
387	}
388
389	break;
390
391	case INTERFACE_INTRINSIC_OP:
392	if (type != current_interface.type || op != current_interface.op)
393	{
394
395	if (current_interface.op == INTRINSIC_ASSIGN)
396	{
397	m = MATCH_ERROR;
398	gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
399	}
400	else
401	{
402	const char *s1, *s2;
403	s1 = gfc_op2string (current_interface.op);
404	s2 = gfc_op2string (op);
405
406	/* The following if-statements are used to enforce C1202
407	from F2003. */
408	if ((strcmp(s1: s1, s2: "==") == 0 && strcmp (s1: s2, s2: ".eq.") == 0)
409	|| (strcmp(s1: s1, s2: ".eq.") == 0 && strcmp (s1: s2, s2: "==") == 0))
410	break;
411	if ((strcmp(s1: s1, s2: "/=") == 0 && strcmp (s1: s2, s2: ".ne.") == 0)
412	|| (strcmp(s1: s1, s2: ".ne.") == 0 && strcmp (s1: s2, s2: "/=") == 0))
413	break;
414	if ((strcmp(s1: s1, s2: "<=") == 0 && strcmp (s1: s2, s2: ".le.") == 0)
415	|| (strcmp(s1: s1, s2: ".le.") == 0 && strcmp (s1: s2, s2: "<=") == 0))
416	break;
417	if ((strcmp(s1: s1, s2: "<") == 0 && strcmp (s1: s2, s2: ".lt.") == 0)
418	|| (strcmp(s1: s1, s2: ".lt.") == 0 && strcmp (s1: s2, s2: "<") == 0))
419	break;
420	if ((strcmp(s1: s1, s2: ">=") == 0 && strcmp (s1: s2, s2: ".ge.") == 0)
421	|| (strcmp(s1: s1, s2: ".ge.") == 0 && strcmp (s1: s2, s2: ">=") == 0))
422	break;
423	if ((strcmp(s1: s1, s2: ">") == 0 && strcmp (s1: s2, s2: ".gt.") == 0)
424	|| (strcmp(s1: s1, s2: ".gt.") == 0 && strcmp (s1: s2, s2: ">") == 0))
425	break;
426
427	m = MATCH_ERROR;
428	if (strcmp(s1: s2, s2: "none") == 0)
429	gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
430	"at %C", s1);
431	else
432	gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
433	"but got %qs", s1, s2);
434	}
435
436	}
437
438	break;
439
440	case INTERFACE_USER_OP:
441	/* Comparing the symbol node names is OK because only use-associated
442	symbols can be renamed. */
443	if (type != current_interface.type
444	|| strcmp (s1: current_interface.uop->name, s2: name) != 0)
445	{
446	gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
447	current_interface.uop->name);
448	m = MATCH_ERROR;
449	}
450
451	break;
452
453	case INTERFACE_DTIO:
454	case INTERFACE_GENERIC:
455	if (type != current_interface.type
456	|| strcmp (s1: current_interface.sym->name, s2: name) != 0)
457	{
458	gfc_error ("Expecting %<END INTERFACE %s%> at %C",
459	current_interface.sym->name);
460	m = MATCH_ERROR;
461	}
462
463	break;
464	}
465
466	return m;
467	}
468
469
470	/* Return whether the component was defined anonymously. */
471
472	static bool
473	is_anonymous_component (gfc_component *cmp)
474	{
475	/* Only UNION and MAP components are anonymous. In the case of a MAP,
476	the derived type symbol is FL_STRUCT and the component name looks like mM*.
477	This is the only case in which the second character of a component name is
478	uppercase. */
479	return cmp->ts.type == BT_UNION
480	|| (cmp->ts.type == BT_DERIVED
481	&& cmp->ts.u.derived->attr.flavor == FL_STRUCT
482	&& cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1]));
483	}
484
485
486	/* Return whether the derived type was defined anonymously. */
487
488	static bool
489	is_anonymous_dt (gfc_symbol *derived)
490	{
491	/* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
492	types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
493	and the type name looks like XX*. This is the only case in which the
494	second character of a type name is uppercase. */
495	return derived->attr.flavor == FL_UNION
496	|| (derived->attr.flavor == FL_STRUCT
497	&& derived->name[0] && derived->name[1] && ISUPPER (derived->name[1]));
498	}
499
500
501	/* Compare components according to 4.4.2 of the Fortran standard. */
502
503	static bool
504	compare_components (gfc_component *cmp1, gfc_component *cmp2,
505	gfc_symbol *derived1, gfc_symbol *derived2)
506	{
507	/* Compare names, but not for anonymous components such as UNION or MAP. */
508	if (!is_anonymous_component (cmp: cmp1) && !is_anonymous_component (cmp: cmp2)
509	&& strcmp (s1: cmp1->name, s2: cmp2->name) != 0)
510	return false;
511
512	if (cmp1->attr.access != cmp2->attr.access)
513	return false;
514
515	if (cmp1->attr.pointer != cmp2->attr.pointer)
516	return false;
517
518	if (cmp1->attr.dimension != cmp2->attr.dimension)
519	return false;
520
521	if (cmp1->attr.allocatable != cmp2->attr.allocatable)
522	return false;
523
524	if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
525	return false;
526
527	if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
528	{
529	gfc_charlen *l1 = cmp1->ts.u.cl;
530	gfc_charlen *l2 = cmp2->ts.u.cl;
531	if (l1 && l2 && l1->length && l2->length
532	&& l1->length->expr_type == EXPR_CONSTANT
533	&& l2->length->expr_type == EXPR_CONSTANT
534	&& gfc_dep_compare_expr (l1->length, l2->length) != 0)
535	return false;
536	}
537
538	/* Make sure that link lists do not put this function into an
539	endless recursive loop! */
540	if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
541	&& !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)
542	&& !gfc_compare_types (&cmp1->ts, &cmp2->ts))
543	return false;
544
545	else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
546	&& !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
547	return false;
548
549	else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
550	&& (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
551	return false;
552
553	return true;
554	}
555
556
557	/* Compare two union types by comparing the components of their maps.
558	Because unions and maps are anonymous their types get special internal
559	names; therefore the usual derived type comparison will fail on them.
560
561	Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
562	gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
563	definitions' than 'equivalent structure'. */
564
565	static bool
566	compare_union_types (gfc_symbol *un1, gfc_symbol *un2)
567	{
568	gfc_component *map1, *map2, *cmp1, *cmp2;
569	gfc_symbol *map1_t, *map2_t;
570
571	if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION)
572	return false;
573
574	if (un1->attr.zero_comp != un2->attr.zero_comp)
575	return false;
576
577	if (un1->attr.zero_comp)
578	return true;
579
580	map1 = un1->components;
581	map2 = un2->components;
582
583	/* In terms of 'equality' here we are worried about types which are
584	declared the same in two places, not types that represent equivalent
585	structures. (This is common because of FORTRAN's weird scoping rules.)
586	Though two unions with their maps in different orders could be equivalent,
587	we will say they are not equal for the purposes of this test; therefore
588	we compare the maps sequentially. */
589	for (;;)
590	{
591	map1_t = map1->ts.u.derived;
592	map2_t = map2->ts.u.derived;
593
594	cmp1 = map1_t->components;
595	cmp2 = map2_t->components;
596
597	/* Protect against null components. */
598	if (map1_t->attr.zero_comp != map2_t->attr.zero_comp)
599	return false;
600
601	if (map1_t->attr.zero_comp)
602	return true;
603
604	for (;;)
605	{
606	/* No two fields will ever point to the same map type unless they are
607	the same component, because one map field is created with its type
608	declaration. Therefore don't worry about recursion here. */
609	/* TODO: worry about recursion into parent types of the unions? */
610	if (!compare_components (cmp1, cmp2, derived1: map1_t, derived2: map2_t))
611	return false;
612
613	cmp1 = cmp1->next;
614	cmp2 = cmp2->next;
615
616	if (cmp1 == NULL && cmp2 == NULL)
617	break;
618	if (cmp1 == NULL || cmp2 == NULL)
619	return false;
620	}
621
622	map1 = map1->next;
623	map2 = map2->next;
624
625	if (map1 == NULL && map2 == NULL)
626	break;
627	if (map1 == NULL || map2 == NULL)
628	return false;
629	}
630
631	return true;
632	}
633
634
635
636	/* Compare two derived types using the criteria in 4.4.2 of the standard,
637	recursing through gfc_compare_types for the components. */
638
639	bool
640	gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
641	{
642	gfc_component *cmp1, *cmp2;
643
644	if (derived1 == derived2)
645	return true;
646
647	if (!derived1 || !derived2)
648	gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
649
650	if (derived1->attr.unlimited_polymorphic
651	&& derived2->attr.unlimited_polymorphic)
652	return true;
653
654	if (derived1->attr.unlimited_polymorphic
655	!= derived2->attr.unlimited_polymorphic)
656	return false;
657
658	/* Compare UNION types specially. */
659	if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION)
660	return compare_union_types (un1: derived1, un2: derived2);
661
662	/* Special case for comparing derived types across namespaces. If the
663	true names and module names are the same and the module name is
664	nonnull, then they are equal. */
665	if (strcmp (s1: derived1->name, s2: derived2->name) == 0
666	&& derived1->module != NULL && derived2->module != NULL
667	&& strcmp (s1: derived1->module, s2: derived2->module) == 0)
668	return true;
669
670	/* Compare type via the rules of the standard. Both types must have the
671	SEQUENCE or BIND(C) attribute to be equal. We also compare types
672	recursively if they are class descriptors types or virtual tables types.
673	STRUCTUREs are special because they can be anonymous; therefore two
674	structures with different names may be equal. */
675
676	/* Compare names, but not for anonymous types such as UNION or MAP. */
677	if (!is_anonymous_dt (derived: derived1) && !is_anonymous_dt (derived: derived2)
678	&& strcmp (s1: derived1->name, s2: derived2->name) != 0)
679	return false;
680
681	if (derived1->component_access == ACCESS_PRIVATE
682	|| derived2->component_access == ACCESS_PRIVATE)
683	return false;
684
685	if (!(derived1->attr.sequence && derived2->attr.sequence)
686	&& !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
687	&& !(derived1->attr.is_class && derived2->attr.is_class)
688	&& !(derived1->attr.vtype && derived2->attr.vtype)
689	&& !(derived1->attr.pdt_type && derived2->attr.pdt_type))
690	return false;
691
692	/* Protect against null components. */
693	if (derived1->attr.zero_comp != derived2->attr.zero_comp)
694	return false;
695
696	if (derived1->attr.zero_comp)
697	return true;
698
699	cmp1 = derived1->components;
700	cmp2 = derived2->components;
701
702	/* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
703	simple test can speed things up. Otherwise, lots of things have to
704	match. */
705	for (;;)
706	{
707	if (!compare_components (cmp1, cmp2, derived1, derived2))
708	return false;
709
710	cmp1 = cmp1->next;
711	cmp2 = cmp2->next;
712
713	if (cmp1 == NULL && cmp2 == NULL)
714	break;
715	if (cmp1 == NULL || cmp2 == NULL)
716	return false;
717	}
718
719	return true;
720	}
721
722
723	/* Compare two typespecs, recursively if necessary. */
724
725	bool
726	gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
727	{
728	/* See if one of the typespecs is a BT_VOID, which is what is being used
729	to allow the funcs like c_f_pointer to accept any pointer type.
730	TODO: Possibly should narrow this to just the one typespec coming in
731	that is for the formal arg, but oh well. */
732	if (ts1->type == BT_VOID || ts2->type == BT_VOID)
733	return true;
734
735	/* Special case for our C interop types. FIXME: There should be a
736	better way of doing this. When ISO C binding is cleared up,
737	this can probably be removed. See PR 57048. */
738
739	if ((ts1->type == BT_INTEGER
740	&& ts2->type == BT_DERIVED
741	&& ts1->f90_type == BT_VOID
742	&& ts2->u.derived->from_intmod == INTMOD_ISO_C_BINDING
743	&& ts1->u.derived
744	&& strcmp (s1: ts1->u.derived->name, s2: ts2->u.derived->name) == 0)
745	|| (ts2->type == BT_INTEGER
746	&& ts1->type == BT_DERIVED
747	&& ts2->f90_type == BT_VOID
748	&& ts1->u.derived->from_intmod == INTMOD_ISO_C_BINDING
749	&& ts2->u.derived
750	&& strcmp (s1: ts1->u.derived->name, s2: ts2->u.derived->name) == 0))
751	return true;
752
753	/* The _data component is not always present, therefore check for its
754	presence before assuming, that its derived->attr is available.
755	When the _data component is not present, then nevertheless the
756	unlimited_polymorphic flag may be set in the derived type's attr. */
757	if (ts1->type == BT_CLASS && ts1->u.derived->components
758	&& ((ts1->u.derived->attr.is_class
759	&& ts1->u.derived->components->ts.u.derived->attr
760	.unlimited_polymorphic)
761	|| ts1->u.derived->attr.unlimited_polymorphic))
762	return true;
763
764	/* F2003: C717 */
765	if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
766	&& ts2->u.derived->components
767	&& ((ts2->u.derived->attr.is_class
768	&& ts2->u.derived->components->ts.u.derived->attr
769	.unlimited_polymorphic)
770	|| ts2->u.derived->attr.unlimited_polymorphic)
771	&& (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
772	return true;
773
774	if (ts1->type != ts2->type
775	&& ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
776	|| (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
777	return false;
778
779	if (ts1->type == BT_UNION)
780	return compare_union_types (un1: ts1->u.derived, un2: ts2->u.derived);
781
782	if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
783	return (ts1->kind == ts2->kind);
784
785	/* Compare derived types. */
786	return gfc_type_compatible (ts1, ts2);
787	}
788
789
790	static bool
791	compare_type (gfc_symbol *s1, gfc_symbol *s2)
792	{
793	if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
794	return true;
795
796	return gfc_compare_types (ts1: &s1->ts, ts2: &s2->ts) || s2->ts.type == BT_ASSUMED;
797	}
798
799
800	static bool
801	compare_type_characteristics (gfc_symbol *s1, gfc_symbol *s2)
802	{
803	/* TYPE and CLASS of the same declared type are type compatible,
804	but have different characteristics. */
805	if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
806	|| (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
807	return false;
808
809	return compare_type (s1, s2);
810	}
811
812
813	static bool
814	compare_rank (gfc_symbol *s1, gfc_symbol *s2)
815	{
816	gfc_array_spec *as1, *as2;
817	int r1, r2;
818
819	if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
820	return true;
821
822	as1 = (s1->ts.type == BT_CLASS
823	&& !s1->ts.u.derived->attr.unlimited_polymorphic)
824	? CLASS_DATA (s1)->as : s1->as;
825	as2 = (s2->ts.type == BT_CLASS
826	&& !s2->ts.u.derived->attr.unlimited_polymorphic)
827	? CLASS_DATA (s2)->as : s2->as;
828
829	r1 = as1 ? as1->rank : 0;
830	r2 = as2 ? as2->rank : 0;
831
832	if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
833	return false; /* Ranks differ. */
834
835	return true;
836	}
837
838
839	/* Given two symbols that are formal arguments, compare their ranks
840	and types. Returns true if they have the same rank and type,
841	false otherwise. */
842
843	static bool
844	compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
845	{
846	return compare_type (s1, s2) && compare_rank (s1, s2);
847	}
848
849
850	/* Given two symbols that are formal arguments, compare their types
851	and rank and their formal interfaces if they are both dummy
852	procedures. Returns true if the same, false if different. */
853
854	static bool
855	compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
856	{
857	if (s1 == NULL || s2 == NULL)
858	return (s1 == s2);
859
860	if (s1 == s2)
861	return true;
862
863	if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
864	return compare_type_rank (s1, s2);
865
866	if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
867	return false;
868
869	/* At this point, both symbols are procedures. It can happen that
870	external procedures are compared, where one is identified by usage
871	to be a function or subroutine but the other is not. Check TKR
872	nonetheless for these cases. */
873	if (s1->attr.function == 0 && s1->attr.subroutine == 0)
874	return s1->attr.external ? compare_type_rank (s1, s2) : false;
875
876	if (s2->attr.function == 0 && s2->attr.subroutine == 0)
877	return s2->attr.external ? compare_type_rank (s1, s2) : false;
878
879	/* Now the type of procedure has been identified. */
880	if (s1->attr.function != s2->attr.function
881	|| s1->attr.subroutine != s2->attr.subroutine)
882	return false;
883
884	if (s1->attr.function && !compare_type_rank (s1, s2))
885	return false;
886
887	/* Originally, gfortran recursed here to check the interfaces of passed
888	procedures. This is explicitly not required by the standard. */
889	return true;
890	}
891
892
893	/* Given a formal argument list and a keyword name, search the list
894	for that keyword. Returns the correct symbol node if found, NULL
895	if not found. */
896
897	static gfc_symbol *
898	find_keyword_arg (const char *name, gfc_formal_arglist *f)
899	{
900	for (; f; f = f->next)
901	if (strcmp (s1: f->sym->name, s2: name) == 0)
902	return f->sym;
903
904	return NULL;
905	}
906
907
908	/******** Interface checking subroutines **********/
909
910
911	/* Given an operator interface and the operator, make sure that all
912	interfaces for that operator are legal. */
913
914	bool
915	gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
916	locus opwhere)
917	{
918	gfc_formal_arglist *formal;
919	sym_intent i1, i2;
920	bt t1, t2;
921	int args, r1, r2, k1, k2;
922
923	gcc_assert (sym);
924
925	args = 0;
926	t1 = t2 = BT_UNKNOWN;
927	i1 = i2 = INTENT_UNKNOWN;
928	r1 = r2 = -1;
929	k1 = k2 = -1;
930
931	for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
932	{
933	gfc_symbol *fsym = formal->sym;
934	if (fsym == NULL)
935	{
936	gfc_error ("Alternate return cannot appear in operator "
937	"interface at %L", &sym->declared_at);
938	return false;
939	}
940	if (args == 0)
941	{
942	t1 = fsym->ts.type;
943	i1 = fsym->attr.intent;
944	r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
945	k1 = fsym->ts.kind;
946	}
947	if (args == 1)
948	{
949	t2 = fsym->ts.type;
950	i2 = fsym->attr.intent;
951	r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
952	k2 = fsym->ts.kind;
953	}
954	args++;
955	}
956
957	/* Only +, - and .not. can be unary operators.
958	.not. cannot be a binary operator. */
959	if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
960	&& op != INTRINSIC_MINUS
961	&& op != INTRINSIC_NOT)
962	|| (args == 2 && op == INTRINSIC_NOT))
963	{
964	if (op == INTRINSIC_ASSIGN)
965	gfc_error ("Assignment operator interface at %L must have "
966	"two arguments", &sym->declared_at);
967	else
968	gfc_error ("Operator interface at %L has the wrong number of arguments",
969	&sym->declared_at);
970	return false;
971	}
972
973	/* Check that intrinsics are mapped to functions, except
974	INTRINSIC_ASSIGN which should map to a subroutine. */
975	if (op == INTRINSIC_ASSIGN)
976	{
977	gfc_formal_arglist *dummy_args;
978
979	if (!sym->attr.subroutine)
980	{
981	gfc_error ("Assignment operator interface at %L must be "
982	"a SUBROUTINE", &sym->declared_at);
983	return false;
984	}
985
986	/* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
987	- First argument an array with different rank than second,
988	- First argument is a scalar and second an array,
989	- Types and kinds do not conform, or
990	- First argument is of derived type. */
991	dummy_args = gfc_sym_get_dummy_args (sym);
992	if (dummy_args->sym->ts.type != BT_DERIVED
993	&& dummy_args->sym->ts.type != BT_CLASS
994	&& (r2 == 0 || r1 == r2)
995	&& (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type
996	|| (gfc_numeric_ts (&dummy_args->sym->ts)
997	&& gfc_numeric_ts (&dummy_args->next->sym->ts))))
998	{
999	gfc_error ("Assignment operator interface at %L must not redefine "
1000	"an INTRINSIC type assignment", &sym->declared_at);
1001	return false;
1002	}
1003	}
1004	else
1005	{
1006	if (!sym->attr.function)
1007	{
1008	gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
1009	&sym->declared_at);
1010	return false;
1011	}
1012	}
1013
1014	/* Check intents on operator interfaces. */
1015	if (op == INTRINSIC_ASSIGN)
1016	{
1017	if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
1018	{
1019	gfc_error ("First argument of defined assignment at %L must be "
1020	"INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
1021	return false;
1022	}
1023
1024	if (i2 != INTENT_IN)
1025	{
1026	gfc_error ("Second argument of defined assignment at %L must be "
1027	"INTENT(IN)", &sym->declared_at);
1028	return false;
1029	}
1030	}
1031	else
1032	{
1033	if (i1 != INTENT_IN)
1034	{
1035	gfc_error ("First argument of operator interface at %L must be "
1036	"INTENT(IN)", &sym->declared_at);
1037	return false;
1038	}
1039
1040	if (args == 2 && i2 != INTENT_IN)
1041	{
1042	gfc_error ("Second argument of operator interface at %L must be "
1043	"INTENT(IN)", &sym->declared_at);
1044	return false;
1045	}
1046	}
1047
1048	/* From now on, all we have to do is check that the operator definition
1049	doesn't conflict with an intrinsic operator. The rules for this
1050	game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
1051	as well as 12.3.2.1.1 of Fortran 2003:
1052
1053	"If the operator is an intrinsic-operator (R310), the number of
1054	function arguments shall be consistent with the intrinsic uses of
1055	that operator, and the types, kind type parameters, or ranks of the
1056	dummy arguments shall differ from those required for the intrinsic
1057	operation (7.1.2)." */
1058
1059	#define IS_NUMERIC_TYPE(t) \
1060	((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
1061
1062	/* Unary ops are easy, do them first. */
1063	if (op == INTRINSIC_NOT)
1064	{
1065	if (t1 == BT_LOGICAL)
1066	goto bad_repl;
1067	else
1068	return true;
1069	}
1070
1071	if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
1072	{
1073	if (IS_NUMERIC_TYPE (t1))
1074	goto bad_repl;
1075	else
1076	return true;
1077	}
1078
1079	/* Character intrinsic operators have same character kind, thus
1080	operator definitions with operands of different character kinds
1081	are always safe. */
1082	if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
1083	return true;
1084
1085	/* Intrinsic operators always perform on arguments of same rank,
1086	so different ranks is also always safe. (rank == 0) is an exception
1087	to that, because all intrinsic operators are elemental. */
1088	if (r1 != r2 && r1 != 0 && r2 != 0)
1089	return true;
1090
1091	switch (op)
1092	{
1093	case INTRINSIC_EQ:
1094	case INTRINSIC_EQ_OS:
1095	case INTRINSIC_NE:
1096	case INTRINSIC_NE_OS:
1097	if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
1098	goto bad_repl;
1099	/* Fall through. */
1100
1101	case INTRINSIC_PLUS:
1102	case INTRINSIC_MINUS:
1103	case INTRINSIC_TIMES:
1104	case INTRINSIC_DIVIDE:
1105	case INTRINSIC_POWER:
1106	if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
1107	goto bad_repl;
1108	break;
1109
1110	case INTRINSIC_GT:
1111	case INTRINSIC_GT_OS:
1112	case INTRINSIC_GE:
1113	case INTRINSIC_GE_OS:
1114	case INTRINSIC_LT:
1115	case INTRINSIC_LT_OS:
1116	case INTRINSIC_LE:
1117	case INTRINSIC_LE_OS:
1118	if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
1119	goto bad_repl;
1120	if ((t1 == BT_INTEGER || t1 == BT_REAL)
1121	&& (t2 == BT_INTEGER || t2 == BT_REAL))
1122	goto bad_repl;
1123	break;
1124
1125	case INTRINSIC_CONCAT:
1126	if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
1127	goto bad_repl;
1128	break;
1129
1130	case INTRINSIC_AND:
1131	case INTRINSIC_OR:
1132	case INTRINSIC_EQV:
1133	case INTRINSIC_NEQV:
1134	if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
1135	goto bad_repl;
1136	break;
1137
1138	default:
1139	break;
1140	}
1141
1142	return true;
1143
1144	#undef IS_NUMERIC_TYPE
1145
1146	bad_repl:
1147	gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1148	&opwhere);
1149	return false;
1150	}
1151
1152
1153	/* Given a pair of formal argument lists, we see if the two lists can
1154	be distinguished by counting the number of nonoptional arguments of
1155	a given type/rank in f1 and seeing if there are less then that
1156	number of those arguments in f2 (including optional arguments).
1157	Since this test is asymmetric, it has to be called twice to make it
1158	symmetric. Returns nonzero if the argument lists are incompatible
1159	by this test. This subroutine implements rule 1 of section F03:16.2.3.
1160	'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1161
1162	static bool
1163	count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
1164	const char *p1, const char *p2)
1165	{
1166	int ac1, ac2, i, j, k, n1;
1167	gfc_formal_arglist *f;
1168
1169	typedef struct
1170	{
1171	int flag;
1172	gfc_symbol *sym;
1173	}
1174	arginfo;
1175
1176	arginfo *arg;
1177
1178	n1 = 0;
1179
1180	for (f = f1; f; f = f->next)
1181	n1++;
1182
1183	/* Build an array of integers that gives the same integer to
1184	arguments of the same type/rank. */
1185	arg = XCNEWVEC (arginfo, n1);
1186
1187	f = f1;
1188	for (i = 0; i < n1; i++, f = f->next)
1189	{
1190	arg[i].flag = -1;
1191	arg[i].sym = f->sym;
1192	}
1193
1194	k = 0;
1195
1196	for (i = 0; i < n1; i++)
1197	{
1198	if (arg[i].flag != -1)
1199	continue;
1200
1201	if (arg[i].sym && (arg[i].sym->attr.optional
1202	|| (p1 && strcmp (s1: arg[i].sym->name, s2: p1) == 0)))
1203	continue; /* Skip OPTIONAL and PASS arguments. */
1204
1205	arg[i].flag = k;
1206
1207	/* Find other non-optional, non-pass arguments of the same type/rank. */
1208	for (j = i + 1; j < n1; j++)
1209	if ((arg[j].sym == NULL
1210	|| !(arg[j].sym->attr.optional
1211	|| (p1 && strcmp (s1: arg[j].sym->name, s2: p1) == 0)))
1212	&& (compare_type_rank_if (s1: arg[i].sym, s2: arg[j].sym)
1213	|| compare_type_rank_if (s1: arg[j].sym, s2: arg[i].sym)))
1214	arg[j].flag = k;
1215
1216	k++;
1217	}
1218
1219	/* Now loop over each distinct type found in f1. */
1220	k = 0;
1221	bool rc = false;
1222
1223	for (i = 0; i < n1; i++)
1224	{
1225	if (arg[i].flag != k)
1226	continue;
1227
1228	ac1 = 1;
1229	for (j = i + 1; j < n1; j++)
1230	if (arg[j].flag == k)
1231	ac1++;
1232
1233	/* Count the number of non-pass arguments in f2 with that type,
1234	including those that are optional. */
1235	ac2 = 0;
1236
1237	for (f = f2; f; f = f->next)
1238	if ((!p2 || strcmp (s1: f->sym->name, s2: p2) != 0)
1239	&& (compare_type_rank_if (s1: arg[i].sym, s2: f->sym)
1240	|| compare_type_rank_if (s1: f->sym, s2: arg[i].sym)))
1241	ac2++;
1242
1243	if (ac1 > ac2)
1244	{
1245	rc = true;
1246	break;
1247	}
1248
1249	k++;
1250	}
1251
1252	free (ptr: arg);
1253
1254	return rc;
1255	}
1256
1257
1258	/* Returns true if two dummy arguments are distinguishable due to their POINTER
1259	and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
1260	The function is asymmetric wrt to the arguments s1 and s2 and should always
1261	be called twice (with flipped arguments in the second call). */
1262
1263	static bool
1264	compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2)
1265	{
1266	/* Is s1 allocatable? */
1267	const bool a1 = s1->ts.type == BT_CLASS ?
1268	CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable;
1269	/* Is s2 a pointer? */
1270	const bool p2 = s2->ts.type == BT_CLASS ?
1271	CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer;
1272	return a1 && p2 && (s2->attr.intent != INTENT_IN);
1273	}
1274
1275
1276	/* Perform the correspondence test in rule (3) of F08:C1215.
1277	Returns zero if no argument is found that satisfies this rule,
1278	nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1279	(if applicable).
1280
1281	This test is also not symmetric in f1 and f2 and must be called
1282	twice. This test finds problems caused by sorting the actual
1283	argument list with keywords. For example:
1284
1285	INTERFACE FOO
1286	SUBROUTINE F1(A, B)
1287	INTEGER :: A ; REAL :: B
1288	END SUBROUTINE F1
1289
1290	SUBROUTINE F2(B, A)
1291	INTEGER :: A ; REAL :: B
1292	END SUBROUTINE F1
1293	END INTERFACE FOO
1294
1295	At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1296
1297	static bool
1298	generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
1299	const char *p1, const char *p2)
1300	{
1301	gfc_formal_arglist *f2_save, *g;
1302	gfc_symbol *sym;
1303
1304	f2_save = f2;
1305
1306	while (f1)
1307	{
1308	if (!f1->sym || f1->sym->attr.optional)
1309	goto next;
1310
1311	if (p1 && strcmp (s1: f1->sym->name, s2: p1) == 0)
1312	f1 = f1->next;
1313	if (f2 && p2 && strcmp (s1: f2->sym->name, s2: p2) == 0)
1314	f2 = f2->next;
1315
1316	if (f2 != NULL && (compare_type_rank (s1: f1->sym, s2: f2->sym)
1317	|| compare_type_rank (s1: f2->sym, s2: f1->sym))
1318	&& !((gfc_option.allow_std & GFC_STD_F2008)
1319	&& (compare_ptr_alloc(s1: f1->sym, s2: f2->sym)
1320	|| compare_ptr_alloc(s1: f2->sym, s2: f1->sym))))
1321	goto next;
1322
1323	/* Now search for a disambiguating keyword argument starting at
1324	the current non-match. */
1325	for (g = f1; g; g = g->next)
1326	{
1327	if (g->sym->attr.optional || (p1 && strcmp (s1: g->sym->name, s2: p1) == 0))
1328	continue;
1329
1330	sym = find_keyword_arg (name: g->sym->name, f: f2_save);
1331	if (sym == NULL || !compare_type_rank (s1: g->sym, s2: sym)
1332	|| ((gfc_option.allow_std & GFC_STD_F2008)
1333	&& (compare_ptr_alloc(s1: sym, s2: g->sym)
1334	|| compare_ptr_alloc(s1: g->sym, s2: sym))))
1335	return true;
1336	}
1337
1338	next:
1339	if (f1 != NULL)
1340	f1 = f1->next;
1341	if (f2 != NULL)
1342	f2 = f2->next;
1343	}
1344
1345	return false;
1346	}
1347
1348
1349	static int
1350	symbol_rank (gfc_symbol *sym)
1351	{
1352	gfc_array_spec *as = NULL;
1353
1354	if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
1355	as = CLASS_DATA (sym)->as;
1356	else
1357	as = sym->as;
1358
1359	return as ? as->rank : 0;
1360	}
1361
1362
1363	/* Check if the characteristics of two dummy arguments match,
1364	cf. F08:12.3.2. */
1365
1366	bool
1367	gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1368	bool type_must_agree, char *errmsg,
1369	int err_len)
1370	{
1371	if (s1 == NULL || s2 == NULL)
1372	return s1 == s2 ? true : false;
1373
1374	if (s1->attr.proc == PROC_ST_FUNCTION || s2->attr.proc == PROC_ST_FUNCTION)
1375	{
1376	strncpy (dest: errmsg, src: "Statement function", n: err_len);
1377	return false;
1378	}
1379
1380	/* Check type and rank. */
1381	if (type_must_agree)
1382	{
1383	if (!compare_type_characteristics (s1, s2)
1384	|| !compare_type_characteristics (s1: s2, s2: s1))
1385	{
1386	snprintf (s: errmsg, maxlen: err_len, format: "Type mismatch in argument '%s' (%s/%s)",
1387	s1->name, gfc_dummy_typename (&s1->ts),
1388	gfc_dummy_typename (&s2->ts));
1389	return false;
1390	}
1391	if (!compare_rank (s1, s2))
1392	{
1393	snprintf (s: errmsg, maxlen: err_len, format: "Rank mismatch in argument '%s' (%i/%i)",
1394	s1->name, symbol_rank (sym: s1), symbol_rank (sym: s2));
1395	return false;
1396	}
1397	}
1398
1399	/* Check INTENT. */
1400	if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial
1401	&& !s2->attr.artificial)
1402	{
1403	snprintf (s: errmsg, maxlen: err_len, format: "INTENT mismatch in argument '%s'",
1404	s1->name);
1405	return false;
1406	}
1407
1408	/* Check OPTIONAL attribute. */
1409	if (s1->attr.optional != s2->attr.optional)
1410	{
1411	snprintf (s: errmsg, maxlen: err_len, format: "OPTIONAL mismatch in argument '%s'",
1412	s1->name);
1413	return false;
1414	}
1415
1416	/* Check ALLOCATABLE attribute. */
1417	if (s1->attr.allocatable != s2->attr.allocatable)
1418	{
1419	snprintf (s: errmsg, maxlen: err_len, format: "ALLOCATABLE mismatch in argument '%s'",
1420	s1->name);
1421	return false;
1422	}
1423
1424	/* Check POINTER attribute. */
1425	if (s1->attr.pointer != s2->attr.pointer)
1426	{
1427	snprintf (s: errmsg, maxlen: err_len, format: "POINTER mismatch in argument '%s'",
1428	s1->name);
1429	return false;
1430	}
1431
1432	/* Check TARGET attribute. */
1433	if (s1->attr.target != s2->attr.target)
1434	{
1435	snprintf (s: errmsg, maxlen: err_len, format: "TARGET mismatch in argument '%s'",
1436	s1->name);
1437	return false;
1438	}
1439
1440	/* Check ASYNCHRONOUS attribute. */
1441	if (s1->attr.asynchronous != s2->attr.asynchronous)
1442	{
1443	snprintf (s: errmsg, maxlen: err_len, format: "ASYNCHRONOUS mismatch in argument '%s'",
1444	s1->name);
1445	return false;
1446	}
1447
1448	/* Check CONTIGUOUS attribute. */
1449	if (s1->attr.contiguous != s2->attr.contiguous)
1450	{
1451	snprintf (s: errmsg, maxlen: err_len, format: "CONTIGUOUS mismatch in argument '%s'",
1452	s1->name);
1453	return false;
1454	}
1455
1456	/* Check VALUE attribute. */
1457	if (s1->attr.value != s2->attr.value)
1458	{
1459	snprintf (s: errmsg, maxlen: err_len, format: "VALUE mismatch in argument '%s'",
1460	s1->name);
1461	return false;
1462	}
1463
1464	/* Check VOLATILE attribute. */
1465	if (s1->attr.volatile_ != s2->attr.volatile_)
1466	{
1467	snprintf (s: errmsg, maxlen: err_len, format: "VOLATILE mismatch in argument '%s'",
1468	s1->name);
1469	return false;
1470	}
1471
1472	/* Check interface of dummy procedures. */
1473	if (s1->attr.flavor == FL_PROCEDURE)
1474	{
1475	char err[200];
1476	if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
1477	NULL, NULL))
1478	{
1479	snprintf (s: errmsg, maxlen: err_len, format: "Interface mismatch in dummy procedure "
1480	"'%s': %s", s1->name, err);
1481	return false;
1482	}
1483	}
1484
1485	/* Check string length. */
1486	if (s1->ts.type == BT_CHARACTER
1487	&& s1->ts.u.cl && s1->ts.u.cl->length
1488	&& s2->ts.u.cl && s2->ts.u.cl->length)
1489	{
1490	int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1491	s2->ts.u.cl->length);
1492	switch (compval)
1493	{
1494	case -1:
1495	case 1:
1496	case -3:
1497	snprintf (s: errmsg, maxlen: err_len, format: "Character length mismatch "
1498	"in argument '%s'", s1->name);
1499	return false;
1500
1501	case -2:
1502	/* FIXME: Implement a warning for this case.
1503	gfc_warning (0, "Possible character length mismatch in argument %qs",
1504	s1->name);*/
1505	break;
1506
1507	case 0:
1508	break;
1509
1510	default:
1511	gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1512	"%i of gfc_dep_compare_expr", compval);
1513	break;
1514	}
1515	}
1516
1517	/* Check array shape. */
1518	if (s1->as && s2->as)
1519	{
1520	int i, compval;
1521	gfc_expr *shape1, *shape2;
1522
1523	/* Sometimes the ambiguity between deferred shape and assumed shape
1524	does not get resolved in module procedures, where the only explicit
1525	declaration of the dummy is in the interface. */
1526	if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure
1527	&& s1->as->type == AS_ASSUMED_SHAPE
1528	&& s2->as->type == AS_DEFERRED)
1529	{
1530	s2->as->type = AS_ASSUMED_SHAPE;
1531	for (i = 0; i < s2->as->rank; i++)
1532	if (s1->as->lower[i] != NULL)
1533	s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]);
1534	}
1535
1536	if (s1->as->type != s2->as->type)
1537	{
1538	snprintf (s: errmsg, maxlen: err_len, format: "Shape mismatch in argument '%s'",
1539	s1->name);
1540	return false;
1541	}
1542
1543	if (s1->as->corank != s2->as->corank)
1544	{
1545	snprintf (s: errmsg, maxlen: err_len, format: "Corank mismatch in argument '%s' (%i/%i)",
1546	s1->name, s1->as->corank, s2->as->corank);
1547	return false;
1548	}
1549
1550	if (s1->as->type == AS_EXPLICIT)
1551	for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++)
1552	{
1553	shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1554	gfc_copy_expr (s1->as->lower[i]));
1555	shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1556	gfc_copy_expr (s2->as->lower[i]));
1557	compval = gfc_dep_compare_expr (shape1, shape2);
1558	gfc_free_expr (shape1);
1559	gfc_free_expr (shape2);
1560	switch (compval)
1561	{
1562	case -1:
1563	case 1:
1564	case -3:
1565	if (i < s1->as->rank)
1566	snprintf (s: errmsg, maxlen: err_len, format: "Shape mismatch in dimension %i of"
1567	" argument '%s'", i + 1, s1->name);
1568	else
1569	snprintf (s: errmsg, maxlen: err_len, format: "Shape mismatch in codimension %i "
1570	"of argument '%s'", i - s1->as->rank + 1, s1->name);
1571	return false;
1572
1573	case -2:
1574	/* FIXME: Implement a warning for this case.
1575	gfc_warning (0, "Possible shape mismatch in argument %qs",
1576	s1->name);*/
1577	break;
1578
1579	case 0:
1580	break;
1581
1582	default:
1583	gfc_internal_error ("check_dummy_characteristics: Unexpected "
1584	"result %i of gfc_dep_compare_expr",
1585	compval);
1586	break;
1587	}
1588	}
1589	}
1590
1591	return true;
1592	}
1593
1594
1595	/* Check if the characteristics of two function results match,
1596	cf. F08:12.3.3. */
1597
1598	bool
1599	gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1600	char *errmsg, int err_len)
1601	{
1602	gfc_symbol *r1, *r2;
1603
1604	if (s1->ts.interface && s1->ts.interface->result)
1605	r1 = s1->ts.interface->result;
1606	else
1607	r1 = s1->result ? s1->result : s1;
1608
1609	if (s2->ts.interface && s2->ts.interface->result)
1610	r2 = s2->ts.interface->result;
1611	else
1612	r2 = s2->result ? s2->result : s2;
1613
1614	if (r1->ts.type == BT_UNKNOWN)
1615	return true;
1616
1617	/* Check type and rank. */
1618	if (!compare_type_characteristics (s1: r1, s2: r2))
1619	{
1620	snprintf (s: errmsg, maxlen: err_len, format: "Type mismatch in function result (%s/%s)",
1621	gfc_typename (&r1->ts), gfc_typename (&r2->ts));
1622	return false;
1623	}
1624	if (!compare_rank (s1: r1, s2: r2))
1625	{
1626	snprintf (s: errmsg, maxlen: err_len, format: "Rank mismatch in function result (%i/%i)",
1627	symbol_rank (sym: r1), symbol_rank (sym: r2));
1628	return false;
1629	}
1630
1631	/* Check ALLOCATABLE attribute. */
1632	if (r1->attr.allocatable != r2->attr.allocatable)
1633	{
1634	snprintf (s: errmsg, maxlen: err_len, format: "ALLOCATABLE attribute mismatch in "
1635	"function result");
1636	return false;
1637	}
1638
1639	/* Check POINTER attribute. */
1640	if (r1->attr.pointer != r2->attr.pointer)
1641	{
1642	snprintf (s: errmsg, maxlen: err_len, format: "POINTER attribute mismatch in "
1643	"function result");
1644	return false;
1645	}
1646
1647	/* Check CONTIGUOUS attribute. */
1648	if (r1->attr.contiguous != r2->attr.contiguous)
1649	{
1650	snprintf (s: errmsg, maxlen: err_len, format: "CONTIGUOUS attribute mismatch in "
1651	"function result");
1652	return false;
1653	}
1654
1655	/* Check PROCEDURE POINTER attribute. */
1656	if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1657	{
1658	snprintf (s: errmsg, maxlen: err_len, format: "PROCEDURE POINTER mismatch in "
1659	"function result");
1660	return false;
1661	}
1662
1663	/* Check string length. */
1664	if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1665	{
1666	if (r1->ts.deferred != r2->ts.deferred)
1667	{
1668	snprintf (s: errmsg, maxlen: err_len, format: "Character length mismatch "
1669	"in function result");
1670	return false;
1671	}
1672
1673	if (r1->ts.u.cl->length && r2->ts.u.cl->length)
1674	{
1675	int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1676	r2->ts.u.cl->length);
1677	switch (compval)
1678	{
1679	case -1:
1680	case 1:
1681	case -3:
1682	snprintf (s: errmsg, maxlen: err_len, format: "Character length mismatch "
1683	"in function result");
1684	return false;
1685
1686	case -2:
1687	/* FIXME: Implement a warning for this case.
1688	snprintf (errmsg, err_len, "Possible character length mismatch "
1689	"in function result");*/
1690	break;
1691
1692	case 0:
1693	break;
1694
1695	default:
1696	gfc_internal_error ("check_result_characteristics (1): Unexpected "
1697	"result %i of gfc_dep_compare_expr", compval);
1698	break;
1699	}
1700	}
1701	}
1702
1703	/* Check array shape. */
1704	if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1705	{
1706	int i, compval;
1707	gfc_expr *shape1, *shape2;
1708
1709	if (r1->as->type != r2->as->type)
1710	{
1711	snprintf (s: errmsg, maxlen: err_len, format: "Shape mismatch in function result");
1712	return false;
1713	}
1714
1715	if (r1->as->type == AS_EXPLICIT)
1716	for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1717	{
1718	shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1719	gfc_copy_expr (r1->as->lower[i]));
1720	shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1721	gfc_copy_expr (r2->as->lower[i]));
1722	compval = gfc_dep_compare_expr (shape1, shape2);
1723	gfc_free_expr (shape1);
1724	gfc_free_expr (shape2);
1725	switch (compval)
1726	{
1727	case -1:
1728	case 1:
1729	case -3:
1730	snprintf (s: errmsg, maxlen: err_len, format: "Shape mismatch in dimension %i of "
1731	"function result", i + 1);
1732	return false;
1733
1734	case -2:
1735	/* FIXME: Implement a warning for this case.
1736	gfc_warning (0, "Possible shape mismatch in return value");*/
1737	break;
1738
1739	case 0:
1740	break;
1741
1742	default:
1743	gfc_internal_error ("check_result_characteristics (2): "
1744	"Unexpected result %i of "
1745	"gfc_dep_compare_expr", compval);
1746	break;
1747	}
1748	}
1749	}
1750
1751	return true;
1752	}
1753
1754
1755	/* 'Compare' two formal interfaces associated with a pair of symbols.
1756	We return true if there exists an actual argument list that
1757	would be ambiguous between the two interfaces, zero otherwise.
1758	'strict_flag' specifies whether all the characteristics are
1759	required to match, which is not the case for ambiguity checks.
1760	'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1761
1762	bool
1763	gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1764	int generic_flag, int strict_flag,
1765	char *errmsg, int err_len,
1766	const char *p1, const char *p2,
1767	bool *bad_result_characteristics)
1768	{
1769	gfc_formal_arglist *f1, *f2;
1770
1771	gcc_assert (name2 != NULL);
1772
1773	if (bad_result_characteristics)
1774	*bad_result_characteristics = false;
1775
1776	if (s1->attr.function && (s2->attr.subroutine
1777	|| (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1778	&& gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1779	{
1780	if (errmsg != NULL)
1781	snprintf (s: errmsg, maxlen: err_len, format: "'%s' is not a function", name2);
1782	return false;
1783	}
1784
1785	if (s1->attr.subroutine && s2->attr.function)
1786	{
1787	if (errmsg != NULL)
1788	snprintf (s: errmsg, maxlen: err_len, format: "'%s' is not a subroutine", name2);
1789	return false;
1790	}
1791
1792	/* Do strict checks on all characteristics
1793	(for dummy procedures and procedure pointer assignments). */
1794	if (!generic_flag && strict_flag)
1795	{
1796	if (s1->attr.function && s2->attr.function)
1797	{
1798	/* If both are functions, check result characteristics. */
1799	if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
1800	|| !gfc_check_result_characteristics (s1: s2, s2: s1, errmsg, err_len))
1801	{
1802	if (bad_result_characteristics)
1803	*bad_result_characteristics = true;
1804	return false;
1805	}
1806	}
1807
1808	if (s1->attr.pure && !s2->attr.pure)
1809	{
1810	snprintf (s: errmsg, maxlen: err_len, format: "Mismatch in PURE attribute");
1811	return false;
1812	}
1813	if (s1->attr.elemental && !s2->attr.elemental)
1814	{
1815	snprintf (s: errmsg, maxlen: err_len, format: "Mismatch in ELEMENTAL attribute");
1816	return false;
1817	}
1818	}
1819
1820	if (s1->attr.if_source == IFSRC_UNKNOWN
1821	|| s2->attr.if_source == IFSRC_UNKNOWN)
1822	return true;
1823
1824	f1 = gfc_sym_get_dummy_args (s1);
1825	f2 = gfc_sym_get_dummy_args (s2);
1826
1827	/* Special case: No arguments. */
1828	if (f1 == NULL && f2 == NULL)
1829	return true;
1830
1831	if (generic_flag)
1832	{
1833	if (count_types_test (f1, f2, p1, p2)
1834	|| count_types_test (f1: f2, f2: f1, p1: p2, p2: p1))
1835	return false;
1836
1837	/* Special case: alternate returns. If both f1->sym and f2->sym are
1838	NULL, then the leading formal arguments are alternate returns.
1839	The previous conditional should catch argument lists with
1840	different number of argument. */
1841	if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
1842	return true;
1843
1844	if (generic_correspondence (f1, f2, p1, p2)
1845	|| generic_correspondence (f1: f2, f2: f1, p1: p2, p2: p1))
1846	return false;
1847	}
1848	else
1849	/* Perform the abbreviated correspondence test for operators (the
1850	arguments cannot be optional and are always ordered correctly).
1851	This is also done when comparing interfaces for dummy procedures and in
1852	procedure pointer assignments. */
1853
1854	for (; f1 || f2; f1 = f1->next, f2 = f2->next)
1855	{
1856	/* Check existence. */
1857	if (f1 == NULL || f2 == NULL)
1858	{
1859	if (errmsg != NULL)
1860	snprintf (s: errmsg, maxlen: err_len, format: "'%s' has the wrong number of "
1861	"arguments", name2);
1862	return false;
1863	}
1864
1865	if (strict_flag)
1866	{
1867	/* Check all characteristics. */
1868	if (!gfc_check_dummy_characteristics (s1: f1->sym, s2: f2->sym, type_must_agree: true,
1869	errmsg, err_len))
1870	return false;
1871	}
1872	else
1873	{
1874	/* Operators: Only check type and rank of arguments. */
1875	if (!compare_type (s1: f2->sym, s2: f1->sym))
1876	{
1877	if (errmsg != NULL)
1878	snprintf (s: errmsg, maxlen: err_len, format: "Type mismatch in argument '%s' "
1879	"(%s/%s)", f1->sym->name,
1880	gfc_typename (&f1->sym->ts),
1881	gfc_typename (&f2->sym->ts));
1882	return false;
1883	}
1884	if (!compare_rank (s1: f2->sym, s2: f1->sym))
1885	{
1886	if (errmsg != NULL)
1887	snprintf (s: errmsg, maxlen: err_len, format: "Rank mismatch in argument "
1888	"'%s' (%i/%i)", f1->sym->name,
1889	symbol_rank (sym: f1->sym), symbol_rank (sym: f2->sym));
1890	return false;
1891	}
1892	if ((gfc_option.allow_std & GFC_STD_F2008)
1893	&& (compare_ptr_alloc(s1: f1->sym, s2: f2->sym)
1894	|| compare_ptr_alloc(s1: f2->sym, s2: f1->sym)))
1895	{
1896	if (errmsg != NULL)
1897	snprintf (s: errmsg, maxlen: err_len, format: "Mismatching POINTER/ALLOCATABLE "
1898	"attribute in argument '%s' ", f1->sym->name);
1899	return false;
1900	}
1901	}
1902	}
1903
1904	return true;
1905	}
1906
1907
1908	/* Given a pointer to an interface pointer, remove duplicate
1909	interfaces and make sure that all symbols are either functions
1910	or subroutines, and all of the same kind. Returns true if
1911	something goes wrong. */
1912
1913	static bool
1914	check_interface0 (gfc_interface *p, const char *interface_name)
1915	{
1916	gfc_interface *psave, *q, *qlast;
1917
1918	psave = p;
1919	for (; p; p = p->next)
1920	{
1921	/* Make sure all symbols in the interface have been defined as
1922	functions or subroutines. */
1923	if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1924	|| !p->sym->attr.if_source)
1925	&& !gfc_fl_struct (p->sym->attr.flavor))
1926	{
1927	const char *guessed
1928	= gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
1929
1930	if (p->sym->attr.external)
1931	if (guessed)
1932	gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1933	"; did you mean %qs?",
1934	p->sym->name, interface_name, &p->sym->declared_at,
1935	guessed);
1936	else
1937	gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1938	p->sym->name, interface_name, &p->sym->declared_at);
1939	else
1940	if (guessed)
1941	gfc_error ("Procedure %qs in %s at %L is neither function nor "
1942	"subroutine; did you mean %qs?", p->sym->name,
1943	interface_name, &p->sym->declared_at, guessed);
1944	else
1945	gfc_error ("Procedure %qs in %s at %L is neither function nor "
1946	"subroutine", p->sym->name, interface_name,
1947	&p->sym->declared_at);
1948	return true;
1949	}
1950
1951	/* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1952	if ((psave->sym->attr.function && !p->sym->attr.function
1953	&& !gfc_fl_struct (p->sym->attr.flavor))
1954	|| (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1955	{
1956	if (!gfc_fl_struct (p->sym->attr.flavor))
1957	gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1958	" or all FUNCTIONs", interface_name,
1959	&p->sym->declared_at);
1960	else if (p->sym->attr.flavor == FL_DERIVED)
1961	gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1962	"generic name is also the name of a derived type",
1963	interface_name, &p->sym->declared_at);
1964	return true;
1965	}
1966
1967	/* F2003, C1207. F2008, C1207. */
1968	if (p->sym->attr.proc == PROC_INTERNAL
1969	&& !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1970	"%qs in %s at %L", p->sym->name,
1971	interface_name, &p->sym->declared_at))
1972	return true;
1973	}
1974	p = psave;
1975
1976	/* Remove duplicate interfaces in this interface list. */
1977	for (; p; p = p->next)
1978	{
1979	qlast = p;
1980
1981	for (q = p->next; q;)
1982	{
1983	if (p->sym != q->sym)
1984	{
1985	qlast = q;
1986	q = q->next;
1987	}
1988	else
1989	{
1990	/* Duplicate interface. */
1991	qlast->next = q->next;
1992	free (ptr: q);
1993	q = qlast->next;
1994	}
1995	}
1996	}
1997
1998	return false;
1999	}
2000
2001
2002	/* Check lists of interfaces to make sure that no two interfaces are
2003	ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
2004
2005	static bool
2006	check_interface1 (gfc_interface *p, gfc_interface *q0,
2007	int generic_flag, const char *interface_name,
2008	bool referenced)
2009	{
2010	gfc_interface *q;
2011	for (; p; p = p->next)
2012	for (q = q0; q; q = q->next)
2013	{
2014	if (p->sym == q->sym)
2015	continue; /* Duplicates OK here. */
2016
2017	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
2018	continue;
2019
2020	if (!gfc_fl_struct (p->sym->attr.flavor)
2021	&& !gfc_fl_struct (q->sym->attr.flavor)
2022	&& gfc_compare_interfaces (s1: p->sym, s2: q->sym, name2: q->sym->name,
2023	generic_flag, strict_flag: 0, NULL, err_len: 0, NULL, NULL))
2024	{
2025	if (referenced)
2026	gfc_error ("Ambiguous interfaces in %s for %qs at %L "
2027	"and %qs at %L", interface_name,
2028	q->sym->name, &q->sym->declared_at,
2029	p->sym->name, &p->sym->declared_at);
2030	else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
2031	gfc_warning (opt: 0, "Ambiguous interfaces in %s for %qs at %L "
2032	"and %qs at %L", interface_name,
2033	q->sym->name, &q->sym->declared_at,
2034	p->sym->name, &p->sym->declared_at);
2035	else
2036	gfc_warning (opt: 0, "Although not referenced, %qs has ambiguous "
2037	"interfaces at %L", interface_name, &p->where);
2038	return true;
2039	}
2040	}
2041	return false;
2042	}
2043
2044
2045	/* Check the generic and operator interfaces of symbols to make sure
2046	that none of the interfaces conflict. The check has to be done
2047	after all of the symbols are actually loaded. */
2048
2049	static void
2050	check_sym_interfaces (gfc_symbol *sym)
2051	{
2052	/* Provide sufficient space to hold "generic interface 'symbol.symbol'". */
2053	char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")];
2054	gfc_interface *p;
2055
2056	if (sym->ns != gfc_current_ns)
2057	return;
2058
2059	if (sym->generic != NULL)
2060	{
2061	size_t len = strlen (s: sym->name) + sizeof("generic interface ''");
2062	gcc_assert (len < sizeof (interface_name));
2063	sprintf (s: interface_name, format: "generic interface '%s'", sym->name);
2064	if (check_interface0 (p: sym->generic, interface_name))
2065	return;
2066
2067	for (p = sym->generic; p; p = p->next)
2068	{
2069	if (p->sym->attr.mod_proc
2070	&& !p->sym->attr.module_procedure
2071	&& (p->sym->attr.if_source != IFSRC_DECL
2072	|| p->sym->attr.procedure))
2073	{
2074	gfc_error ("%qs at %L is not a module procedure",
2075	p->sym->name, &p->where);
2076	return;
2077	}
2078	}
2079
2080	/* Originally, this test was applied to host interfaces too;
2081	this is incorrect since host associated symbols, from any
2082	source, cannot be ambiguous with local symbols. */
2083	check_interface1 (p: sym->generic, q0: sym->generic, generic_flag: 1, interface_name,
2084	referenced: sym->attr.referenced || !sym->attr.use_assoc);
2085	}
2086	}
2087
2088
2089	static void
2090	check_uop_interfaces (gfc_user_op *uop)
2091	{
2092	char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")];
2093	gfc_user_op *uop2;
2094	gfc_namespace *ns;
2095
2096	sprintf (s: interface_name, format: "operator interface '%s'", uop->name);
2097	if (check_interface0 (p: uop->op, interface_name))
2098	return;
2099
2100	for (ns = gfc_current_ns; ns; ns = ns->parent)
2101	{
2102	uop2 = gfc_find_uop (uop->name, ns);
2103	if (uop2 == NULL)
2104	continue;
2105
2106	check_interface1 (p: uop->op, q0: uop2->op, generic_flag: 0,
2107	interface_name, referenced: true);
2108	}
2109	}
2110
2111	/* Given an intrinsic op, return an equivalent op if one exists,
2112	or INTRINSIC_NONE otherwise. */
2113
2114	gfc_intrinsic_op
2115	gfc_equivalent_op (gfc_intrinsic_op op)
2116	{
2117	switch(op)
2118	{
2119	case INTRINSIC_EQ:
2120	return INTRINSIC_EQ_OS;
2121
2122	case INTRINSIC_EQ_OS:
2123	return INTRINSIC_EQ;
2124
2125	case INTRINSIC_NE:
2126	return INTRINSIC_NE_OS;
2127
2128	case INTRINSIC_NE_OS:
2129	return INTRINSIC_NE;
2130
2131	case INTRINSIC_GT:
2132	return INTRINSIC_GT_OS;
2133
2134	case INTRINSIC_GT_OS:
2135	return INTRINSIC_GT;
2136
2137	case INTRINSIC_GE:
2138	return INTRINSIC_GE_OS;
2139
2140	case INTRINSIC_GE_OS:
2141	return INTRINSIC_GE;
2142
2143	case INTRINSIC_LT:
2144	return INTRINSIC_LT_OS;
2145
2146	case INTRINSIC_LT_OS:
2147	return INTRINSIC_LT;
2148
2149	case INTRINSIC_LE:
2150	return INTRINSIC_LE_OS;
2151
2152	case INTRINSIC_LE_OS:
2153	return INTRINSIC_LE;
2154
2155	default:
2156	return INTRINSIC_NONE;
2157	}
2158	}
2159
2160	/* For the namespace, check generic, user operator and intrinsic
2161	operator interfaces for consistency and to remove duplicate
2162	interfaces. We traverse the whole namespace, counting on the fact
2163	that most symbols will not have generic or operator interfaces. */
2164
2165	void
2166	gfc_check_interfaces (gfc_namespace *ns)
2167	{
2168	gfc_namespace *old_ns, *ns2;
2169	char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")];
2170	int i;
2171
2172	old_ns = gfc_current_ns;
2173	gfc_current_ns = ns;
2174
2175	gfc_traverse_ns (ns, check_sym_interfaces);
2176
2177	gfc_traverse_user_op (ns, check_uop_interfaces);
2178
2179	for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2180	{
2181	if (i == INTRINSIC_USER)
2182	continue;
2183
2184	if (i == INTRINSIC_ASSIGN)
2185	strcpy (dest: interface_name, src: "intrinsic assignment operator");
2186	else
2187	sprintf (s: interface_name, format: "intrinsic '%s' operator",
2188	gfc_op2string ((gfc_intrinsic_op) i));
2189
2190	if (check_interface0 (p: ns->op[i], interface_name))
2191	continue;
2192
2193	if (ns->op[i])
2194	gfc_check_operator_interface (sym: ns->op[i]->sym, op: (gfc_intrinsic_op) i,
2195	opwhere: ns->op[i]->where);
2196
2197	for (ns2 = ns; ns2; ns2 = ns2->parent)
2198	{
2199	gfc_intrinsic_op other_op;
2200
2201	if (check_interface1 (p: ns->op[i], q0: ns2->op[i], generic_flag: 0,
2202	interface_name, referenced: true))
2203	goto done;
2204
2205	/* i should be gfc_intrinsic_op, but has to be int with this cast
2206	here for stupid C++ compatibility rules. */
2207	other_op = gfc_equivalent_op (op: (gfc_intrinsic_op) i);
2208	if (other_op != INTRINSIC_NONE
2209	&& check_interface1 (p: ns->op[i], q0: ns2->op[other_op],
2210	generic_flag: 0, interface_name, referenced: true))
2211	goto done;
2212	}
2213	}
2214
2215	done:
2216	gfc_current_ns = old_ns;
2217	}
2218
2219
2220	/* Given a symbol of a formal argument list and an expression, if the
2221	formal argument is allocatable, check that the actual argument is
2222	allocatable. Returns true if compatible, zero if not compatible. */
2223
2224	static bool
2225	compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
2226	{
2227	if (formal->attr.allocatable
2228	|| (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
2229	{
2230	symbol_attribute attr = gfc_expr_attr (actual);
2231	if (actual->ts.type == BT_CLASS && !attr.class_ok)
2232	return true;
2233	else if (!attr.allocatable)
2234	return false;
2235	}
2236
2237	return true;
2238	}
2239
2240
2241	/* Given a symbol of a formal argument list and an expression, if the
2242	formal argument is a pointer, see if the actual argument is a
2243	pointer. Returns nonzero if compatible, zero if not compatible. */
2244
2245	static int
2246	compare_pointer (gfc_symbol *formal, gfc_expr *actual)
2247	{
2248	symbol_attribute attr;
2249
2250	if (formal->attr.pointer
2251	|| (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
2252	&& CLASS_DATA (formal)->attr.class_pointer))
2253	{
2254	attr = gfc_expr_attr (actual);
2255
2256	/* Fortran 2008 allows non-pointer actual arguments. */
2257	if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
2258	return 2;
2259
2260	if (!attr.pointer)
2261	return 0;
2262	}
2263
2264	return 1;
2265	}
2266
2267
2268	/* Emit clear error messages for rank mismatch. */
2269
2270	static void
2271	argument_rank_mismatch (const char *name, locus *where,
2272	int rank1, int rank2, locus *where_formal)
2273	{
2274
2275	/* TS 29113, C407b. */
2276	if (where_formal == NULL)
2277	{
2278	if (rank2 == -1)
2279	gfc_error ("The assumed-rank array at %L requires that the dummy "
2280	"argument %qs has assumed-rank", where, name);
2281	else if (rank1 == 0)
2282	gfc_error_opt (opt: 0, "Rank mismatch in argument %qs "
2283	"at %L (scalar and rank-%d)", name, where, rank2);
2284	else if (rank2 == 0)
2285	gfc_error_opt (opt: 0, "Rank mismatch in argument %qs "
2286	"at %L (rank-%d and scalar)", name, where, rank1);
2287	else
2288	gfc_error_opt (opt: 0, "Rank mismatch in argument %qs "
2289	"at %L (rank-%d and rank-%d)", name, where, rank1,
2290	rank2);
2291	}
2292	else
2293	{
2294	if (rank2 == -1)
2295	/* This is an assumed rank-actual passed to a function without
2296	an explicit interface, which is already diagnosed in
2297	gfc_procedure_use. */
2298	return;
2299	if (rank1 == 0)
2300	gfc_error_opt (opt: 0, "Rank mismatch between actual argument at %L "
2301	"and actual argument at %L (scalar and rank-%d)",
2302	where, where_formal, rank2);
2303	else if (rank2 == 0)
2304	gfc_error_opt (opt: 0, "Rank mismatch between actual argument at %L "
2305	"and actual argument at %L (rank-%d and scalar)",
2306	where, where_formal, rank1);
2307	else
2308	gfc_error_opt (opt: 0, "Rank mismatch between actual argument at %L "
2309	"and actual argument at %L (rank-%d and rank-%d)", where,
2310	where_formal, rank1, rank2);
2311	}
2312	}
2313
2314
2315	/* Under certain conditions, a scalar actual argument can be passed
2316	to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
2317	This function returns true for these conditions so that an error
2318	or warning for this can be suppressed later. Always return false
2319	for expressions with rank > 0. */
2320
2321	bool
2322	maybe_dummy_array_arg (gfc_expr *e)
2323	{
2324	gfc_symbol *s;
2325	gfc_ref *ref;
2326	bool array_pointer = false;
2327	bool assumed_shape = false;
2328	bool scalar_ref = true;
2329
2330	if (e->rank > 0)
2331	return false;
2332
2333	if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
2334	return true;
2335
2336	/* If this comes from a constructor, it has been an array element
2337	originally. */
2338
2339	if (e->expr_type == EXPR_CONSTANT)
2340	return e->from_constructor;
2341
2342	if (e->expr_type != EXPR_VARIABLE)
2343	return false;
2344
2345	s = e->symtree->n.sym;
2346
2347	if (s->attr.dimension)
2348	{
2349	scalar_ref = false;
2350	array_pointer = s->attr.pointer;
2351	}
2352
2353	if (s->as && s->as->type == AS_ASSUMED_SHAPE)
2354	assumed_shape = true;
2355
2356	for (ref=e->ref; ref; ref=ref->next)
2357	{
2358	if (ref->type == REF_COMPONENT)
2359	{
2360	symbol_attribute *attr;
2361	attr = &ref->u.c.component->attr;
2362	if (attr->dimension)
2363	{
2364	array_pointer = attr->pointer;
2365	assumed_shape = false;
2366	scalar_ref = false;
2367	}
2368	else
2369	scalar_ref = true;
2370	}
2371	}
2372
2373	return !(scalar_ref || array_pointer || assumed_shape);
2374	}
2375
2376	/* Given a symbol of a formal argument list and an expression, see if
2377	the two are compatible as arguments. Returns true if
2378	compatible, false if not compatible. */
2379
2380	static bool
2381	compare_parameter (gfc_symbol *formal, gfc_expr *actual,
2382	int ranks_must_agree, int is_elemental, locus *where)
2383	{
2384	gfc_ref *ref;
2385	bool rank_check, is_pointer;
2386	char err[200];
2387	gfc_component *ppc;
2388	bool codimension = false;
2389	gfc_array_spec *formal_as;
2390
2391	/* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2392	procs c_f_pointer or c_f_procpointer, and we need to accept most
2393	pointers the user could give us. This should allow that. */
2394	if (formal->ts.type == BT_VOID)
2395	return true;
2396
2397	if (formal->ts.type == BT_DERIVED
2398	&& formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
2399	&& actual->ts.type == BT_DERIVED
2400	&& actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
2401	{
2402	if (formal->ts.u.derived->intmod_sym_id
2403	!= actual->ts.u.derived->intmod_sym_id)
2404	return false;
2405
2406	if (ranks_must_agree
2407	&& symbol_rank (sym: formal) != actual->rank
2408	&& symbol_rank (sym: formal) != -1)
2409	{
2410	if (where)
2411	argument_rank_mismatch (name: formal->name, where: &actual->where,
2412	rank1: symbol_rank (sym: formal), rank2: actual->rank,
2413	NULL);
2414	return false;
2415	}
2416	return true;
2417	}
2418
2419	if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
2420	/* Make sure the vtab symbol is present when
2421	the module variables are generated. */
2422	gfc_find_derived_vtab (actual->ts.u.derived);
2423
2424	if (actual->ts.type == BT_PROCEDURE)
2425	{
2426	gfc_symbol *act_sym = actual->symtree->n.sym;
2427
2428	if (formal->attr.flavor != FL_PROCEDURE)
2429	{
2430	if (where)
2431	gfc_error ("Invalid procedure argument at %L", &actual->where);
2432	return false;
2433	}
2434
2435	if (!gfc_compare_interfaces (s1: formal, s2: act_sym, name2: act_sym->name, generic_flag: 0, strict_flag: 1, errmsg: err,
2436	err_len: sizeof(err), NULL, NULL))
2437	{
2438	if (where)
2439	gfc_error_opt (opt: 0, "Interface mismatch in dummy procedure %qs at %L:"
2440	" %s", formal->name, &actual->where, err);
2441	return false;
2442	}
2443
2444	if (formal->attr.function && !act_sym->attr.function)
2445	{
2446	gfc_add_function (&act_sym->attr, act_sym->name,
2447	&act_sym->declared_at);
2448	if (act_sym->ts.type == BT_UNKNOWN
2449	&& !gfc_set_default_type (act_sym, 1, act_sym->ns))
2450	return false;
2451	}
2452	else if (formal->attr.subroutine && !act_sym->attr.subroutine)
2453	gfc_add_subroutine (&act_sym->attr, act_sym->name,
2454	&act_sym->declared_at);
2455
2456	return true;
2457	}
2458
2459	ppc = gfc_get_proc_ptr_comp (actual);
2460	if (ppc && ppc->ts.interface)
2461	{
2462	if (!gfc_compare_interfaces (s1: formal, s2: ppc->ts.interface, name2: ppc->name, generic_flag: 0, strict_flag: 1,
2463	errmsg: err, err_len: sizeof(err), NULL, NULL))
2464	{
2465	if (where)
2466	gfc_error_opt (opt: 0, "Interface mismatch in dummy procedure %qs at %L:"
2467	" %s", formal->name, &actual->where, err);
2468	return false;
2469	}
2470	}
2471
2472	/* F2008, C1241. */
2473	if (formal->attr.pointer && formal->attr.contiguous
2474	&& !gfc_is_simply_contiguous (actual, true, false))
2475	{
2476	if (where)
2477	gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2478	"must be simply contiguous", formal->name, &actual->where);
2479	return false;
2480	}
2481
2482	symbol_attribute actual_attr = gfc_expr_attr (actual);
2483	if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
2484	return true;
2485
2486	if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
2487	&& actual->ts.type != BT_HOLLERITH
2488	&& formal->ts.type != BT_ASSUMED
2489	&& !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2490	&& !gfc_compare_types (ts1: &formal->ts, ts2: &actual->ts)
2491	&& !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
2492	&& gfc_compare_derived_types (derived1: formal->ts.u.derived,
2493	CLASS_DATA (actual)->ts.u.derived)))
2494	{
2495	if (where)
2496	{
2497	if (formal->attr.artificial)
2498	{
2499	if (!flag_allow_argument_mismatch || !formal->error)
2500	gfc_error_opt (opt: 0, "Type mismatch between actual argument at %L "
2501	"and actual argument at %L (%s/%s).",
2502	&actual->where,
2503	&formal->declared_at,
2504	gfc_typename (actual),
2505	gfc_dummy_typename (&formal->ts));
2506
2507	formal->error = 1;
2508	}
2509	else
2510	gfc_error_opt (opt: 0, "Type mismatch in argument %qs at %L; passed %s "
2511	"to %s", formal->name, where, gfc_typename (actual),
2512	gfc_dummy_typename (&formal->ts));
2513	}
2514	return false;
2515	}
2516
2517	if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
2518	{
2519	if (where)
2520	gfc_error ("Assumed-type actual argument at %L requires that dummy "
2521	"argument %qs is of assumed type", &actual->where,
2522	formal->name);
2523	return false;
2524	}
2525
2526	/* TS29113 C407c; F2018 C711. */
2527	if (actual->ts.type == BT_ASSUMED
2528	&& symbol_rank (sym: formal) == -1
2529	&& actual->rank != -1
2530	&& !(actual->symtree->n.sym->as
2531	&& actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))
2532	{
2533	if (where)
2534	gfc_error ("Assumed-type actual argument at %L corresponding to "
2535	"assumed-rank dummy argument %qs must be "
2536	"assumed-shape or assumed-rank",
2537	&actual->where, formal->name);
2538	return false;
2539	}
2540
2541	/* F2008, 12.5.2.5; IR F08/0073. */
2542	if (formal->ts.type == BT_CLASS && formal->attr.class_ok
2543	&& actual->expr_type != EXPR_NULL
2544	&& ((CLASS_DATA (formal)->attr.class_pointer
2545	&& formal->attr.intent != INTENT_IN)
2546	|| CLASS_DATA (formal)->attr.allocatable))
2547	{
2548	if (actual->ts.type != BT_CLASS)
2549	{
2550	if (where)
2551	gfc_error ("Actual argument to %qs at %L must be polymorphic",
2552	formal->name, &actual->where);
2553	return false;
2554	}
2555
2556	if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
2557	&& !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
2558	CLASS_DATA (formal)->ts.u.derived))
2559	{
2560	if (where)
2561	gfc_error ("Actual argument to %qs at %L must have the same "
2562	"declared type", formal->name, &actual->where);
2563	return false;
2564	}
2565	}
2566
2567	/* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2568	is necessary also for F03, so retain error for both.
2569	NOTE: Other type/kind errors pre-empt this error. Since they are F03
2570	compatible, no attempt has been made to channel to this one. */
2571	if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
2572	&& (CLASS_DATA (formal)->attr.allocatable
2573	||CLASS_DATA (formal)->attr.class_pointer))
2574	{
2575	if (where)
2576	gfc_error ("Actual argument to %qs at %L must be unlimited "
2577	"polymorphic since the formal argument is a "
2578	"pointer or allocatable unlimited polymorphic "
2579	"entity [F2008: 12.5.2.5]", formal->name,
2580	&actual->where);
2581	return false;
2582	}
2583
2584	if (formal->ts.type == BT_CLASS && formal->attr.class_ok)
2585	codimension = CLASS_DATA (formal)->attr.codimension;
2586	else
2587	codimension = formal->attr.codimension;
2588
2589	if (codimension && !gfc_is_coarray (actual))
2590	{
2591	if (where)
2592	gfc_error ("Actual argument to %qs at %L must be a coarray",
2593	formal->name, &actual->where);
2594	return false;
2595	}
2596
2597	formal_as = (formal->ts.type == BT_CLASS
2598	? CLASS_DATA (formal)->as : formal->as);
2599
2600	if (codimension && formal->attr.allocatable)
2601	{
2602	gfc_ref *last = NULL;
2603
2604	for (ref = actual->ref; ref; ref = ref->next)
2605	if (ref->type == REF_COMPONENT)
2606	last = ref;
2607
2608	/* F2008, 12.5.2.6. */
2609	if ((last && last->u.c.component->as->corank != formal->as->corank)
2610	|| (!last
2611	&& actual->symtree->n.sym->as->corank != formal->as->corank))
2612	{
2613	if (where)
2614	gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2615	formal->name, &actual->where, formal->as->corank,
2616	last ? last->u.c.component->as->corank
2617	: actual->symtree->n.sym->as->corank);
2618	return false;
2619	}
2620	}
2621
2622	if (codimension)
2623	{
2624	/* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2625	/* F2018, 12.5.2.8. */
2626	if (formal->attr.dimension
2627	&& (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
2628	&& actual_attr.dimension
2629	&& !gfc_is_simply_contiguous (actual, true, true))
2630	{
2631	if (where)
2632	gfc_error ("Actual argument to %qs at %L must be simply "
2633	"contiguous or an element of such an array",
2634	formal->name, &actual->where);
2635	return false;
2636	}
2637
2638	/* F2008, C1303 and C1304. */
2639	if (formal->attr.intent != INTENT_INOUT
2640	&& (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2641	&& formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2642	&& formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2643	|| formal->attr.lock_comp))
2644
2645	{
2646	if (where)
2647	gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2648	"which is LOCK_TYPE or has a LOCK_TYPE component",
2649	formal->name, &actual->where);
2650	return false;
2651	}
2652
2653	/* TS18508, C702/C703. */
2654	if (formal->attr.intent != INTENT_INOUT
2655	&& (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2656	&& formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2657	&& formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
2658	|| formal->attr.event_comp))
2659
2660	{
2661	if (where)
2662	gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2663	"which is EVENT_TYPE or has a EVENT_TYPE component",
2664	formal->name, &actual->where);
2665	return false;
2666	}
2667	}
2668
2669	/* F2008, C1239/C1240. */
2670	if (actual->expr_type == EXPR_VARIABLE
2671	&& (actual->symtree->n.sym->attr.asynchronous
2672	|| actual->symtree->n.sym->attr.volatile_)
2673	&& (formal->attr.asynchronous || formal->attr.volatile_)
2674	&& actual->rank && formal->as
2675	&& !gfc_is_simply_contiguous (actual, true, false)
2676	&& ((formal->as->type != AS_ASSUMED_SHAPE
2677	&& formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
2678	|| formal->attr.contiguous))
2679	{
2680	if (where)
2681	gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2682	"assumed-rank array without CONTIGUOUS attribute - as actual"
2683	" argument at %L is not simply contiguous and both are "
2684	"ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
2685	return false;
2686	}
2687
2688	if (formal->attr.allocatable && !codimension
2689	&& actual_attr.codimension)
2690	{
2691	if (formal->attr.intent == INTENT_OUT)
2692	{
2693	if (where)
2694	gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2695	"INTENT(OUT) dummy argument %qs", &actual->where,
2696	formal->name);
2697	return false;
2698	}
2699	else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
2700	gfc_warning (opt: OPT_Wsurprising,
2701	"Passing coarray at %L to allocatable, noncoarray dummy "
2702	"argument %qs, which is invalid if the allocation status"
2703	" is modified", &actual->where, formal->name);
2704	}
2705
2706	/* If the rank is the same or the formal argument has assumed-rank. */
2707	if (symbol_rank (sym: formal) == actual->rank || symbol_rank (sym: formal) == -1)
2708	return true;
2709
2710	rank_check = where != NULL && !is_elemental && formal_as
2711	&& (formal_as->type == AS_ASSUMED_SHAPE
2712	|| formal_as->type == AS_DEFERRED)
2713	&& actual->expr_type != EXPR_NULL;
2714
2715	/* Skip rank checks for NO_ARG_CHECK. */
2716	if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2717	return true;
2718
2719	/* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2720	if (rank_check || ranks_must_agree
2721	|| (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2722	|| (actual->rank != 0
2723	&& !(is_elemental || formal->attr.dimension
2724	|| (formal->ts.type == BT_CLASS
2725	&& CLASS_DATA (formal)->attr.dimension)))
2726	|| (actual->rank == 0
2727	&& ((formal->ts.type == BT_CLASS
2728	&& CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2729	|| (formal->ts.type != BT_CLASS
2730	&& formal->as->type == AS_ASSUMED_SHAPE))
2731	&& actual->expr_type != EXPR_NULL)
2732	|| (actual->rank == 0
2733	&& (formal->attr.dimension
2734	|| (formal->ts.type == BT_CLASS
2735	&& CLASS_DATA (formal)->attr.dimension))
2736	&& gfc_is_coindexed (actual))
2737	/* Assumed-rank actual argument; F2018 C838. */
2738	|| actual->rank == -1)
2739	{
2740	if (where
2741	&& (!formal->attr.artificial || (!formal->maybe_array
2742	&& !maybe_dummy_array_arg (e: actual))))
2743	{
2744	locus *where_formal;
2745	if (formal->attr.artificial)
2746	where_formal = &formal->declared_at;
2747	else
2748	where_formal = NULL;
2749
2750	argument_rank_mismatch (name: formal->name, where: &actual->where,
2751	rank1: symbol_rank (sym: formal), rank2: actual->rank,
2752	where_formal);
2753	}
2754	return false;
2755	}
2756	else if (actual->rank != 0
2757	&& (is_elemental || formal->attr.dimension
2758	|| (formal->ts.type == BT_CLASS
2759	&& CLASS_DATA (formal)->attr.dimension)))
2760	return true;
2761
2762	/* At this point, we are considering a scalar passed to an array. This
2763	is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2764	- if the actual argument is (a substring of) an element of a
2765	non-assumed-shape/non-pointer/non-polymorphic array; or
2766	- (F2003) if the actual argument is of type character of default/c_char
2767	kind.
2768	- (F2018) if the dummy argument is type(*). */
2769
2770	is_pointer = actual->expr_type == EXPR_VARIABLE
2771	? actual->symtree->n.sym->attr.pointer : false;
2772
2773	for (ref = actual->ref; ref; ref = ref->next)
2774	{
2775	if (ref->type == REF_COMPONENT)
2776	is_pointer = ref->u.c.component->attr.pointer;
2777	else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2778	&& ref->u.ar.dimen > 0
2779	&& (!ref->next
2780	|| (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2781	break;
2782	}
2783
2784	if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2785	{
2786	if (where)
2787	gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2788	"at %L", formal->name, &actual->where);
2789	return false;
2790	}
2791
2792	if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2793	&& (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2794	{
2795	if (where)
2796	{
2797	if (formal->attr.artificial)
2798	gfc_error ("Element of assumed-shape or pointer array "
2799	"as actual argument at %L cannot correspond to "
2800	"actual argument at %L",
2801	&actual->where, &formal->declared_at);
2802	else
2803	gfc_error ("Element of assumed-shape or pointer "
2804	"array passed to array dummy argument %qs at %L",
2805	formal->name, &actual->where);
2806	}
2807	return false;
2808	}
2809
2810	if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2811	&& (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2812	{
2813	if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2814	{
2815	if (where)
2816	gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2817	"CHARACTER actual argument with array dummy argument "
2818	"%qs at %L", formal->name, &actual->where);
2819	return false;
2820	}
2821
2822	if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2823	{
2824	gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2825	"array dummy argument %qs at %L",
2826	formal->name, &actual->where);
2827	return false;
2828	}
2829	else
2830	return ((gfc_option.allow_std & GFC_STD_F2003) != 0);
2831	}
2832
2833	if (ref == NULL && actual->expr_type != EXPR_NULL)
2834	{
2835	if (actual->rank == 0
2836	&& formal->ts.type == BT_ASSUMED
2837	&& formal->as
2838	&& formal->as->type == AS_ASSUMED_SIZE)
2839	/* This is new in F2018, type(*) is new in TS29113, but gfortran does
2840	not differentiate. Thus, if type(*) exists, it is valid;
2841	otherwise, type(*) is already rejected. */
2842	return true;
2843	if (where
2844	&& (!formal->attr.artificial || (!formal->maybe_array
2845	&& !maybe_dummy_array_arg (e: actual))))
2846	{
2847	locus *where_formal;
2848	if (formal->attr.artificial)
2849	where_formal = &formal->declared_at;
2850	else
2851	where_formal = NULL;
2852
2853	argument_rank_mismatch (name: formal->name, where: &actual->where,
2854	rank1: symbol_rank (sym: formal), rank2: actual->rank,
2855	where_formal);
2856	}
2857	return false;
2858	}
2859
2860	return true;
2861	}
2862
2863
2864	/* Returns the storage size of a symbol (formal argument) or
2865	zero if it cannot be determined. */
2866
2867	static unsigned long
2868	get_sym_storage_size (gfc_symbol *sym)
2869	{
2870	int i;
2871	unsigned long strlen, elements;
2872
2873	if (sym->ts.type == BT_CHARACTER)
2874	{
2875	if (sym->ts.u.cl && sym->ts.u.cl->length
2876	&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2877	&& sym->ts.u.cl->length->ts.type == BT_INTEGER)
2878	strlen = mpz_get_ui (gmp_z: sym->ts.u.cl->length->value.integer);
2879	else
2880	return 0;
2881	}
2882	else
2883	strlen = 1;
2884
2885	if (symbol_rank (sym) == 0)
2886	return strlen;
2887
2888	elements = 1;
2889	if (sym->as->type != AS_EXPLICIT)
2890	return 0;
2891	for (i = 0; i < sym->as->rank; i++)
2892	{
2893	if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
2894	|| sym->as->lower[i]->expr_type != EXPR_CONSTANT
2895	|| sym->as->upper[i]->ts.type != BT_INTEGER
2896	|| sym->as->lower[i]->ts.type != BT_INTEGER)
2897	return 0;
2898
2899	elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2900	- mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2901	}
2902
2903	return strlen*elements;
2904	}
2905
2906
2907	/* Returns the storage size of an expression (actual argument) or
2908	zero if it cannot be determined. For an array element, it returns
2909	the remaining size as the element sequence consists of all storage
2910	units of the actual argument up to the end of the array. */
2911
2912	static unsigned long
2913	get_expr_storage_size (gfc_expr *e)
2914	{
2915	int i;
2916	long int strlen, elements;
2917	long int substrlen = 0;
2918	bool is_str_storage = false;
2919	gfc_ref *ref;
2920
2921	if (e == NULL)
2922	return 0;
2923
2924	if (e->ts.type == BT_CHARACTER)
2925	{
2926	if (e->ts.u.cl && e->ts.u.cl->length
2927	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT
2928	&& e->ts.u.cl->length->ts.type == BT_INTEGER)
2929	strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2930	else if (e->expr_type == EXPR_CONSTANT
2931	&& (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2932	strlen = e->value.character.length;
2933	else
2934	return 0;
2935	}
2936	else
2937	strlen = 1; /* Length per element. */
2938
2939	if (e->rank == 0 && !e->ref)
2940	return strlen;
2941
2942	elements = 1;
2943	if (!e->ref)
2944	{
2945	if (!e->shape)
2946	return 0;
2947	for (i = 0; i < e->rank; i++)
2948	elements *= mpz_get_si (e->shape[i]);
2949	return elements*strlen;
2950	}
2951
2952	for (ref = e->ref; ref; ref = ref->next)
2953	{
2954	if (ref->type == REF_SUBSTRING && ref->u.ss.start
2955	&& ref->u.ss.start->expr_type == EXPR_CONSTANT)
2956	{
2957	if (is_str_storage)
2958	{
2959	/* The string length is the substring length.
2960	Set now to full string length. */
2961	if (!ref->u.ss.length || !ref->u.ss.length->length
2962	|| ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2963	return 0;
2964
2965	strlen = mpz_get_ui (gmp_z: ref->u.ss.length->length->value.integer);
2966	}
2967	substrlen = strlen - mpz_get_ui (gmp_z: ref->u.ss.start->value.integer) + 1;
2968	continue;
2969	}
2970
2971	if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2972	for (i = 0; i < ref->u.ar.dimen; i++)
2973	{
2974	long int start, end, stride;
2975	stride = 1;
2976
2977	if (ref->u.ar.stride[i])
2978	{
2979	if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT
2980	&& ref->u.ar.stride[i]->ts.type == BT_INTEGER)
2981	stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2982	else
2983	return 0;
2984	}
2985
2986	if (ref->u.ar.start[i])
2987	{
2988	if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT
2989	&& ref->u.ar.start[i]->ts.type == BT_INTEGER)
2990	start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2991	else
2992	return 0;
2993	}
2994	else if (ref->u.ar.as->lower[i]
2995	&& ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2996	&& ref->u.ar.as->lower[i]->ts.type == BT_INTEGER)
2997	start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2998	else
2999	return 0;
3000
3001	if (ref->u.ar.end[i])
3002	{
3003	if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT
3004	&& ref->u.ar.end[i]->ts.type == BT_INTEGER)
3005	end = mpz_get_si (ref->u.ar.end[i]->value.integer);
3006	else
3007	return 0;
3008	}
3009	else if (ref->u.ar.as->upper[i]
3010	&& ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
3011	&& ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
3012	end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
3013	else
3014	return 0;
3015
3016	elements *= (end - start)/stride + 1L;
3017	}
3018	else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
3019	for (i = 0; i < ref->u.ar.as->rank; i++)
3020	{
3021	if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
3022	&& ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
3023	&& ref->u.ar.as->lower[i]->ts.type == BT_INTEGER
3024	&& ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
3025	&& ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
3026	elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
3027	- mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
3028	+ 1L;
3029	else
3030	return 0;
3031	}
3032	else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
3033	&& e->expr_type == EXPR_VARIABLE)
3034	{
3035	if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
3036	|| e->symtree->n.sym->attr.pointer)
3037	{
3038	elements = 1;
3039	continue;
3040	}
3041
3042	/* Determine the number of remaining elements in the element
3043	sequence for array element designators. */
3044	is_str_storage = true;
3045	for (i = ref->u.ar.dimen - 1; i >= 0; i--)
3046	{
3047	if (ref->u.ar.start[i] == NULL
3048	|| ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
3049	|| ref->u.ar.as->upper[i] == NULL
3050	|| ref->u.ar.as->lower[i] == NULL
3051	|| ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
3052	|| ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT
3053	|| ref->u.ar.as->upper[i]->ts.type != BT_INTEGER
3054	|| ref->u.ar.as->lower[i]->ts.type != BT_INTEGER)
3055	return 0;
3056
3057	elements
3058	= elements
3059	* (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
3060	- mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
3061	+ 1L)
3062	- (mpz_get_si (ref->u.ar.start[i]->value.integer)
3063	- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
3064	}
3065	}
3066	else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
3067	&& ref->u.c.component->attr.proc_pointer
3068	&& ref->u.c.component->attr.dimension)
3069	{
3070	/* Array-valued procedure-pointer components. */
3071	gfc_array_spec *as = ref->u.c.component->as;
3072	for (i = 0; i < as->rank; i++)
3073	{
3074	if (!as->upper[i] || !as->lower[i]
3075	|| as->upper[i]->expr_type != EXPR_CONSTANT
3076	|| as->lower[i]->expr_type != EXPR_CONSTANT
3077	|| as->upper[i]->ts.type != BT_INTEGER
3078	|| as->lower[i]->ts.type != BT_INTEGER)
3079	return 0;
3080
3081	elements = elements
3082	* (mpz_get_si (as->upper[i]->value.integer)
3083	- mpz_get_si (as->lower[i]->value.integer) + 1L);
3084	}
3085	}
3086	}
3087
3088	if (substrlen)
3089	return (is_str_storage) ? substrlen + (elements-1)*strlen
3090	: elements*strlen;
3091	else
3092	return elements*strlen;
3093	}
3094
3095
3096	/* Given an expression, check whether it is an array section
3097	which has a vector subscript. */
3098
3099	bool
3100	gfc_has_vector_subscript (gfc_expr *e)
3101	{
3102	int i;
3103	gfc_ref *ref;
3104
3105	if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
3106	return false;
3107
3108	for (ref = e->ref; ref; ref = ref->next)
3109	if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3110	for (i = 0; i < ref->u.ar.dimen; i++)
3111	if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3112	return true;
3113
3114	return false;
3115	}
3116
3117
3118	static bool
3119	is_procptr_result (gfc_expr *expr)
3120	{
3121	gfc_component *c = gfc_get_proc_ptr_comp (expr);
3122	if (c)
3123	return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1));
3124	else
3125	return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
3126	&& (expr->symtree->n.sym->result->attr.proc_pointer == 1));
3127	}
3128
3129
3130	/* Recursively append candidate argument ARG to CANDIDATES. Store the
3131	number of total candidates in CANDIDATES_LEN. */
3132
3133	static void
3134	lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
3135	char **&candidates,
3136	size_t &candidates_len)
3137	{
3138	for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
3139	vec_push (optr&: candidates, osz&: candidates_len, elt: p->sym->name);
3140	}
3141
3142
3143	/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
3144
3145	static const char*
3146	lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
3147	{
3148	char **candidates = NULL;
3149	size_t candidates_len = 0;
3150	lookup_arg_fuzzy_find_candidates (arg: arguments, candidates, candidates_len);
3151	return gfc_closest_fuzzy_match (arg, candidates);
3152	}
3153
3154
3155	static gfc_dummy_arg *
3156	get_nonintrinsic_dummy_arg (gfc_formal_arglist *formal)
3157	{
3158	gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg ();
3159
3160	dummy_arg->intrinsicness = GFC_NON_INTRINSIC_DUMMY_ARG;
3161	dummy_arg->u.non_intrinsic = formal;
3162
3163	return dummy_arg;
3164	}
3165
3166
3167	/* Given formal and actual argument lists, see if they are compatible.
3168	If they are compatible, the actual argument list is sorted to
3169	correspond with the formal list, and elements for missing optional
3170	arguments are inserted. If WHERE pointer is nonnull, then we issue
3171	errors when things don't match instead of just returning the status
3172	code. */
3173
3174	bool
3175	gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
3176	int ranks_must_agree, int is_elemental,
3177	bool in_statement_function, locus *where)
3178	{
3179	gfc_actual_arglist **new_arg, *a, *actual;
3180	gfc_formal_arglist *f;
3181	int i, n, na;
3182	unsigned long actual_size, formal_size;
3183	bool full_array = false;
3184	gfc_array_ref *actual_arr_ref;
3185	gfc_array_spec *fas, *aas;
3186	bool pointer_dummy, pointer_arg, allocatable_arg;
3187
3188	bool ok = true;
3189
3190	actual = *ap;
3191
3192	if (actual == NULL && formal == NULL)
3193	return true;
3194
3195	n = 0;
3196	for (f = formal; f; f = f->next)
3197	n++;
3198
3199	new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
3200
3201	for (i = 0; i < n; i++)
3202	new_arg[i] = NULL;
3203
3204	na = 0;
3205	f = formal;
3206	i = 0;
3207
3208	for (a = actual; a; a = a->next, f = f->next)
3209	{
3210	if (a->name != NULL && in_statement_function)
3211	{
3212	gfc_error ("Keyword argument %qs at %L is invalid in "
3213	"a statement function", a->name, &a->expr->where);
3214	return false;
3215	}
3216
3217	/* Look for keywords but ignore g77 extensions like %VAL. */
3218	if (a->name != NULL && a->name[0] != '%')
3219	{
3220	i = 0;
3221	for (f = formal; f; f = f->next, i++)
3222	{
3223	if (f->sym == NULL)
3224	continue;
3225	if (strcmp (s1: f->sym->name, s2: a->name) == 0)
3226	break;
3227	}
3228
3229	if (f == NULL)
3230	{
3231	if (where)
3232	{
3233	const char *guessed = lookup_arg_fuzzy (arg: a->name, arguments: formal);
3234	if (guessed)
3235	gfc_error ("Keyword argument %qs at %L is not in "
3236	"the procedure; did you mean %qs?",
3237	a->name, &a->expr->where, guessed);
3238	else
3239	gfc_error ("Keyword argument %qs at %L is not in "
3240	"the procedure", a->name, &a->expr->where);
3241	}
3242	return false;
3243	}
3244
3245	if (new_arg[i] != NULL)
3246	{
3247	if (where)
3248	gfc_error ("Keyword argument %qs at %L is already associated "
3249	"with another actual argument", a->name,
3250	&a->expr->where);
3251	return false;
3252	}
3253	}
3254
3255	if (f == NULL)
3256	{
3257	if (where)
3258	gfc_error ("More actual than formal arguments in procedure "
3259	"call at %L", where);
3260	return false;
3261	}
3262
3263	if (f->sym == NULL && a->expr == NULL)
3264	goto match;
3265
3266	if (f->sym == NULL)
3267	{
3268	/* These errors have to be issued, otherwise an ICE can occur.
3269	See PR 78865. */
3270	if (where)
3271	gfc_error_now ("Missing alternate return specifier in subroutine "
3272	"call at %L", where);
3273	return false;
3274	}
3275	else
3276	a->associated_dummy = get_nonintrinsic_dummy_arg (formal: f);
3277
3278	if (a->expr == NULL)
3279	{
3280	if (f->sym->attr.optional)
3281	continue;
3282	else
3283	{
3284	if (where)
3285	gfc_error_now ("Unexpected alternate return specifier in "
3286	"subroutine call at %L", where);
3287	return false;
3288	}
3289	}
3290
3291	/* Make sure that intrinsic vtables exist for calls to unlimited
3292	polymorphic formal arguments. */
3293	if (UNLIMITED_POLY (f->sym)
3294	&& a->expr->ts.type != BT_DERIVED
3295	&& a->expr->ts.type != BT_CLASS
3296	&& a->expr->ts.type != BT_ASSUMED)
3297	gfc_find_vtab (&a->expr->ts);
3298
3299	if (a->expr->expr_type == EXPR_NULL
3300	&& ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
3301	&& (f->sym->attr.allocatable || !f->sym->attr.optional
3302	|| (gfc_option.allow_std & GFC_STD_F2008) == 0))
3303	|| (f->sym->ts.type == BT_CLASS
3304	&& !CLASS_DATA (f->sym)->attr.class_pointer
3305	&& (CLASS_DATA (f->sym)->attr.allocatable
3306	|| !f->sym->attr.optional
3307	|| (gfc_option.allow_std & GFC_STD_F2008) == 0))))
3308	{
3309	if (where
3310	&& (!f->sym->attr.optional
3311	|| (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
3312	|| (f->sym->ts.type == BT_CLASS
3313	&& CLASS_DATA (f->sym)->attr.allocatable)))
3314	gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
3315	where, f->sym->name);
3316	else if (where)
3317	gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3318	"dummy %qs", where, f->sym->name);
3319	ok = false;
3320	goto match;
3321	}
3322
3323	if (!compare_parameter (formal: f->sym, actual: a->expr, ranks_must_agree,
3324	is_elemental, where))
3325	{
3326	ok = false;
3327	goto match;
3328	}
3329
3330	/* TS 29113, 6.3p2; F2018 15.5.2.4. */
3331	if (f->sym->ts.type == BT_ASSUMED
3332	&& (a->expr->ts.type == BT_DERIVED
3333	|| (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
3334	{
3335	gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED
3336	? a->expr->ts.u.derived
3337	: CLASS_DATA (a->expr)->ts.u.derived);
3338	gfc_namespace *f2k_derived = derived->f2k_derived;
3339	if (derived->attr.pdt_type
3340	|| (f2k_derived
3341	&& (f2k_derived->finalizers || f2k_derived->tb_sym_root)))
3342	{
3343	gfc_error ("Actual argument at %L to assumed-type dummy "
3344	"has type parameters or is of "
3345	"derived type with type-bound or FINAL procedures",
3346	&a->expr->where);
3347	ok = false;
3348	goto match;
3349	}
3350	}
3351
3352	if (UNLIMITED_POLY (a->expr)
3353	&& !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym)))
3354	{
3355	gfc_error ("Unlimited polymorphic actual argument at %L is not "
3356	"matched with either an unlimited polymorphic or "
3357	"assumed type dummy argument", &a->expr->where);
3358	ok = false;
3359	goto match;
3360	}
3361
3362	/* Special case for character arguments. For allocatable, pointer
3363	and assumed-shape dummies, the string length needs to match
3364	exactly. */
3365	if (a->expr->ts.type == BT_CHARACTER
3366	&& a->expr->ts.u.cl && a->expr->ts.u.cl->length
3367	&& a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
3368	&& a->expr->ts.u.cl->length->ts.type == BT_INTEGER
3369	&& f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl
3370	&& f->sym->ts.u.cl->length
3371	&& f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
3372	&& f->sym->ts.u.cl->length->ts.type == BT_INTEGER
3373	&& (f->sym->attr.pointer || f->sym->attr.allocatable
3374	|| (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3375	&& (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
3376	f->sym->ts.u.cl->length->value.integer) != 0))
3377	{
3378	if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
3379	gfc_warning (opt: 0, "Character length mismatch (%ld/%ld) between actual "
3380	"argument and pointer or allocatable dummy argument "
3381	"%qs at %L",
3382	mpz_get_si (a->expr->ts.u.cl->length->value.integer),
3383	mpz_get_si (f->sym->ts.u.cl->length->value.integer),
3384	f->sym->name, &a->expr->where);
3385	else if (where)
3386	gfc_warning (opt: 0, "Character length mismatch (%ld/%ld) between actual "
3387	"argument and assumed-shape dummy argument %qs "
3388	"at %L",
3389	mpz_get_si (a->expr->ts.u.cl->length->value.integer),
3390	mpz_get_si (f->sym->ts.u.cl->length->value.integer),
3391	f->sym->name, &a->expr->where);
3392	ok = false;
3393	goto match;
3394	}
3395
3396	if ((f->sym->attr.pointer || f->sym->attr.allocatable)
3397	&& f->sym->ts.deferred != a->expr->ts.deferred
3398	&& a->expr->ts.type == BT_CHARACTER)
3399	{
3400	if (where)
3401	gfc_error ("Actual argument at %L to allocatable or "
3402	"pointer dummy argument %qs must have a deferred "
3403	"length type parameter if and only if the dummy has one",
3404	&a->expr->where, f->sym->name);
3405	ok = false;
3406	goto match;
3407	}
3408
3409	if (f->sym->ts.type == BT_CLASS)
3410	goto skip_size_check;
3411
3412	actual_size = get_expr_storage_size (e: a->expr);
3413	formal_size = get_sym_storage_size (sym: f->sym);
3414	if (actual_size != 0 && actual_size < formal_size
3415	&& a->expr->ts.type != BT_PROCEDURE
3416	&& f->sym->attr.flavor != FL_PROCEDURE)
3417	{
3418	if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
3419	{
3420	gfc_warning (opt: 0, "Character length of actual argument shorter "
3421	"than of dummy argument %qs (%lu/%lu) at %L",
3422	f->sym->name, actual_size, formal_size,
3423	&a->expr->where);
3424	goto skip_size_check;
3425	}
3426	else if (where)
3427	{
3428	/* Emit a warning for -std=legacy and an error otherwise. */
3429	if (gfc_option.warn_std == 0)
3430	gfc_warning (opt: 0, "Actual argument contains too few "
3431	"elements for dummy argument %qs (%lu/%lu) "
3432	"at %L", f->sym->name, actual_size,
3433	formal_size, &a->expr->where);
3434	else
3435	gfc_error_now ("Actual argument contains too few "
3436	"elements for dummy argument %qs (%lu/%lu) "
3437	"at %L", f->sym->name, actual_size,
3438	formal_size, &a->expr->where);
3439	}
3440	ok = false;
3441	goto match;
3442	}
3443
3444	skip_size_check:
3445
3446	/* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3447	argument is provided for a procedure pointer formal argument. */
3448	if (f->sym->attr.proc_pointer
3449	&& !((a->expr->expr_type == EXPR_VARIABLE
3450	&& (a->expr->symtree->n.sym->attr.proc_pointer
3451	|| gfc_is_proc_ptr_comp (a->expr)))
3452	|| (a->expr->expr_type == EXPR_FUNCTION
3453	&& is_procptr_result (expr: a->expr))))
3454	{
3455	if (where)
3456	gfc_error ("Expected a procedure pointer for argument %qs at %L",
3457	f->sym->name, &a->expr->where);
3458	ok = false;
3459	goto match;
3460	}
3461
3462	/* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3463	provided for a procedure formal argument. */
3464	if (f->sym->attr.flavor == FL_PROCEDURE
3465	&& !((a->expr->expr_type == EXPR_VARIABLE
3466	&& (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
3467	|| a->expr->symtree->n.sym->attr.proc_pointer
3468	|| gfc_is_proc_ptr_comp (a->expr)))
3469	|| (a->expr->expr_type == EXPR_FUNCTION
3470	&& is_procptr_result (expr: a->expr))))
3471	{
3472	if (where)
3473	gfc_error ("Expected a procedure for argument %qs at %L",
3474	f->sym->name, &a->expr->where);
3475	ok = false;
3476	goto match;
3477	}
3478
3479	/* Class array variables and expressions store array info in a
3480	different place from non-class objects; consolidate the logic
3481	to access it here instead of repeating it below. Note that
3482	pointer_arg and allocatable_arg are not fully general and are
3483	only used in a specific situation below with an assumed-rank
3484	argument. */
3485	if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym))
3486	{
3487	gfc_component *classdata = CLASS_DATA (f->sym);
3488	fas = classdata->as;
3489	pointer_dummy = classdata->attr.class_pointer;
3490	}
3491	else
3492	{
3493	fas = f->sym->as;
3494	pointer_dummy = f->sym->attr.pointer;
3495	}
3496
3497	if (a->expr->expr_type != EXPR_VARIABLE)
3498	{
3499	aas = NULL;
3500	pointer_arg = false;
3501	allocatable_arg = false;
3502	}
3503	else if (a->expr->ts.type == BT_CLASS
3504	&& a->expr->symtree->n.sym
3505	&& CLASS_DATA (a->expr->symtree->n.sym))
3506	{
3507	gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym);
3508	aas = classdata->as;
3509	pointer_arg = classdata->attr.class_pointer;
3510	allocatable_arg = classdata->attr.allocatable;
3511	}
3512	else
3513	{
3514	aas = a->expr->symtree->n.sym->as;
3515	pointer_arg = a->expr->symtree->n.sym->attr.pointer;
3516	allocatable_arg = a->expr->symtree->n.sym->attr.allocatable;
3517	}
3518
3519	/* F2018:9.5.2(2) permits assumed-size whole array expressions as
3520	actual arguments only if the shape is not required; thus it
3521	cannot be passed to an assumed-shape array dummy.
3522	F2018:15.5.2.(2) permits passing a nonpointer actual to an
3523	intent(in) pointer dummy argument and this is accepted by
3524	the compare_pointer check below, but this also requires shape
3525	information.
3526	There's more discussion of this in PR94110. */
3527	if (fas
3528	&& (fas->type == AS_ASSUMED_SHAPE
3529	|| fas->type == AS_DEFERRED
3530	|| (fas->type == AS_ASSUMED_RANK && pointer_dummy))
3531	&& aas
3532	&& aas->type == AS_ASSUMED_SIZE
3533	&& (a->expr->ref == NULL
3534	|| (a->expr->ref->type == REF_ARRAY
3535	&& a->expr->ref->u.ar.type == AR_FULL)))
3536	{
3537	if (where)
3538	gfc_error ("Actual argument for %qs cannot be an assumed-size"
3539	" array at %L", f->sym->name, where);
3540	ok = false;
3541	goto match;
3542	}
3543
3544	/* Diagnose F2018 C839 (TS29113 C535c). Here the problem is
3545	passing an assumed-size array to an INTENT(OUT) assumed-rank
3546	dummy when it doesn't have the size information needed to run
3547	initializers and finalizers. */
3548	if (f->sym->attr.intent == INTENT_OUT
3549	&& fas
3550	&& fas->type == AS_ASSUMED_RANK
3551	&& aas
3552	&& ((aas->type == AS_ASSUMED_SIZE
3553	&& (a->expr->ref == NULL
3554	|| (a->expr->ref->type == REF_ARRAY
3555	&& a->expr->ref->u.ar.type == AR_FULL)))
3556	|| (aas->type == AS_ASSUMED_RANK
3557	&& !pointer_arg
3558	&& !allocatable_arg))
3559	&& (a->expr->ts.type == BT_CLASS
3560	|| (a->expr->ts.type == BT_DERIVED
3561	&& (gfc_is_finalizable (a->expr->ts.u.derived, NULL)
3562	|| gfc_has_ultimate_allocatable (a->expr)
3563	|| gfc_has_default_initializer
3564	(a->expr->ts.u.derived)))))
3565	{
3566	if (where)
3567	gfc_error ("Actual argument to assumed-rank INTENT(OUT) "
3568	"dummy %qs at %L cannot be of unknown size",
3569	f->sym->name, where);
3570	ok = false;
3571	goto match;
3572	}
3573
3574	if (a->expr->expr_type != EXPR_NULL)
3575	{
3576	int cmp = compare_pointer (formal: f->sym, actual: a->expr);
3577	bool pre2008 = ((gfc_option.allow_std & GFC_STD_F2008) == 0);
3578
3579	if (pre2008 && cmp == 0)
3580	{
3581	if (where)
3582	gfc_error ("Actual argument for %qs at %L must be a pointer",
3583	f->sym->name, &a->expr->where);
3584	ok = false;
3585	goto match;
3586	}
3587
3588	if (pre2008 && cmp == 2)
3589	{
3590	if (where)
3591	gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3592	"pointer dummy %qs", &a->expr->where, f->sym->name);
3593	ok = false;
3594	goto match;
3595	}
3596
3597	if (!pre2008 && cmp == 0)
3598	{
3599	if (where)
3600	gfc_error ("Actual argument for %qs at %L must be a pointer "
3601	"or a valid target for the dummy pointer in a "
3602	"pointer assignment statement",
3603	f->sym->name, &a->expr->where);
3604	ok = false;
3605	goto match;
3606	}
3607	}
3608
3609
3610	/* Fortran 2008, C1242. */
3611	if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
3612	{
3613	if (where)
3614	gfc_error ("Coindexed actual argument at %L to pointer "
3615	"dummy %qs",
3616	&a->expr->where, f->sym->name);
3617	ok = false;
3618	goto match;
3619	}
3620
3621	/* Fortran 2008, 12.5.2.5 (no constraint). */
3622	if (a->expr->expr_type == EXPR_VARIABLE
3623	&& f->sym->attr.intent != INTENT_IN
3624	&& f->sym->attr.allocatable
3625	&& gfc_is_coindexed (a->expr))
3626	{
3627	if (where)
3628	gfc_error ("Coindexed actual argument at %L to allocatable "
3629	"dummy %qs requires INTENT(IN)",
3630	&a->expr->where, f->sym->name);
3631	ok = false;
3632	goto match;
3633	}
3634
3635	/* Fortran 2008, C1237. */
3636	if (a->expr->expr_type == EXPR_VARIABLE
3637	&& (f->sym->attr.asynchronous || f->sym->attr.volatile_)
3638	&& gfc_is_coindexed (a->expr)
3639	&& (a->expr->symtree->n.sym->attr.volatile_
3640	|| a->expr->symtree->n.sym->attr.asynchronous))
3641	{
3642	if (where)
3643	gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3644	"%L requires that dummy %qs has neither "
3645	"ASYNCHRONOUS nor VOLATILE", &a->expr->where,
3646	f->sym->name);
3647	ok = false;
3648	goto match;
3649	}
3650
3651	/* Fortran 2008, 12.5.2.4 (no constraint). */
3652	if (a->expr->expr_type == EXPR_VARIABLE
3653	&& f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
3654	&& gfc_is_coindexed (a->expr)
3655	&& gfc_has_ultimate_allocatable (a->expr))
3656	{
3657	if (where)
3658	gfc_error ("Coindexed actual argument at %L with allocatable "
3659	"ultimate component to dummy %qs requires either VALUE "
3660	"or INTENT(IN)", &a->expr->where, f->sym->name);
3661	ok = false;
3662	goto match;
3663	}
3664
3665	if (f->sym->ts.type == BT_CLASS
3666	&& CLASS_DATA (f->sym)->attr.allocatable
3667	&& gfc_is_class_array_ref (a->expr, &full_array)
3668	&& !full_array)
3669	{
3670	if (where)
3671	gfc_error ("Actual CLASS array argument for %qs must be a full "
3672	"array at %L", f->sym->name, &a->expr->where);
3673	ok = false;
3674	goto match;
3675	}
3676
3677
3678	if (a->expr->expr_type != EXPR_NULL
3679	&& !compare_allocatable (formal: f->sym, actual: a->expr))
3680	{
3681	if (where)
3682	gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3683	f->sym->name, &a->expr->where);
3684	ok = false;
3685	goto match;
3686	}
3687
3688	if (a->expr->expr_type == EXPR_FUNCTION
3689	&& a->expr->value.function.esym
3690	&& f->sym->attr.allocatable)
3691	{
3692	if (where)
3693	gfc_error ("Actual argument for %qs at %L is a function result "
3694	"and the dummy argument is ALLOCATABLE",
3695	f->sym->name, &a->expr->where);
3696	ok = false;
3697	goto match;
3698	}
3699
3700	/* Check intent = OUT/INOUT for definable actual argument. */
3701	if (!in_statement_function
3702	&& (f->sym->attr.intent == INTENT_OUT
3703	|| f->sym->attr.intent == INTENT_INOUT))
3704	{
3705	const char* context = (where
3706	? _("actual argument to INTENT = OUT/INOUT")
3707	: NULL);
3708
3709	if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3710	&& CLASS_DATA (f->sym)->attr.class_pointer)
3711	|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3712	&& !gfc_check_vardef_context (a->expr, true, false, false, context))
3713	{
3714	ok = false;
3715	goto match;
3716	}
3717	if (!gfc_check_vardef_context (a->expr, false, false, false, context))
3718	{
3719	ok = false;
3720	goto match;
3721	}
3722	}
3723
3724	if ((f->sym->attr.intent == INTENT_OUT
3725	|| f->sym->attr.intent == INTENT_INOUT
3726	|| f->sym->attr.volatile_
3727	|| f->sym->attr.asynchronous)
3728	&& gfc_has_vector_subscript (e: a->expr))
3729	{
3730	if (where)
3731	gfc_error ("Array-section actual argument with vector "
3732	"subscripts at %L is incompatible with INTENT(OUT), "
3733	"INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3734	"of the dummy argument %qs",
3735	&a->expr->where, f->sym->name);
3736	ok = false;
3737	goto match;
3738	}
3739
3740	/* C1232 (R1221) For an actual argument which is an array section or
3741	an assumed-shape array, the dummy argument shall be an assumed-
3742	shape array, if the dummy argument has the VOLATILE attribute. */
3743
3744	if (f->sym->attr.volatile_
3745	&& a->expr->expr_type == EXPR_VARIABLE
3746	&& a->expr->symtree->n.sym->as
3747	&& a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
3748	&& !(fas && fas->type == AS_ASSUMED_SHAPE))
3749	{
3750	if (where)
3751	gfc_error ("Assumed-shape actual argument at %L is "
3752	"incompatible with the non-assumed-shape "
3753	"dummy argument %qs due to VOLATILE attribute",
3754	&a->expr->where,f->sym->name);
3755	ok = false;
3756	goto match;
3757	}
3758
3759	/* Find the last array_ref. */
3760	actual_arr_ref = NULL;
3761	if (a->expr->ref)
3762	actual_arr_ref = gfc_find_array_ref (a->expr, a: true);
3763
3764	if (f->sym->attr.volatile_
3765	&& actual_arr_ref && actual_arr_ref->type == AR_SECTION
3766	&& !(fas && fas->type == AS_ASSUMED_SHAPE))
3767	{
3768	if (where)
3769	gfc_error ("Array-section actual argument at %L is "
3770	"incompatible with the non-assumed-shape "
3771	"dummy argument %qs due to VOLATILE attribute",
3772	&a->expr->where, f->sym->name);
3773	ok = false;
3774	goto match;
3775	}
3776
3777	/* C1233 (R1221) For an actual argument which is a pointer array, the
3778	dummy argument shall be an assumed-shape or pointer array, if the
3779	dummy argument has the VOLATILE attribute. */
3780
3781	if (f->sym->attr.volatile_
3782	&& a->expr->expr_type == EXPR_VARIABLE
3783	&& a->expr->symtree->n.sym->attr.pointer
3784	&& a->expr->symtree->n.sym->as
3785	&& !(fas
3786	&& (fas->type == AS_ASSUMED_SHAPE
3787	|| f->sym->attr.pointer)))
3788	{
3789	if (where)
3790	gfc_error ("Pointer-array actual argument at %L requires "
3791	"an assumed-shape or pointer-array dummy "
3792	"argument %qs due to VOLATILE attribute",
3793	&a->expr->where,f->sym->name);
3794	ok = false;
3795	goto match;
3796	}
3797
3798	match:
3799	if (a == actual)
3800	na = i;
3801
3802	new_arg[i++] = a;
3803	}
3804
3805	/* Give up now if we saw any bad argument. */
3806	if (!ok)
3807	return false;
3808
3809	/* Make sure missing actual arguments are optional. */
3810	i = 0;
3811	for (f = formal; f; f = f->next, i++)
3812	{
3813	if (new_arg[i] != NULL)
3814	continue;
3815	if (f->sym == NULL)
3816	{
3817	if (where)
3818	gfc_error ("Missing alternate return spec in subroutine call "
3819	"at %L", where);
3820	return false;
3821	}
3822	/* For CLASS, the optional attribute might be set at either location. */
3823	if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional)
3824	&& !f->sym->attr.optional)
3825	|| (in_statement_function
3826	&& (f->sym->attr.optional
3827	|| (f->sym->ts.type == BT_CLASS
3828	&& CLASS_DATA (f->sym)->attr.optional))))
3829	{
3830	if (where)
3831	gfc_error ("Missing actual argument for argument %qs at %L",
3832	f->sym->name, where);
3833	return false;
3834	}
3835	}
3836
3837	/* We should have handled the cases where the formal arglist is null
3838	already. */
3839	gcc_assert (n > 0);
3840
3841	/* The argument lists are compatible. We now relink a new actual
3842	argument list with null arguments in the right places. The head
3843	of the list remains the head. */
3844	for (f = formal, i = 0; f; f = f->next, i++)
3845	if (new_arg[i] == NULL)
3846	{
3847	new_arg[i] = gfc_get_actual_arglist ();
3848	new_arg[i]->associated_dummy = get_nonintrinsic_dummy_arg (formal: f);
3849	}
3850
3851	if (na != 0)
3852	{
3853	std::swap (a&: *new_arg[0], b&: *actual);
3854	std::swap (a&: new_arg[0], b&: new_arg[na]);
3855	}
3856
3857	for (i = 0; i < n - 1; i++)
3858	new_arg[i]->next = new_arg[i + 1];
3859
3860	new_arg[i]->next = NULL;
3861
3862	if (*ap == NULL && n > 0)
3863	*ap = new_arg[0];
3864
3865	return true;
3866	}
3867
3868
3869	typedef struct
3870	{
3871	gfc_formal_arglist *f;
3872	gfc_actual_arglist *a;
3873	}
3874	argpair;
3875
3876	/* qsort comparison function for argument pairs, with the following
3877	order:
3878	- p->a->expr == NULL
3879	- p->a->expr->expr_type != EXPR_VARIABLE
3880	- by gfc_symbol pointer value (larger first). */
3881
3882	static int
3883	pair_cmp (const void *p1, const void *p2)
3884	{
3885	const gfc_actual_arglist *a1, *a2;
3886
3887	/* *p1 and *p2 are elements of the to-be-sorted array. */
3888	a1 = ((const argpair *) p1)->a;
3889	a2 = ((const argpair *) p2)->a;
3890	if (!a1->expr)
3891	{
3892	if (!a2->expr)
3893	return 0;
3894	return -1;
3895	}
3896	if (!a2->expr)
3897	return 1;
3898	if (a1->expr->expr_type != EXPR_VARIABLE)
3899	{
3900	if (a2->expr->expr_type != EXPR_VARIABLE)
3901	return 0;
3902	return -1;
3903	}
3904	if (a2->expr->expr_type != EXPR_VARIABLE)
3905	return 1;
3906	if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym)
3907	return -1;
3908	return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
3909	}
3910
3911
3912	/* Given two expressions from some actual arguments, test whether they
3913	refer to the same expression. The analysis is conservative.
3914	Returning false will produce no warning. */
3915
3916	static bool
3917	compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
3918	{
3919	const gfc_ref *r1, *r2;
3920
3921	if (!e1 || !e2
3922	|| e1->expr_type != EXPR_VARIABLE
3923	|| e2->expr_type != EXPR_VARIABLE
3924	|| e1->symtree->n.sym != e2->symtree->n.sym)
3925	return false;
3926
3927	/* TODO: improve comparison, see expr.cc:show_ref(). */
3928	for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
3929	{
3930	if (r1->type != r2->type)
3931	return false;
3932	switch (r1->type)
3933	{
3934	case REF_ARRAY:
3935	if (r1->u.ar.type != r2->u.ar.type)
3936	return false;
3937	/* TODO: At the moment, consider only full arrays;
3938	we could do better. */
3939	if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
3940	return false;
3941	break;
3942
3943	case REF_COMPONENT:
3944	if (r1->u.c.component != r2->u.c.component)
3945	return false;
3946	break;
3947
3948	case REF_SUBSTRING:
3949	return false;
3950
3951	case REF_INQUIRY:
3952	if (e1->symtree->n.sym->ts.type == BT_COMPLEX
3953	&& e1->ts.type == BT_REAL && e2->ts.type == BT_REAL
3954	&& r1->u.i != r2->u.i)
3955	return false;
3956	break;
3957
3958	default:
3959	gfc_internal_error ("compare_actual_expr(): Bad component code");
3960	}
3961	}
3962	if (!r1 && !r2)
3963	return true;
3964	return false;
3965	}
3966
3967
3968	/* Given formal and actual argument lists that correspond to one
3969	another, check that identical actual arguments aren't not
3970	associated with some incompatible INTENTs. */
3971
3972	static bool
3973	check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
3974	{
3975	sym_intent f1_intent, f2_intent;
3976	gfc_formal_arglist *f1;
3977	gfc_actual_arglist *a1;
3978	size_t n, i, j;
3979	argpair *p;
3980	bool t = true;
3981
3982	n = 0;
3983	for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
3984	{
3985	if (f1 == NULL && a1 == NULL)
3986	break;
3987	if (f1 == NULL || a1 == NULL)
3988	gfc_internal_error ("check_some_aliasing(): List mismatch");
3989	n++;
3990	}
3991	if (n == 0)
3992	return t;
3993	p = XALLOCAVEC (argpair, n);
3994
3995	for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
3996	{
3997	p[i].f = f1;
3998	p[i].a = a1;
3999	}
4000
4001	qsort (p, n, sizeof (argpair), pair_cmp);
4002
4003	for (i = 0; i < n; i++)
4004	{
4005	if (!p[i].a->expr
4006	|| p[i].a->expr->expr_type != EXPR_VARIABLE
4007	|| p[i].a->expr->ts.type == BT_PROCEDURE)
4008	continue;
4009	f1_intent = p[i].f->sym->attr.intent;
4010	for (j = i + 1; j < n; j++)
4011	{
4012	/* Expected order after the sort. */
4013	if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
4014	gfc_internal_error ("check_some_aliasing(): corrupted data");
4015
4016	/* Are the expression the same? */
4017	if (!compare_actual_expr (e1: p[i].a->expr, e2: p[j].a->expr))
4018	break;
4019	f2_intent = p[j].f->sym->attr.intent;
4020	if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
4021	|| (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
4022	|| (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
4023	{
4024	gfc_warning (opt: 0, "Same actual argument associated with INTENT(%s) "
4025	"argument %qs and INTENT(%s) argument %qs at %L",
4026	gfc_intent_string (f1_intent), p[i].f->sym->name,
4027	gfc_intent_string (f2_intent), p[j].f->sym->name,
4028	&p[i].a->expr->where);
4029	t = false;
4030	}
4031	}
4032	}
4033
4034	return t;
4035	}
4036
4037
4038	/* Given formal and actual argument lists that correspond to one
4039	another, check that they are compatible in the sense that intents
4040	are not mismatched. */
4041
4042	static bool
4043	check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
4044	{
4045	sym_intent f_intent;
4046
4047	for (;; f = f->next, a = a->next)
4048	{
4049	gfc_expr *expr;
4050
4051	if (f == NULL && a == NULL)
4052	break;
4053	if (f == NULL || a == NULL)
4054	gfc_internal_error ("check_intents(): List mismatch");
4055
4056	if (a->expr && a->expr->expr_type == EXPR_FUNCTION
4057	&& a->expr->value.function.isym
4058	&& a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
4059	expr = a->expr->value.function.actual->expr;
4060	else
4061	expr = a->expr;
4062
4063	if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
4064	continue;
4065
4066	f_intent = f->sym->attr.intent;
4067
4068	if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
4069	{
4070	if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
4071	&& CLASS_DATA (f->sym)->attr.class_pointer)
4072	|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
4073	{
4074	gfc_error ("Procedure argument at %L is local to a PURE "
4075	"procedure and has the POINTER attribute",
4076	&expr->where);
4077	return false;
4078	}
4079	}
4080
4081	/* Fortran 2008, C1283. */
4082	if (gfc_pure (NULL) && gfc_is_coindexed (expr))
4083	{
4084	if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
4085	{
4086	gfc_error ("Coindexed actual argument at %L in PURE procedure "
4087	"is passed to an INTENT(%s) argument",
4088	&expr->where, gfc_intent_string (f_intent));
4089	return false;
4090	}
4091
4092	if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
4093	&& CLASS_DATA (f->sym)->attr.class_pointer)
4094	|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
4095	{
4096	gfc_error ("Coindexed actual argument at %L in PURE procedure "
4097	"is passed to a POINTER dummy argument",
4098	&expr->where);
4099	return false;
4100	}
4101	}
4102
4103	/* F2008, Section 12.5.2.4. */
4104	if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
4105	&& gfc_is_coindexed (expr))
4106	{
4107	gfc_error ("Coindexed polymorphic actual argument at %L is passed "
4108	"polymorphic dummy argument %qs",
4109	&expr->where, f->sym->name);
4110	return false;
4111	}
4112	}
4113
4114	return true;
4115	}
4116
4117
4118	/* Check how a procedure is used against its interface. If all goes
4119	well, the actual argument list will also end up being properly
4120	sorted. */
4121
4122	bool
4123	gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
4124	{
4125	gfc_actual_arglist *a;
4126	gfc_formal_arglist *dummy_args;
4127	bool implicit = false;
4128
4129	/* Warn about calls with an implicit interface. Special case
4130	for calling a ISO_C_BINDING because c_loc and c_funloc
4131	are pseudo-unknown. Additionally, warn about procedures not
4132	explicitly declared at all if requested. */
4133	if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
4134	{
4135	bool has_implicit_none_export = false;
4136	implicit = true;
4137	if (sym->attr.proc == PROC_UNKNOWN)
4138	for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
4139	if (ns->has_implicit_none_export)
4140	{
4141	has_implicit_none_export = true;
4142	break;
4143	}
4144	if (has_implicit_none_export)
4145	{
4146	const char *guessed
4147	= gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
4148	if (guessed)
4149	gfc_error ("Procedure %qs called at %L is not explicitly declared"
4150	"; did you mean %qs?",
4151	sym->name, where, guessed);
4152	else
4153	gfc_error ("Procedure %qs called at %L is not explicitly declared",
4154	sym->name, where);
4155	return false;
4156	}
4157	if (warn_implicit_interface)
4158	gfc_warning (opt: OPT_Wimplicit_interface,
4159	"Procedure %qs called with an implicit interface at %L",
4160	sym->name, where);
4161	else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
4162	gfc_warning (opt: OPT_Wimplicit_procedure,
4163	"Procedure %qs called at %L is not explicitly declared",
4164	sym->name, where);
4165	gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1;
4166	}
4167
4168	if (sym->attr.if_source == IFSRC_UNKNOWN)
4169	{
4170	if (sym->attr.pointer)
4171	{
4172	gfc_error ("The pointer object %qs at %L must have an explicit "
4173	"function interface or be declared as array",
4174	sym->name, where);
4175	return false;
4176	}
4177
4178	if (sym->attr.allocatable && !sym->attr.external)
4179	{
4180	gfc_error ("The allocatable object %qs at %L must have an explicit "
4181	"function interface or be declared as array",
4182	sym->name, where);
4183	return false;
4184	}
4185
4186	if (sym->attr.allocatable)
4187	{
4188	gfc_error ("Allocatable function %qs at %L must have an explicit "
4189	"function interface", sym->name, where);
4190	return false;
4191	}
4192
4193	for (a = *ap; a; a = a->next)
4194	{
4195	if (a->expr && a->expr->error)
4196	return false;
4197
4198	/* F2018, 15.4.2.2 Explicit interface is required for a
4199	polymorphic dummy argument, so there is no way to
4200	legally have a class appear in an argument with an
4201	implicit interface. */
4202
4203	if (implicit && a->expr && a->expr->ts.type == BT_CLASS)
4204	{
4205	gfc_error ("Explicit interface required for polymorphic "
4206	"argument at %L",&a->expr->where);
4207	a->expr->error = 1;
4208	break;
4209	}
4210
4211	/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4212	if (a->name != NULL && a->name[0] != '%')
4213	{
4214	gfc_error ("Keyword argument requires explicit interface "
4215	"for procedure %qs at %L", sym->name, &a->expr->where);
4216	break;
4217	}
4218
4219	/* TS 29113, 6.2. */
4220	if (a->expr && a->expr->ts.type == BT_ASSUMED
4221	&& sym->intmod_sym_id != ISOCBINDING_LOC)
4222	{
4223	gfc_error ("Assumed-type argument %s at %L requires an explicit "
4224	"interface", a->expr->symtree->n.sym->name,
4225	&a->expr->where);
4226	a->expr->error = 1;
4227	break;
4228	}
4229
4230	/* F2008, C1303 and C1304. */
4231	if (a->expr
4232	&& (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
4233	&& a->expr->ts.u.derived
4234	&& ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
4235	&& a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
4236	|| gfc_expr_attr (a->expr).lock_comp))
4237	{
4238	gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
4239	"component at %L requires an explicit interface for "
4240	"procedure %qs", &a->expr->where, sym->name);
4241	a->expr->error = 1;
4242	break;
4243	}
4244
4245	if (a->expr
4246	&& (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
4247	&& a->expr->ts.u.derived
4248	&& ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
4249	&& a->expr->ts.u.derived->intmod_sym_id
4250	== ISOFORTRAN_EVENT_TYPE)
4251	|| gfc_expr_attr (a->expr).event_comp))
4252	{
4253	gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
4254	"component at %L requires an explicit interface for "
4255	"procedure %qs", &a->expr->where, sym->name);
4256	a->expr->error = 1;
4257	break;
4258	}
4259
4260	if (a->expr && a->expr->expr_type == EXPR_NULL
4261	&& a->expr->ts.type == BT_UNKNOWN)
4262	{
4263	gfc_error ("MOLD argument to NULL required at %L",
4264	&a->expr->where);
4265	a->expr->error = 1;
4266	return false;
4267	}
4268
4269	if (a->expr && a->expr->expr_type == EXPR_NULL)
4270	{
4271	gfc_error ("Passing intrinsic NULL as actual argument at %L "
4272	"requires an explicit interface", &a->expr->where);
4273	a->expr->error = 1;
4274	return false;
4275	}
4276
4277	/* TS 29113, C407b. */
4278	if (a->expr && a->expr->expr_type == EXPR_VARIABLE
4279	&& symbol_rank (sym: a->expr->symtree->n.sym) == -1)
4280	{
4281	gfc_error ("Assumed-rank argument requires an explicit interface "
4282	"at %L", &a->expr->where);
4283	a->expr->error = 1;
4284	return false;
4285	}
4286	}
4287
4288	return true;
4289	}
4290
4291	dummy_args = gfc_sym_get_dummy_args (sym);
4292
4293	/* For a statement function, check that types and type parameters of actual
4294	arguments and dummy arguments match. */
4295	if (!gfc_compare_actual_formal (ap, formal: dummy_args, ranks_must_agree: 0, is_elemental: sym->attr.elemental,
4296	in_statement_function: sym->attr.proc == PROC_ST_FUNCTION, where))
4297	return false;
4298
4299	if (!check_intents (f: dummy_args, a: *ap))
4300	return false;
4301
4302	if (warn_aliasing)
4303	check_some_aliasing (f: dummy_args, a: *ap);
4304
4305	return true;
4306	}
4307
4308
4309	/* Check how a procedure pointer component is used against its interface.
4310	If all goes well, the actual argument list will also end up being properly
4311	sorted. Completely analogous to gfc_procedure_use. */
4312
4313	void
4314	gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
4315	{
4316	/* Warn about calls with an implicit interface. Special case
4317	for calling a ISO_C_BINDING because c_loc and c_funloc
4318	are pseudo-unknown. */
4319	if (warn_implicit_interface
4320	&& comp->attr.if_source == IFSRC_UNKNOWN
4321	&& !comp->attr.is_iso_c)
4322	gfc_warning (opt: OPT_Wimplicit_interface,
4323	"Procedure pointer component %qs called with an implicit "
4324	"interface at %L", comp->name, where);
4325
4326	if (comp->attr.if_source == IFSRC_UNKNOWN)
4327	{
4328	gfc_actual_arglist *a;
4329	for (a = *ap; a; a = a->next)
4330	{
4331	/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4332	if (a->name != NULL && a->name[0] != '%')
4333	{
4334	gfc_error ("Keyword argument requires explicit interface "
4335	"for procedure pointer component %qs at %L",
4336	comp->name, &a->expr->where);
4337	break;
4338	}
4339	}
4340
4341	return;
4342	}
4343
4344	if (!gfc_compare_actual_formal (ap, formal: comp->ts.interface->formal, ranks_must_agree: 0,
4345	is_elemental: comp->attr.elemental, in_statement_function: false, where))
4346	return;
4347
4348	check_intents (f: comp->ts.interface->formal, a: *ap);
4349	if (warn_aliasing)
4350	check_some_aliasing (f: comp->ts.interface->formal, a: *ap);
4351	}
4352
4353
4354	/* Try if an actual argument list matches the formal list of a symbol,
4355	respecting the symbol's attributes like ELEMENTAL. This is used for
4356	GENERIC resolution. */
4357
4358	bool
4359	gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
4360	{
4361	gfc_formal_arglist *dummy_args;
4362	bool r;
4363
4364	if (sym->attr.flavor != FL_PROCEDURE)
4365	return false;
4366
4367	dummy_args = gfc_sym_get_dummy_args (sym);
4368
4369	r = !sym->attr.elemental;
4370	if (gfc_compare_actual_formal (ap: args, formal: dummy_args, ranks_must_agree: r, is_elemental: !r, in_statement_function: false, NULL))
4371	{
4372	check_intents (f: dummy_args, a: *args);
4373	if (warn_aliasing)
4374	check_some_aliasing (f: dummy_args, a: *args);
4375	return true;
4376	}
4377
4378	return false;
4379	}
4380
4381
4382	/* Given an interface pointer and an actual argument list, search for
4383	a formal argument list that matches the actual. If found, returns
4384	a pointer to the symbol of the correct interface. Returns NULL if
4385	not found. */
4386
4387	gfc_symbol *
4388	gfc_search_interface (gfc_interface *intr, int sub_flag,
4389	gfc_actual_arglist **ap)
4390	{
4391	gfc_symbol *elem_sym = NULL;
4392	gfc_symbol *null_sym = NULL;
4393	locus null_expr_loc;
4394	gfc_actual_arglist *a;
4395	bool has_null_arg = false;
4396
4397	for (a = *ap; a; a = a->next)
4398	if (a->expr && a->expr->expr_type == EXPR_NULL
4399	&& a->expr->ts.type == BT_UNKNOWN)
4400	{
4401	has_null_arg = true;
4402	null_expr_loc = a->expr->where;
4403	break;
4404	}
4405
4406	for (; intr; intr = intr->next)
4407	{
4408	if (gfc_fl_struct (intr->sym->attr.flavor))
4409	continue;
4410	if (sub_flag && intr->sym->attr.function)
4411	continue;
4412	if (!sub_flag && intr->sym->attr.subroutine)
4413	continue;
4414
4415	if (gfc_arglist_matches_symbol (args: ap, sym: intr->sym))
4416	{
4417	if (has_null_arg && null_sym)
4418	{
4419	gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
4420	"between specific functions %s and %s",
4421	&null_expr_loc, null_sym->name, intr->sym->name);
4422	return NULL;
4423	}
4424	else if (has_null_arg)
4425	{
4426	null_sym = intr->sym;
4427	continue;
4428	}
4429
4430	/* Satisfy 12.4.4.1 such that an elemental match has lower
4431	weight than a non-elemental match. */
4432	if (intr->sym->attr.elemental)
4433	{
4434	elem_sym = intr->sym;
4435	continue;
4436	}
4437	return intr->sym;
4438	}
4439	}
4440
4441	if (null_sym)
4442	return null_sym;
4443
4444	return elem_sym ? elem_sym : NULL;
4445	}
4446
4447
4448	/* Do a brute force recursive search for a symbol. */
4449
4450	static gfc_symtree *
4451	find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
4452	{
4453	gfc_symtree * st;
4454
4455	if (root->n.sym == sym)
4456	return root;
4457
4458	st = NULL;
4459	if (root->left)
4460	st = find_symtree0 (root: root->left, sym);
4461	if (root->right && ! st)
4462	st = find_symtree0 (root: root->right, sym);
4463	return st;
4464	}
4465
4466
4467	/* Find a symtree for a symbol. */
4468
4469	gfc_symtree *
4470	gfc_find_sym_in_symtree (gfc_symbol *sym)
4471	{
4472	gfc_symtree *st;
4473	gfc_namespace *ns;
4474
4475	/* First try to find it by name. */
4476	gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
4477	if (st && st->n.sym == sym)
4478	return st;
4479
4480	/* If it's been renamed, resort to a brute-force search. */
4481	/* TODO: avoid having to do this search. If the symbol doesn't exist
4482	in the symtree for the current namespace, it should probably be added. */
4483	for (ns = gfc_current_ns; ns; ns = ns->parent)
4484	{
4485	st = find_symtree0 (root: ns->sym_root, sym);
4486	if (st)
4487	return st;
4488	}
4489	gfc_internal_error ("Unable to find symbol %qs", sym->name);
4490	/* Not reached. */
4491	}
4492
4493
4494	/* See if the arglist to an operator-call contains a derived-type argument
4495	with a matching type-bound operator. If so, return the matching specific
4496	procedure defined as operator-target as well as the base-object to use
4497	(which is the found derived-type argument with operator). The generic
4498	name, if any, is transmitted to the final expression via 'gname'. */
4499
4500	static gfc_typebound_proc*
4501	matching_typebound_op (gfc_expr** tb_base,
4502	gfc_actual_arglist* args,
4503	gfc_intrinsic_op op, const char* uop,
4504	const char ** gname)
4505	{
4506	gfc_actual_arglist* base;
4507
4508	for (base = args; base; base = base->next)
4509	if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
4510	{
4511	gfc_typebound_proc* tb;
4512	gfc_symbol* derived;
4513	bool result;
4514
4515	while (base->expr->expr_type == EXPR_OP
4516	&& base->expr->value.op.op == INTRINSIC_PARENTHESES)
4517	base->expr = base->expr->value.op.op1;
4518
4519	if (base->expr->ts.type == BT_CLASS)
4520	{
4521	if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL
4522	|| !gfc_expr_attr (base->expr).class_ok)
4523	continue;
4524	derived = CLASS_DATA (base->expr)->ts.u.derived;
4525	}
4526	else
4527	derived = base->expr->ts.u.derived;
4528
4529	if (op == INTRINSIC_USER)
4530	{
4531	gfc_symtree* tb_uop;
4532
4533	gcc_assert (uop);
4534	tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
4535	false, NULL);
4536
4537	if (tb_uop)
4538	tb = tb_uop->n.tb;
4539	else
4540	tb = NULL;
4541	}
4542	else
4543	tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
4544	false, NULL);
4545
4546	/* This means we hit a PRIVATE operator which is use-associated and
4547	should thus not be seen. */
4548	if (!result)
4549	tb = NULL;
4550
4551	/* Look through the super-type hierarchy for a matching specific
4552	binding. */
4553	for (; tb; tb = tb->overridden)
4554	{
4555	gfc_tbp_generic* g;
4556
4557	gcc_assert (tb->is_generic);
4558	for (g = tb->u.generic; g; g = g->next)
4559	{
4560	gfc_symbol* target;
4561	gfc_actual_arglist* argcopy;
4562	bool matches;
4563
4564	gcc_assert (g->specific);
4565	if (g->specific->error)
4566	continue;
4567
4568	target = g->specific->u.specific->n.sym;
4569
4570	/* Check if this arglist matches the formal. */
4571	argcopy = gfc_copy_actual_arglist (args);
4572	matches = gfc_arglist_matches_symbol (args: &argcopy, sym: target);
4573	gfc_free_actual_arglist (argcopy);
4574
4575	/* Return if we found a match. */
4576	if (matches)
4577	{
4578	*tb_base = base->expr;
4579	*gname = g->specific_st->name;
4580	return g->specific;
4581	}
4582	}
4583	}
4584	}
4585
4586	return NULL;
4587	}
4588
4589
4590	/* For the 'actual arglist' of an operator call and a specific typebound
4591	procedure that has been found the target of a type-bound operator, build the
4592	appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4593	type-bound procedures rather than resolving type-bound operators 'directly'
4594	so that we can reuse the existing logic. */
4595
4596	static void
4597	build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
4598	gfc_expr* base, gfc_typebound_proc* target,
4599	const char *gname)
4600	{
4601	e->expr_type = EXPR_COMPCALL;
4602	e->value.compcall.tbp = target;
4603	e->value.compcall.name = gname ? gname : "$op";
4604	e->value.compcall.actual = actual;
4605	e->value.compcall.base_object = base;
4606	e->value.compcall.ignore_pass = 1;
4607	e->value.compcall.assign = 0;
4608	if (e->ts.type == BT_UNKNOWN
4609	&& target->function)
4610	{
4611	if (target->is_generic)
4612	e->ts = target->u.generic->specific->u.specific->n.sym->ts;
4613	else
4614	e->ts = target->u.specific->n.sym->ts;
4615	}
4616	}
4617
4618
4619	/* This subroutine is called when an expression is being resolved.
4620	The expression node in question is either a user defined operator
4621	or an intrinsic operator with arguments that aren't compatible
4622	with the operator. This subroutine builds an actual argument list
4623	corresponding to the operands, then searches for a compatible
4624	interface. If one is found, the expression node is replaced with
4625	the appropriate function call. We use the 'match' enum to specify
4626	whether a replacement has been made or not, or if an error occurred. */
4627
4628	match
4629	gfc_extend_expr (gfc_expr *e)
4630	{
4631	gfc_actual_arglist *actual;
4632	gfc_symbol *sym;
4633	gfc_namespace *ns;
4634	gfc_user_op *uop;
4635	gfc_intrinsic_op i;
4636	const char *gname;
4637	gfc_typebound_proc* tbo;
4638	gfc_expr* tb_base;
4639
4640	sym = NULL;
4641
4642	actual = gfc_get_actual_arglist ();
4643	actual->expr = e->value.op.op1;
4644
4645	gname = NULL;
4646
4647	if (e->value.op.op2 != NULL)
4648	{
4649	actual->next = gfc_get_actual_arglist ();
4650	actual->next->expr = e->value.op.op2;
4651	}
4652
4653	i = fold_unary_intrinsic (op: e->value.op.op);
4654
4655	/* See if we find a matching type-bound operator. */
4656	if (i == INTRINSIC_USER)
4657	tbo = matching_typebound_op (tb_base: &tb_base, args: actual,
4658	op: i, uop: e->value.op.uop->name, gname: &gname);
4659	else
4660	switch (i)
4661	{
4662	#define CHECK_OS_COMPARISON(comp) \
4663	case INTRINSIC_##comp: \
4664	case INTRINSIC_##comp##_OS: \
4665	tbo = matching_typebound_op (&tb_base, actual, \
4666	INTRINSIC_##comp, NULL, &gname); \
4667	if (!tbo) \
4668	tbo = matching_typebound_op (&tb_base, actual, \
4669	INTRINSIC_##comp##_OS, NULL, &gname); \
4670	break;
4671	CHECK_OS_COMPARISON(EQ)
4672	CHECK_OS_COMPARISON(NE)
4673	CHECK_OS_COMPARISON(GT)
4674	CHECK_OS_COMPARISON(GE)
4675	CHECK_OS_COMPARISON(LT)
4676	CHECK_OS_COMPARISON(LE)
4677	#undef CHECK_OS_COMPARISON
4678
4679	default:
4680	tbo = matching_typebound_op (tb_base: &tb_base, args: actual, op: i, NULL, gname: &gname);
4681	break;
4682	}
4683
4684	/* If there is a matching typebound-operator, replace the expression with
4685	a call to it and succeed. */
4686	if (tbo)
4687	{
4688	gcc_assert (tb_base);
4689	build_compcall_for_operator (e, actual, base: tb_base, target: tbo, gname);
4690
4691	if (!gfc_resolve_expr (e))
4692	return MATCH_ERROR;
4693	else
4694	return MATCH_YES;
4695	}
4696
4697	if (i == INTRINSIC_USER)
4698	{
4699	for (ns = gfc_current_ns; ns; ns = ns->parent)
4700	{
4701	uop = gfc_find_uop (e->value.op.uop->name, ns);
4702	if (uop == NULL)
4703	continue;
4704
4705	sym = gfc_search_interface (intr: uop->op, sub_flag: 0, ap: &actual);
4706	if (sym != NULL)
4707	break;
4708	}
4709	}
4710	else
4711	{
4712	for (ns = gfc_current_ns; ns; ns = ns->parent)
4713	{
4714	/* Due to the distinction between '==' and '.eq.' and friends, one has
4715	to check if either is defined. */
4716	switch (i)
4717	{
4718	#define CHECK_OS_COMPARISON(comp) \
4719	case INTRINSIC_##comp: \
4720	case INTRINSIC_##comp##_OS: \
4721	sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4722	if (!sym) \
4723	sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4724	break;
4725	CHECK_OS_COMPARISON(EQ)
4726	CHECK_OS_COMPARISON(NE)
4727	CHECK_OS_COMPARISON(GT)
4728	CHECK_OS_COMPARISON(GE)
4729	CHECK_OS_COMPARISON(LT)
4730	CHECK_OS_COMPARISON(LE)
4731	#undef CHECK_OS_COMPARISON
4732
4733	default:
4734	sym = gfc_search_interface (intr: ns->op[i], sub_flag: 0, ap: &actual);
4735	}
4736
4737	if (sym != NULL)
4738	break;
4739	}
4740
4741	/* F2018(15.4.3.4.2) requires that the use of unlimited polymorphic
4742	formal arguments does not override the intrinsic uses. */
4743	gfc_push_suppress_errors ();
4744	if (sym
4745	&& (UNLIMITED_POLY (sym->formal->sym)
4746	|| (sym->formal->next
4747	&& UNLIMITED_POLY (sym->formal->next->sym)))
4748	&& !gfc_check_operator_interface (sym, op: e->value.op.op, opwhere: e->where))
4749	sym = NULL;
4750	gfc_pop_suppress_errors ();
4751	}
4752
4753	/* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4754	found rather than just taking the first one and not checking further. */
4755
4756	if (sym == NULL)
4757	{
4758	/* Don't use gfc_free_actual_arglist(). */
4759	free (ptr: actual->next);
4760	free (ptr: actual);
4761	return MATCH_NO;
4762	}
4763
4764	/* Change the expression node to a function call. */
4765	e->expr_type = EXPR_FUNCTION;
4766	e->symtree = gfc_find_sym_in_symtree (sym);
4767	e->value.function.actual = actual;
4768	e->value.function.esym = NULL;
4769	e->value.function.isym = NULL;
4770	e->value.function.name = NULL;
4771	e->user_operator = 1;
4772
4773	if (!gfc_resolve_expr (e))
4774	return MATCH_ERROR;
4775
4776	return MATCH_YES;
4777	}
4778
4779
4780	/* Tries to replace an assignment code node with a subroutine call to the
4781	subroutine associated with the assignment operator. Return true if the node
4782	was replaced. On false, no error is generated. */
4783
4784	bool
4785	gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
4786	{
4787	gfc_actual_arglist *actual;
4788	gfc_expr *lhs, *rhs, *tb_base;
4789	gfc_symbol *sym = NULL;
4790	const char *gname = NULL;
4791	gfc_typebound_proc* tbo;
4792
4793	lhs = c->expr1;
4794	rhs = c->expr2;
4795
4796	/* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
4797	if (c->op == EXEC_ASSIGN
4798	&& c->expr1->expr_type == EXPR_VARIABLE
4799	&& c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ)
4800	return false;
4801
4802	/* Don't allow an intrinsic assignment to be replaced. */
4803	if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
4804	&& (rhs->rank == 0 || rhs->rank == lhs->rank)
4805	&& (lhs->ts.type == rhs->ts.type
4806	|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
4807	return false;
4808
4809	actual = gfc_get_actual_arglist ();
4810	actual->expr = lhs;
4811
4812	actual->next = gfc_get_actual_arglist ();
4813	actual->next->expr = rhs;
4814
4815	/* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4816
4817	/* See if we find a matching type-bound assignment. */
4818	tbo = matching_typebound_op (tb_base: &tb_base, args: actual, op: INTRINSIC_ASSIGN,
4819	NULL, gname: &gname);
4820
4821	if (tbo)
4822	{
4823	/* Success: Replace the expression with a type-bound call. */
4824	gcc_assert (tb_base);
4825	c->expr1 = gfc_get_expr ();
4826	build_compcall_for_operator (e: c->expr1, actual, base: tb_base, target: tbo, gname);
4827	c->expr1->value.compcall.assign = 1;
4828	c->expr1->where = c->loc;
4829	c->expr2 = NULL;
4830	c->op = EXEC_COMPCALL;
4831	return true;
4832	}
4833
4834	/* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4835	for (; ns; ns = ns->parent)
4836	{
4837	sym = gfc_search_interface (intr: ns->op[INTRINSIC_ASSIGN], sub_flag: 1, ap: &actual);
4838	if (sym != NULL)
4839	break;
4840	}
4841
4842	if (sym)
4843	{
4844	/* Success: Replace the assignment with the call. */
4845	c->op = EXEC_ASSIGN_CALL;
4846	c->symtree = gfc_find_sym_in_symtree (sym);
4847	c->expr1 = NULL;
4848	c->expr2 = NULL;
4849	c->ext.actual = actual;
4850	return true;
4851	}
4852
4853	/* Failure: No assignment procedure found. */
4854	free (ptr: actual->next);
4855	free (ptr: actual);
4856	return false;
4857	}
4858
4859
4860	/* Make sure that the interface just parsed is not already present in
4861	the given interface list. Ambiguity isn't checked yet since module
4862	procedures can be present without interfaces. */
4863
4864	bool
4865	gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
4866	{
4867	gfc_interface *ip;
4868
4869	for (ip = base; ip; ip = ip->next)
4870	{
4871	if (ip->sym == new_sym)
4872	{
4873	gfc_error ("Entity %qs at %L is already present in the interface",
4874	new_sym->name, &loc);
4875	return false;
4876	}
4877	}
4878
4879	return true;
4880	}
4881
4882
4883	/* Add a symbol to the current interface. */
4884
4885	bool
4886	gfc_add_interface (gfc_symbol *new_sym)
4887	{
4888	gfc_interface **head, *intr;
4889	gfc_namespace *ns;
4890	gfc_symbol *sym;
4891
4892	switch (current_interface.type)
4893	{
4894	case INTERFACE_NAMELESS:
4895	case INTERFACE_ABSTRACT:
4896	return true;
4897
4898	case INTERFACE_INTRINSIC_OP:
4899	for (ns = current_interface.ns; ns; ns = ns->parent)
4900	switch (current_interface.op)
4901	{
4902	case INTRINSIC_EQ:
4903	case INTRINSIC_EQ_OS:
4904	if (!gfc_check_new_interface (base: ns->op[INTRINSIC_EQ], new_sym,
4905	loc: gfc_current_locus)
4906	|| !gfc_check_new_interface (base: ns->op[INTRINSIC_EQ_OS],
4907	new_sym, loc: gfc_current_locus))
4908	return false;
4909	break;
4910
4911	case INTRINSIC_NE:
4912	case INTRINSIC_NE_OS:
4913	if (!gfc_check_new_interface (base: ns->op[INTRINSIC_NE], new_sym,
4914	loc: gfc_current_locus)
4915	|| !gfc_check_new_interface (base: ns->op[INTRINSIC_NE_OS],
4916	new_sym, loc: gfc_current_locus))
4917	return false;
4918	break;
4919
4920	case INTRINSIC_GT:
4921	case INTRINSIC_GT_OS:
4922	if (!gfc_check_new_interface (base: ns->op[INTRINSIC_GT],
4923	new_sym, loc: gfc_current_locus)
4924	|| !gfc_check_new_interface (base: ns->op[INTRINSIC_GT_OS],
4925	new_sym, loc: gfc_current_locus))
4926	return false;
4927	break;
4928
4929	case INTRINSIC_GE:
4930	case INTRINSIC_GE_OS:
4931	if (!gfc_check_new_interface (base: ns->op[INTRINSIC_GE],
4932	new_sym, loc: gfc_current_locus)
4933	|| !gfc_check_new_interface (base: ns->op[INTRINSIC_GE_OS],
4934	new_sym, loc: gfc_current_locus))
4935	return false;
4936	break;
4937
4938	case INTRINSIC_LT:
4939	case INTRINSIC_LT_OS:
4940	if (!gfc_check_new_interface (base: ns->op[INTRINSIC_LT],
4941	new_sym, loc: gfc_current_locus)
4942	|| !gfc_check_new_interface (base: ns->op[INTRINSIC_LT_OS],
4943	new_sym, loc: gfc_current_locus))
4944	return false;
4945	break;
4946
4947	case INTRINSIC_LE:
4948	case INTRINSIC_LE_OS:
4949	if (!gfc_check_new_interface (base: ns->op[INTRINSIC_LE],
4950	new_sym, loc: gfc_current_locus)
4951	|| !gfc_check_new_interface (base: ns->op[INTRINSIC_LE_OS],
4952	new_sym, loc: gfc_current_locus))
4953	return false;
4954	break;
4955
4956	default:
4957	if (!gfc_check_new_interface (base: ns->op[current_interface.op],
4958	new_sym, loc: gfc_current_locus))
4959	return false;
4960	}
4961
4962	head = &current_interface.ns->op[current_interface.op];
4963	break;
4964
4965	case INTERFACE_GENERIC:
4966	case INTERFACE_DTIO:
4967	for (ns = current_interface.ns; ns; ns = ns->parent)
4968	{
4969	gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
4970	if (sym == NULL)
4971	continue;
4972
4973	if (!gfc_check_new_interface (base: sym->generic,
4974	new_sym, loc: gfc_current_locus))
4975	return false;
4976	}
4977
4978	head = &current_interface.sym->generic;
4979	break;
4980
4981	case INTERFACE_USER_OP:
4982	if (!gfc_check_new_interface (base: current_interface.uop->op,
4983	new_sym, loc: gfc_current_locus))
4984	return false;
4985
4986	head = &current_interface.uop->op;
4987	break;
4988
4989	default:
4990	gfc_internal_error ("gfc_add_interface(): Bad interface type");
4991	}
4992
4993	intr = gfc_get_interface ();
4994	intr->sym = new_sym;
4995	intr->where = gfc_current_locus;
4996
4997	intr->next = *head;
4998	*head = intr;
4999
5000	return true;
5001	}
5002
5003
5004	gfc_interface *&
5005	gfc_current_interface_head (void)
5006	{
5007	switch (current_interface.type)
5008	{
5009	case INTERFACE_INTRINSIC_OP:
5010	return current_interface.ns->op[current_interface.op];
5011
5012	case INTERFACE_GENERIC:
5013	case INTERFACE_DTIO:
5014	return current_interface.sym->generic;
5015
5016	case INTERFACE_USER_OP:
5017	return current_interface.uop->op;
5018
5019	default:
5020	gcc_unreachable ();
5021	}
5022	}
5023
5024
5025	void
5026	gfc_set_current_interface_head (gfc_interface *i)
5027	{
5028	switch (current_interface.type)
5029	{
5030	case INTERFACE_INTRINSIC_OP:
5031	current_interface.ns->op[current_interface.op] = i;
5032	break;
5033
5034	case INTERFACE_GENERIC:
5035	case INTERFACE_DTIO:
5036	current_interface.sym->generic = i;
5037	break;
5038
5039	case INTERFACE_USER_OP:
5040	current_interface.uop->op = i;
5041	break;
5042
5043	default:
5044	gcc_unreachable ();
5045	}
5046	}
5047
5048
5049	/* Gets rid of a formal argument list. We do not free symbols.
5050	Symbols are freed when a namespace is freed. */
5051
5052	void
5053	gfc_free_formal_arglist (gfc_formal_arglist *p)
5054	{
5055	gfc_formal_arglist *q;
5056
5057	for (; p; p = q)
5058	{
5059	q = p->next;
5060	free (ptr: p);
5061	}
5062	}
5063
5064
5065	/* Check that it is ok for the type-bound procedure 'proc' to override the
5066	procedure 'old', cf. F08:4.5.7.3. */
5067
5068	bool
5069	gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
5070	{
5071	locus where;
5072	gfc_symbol *proc_target, *old_target;
5073	unsigned proc_pass_arg, old_pass_arg, argpos;
5074	gfc_formal_arglist *proc_formal, *old_formal;
5075	bool check_type;
5076	char err[200];
5077
5078	/* This procedure should only be called for non-GENERIC proc. */
5079	gcc_assert (!proc->n.tb->is_generic);
5080
5081	/* If the overwritten procedure is GENERIC, this is an error. */
5082	if (old->n.tb->is_generic)
5083	{
5084	gfc_error ("Cannot overwrite GENERIC %qs at %L",
5085	old->name, &proc->n.tb->where);
5086	return false;
5087	}
5088
5089	where = proc->n.tb->where;
5090	proc_target = proc->n.tb->u.specific->n.sym;
5091	old_target = old->n.tb->u.specific->n.sym;
5092
5093	/* Check that overridden binding is not NON_OVERRIDABLE. */
5094	if (old->n.tb->non_overridable)
5095	{
5096	gfc_error ("%qs at %L overrides a procedure binding declared"
5097	" NON_OVERRIDABLE", proc->name, &where);
5098	return false;
5099	}
5100
5101	/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
5102	if (!old->n.tb->deferred && proc->n.tb->deferred)
5103	{
5104	gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
5105	" non-DEFERRED binding", proc->name, &where);
5106	return false;
5107	}
5108
5109	/* If the overridden binding is PURE, the overriding must be, too. */
5110	if (old_target->attr.pure && !proc_target->attr.pure)
5111	{
5112	gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
5113	proc->name, &where);
5114	return false;
5115	}
5116
5117	/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
5118	is not, the overriding must not be either. */
5119	if (old_target->attr.elemental && !proc_target->attr.elemental)
5120	{
5121	gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
5122	" ELEMENTAL", proc->name, &where);
5123	return false;
5124	}
5125	if (!old_target->attr.elemental && proc_target->attr.elemental)
5126	{
5127	gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
5128	" be ELEMENTAL, either", proc->name, &where);
5129	return false;
5130	}
5131
5132	/* If the overridden binding is a SUBROUTINE, the overriding must also be a
5133	SUBROUTINE. */
5134	if (old_target->attr.subroutine && !proc_target->attr.subroutine)
5135	{
5136	gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
5137	" SUBROUTINE", proc->name, &where);
5138	return false;
5139	}
5140
5141	/* If the overridden binding is a FUNCTION, the overriding must also be a
5142	FUNCTION and have the same characteristics. */
5143	if (old_target->attr.function)
5144	{
5145	if (!proc_target->attr.function)
5146	{
5147	gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
5148	" FUNCTION", proc->name, &where);
5149	return false;
5150	}
5151
5152	if (!gfc_check_result_characteristics (s1: proc_target, s2: old_target,
5153	errmsg: err, err_len: sizeof(err)))
5154	{
5155	gfc_error ("Result mismatch for the overriding procedure "
5156	"%qs at %L: %s", proc->name, &where, err);
5157	return false;
5158	}
5159	}
5160
5161	/* If the overridden binding is PUBLIC, the overriding one must not be
5162	PRIVATE. */
5163	if (old->n.tb->access == ACCESS_PUBLIC
5164	&& proc->n.tb->access == ACCESS_PRIVATE)
5165	{
5166	gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
5167	" PRIVATE", proc->name, &where);
5168	return false;
5169	}
5170
5171	/* Compare the formal argument lists of both procedures. This is also abused
5172	to find the position of the passed-object dummy arguments of both
5173	bindings as at least the overridden one might not yet be resolved and we
5174	need those positions in the check below. */
5175	proc_pass_arg = old_pass_arg = 0;
5176	if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
5177	proc_pass_arg = 1;
5178	if (!old->n.tb->nopass && !old->n.tb->pass_arg)
5179	old_pass_arg = 1;
5180	argpos = 1;
5181	proc_formal = gfc_sym_get_dummy_args (proc_target);
5182	old_formal = gfc_sym_get_dummy_args (old_target);
5183	for ( ; proc_formal && old_formal;
5184	proc_formal = proc_formal->next, old_formal = old_formal->next)
5185	{
5186	if (proc->n.tb->pass_arg
5187	&& !strcmp (s1: proc->n.tb->pass_arg, s2: proc_formal->sym->name))
5188	proc_pass_arg = argpos;
5189	if (old->n.tb->pass_arg
5190	&& !strcmp (s1: old->n.tb->pass_arg, s2: old_formal->sym->name))
5191	old_pass_arg = argpos;
5192
5193	/* Check that the names correspond. */
5194	if (strcmp (s1: proc_formal->sym->name, s2: old_formal->sym->name))
5195	{
5196	gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
5197	" to match the corresponding argument of the overridden"
5198	" procedure", proc_formal->sym->name, proc->name, &where,
5199	old_formal->sym->name);
5200	return false;
5201	}
5202
5203	check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
5204	if (!gfc_check_dummy_characteristics (s1: proc_formal->sym, s2: old_formal->sym,
5205	type_must_agree: check_type, errmsg: err, err_len: sizeof(err)))
5206	{
5207	gfc_error_opt (opt: 0, "Argument mismatch for the overriding procedure "
5208	"%qs at %L: %s", proc->name, &where, err);
5209	return false;
5210	}
5211
5212	++argpos;
5213	}
5214	if (proc_formal || old_formal)
5215	{
5216	gfc_error ("%qs at %L must have the same number of formal arguments as"
5217	" the overridden procedure", proc->name, &where);
5218	return false;
5219	}
5220
5221	/* If the overridden binding is NOPASS, the overriding one must also be
5222	NOPASS. */
5223	if (old->n.tb->nopass && !proc->n.tb->nopass)
5224	{
5225	gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
5226	" NOPASS", proc->name, &where);
5227	return false;
5228	}
5229
5230	/* If the overridden binding is PASS(x), the overriding one must also be
5231	PASS and the passed-object dummy arguments must correspond. */
5232	if (!old->n.tb->nopass)
5233	{
5234	if (proc->n.tb->nopass)
5235	{
5236	gfc_error ("%qs at %L overrides a binding with PASS and must also be"
5237	" PASS", proc->name, &where);
5238	return false;
5239	}
5240
5241	if (proc_pass_arg != old_pass_arg)
5242	{
5243	gfc_error ("Passed-object dummy argument of %qs at %L must be at"
5244	" the same position as the passed-object dummy argument of"
5245	" the overridden procedure", proc->name, &where);
5246	return false;
5247	}
5248	}
5249
5250	return true;
5251	}
5252
5253
5254	/* The following three functions check that the formal arguments
5255	of user defined derived type IO procedures are compliant with
5256	the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
5257
5258	static void
5259	check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
5260	int kind, int rank, sym_intent intent)
5261	{
5262	if (fsym->ts.type != type)
5263	{
5264	gfc_error ("DTIO dummy argument at %L must be of type %s",
5265	&fsym->declared_at, gfc_basic_typename (type));
5266	return;
5267	}
5268
5269	if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
5270	&& fsym->ts.kind != kind)
5271	gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
5272	&fsym->declared_at, kind);
5273
5274	if (!typebound
5275	&& rank == 0
5276	&& (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
5277	|| ((type != BT_CLASS) && fsym->attr.dimension)))
5278	gfc_error ("DTIO dummy argument at %L must be a scalar",
5279	&fsym->declared_at);
5280	else if (rank == 1
5281	&& (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
5282	gfc_error ("DTIO dummy argument at %L must be an "
5283	"ASSUMED SHAPE ARRAY", &fsym->declared_at);
5284
5285	if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)
5286	gfc_error ("DTIO character argument at %L must have assumed length",
5287	&fsym->declared_at);
5288
5289	if (fsym->attr.intent != intent)
5290	gfc_error ("DTIO dummy argument at %L must have INTENT %s",
5291	&fsym->declared_at, gfc_code2string (intents, (int)intent));
5292	return;
5293	}
5294
5295
5296	static void
5297	check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
5298	bool typebound, bool formatted, int code)
5299	{
5300	gfc_symbol *dtio_sub, *generic_proc, *fsym;
5301	gfc_typebound_proc *tb_io_proc, *specific_proc;
5302	gfc_interface *intr;
5303	gfc_formal_arglist *formal;
5304	int arg_num;
5305
5306	bool read = ((dtio_codes)code == DTIO_RF)
5307	|| ((dtio_codes)code == DTIO_RUF);
5308	bt type;
5309	sym_intent intent;
5310	int kind;
5311
5312	dtio_sub = NULL;
5313	if (typebound)
5314	{
5315	/* Typebound DTIO binding. */
5316	tb_io_proc = tb_io_st->n.tb;
5317	if (tb_io_proc == NULL)
5318	return;
5319
5320	gcc_assert (tb_io_proc->is_generic);
5321
5322	specific_proc = tb_io_proc->u.generic->specific;
5323	if (specific_proc == NULL || specific_proc->is_generic)
5324	return;
5325
5326	dtio_sub = specific_proc->u.specific->n.sym;
5327	}
5328	else
5329	{
5330	generic_proc = tb_io_st->n.sym;
5331	if (generic_proc == NULL || generic_proc->generic == NULL)
5332	return;
5333
5334	for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
5335	{
5336	if (intr->sym && intr->sym->formal && intr->sym->formal->sym
5337	&& ((intr->sym->formal->sym->ts.type == BT_CLASS
5338	&& CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
5339	== derived)
5340	|| (intr->sym->formal->sym->ts.type == BT_DERIVED
5341	&& intr->sym->formal->sym->ts.u.derived == derived)))
5342	{
5343	dtio_sub = intr->sym;
5344	break;
5345	}
5346	else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
5347	{
5348	gfc_error ("Alternate return at %L is not permitted in a DTIO "
5349	"procedure", &intr->sym->declared_at);
5350	return;
5351	}
5352	}
5353
5354	if (dtio_sub == NULL)
5355	return;
5356	}
5357
5358	gcc_assert (dtio_sub);
5359	if (!dtio_sub->attr.subroutine)
5360	gfc_error ("DTIO procedure %qs at %L must be a subroutine",
5361	dtio_sub->name, &dtio_sub->declared_at);
5362
5363	if (!dtio_sub->resolve_symbol_called)
5364	gfc_resolve_formal_arglist (dtio_sub);
5365
5366	arg_num = 0;
5367	for (formal = dtio_sub->formal; formal; formal = formal->next)
5368	arg_num++;
5369
5370	if (arg_num < (formatted ? 6 : 4))
5371	{
5372	gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
5373	dtio_sub->name, &dtio_sub->declared_at);
5374	return;
5375	}
5376
5377	if (arg_num > (formatted ? 6 : 4))
5378	{
5379	gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
5380	dtio_sub->name, &dtio_sub->declared_at);
5381	return;
5382	}
5383
5384	/* Now go through the formal arglist. */
5385	arg_num = 1;
5386	for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
5387	{
5388	if (!formatted && arg_num == 3)
5389	arg_num = 5;
5390	fsym = formal->sym;
5391
5392	if (fsym == NULL)
5393	{
5394	gfc_error ("Alternate return at %L is not permitted in a DTIO "
5395	"procedure", &dtio_sub->declared_at);
5396	return;
5397	}
5398
5399	switch (arg_num)
5400	{
5401	case(1): /* DTV */
5402	type = derived->attr.sequence || derived->attr.is_bind_c ?
5403	BT_DERIVED : BT_CLASS;
5404	kind = 0;
5405	intent = read ? INTENT_INOUT : INTENT_IN;
5406	check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5407	rank: 0, intent);
5408	break;
5409
5410	case(2): /* UNIT */
5411	type = BT_INTEGER;
5412	kind = gfc_default_integer_kind;
5413	intent = INTENT_IN;
5414	check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5415	rank: 0, intent);
5416	break;
5417	case(3): /* IOTYPE */
5418	type = BT_CHARACTER;
5419	kind = gfc_default_character_kind;
5420	intent = INTENT_IN;
5421	check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5422	rank: 0, intent);
5423	break;
5424	case(4): /* VLIST */
5425	type = BT_INTEGER;
5426	kind = gfc_default_integer_kind;
5427	intent = INTENT_IN;
5428	check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5429	rank: 1, intent);
5430	break;
5431	case(5): /* IOSTAT */
5432	type = BT_INTEGER;
5433	kind = gfc_default_integer_kind;
5434	intent = INTENT_OUT;
5435	check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5436	rank: 0, intent);
5437	break;
5438	case(6): /* IOMSG */
5439	type = BT_CHARACTER;
5440	kind = gfc_default_character_kind;
5441	intent = INTENT_INOUT;
5442	check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5443	rank: 0, intent);
5444	break;
5445	default:
5446	gcc_unreachable ();
5447	}
5448	}
5449	derived->attr.has_dtio_procs = 1;
5450	return;
5451	}
5452
5453	void
5454	gfc_check_dtio_interfaces (gfc_symbol *derived)
5455	{
5456	gfc_symtree *tb_io_st;
5457	bool t = false;
5458	int code;
5459	bool formatted;
5460
5461	if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
5462	return;
5463
5464	/* Check typebound DTIO bindings. */
5465	for (code = 0; code < 4; code++)
5466	{
5467	formatted = ((dtio_codes)code == DTIO_RF)
5468	|| ((dtio_codes)code == DTIO_WF);
5469
5470	tb_io_st = gfc_find_typebound_proc (derived, &t,
5471	gfc_code2string (dtio_procs, code),
5472	true, &derived->declared_at);
5473	if (tb_io_st != NULL)
5474	check_dtio_interface1 (derived, tb_io_st, typebound: true, formatted, code);
5475	}
5476
5477	/* Check generic DTIO interfaces. */
5478	for (code = 0; code < 4; code++)
5479	{
5480	formatted = ((dtio_codes)code == DTIO_RF)
5481	|| ((dtio_codes)code == DTIO_WF);
5482
5483	tb_io_st = gfc_find_symtree (derived->ns->sym_root,
5484	gfc_code2string (dtio_procs, code));
5485	if (tb_io_st != NULL)
5486	check_dtio_interface1 (derived, tb_io_st, typebound: false, formatted, code);
5487	}
5488	}
5489
5490
5491	gfc_symtree*
5492	gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
5493	{
5494	gfc_symtree *tb_io_st = NULL;
5495	bool t = false;
5496
5497	if (!derived || !derived->resolve_symbol_called
5498	|| derived->attr.flavor != FL_DERIVED)
5499	return NULL;
5500
5501	/* Try to find a typebound DTIO binding. */
5502	if (formatted == true)
5503	{
5504	if (write == true)
5505	tb_io_st = gfc_find_typebound_proc (derived, &t,
5506	gfc_code2string (dtio_procs,
5507	DTIO_WF),
5508	true,
5509	&derived->declared_at);
5510	else
5511	tb_io_st = gfc_find_typebound_proc (derived, &t,
5512	gfc_code2string (dtio_procs,
5513	DTIO_RF),
5514	true,
5515	&derived->declared_at);
5516	}
5517	else
5518	{
5519	if (write == true)
5520	tb_io_st = gfc_find_typebound_proc (derived, &t,
5521	gfc_code2string (dtio_procs,
5522	DTIO_WUF),
5523	true,
5524	&derived->declared_at);
5525	else
5526	tb_io_st = gfc_find_typebound_proc (derived, &t,
5527	gfc_code2string (dtio_procs,
5528	DTIO_RUF),
5529	true,
5530	&derived->declared_at);
5531	}
5532	return tb_io_st;
5533	}
5534
5535
5536	gfc_symbol *
5537	gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
5538	{
5539	gfc_symtree *tb_io_st = NULL;
5540	gfc_symbol *dtio_sub = NULL;
5541	gfc_symbol *extended;
5542	gfc_typebound_proc *tb_io_proc, *specific_proc;
5543
5544	tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted);
5545
5546	if (tb_io_st != NULL)
5547	{
5548	const char *genname;
5549	gfc_symtree *st;
5550
5551	tb_io_proc = tb_io_st->n.tb;
5552	gcc_assert (tb_io_proc != NULL);
5553	gcc_assert (tb_io_proc->is_generic);
5554	gcc_assert (tb_io_proc->u.generic->next == NULL);
5555
5556	specific_proc = tb_io_proc->u.generic->specific;
5557	gcc_assert (!specific_proc->is_generic);
5558
5559	/* Go back and make sure that we have the right specific procedure.
5560	Here we most likely have a procedure from the parent type, which
5561	can be overridden in extensions. */
5562	genname = tb_io_proc->u.generic->specific_st->name;
5563	st = gfc_find_typebound_proc (derived, NULL, genname,
5564	true, &tb_io_proc->where);
5565	if (st)
5566	dtio_sub = st->n.tb->u.specific->n.sym;
5567	else
5568	dtio_sub = specific_proc->u.specific->n.sym;
5569
5570	goto finish;
5571	}
5572
5573	/* If there is not a typebound binding, look for a generic
5574	DTIO interface. */
5575	for (extended = derived; extended;
5576	extended = gfc_get_derived_super_type (extended))
5577	{
5578	if (extended == NULL || extended->ns == NULL
5579	|| extended->attr.flavor == FL_UNKNOWN)
5580	return NULL;
5581
5582	if (formatted == true)
5583	{
5584	if (write == true)
5585	tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5586	gfc_code2string (dtio_procs,
5587	DTIO_WF));
5588	else
5589	tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5590	gfc_code2string (dtio_procs,
5591	DTIO_RF));
5592	}
5593	else
5594	{
5595	if (write == true)
5596	tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5597	gfc_code2string (dtio_procs,
5598	DTIO_WUF));
5599	else
5600	tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5601	gfc_code2string (dtio_procs,
5602	DTIO_RUF));
5603	}
5604
5605	if (tb_io_st != NULL
5606	&& tb_io_st->n.sym
5607	&& tb_io_st->n.sym->generic)
5608	{
5609	for (gfc_interface *intr = tb_io_st->n.sym->generic;
5610	intr && intr->sym; intr = intr->next)
5611	{
5612	if (intr->sym->formal)
5613	{
5614	gfc_symbol *fsym = intr->sym->formal->sym;
5615	if ((fsym->ts.type == BT_CLASS
5616	&& CLASS_DATA (fsym)->ts.u.derived == extended)
5617	|| (fsym->ts.type == BT_DERIVED
5618	&& fsym->ts.u.derived == extended))
5619	{
5620	dtio_sub = intr->sym;
5621	break;
5622	}
5623	}
5624	}
5625	}
5626	}
5627
5628	finish:
5629	if (dtio_sub
5630	&& dtio_sub->formal->sym->ts.type == BT_CLASS
5631	&& derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
5632	gfc_find_derived_vtab (derived);
5633
5634	return dtio_sub;
5635	}
5636
5637	/* Helper function - if we do not find an interface for a procedure,
5638	construct it from the actual arglist. Luckily, this can only
5639	happen for call by reference, so the information we actually need
5640	to provide (and which would be impossible to guess from the call
5641	itself) is not actually needed. */
5642
5643	void
5644	gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
5645	gfc_actual_arglist *actual_args)
5646	{
5647	gfc_actual_arglist *a;
5648	gfc_formal_arglist **f;
5649	gfc_symbol *s;
5650	char name[GFC_MAX_SYMBOL_LEN + 1];
5651	static int var_num;
5652
5653	f = &sym->formal;
5654	for (a = actual_args; a != NULL; a = a->next)
5655	{
5656	(*f) = gfc_get_formal_arglist ();
5657	if (a->expr)
5658	{
5659	snprintf (s: name, GFC_MAX_SYMBOL_LEN, format: "_formal_%d", var_num ++);
5660	gfc_get_symbol (name, gfc_current_ns, &s);
5661	if (a->expr->ts.type == BT_PROCEDURE)
5662	{
5663	s->attr.flavor = FL_PROCEDURE;
5664	}
5665	else
5666	{
5667	s->ts = a->expr->ts;
5668
5669	if (s->ts.type == BT_CHARACTER)
5670	s->ts.u.cl = gfc_get_charlen ();
5671
5672	s->ts.deferred = 0;
5673	s->ts.is_iso_c = 0;
5674	s->ts.is_c_interop = 0;
5675	s->attr.flavor = FL_VARIABLE;
5676	if (a->expr->rank > 0)
5677	{
5678	s->attr.dimension = 1;
5679	s->as = gfc_get_array_spec ();
5680	s->as->rank = 1;
5681	s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5682	&a->expr->where, 1);
5683	s->as->upper[0] = NULL;
5684	s->as->type = AS_ASSUMED_SIZE;
5685	}
5686	else
5687	s->maybe_array = maybe_dummy_array_arg (e: a->expr);
5688	}
5689	s->attr.dummy = 1;
5690	s->attr.artificial = 1;
5691	s->declared_at = a->expr->where;
5692	s->attr.intent = INTENT_UNKNOWN;
5693	(*f)->sym = s;
5694	}
5695	else /* If a->expr is NULL, this is an alternate rerturn. */
5696	(*f)->sym = NULL;
5697
5698	f = &((*f)->next);
5699	}
5700	}
5701
5702
5703	const char *
5704	gfc_dummy_arg_get_name (gfc_dummy_arg & dummy_arg)
5705	{
5706	switch (dummy_arg.intrinsicness)
5707	{
5708	case GFC_INTRINSIC_DUMMY_ARG:
5709	return dummy_arg.u.intrinsic->name;
5710
5711	case GFC_NON_INTRINSIC_DUMMY_ARG:
5712	return dummy_arg.u.non_intrinsic->sym->name;
5713
5714	default:
5715	gcc_unreachable ();
5716	}
5717	}
5718
5719
5720	const gfc_typespec &
5721	gfc_dummy_arg_get_typespec (gfc_dummy_arg & dummy_arg)
5722	{
5723	switch (dummy_arg.intrinsicness)
5724	{
5725	case GFC_INTRINSIC_DUMMY_ARG:
5726	return dummy_arg.u.intrinsic->ts;
5727
5728	case GFC_NON_INTRINSIC_DUMMY_ARG:
5729	return dummy_arg.u.non_intrinsic->sym->ts;
5730
5731	default:
5732	gcc_unreachable ();
5733	}
5734	}
5735
5736
5737	bool
5738	gfc_dummy_arg_is_optional (gfc_dummy_arg & dummy_arg)
5739	{
5740	switch (dummy_arg.intrinsicness)
5741	{
5742	case GFC_INTRINSIC_DUMMY_ARG:
5743	return dummy_arg.u.intrinsic->optional;
5744
5745	case GFC_NON_INTRINSIC_DUMMY_ARG:
5746	return dummy_arg.u.non_intrinsic->sym->attr.optional;
5747
5748	default:
5749	gcc_unreachable ();
5750	}
5751	}
5752