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