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 22561822 : free_interface_elements_until (gfc_interface *intr, gfc_interface *end)
88 : {
89 22561822 : gfc_interface *next;
90 :
91 22762740 : for (; intr != end; intr = next)
92 : {
93 200918 : next = intr->next;
94 200918 : free (intr);
95 : }
96 0 : }
97 :
98 :
99 : /* Free a singly linked list of gfc_interface structures. */
100 :
101 : void
102 21846619 : gfc_free_interface (gfc_interface *intr)
103 : {
104 21846619 : free_interface_elements_until (intr, nullptr);
105 21846619 : }
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 9307431 : gfc_drop_interface_elements_before (gfc_interface **ifc_ptr,
115 : gfc_interface *tail)
116 : {
117 9307431 : if (ifc_ptr == nullptr)
118 : return;
119 :
120 715203 : free_interface_elements_until (*ifc_ptr, tail);
121 715203 : *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 3003 : 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 2989 : 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 410 : dtio_op (char* mode)
153 : {
154 410 : 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 30247 : gfc_match_generic_spec (interface_type *type,
168 : char *name,
169 : gfc_intrinsic_op *op)
170 : {
171 30247 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
172 30247 : match m;
173 30247 : gfc_intrinsic_op i;
174 :
175 30247 : if (gfc_match (" assignment ( = )") == MATCH_YES)
176 : {
177 580 : *type = INTERFACE_INTRINSIC_OP;
178 580 : *op = INTRINSIC_ASSIGN;
179 580 : return MATCH_YES;
180 : }
181 :
182 29667 : if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
183 : { /* Operator i/f */
184 770 : *type = INTERFACE_INTRINSIC_OP;
185 770 : *op = fold_unary_intrinsic (i);
186 770 : return MATCH_YES;
187 : }
188 :
189 28897 : *op = INTRINSIC_NONE;
190 28897 : if (gfc_match (" operator ( ") == MATCH_YES)
191 : {
192 368 : m = gfc_match_defined_op_name (buffer, 1);
193 368 : if (m == MATCH_NO)
194 0 : goto syntax;
195 368 : if (m != MATCH_YES)
196 : return MATCH_ERROR;
197 :
198 368 : m = gfc_match_char (')');
199 368 : if (m == MATCH_NO)
200 0 : goto syntax;
201 368 : if (m != MATCH_YES)
202 : return MATCH_ERROR;
203 :
204 368 : strcpy (name, buffer);
205 368 : *type = INTERFACE_USER_OP;
206 368 : return MATCH_YES;
207 : }
208 :
209 28529 : 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 28363 : if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
231 : {
232 244 : *op = dtio_op (buffer);
233 244 : if (*op == INTRINSIC_FORMATTED)
234 : {
235 203 : if (flag_default_integer)
236 1 : goto conflict;
237 202 : strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
238 202 : *type = INTERFACE_DTIO;
239 : }
240 243 : 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 243 : if (*op != INTRINSIC_NONE)
248 : return MATCH_YES;
249 : }
250 :
251 28119 : if (gfc_match_name (buffer) == MATCH_YES)
252 : {
253 22355 : strcpy (name, buffer);
254 22355 : *type = INTERFACE_GENERIC;
255 22355 : return MATCH_YES;
256 : }
257 :
258 5764 : *type = INTERFACE_NAMELESS;
259 5764 : 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 10893 : gfc_match_interface (void)
277 : {
278 10893 : char name[GFC_MAX_SYMBOL_LEN + 1];
279 10893 : interface_type type;
280 10893 : gfc_symbol *sym;
281 10893 : gfc_intrinsic_op op;
282 10893 : match m;
283 :
284 10893 : m = gfc_match_space ();
285 :
286 10893 : 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 10892 : if (gfc_match_eos () != MATCH_YES
292 10892 : || (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 10892 : current_interface.type = type;
300 :
301 10892 : switch (type)
302 : {
303 4420 : case INTERFACE_DTIO:
304 4420 : case INTERFACE_GENERIC:
305 4420 : if (gfc_get_symbol (name, NULL, &sym))
306 : return MATCH_ERROR;
307 :
308 4420 : if (!sym->attr.generic
309 4420 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
310 : return MATCH_ERROR;
311 :
312 4419 : 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 4419 : current_interface.sym = gfc_new_block = sym;
320 4419 : break;
321 :
322 156 : case INTERFACE_USER_OP:
323 156 : current_interface.uop = gfc_get_uop (name);
324 156 : break;
325 :
326 556 : case INTERFACE_INTRINSIC_OP:
327 556 : current_interface.op = op;
328 556 : 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 494 : gfc_match_abstract_interface (void)
344 : {
345 494 : match m;
346 :
347 494 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
348 : return MATCH_ERROR;
349 :
350 493 : m = gfc_match_eos ();
351 :
352 493 : 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 492 : current_interface.type = INTERFACE_ABSTRACT;
359 :
360 492 : 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 696 : gfc_match_end_interface (void)
369 : {
370 696 : char name[GFC_MAX_SYMBOL_LEN + 1];
371 696 : interface_type type;
372 696 : gfc_intrinsic_op op;
373 696 : match m;
374 :
375 696 : m = gfc_match_space ();
376 :
377 696 : 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 696 : if (gfc_match_eos () != MATCH_YES
383 696 : || (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 696 : m = MATCH_YES;
391 :
392 696 : 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 157 : case INTERFACE_INTRINSIC_OP:
405 157 : 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 15 : case INTERFACE_USER_OP:
454 : /* Comparing the symbol node names is OK because only use-associated
455 : symbols can be renamed. */
456 15 : if (type != current_interface.type
457 15 : || 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 524 : case INTERFACE_DTIO:
467 524 : case INTERFACE_GENERIC:
468 : /* If a use-associated symbol is renamed, check the local_name. */
469 524 : const char *local_name = current_interface.sym->name;
470 :
471 524 : 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 524 : if (type != current_interface.type
479 524 : || 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 11353 : 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 11353 : return cmp->ts.type == BT_UNION
502 11353 : || (cmp->ts.type == BT_DERIVED
503 4192 : && 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 627053 : 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 627053 : return derived->attr.flavor == FL_UNION
518 627053 : || (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 5840 : 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 5513 : if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
531 11068 : && strcmp (cmp1->name, cmp2->name) != 0)
532 : return false;
533 :
534 4977 : if (cmp1->attr.access != cmp2->attr.access)
535 : return false;
536 :
537 4976 : if (cmp1->attr.pointer != cmp2->attr.pointer)
538 : return false;
539 :
540 4976 : if (cmp1->attr.dimension != cmp2->attr.dimension)
541 : return false;
542 :
543 4842 : if (cmp1->attr.codimension != cmp2->attr.codimension)
544 : return false;
545 :
546 4842 : if (cmp1->attr.allocatable != cmp2->attr.allocatable)
547 : return false;
548 :
549 4842 : if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
550 : return false;
551 :
552 4438 : if (cmp1->attr.codimension
553 4438 : && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
554 : return false;
555 :
556 4438 : 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 1697 : if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
570 4208 : && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)
571 8641 : && !gfc_compare_types (&cmp1->ts, &cmp2->ts))
572 : return false;
573 :
574 4015 : else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
575 225 : && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
576 : return false;
577 :
578 4015 : else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
579 3790 : && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
580 0 : 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 651848 : gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
670 : {
671 651848 : gfc_component *cmp1, *cmp2;
672 :
673 651848 : if (derived1 == derived2)
674 : return true;
675 :
676 345703 : if (!derived1 || !derived2)
677 0 : gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
678 :
679 345703 : if (derived1->attr.unlimited_polymorphic
680 319 : && derived2->attr.unlimited_polymorphic)
681 : return true;
682 :
683 345398 : if (derived1->attr.unlimited_polymorphic
684 345398 : != derived2->attr.unlimited_polymorphic)
685 : return false;
686 :
687 : /* Compare UNION types specially. */
688 345279 : 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 344634 : if (strcmp (derived1->name, derived2->name) == 0
695 33597 : && derived1->module != NULL && derived2->module != NULL
696 31133 : && 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 312962 : if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
707 626698 : && strcmp (derived1->name, derived2->name) != 0)
708 : return false;
709 :
710 4538 : if (derived1->component_access == ACCESS_PRIVATE
711 4537 : || derived2->component_access == ACCESS_PRIVATE)
712 : return false;
713 :
714 4537 : if (!(derived1->attr.sequence && derived2->attr.sequence)
715 2796 : && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)
716 2783 : && !(derived1->attr.is_class && derived2->attr.is_class)
717 1791 : && !(derived1->attr.vtype && derived2->attr.vtype)
718 1543 : && !(derived1->attr.pdt_type && derived2->attr.pdt_type))
719 : return false;
720 :
721 : /* Protect against null components. */
722 2994 : if (derived1->attr.zero_comp != derived2->attr.zero_comp)
723 : return false;
724 :
725 2985 : if (derived1->attr.zero_comp)
726 : return true;
727 :
728 2985 : cmp1 = derived1->components;
729 2985 : 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 5231 : for (;;)
735 : {
736 5231 : if (!compare_components (cmp1, cmp2, derived1, derived2))
737 : return false;
738 :
739 3412 : cmp1 = cmp1->next;
740 3412 : cmp2 = cmp2->next;
741 :
742 3412 : if (cmp1 == NULL && cmp2 == NULL)
743 : break;
744 2252 : 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 7556181 : 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 7556181 : 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 7556128 : if ((ts1->type == BT_INTEGER
769 2016845 : && ts2->type == BT_DERIVED
770 5656 : && 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 7556043 : || (ts2->type == BT_INTEGER
775 2156391 : && ts1->type == BT_DERIVED
776 5212 : && 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 7555959 : if (ts1->type == BT_CLASS && ts1->u.derived->components
787 32962 : && ((ts1->u.derived->attr.is_class
788 32955 : && ts1->u.derived->components->ts.u.derived->attr
789 32955 : .unlimited_polymorphic)
790 27218 : || ts1->u.derived->attr.unlimited_polymorphic))
791 : return true;
792 :
793 : /* F2003: C717 */
794 7550215 : if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
795 1103 : && ts2->u.derived->components
796 1102 : && ((ts2->u.derived->attr.is_class
797 1100 : && ts2->u.derived->components->ts.u.derived->attr
798 1100 : .unlimited_polymorphic)
799 1055 : || ts2->u.derived->attr.unlimited_polymorphic)
800 47 : && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
801 : return true;
802 :
803 7550189 : if (ts1->type != ts2->type
804 1062903 : && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
805 72644 : || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
806 : return false;
807 :
808 6496558 : if (ts1->type == BT_UNION)
809 148 : return compare_union_types (ts1->u.derived, ts2->u.derived);
810 :
811 6496410 : if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
812 6204266 : return (ts1->kind == ts2->kind);
813 :
814 : /* Compare derived types. */
815 292144 : return gfc_type_compatible (ts1, ts2);
816 : }
817 :
818 :
819 : static bool
820 5315545 : compare_type (gfc_symbol *s1, gfc_symbol *s2)
821 : {
822 5315545 : if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
823 : return true;
824 :
825 5115097 : return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
826 : }
827 :
828 :
829 : static bool
830 312415 : 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 312415 : if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
835 312407 : || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
836 : return false;
837 :
838 312406 : return compare_type (s1, s2);
839 : }
840 :
841 :
842 : static bool
843 923011 : compare_rank (gfc_symbol *s1, gfc_symbol *s2)
844 : {
845 923011 : gfc_array_spec *as1, *as2;
846 923011 : int r1, r2;
847 :
848 923011 : if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
849 : return true;
850 :
851 718088 : as1 = (s1->ts.type == BT_CLASS
852 5175 : && !s1->ts.u.derived->attr.unlimited_polymorphic)
853 728434 : ? CLASS_DATA (s1)->as : s1->as;
854 718106 : as2 = (s2->ts.type == BT_CLASS
855 5157 : && !s2->ts.u.derived->attr.unlimited_polymorphic)
856 728416 : ? CLASS_DATA (s2)->as : s2->as;
857 :
858 723261 : r1 = as1 ? as1->rank : 0;
859 723261 : r2 = as2 ? as2->rank : 0;
860 :
861 723261 : if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
862 3862 : 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 4999832 : compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
874 : {
875 4999832 : 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 4881825 : compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
885 : {
886 4881825 : if (s1 == NULL || s2 == NULL)
887 120 : return (s1 == s2);
888 :
889 4881705 : if (s1 == s2)
890 : return true;
891 :
892 4881705 : if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
893 4881535 : return compare_type_rank (s1, s2);
894 :
895 170 : 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 34328 : find_keyword_arg (const char *name, gfc_formal_arglist *f)
928 : {
929 49586 : for (; f; f = f->next)
930 49586 : 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 3623 : gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
945 : locus opwhere)
946 : {
947 3623 : gfc_formal_arglist *formal;
948 3623 : sym_intent i1, i2;
949 3623 : bt t1, t2;
950 3623 : int args, r1, r2, k1, k2;
951 :
952 3623 : gcc_assert (sym);
953 :
954 3623 : args = 0;
955 3623 : t1 = t2 = BT_UNKNOWN;
956 3623 : i1 = i2 = INTENT_UNKNOWN;
957 3623 : r1 = r2 = -1;
958 3623 : k1 = k2 = -1;
959 :
960 10837 : for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
961 : {
962 7215 : gfc_symbol *fsym = formal->sym;
963 7215 : 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 7214 : if (args == 0)
970 : {
971 3623 : t1 = fsym->ts.type;
972 3623 : i1 = fsym->attr.intent;
973 3623 : r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
974 3623 : k1 = fsym->ts.kind;
975 : }
976 7214 : if (args == 1)
977 : {
978 3591 : t2 = fsym->ts.type;
979 3591 : i2 = fsym->attr.intent;
980 3591 : r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
981 3591 : k2 = fsym->ts.kind;
982 : }
983 7214 : args++;
984 : }
985 :
986 : /* Only +, - and .not. can be unary operators.
987 : .not. cannot be a binary operator. */
988 3622 : if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
989 30 : && op != INTRINSIC_MINUS
990 30 : && op != INTRINSIC_NOT)
991 3621 : || (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 : return false;
1000 : }
1001 :
1002 : /* Check that intrinsics are mapped to functions, except
1003 : INTRINSIC_ASSIGN which should map to a subroutine. */
1004 3621 : if (op == INTRINSIC_ASSIGN)
1005 : {
1006 1409 : gfc_formal_arglist *dummy_args;
1007 :
1008 1409 : 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 1408 : dummy_args = gfc_sym_get_dummy_args (sym);
1021 1408 : if (dummy_args->sym->ts.type != BT_DERIVED
1022 1177 : && dummy_args->sym->ts.type != BT_CLASS
1023 94 : && (r2 == 0 || r1 == r2)
1024 1497 : && (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 2212 : 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 3614 : if (op == INTRINSIC_ASSIGN)
1045 : {
1046 1403 : 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 1403 : 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 2211 : 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 2211 : 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 3614 : if (op == INTRINSIC_NOT)
1093 : {
1094 5 : if (t1 == BT_LOGICAL)
1095 0 : goto bad_repl;
1096 : else
1097 : return true;
1098 : }
1099 :
1100 3609 : 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 3584 : 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 3584 : if (r1 != r2 && r1 != 0 && r2 != 0)
1118 : return true;
1119 :
1120 3518 : 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 1748 : case INTRINSIC_PLUS:
1131 1748 : case INTRINSIC_MINUS:
1132 1748 : case INTRINSIC_TIMES:
1133 1748 : case INTRINSIC_DIVIDE:
1134 1748 : case INTRINSIC_POWER:
1135 1748 : 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 897732 : count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
1193 : const char *p1, const char *p2)
1194 : {
1195 897732 : int ac1, ac2, i, j, k, n1;
1196 897732 : gfc_formal_arglist *f;
1197 :
1198 897732 : typedef struct
1199 : {
1200 : int flag;
1201 : gfc_symbol *sym;
1202 : }
1203 : arginfo;
1204 :
1205 897732 : arginfo *arg;
1206 :
1207 897732 : n1 = 0;
1208 :
1209 2540442 : for (f = f1; f; f = f->next)
1210 1642710 : n1++;
1211 :
1212 : /* Build an array of integers that gives the same integer to
1213 : arguments of the same type/rank. */
1214 897732 : arg = XCNEWVEC (arginfo, n1);
1215 :
1216 897732 : f = f1;
1217 3438174 : for (i = 0; i < n1; i++, f = f->next)
1218 : {
1219 1642710 : arg[i].flag = -1;
1220 1642710 : arg[i].sym = f->sym;
1221 : }
1222 :
1223 : k = 0;
1224 :
1225 2540442 : for (i = 0; i < n1; i++)
1226 : {
1227 1642710 : if (arg[i].flag != -1)
1228 276314 : continue;
1229 :
1230 1366396 : if (arg[i].sym && (arg[i].sym->attr.optional
1231 1366207 : || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
1232 505 : continue; /* Skip OPTIONAL and PASS arguments. */
1233 :
1234 1365891 : arg[i].flag = k;
1235 :
1236 : /* Find other non-optional, non-pass arguments of the same type/rank. */
1237 2127742 : for (j = i + 1; j < n1; j++)
1238 761851 : if ((arg[j].sym == NULL
1239 761819 : || !(arg[j].sym->attr.optional
1240 188 : || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
1241 1523312 : && (compare_type_rank_if (arg[i].sym, arg[j].sym)
1242 575251 : || compare_type_rank_if (arg[j].sym, arg[i].sym)))
1243 276314 : arg[j].flag = k;
1244 :
1245 1365891 : k++;
1246 : }
1247 :
1248 : /* Now loop over each distinct type found in f1. */
1249 : k = 0;
1250 1218583 : bool rc = false;
1251 :
1252 1218583 : for (i = 0; i < n1; i++)
1253 : {
1254 1115103 : if (arg[i].flag != k)
1255 48262 : continue;
1256 :
1257 1066841 : ac1 = 1;
1258 1828431 : for (j = i + 1; j < n1; j++)
1259 761590 : if (arg[j].flag == k)
1260 276293 : 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 3022958 : for (f = f2; f; f = f->next)
1267 627 : if ((!p2 || strcmp (f->sym->name, p2) != 0)
1268 1956388 : && (compare_type_rank_if (arg[i].sym, f->sym)
1269 1589320 : || compare_type_rank_if (f->sym, arg[i].sym)))
1270 441309 : ac2++;
1271 :
1272 1066841 : if (ac1 > ac2)
1273 : {
1274 : rc = true;
1275 : break;
1276 : }
1277 :
1278 272589 : k++;
1279 : }
1280 :
1281 897732 : free (arg);
1282 :
1283 897732 : 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 31329 : compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2)
1294 : {
1295 : /* Is s1 allocatable? */
1296 31329 : const bool a1 = s1->ts.type == BT_CLASS ?
1297 31329 : CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable;
1298 : /* Is s2 a pointer? */
1299 31329 : const bool p2 = s2->ts.type == BT_CLASS ?
1300 31329 : CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer;
1301 31329 : 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 34378 : generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
1328 : const char *p1, const char *p2)
1329 : {
1330 34378 : gfc_formal_arglist *f2_save, *g;
1331 34378 : gfc_symbol *sym;
1332 :
1333 34378 : f2_save = f2;
1334 :
1335 49704 : while (f1)
1336 : {
1337 49654 : if (!f1->sym || f1->sym->attr.optional)
1338 4 : goto next;
1339 :
1340 49650 : if (p1 && strcmp (f1->sym->name, p1) == 0)
1341 7 : f1 = f1->next;
1342 49650 : if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
1343 5 : f2 = f2->next;
1344 :
1345 49646 : if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
1346 34319 : || compare_type_rank (f2->sym, f1->sym))
1347 64980 : && !((gfc_option.allow_std & GFC_STD_F2008)
1348 15330 : && (compare_ptr_alloc(f1->sym, f2->sym)
1349 15323 : || compare_ptr_alloc(f2->sym, f1->sym))))
1350 15318 : goto next;
1351 :
1352 : /* Now search for a disambiguating keyword argument starting at
1353 : the current non-match. */
1354 34332 : for (g = f1; g; g = g->next)
1355 : {
1356 34328 : if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
1357 0 : continue;
1358 :
1359 34328 : sym = find_keyword_arg (g->sym->name, f2_save);
1360 34328 : if (sym == NULL || !compare_type_rank (g->sym, sym)
1361 34342 : || ((gfc_option.allow_std & GFC_STD_F2008)
1362 14 : && (compare_ptr_alloc(sym, g->sym)
1363 7 : || compare_ptr_alloc(g->sym, sym))))
1364 : return true;
1365 : }
1366 :
1367 15326 : next:
1368 15326 : if (f1 != NULL)
1369 15322 : f1 = f1->next;
1370 15326 : if (f2 != NULL)
1371 15322 : f2 = f2->next;
1372 : }
1373 :
1374 : return false;
1375 : }
1376 :
1377 :
1378 : int
1379 573134 : gfc_symbol_rank (gfc_symbol *sym)
1380 : {
1381 573134 : gfc_array_spec *as = NULL;
1382 :
1383 573134 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
1384 17379 : as = CLASS_DATA (sym)->as;
1385 : else
1386 555755 : as = sym->as;
1387 :
1388 573134 : 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 127705 : gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1397 : bool type_must_agree, char *errmsg,
1398 : int err_len)
1399 : {
1400 127705 : if (s1 == NULL || s2 == NULL)
1401 27 : return s1 == s2;
1402 :
1403 127678 : 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 127677 : if (type_must_agree)
1411 : {
1412 126508 : if (!compare_type_characteristics (s1, s2)
1413 126508 : || !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 126484 : if (!compare_rank (s1, s2))
1421 : {
1422 5 : snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
1423 : s1->name, gfc_symbol_rank (s1), gfc_symbol_rank (s2));
1424 5 : 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 127648 : if (!s1->attr.artificial && !s2->attr.artificial)
1432 : {
1433 : /* Check INTENT. */
1434 100572 : 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 100567 : 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 100566 : 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 100566 : 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 100566 : 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 100566 : 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 100565 : 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 100564 : 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 100563 : 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 127638 : if (s1->attr.flavor == FL_PROCEDURE)
1508 : {
1509 129 : char err[200];
1510 129 : 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 127637 : if (s1->ts.type == BT_CHARACTER
1521 2801 : && s1->ts.u.cl && s1->ts.u.cl->length
1522 897 : && s2->ts.u.cl && s2->ts.u.cl->length)
1523 : {
1524 897 : int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1525 : s2->ts.u.cl->length);
1526 897 : 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 127637 : if (s1->as && s2->as)
1553 : {
1554 22292 : int i, compval;
1555 22292 : gfc_expr *shape1, *shape2;
1556 :
1557 22292 : if (s1->as->rank != s2->as->rank)
1558 : {
1559 2 : snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
1560 : s1->name, s1->as->rank, s2->as->rank);
1561 2 : return false;
1562 : }
1563 :
1564 : /* Sometimes the ambiguity between deferred shape and assumed shape
1565 : does not get resolved in module procedures, where the only explicit
1566 : declaration of the dummy is in the interface. */
1567 22290 : if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure
1568 114 : && s1->as->type == AS_ASSUMED_SHAPE
1569 67 : && s2->as->type == AS_DEFERRED)
1570 : {
1571 7 : s2->as->type = AS_ASSUMED_SHAPE;
1572 14 : for (i = 0; i < s2->as->rank; i++)
1573 7 : if (s1->as->lower[i] != NULL)
1574 7 : s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]);
1575 : }
1576 :
1577 22290 : if (s1->as->type != s2->as->type
1578 4 : && !(s1->as->type == AS_DEFERRED
1579 : && s2->as->type == AS_ASSUMED_SHAPE))
1580 : {
1581 2 : snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1582 : s1->name);
1583 2 : return false;
1584 : }
1585 :
1586 22288 : if (s1->as->corank != s2->as->corank)
1587 : {
1588 1 : snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
1589 : s1->name, s1->as->corank, s2->as->corank);
1590 1 : return false;
1591 : }
1592 :
1593 22287 : if (s1->as->type == AS_EXPLICIT)
1594 3891 : for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++)
1595 : {
1596 2096 : shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1597 2096 : gfc_copy_expr (s1->as->lower[i]));
1598 2096 : shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1599 2096 : gfc_copy_expr (s2->as->lower[i]));
1600 2096 : compval = gfc_dep_compare_expr (shape1, shape2);
1601 2096 : gfc_free_expr (shape1);
1602 2096 : gfc_free_expr (shape2);
1603 2096 : switch (compval)
1604 : {
1605 2 : case -1:
1606 2 : case 1:
1607 2 : case -3:
1608 2 : if (i < s1->as->rank)
1609 2 : snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
1610 : " argument '%s'", i + 1, s1->name);
1611 : else
1612 0 : snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
1613 0 : "of argument '%s'", i - s1->as->rank + 1, s1->name);
1614 : return false;
1615 :
1616 : case -2:
1617 : /* FIXME: Implement a warning for this case.
1618 : gfc_warning (0, "Possible shape mismatch in argument %qs",
1619 : s1->name);*/
1620 : break;
1621 :
1622 : case 0:
1623 : break;
1624 :
1625 0 : default:
1626 0 : gfc_internal_error ("check_dummy_characteristics: Unexpected "
1627 : "result %i of gfc_dep_compare_expr",
1628 : compval);
1629 2094 : break;
1630 : }
1631 : }
1632 : }
1633 :
1634 : return true;
1635 : }
1636 :
1637 :
1638 : /* Check if the characteristics of two function results match,
1639 : cf. F08:12.3.3. */
1640 :
1641 : bool
1642 59689 : gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1643 : char *errmsg, int err_len)
1644 : {
1645 59689 : gfc_symbol *r1, *r2;
1646 :
1647 59689 : if (s1->ts.interface && s1->ts.interface->result)
1648 : r1 = s1->ts.interface->result;
1649 : else
1650 59218 : r1 = s1->result ? s1->result : s1;
1651 :
1652 59689 : if (s2->ts.interface && s2->ts.interface->result)
1653 : r2 = s2->ts.interface->result;
1654 : else
1655 59220 : r2 = s2->result ? s2->result : s2;
1656 :
1657 59689 : if (r1->ts.type == BT_UNKNOWN)
1658 : return true;
1659 :
1660 : /* Check type and rank. */
1661 59421 : if (!compare_type_characteristics (r1, r2))
1662 : {
1663 21 : snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
1664 : gfc_typename (&r1->ts), gfc_typename (&r2->ts));
1665 21 : return false;
1666 : }
1667 59400 : if (!compare_rank (r1, r2))
1668 : {
1669 5 : snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
1670 : gfc_symbol_rank (r1), gfc_symbol_rank (r2));
1671 5 : return false;
1672 : }
1673 :
1674 : /* Check ALLOCATABLE attribute. */
1675 59395 : if (r1->attr.allocatable != r2->attr.allocatable)
1676 : {
1677 2 : snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1678 : "function result");
1679 2 : return false;
1680 : }
1681 :
1682 : /* Check POINTER attribute. */
1683 59393 : if (r1->attr.pointer != r2->attr.pointer)
1684 : {
1685 2 : snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1686 : "function result");
1687 2 : return false;
1688 : }
1689 :
1690 : /* Check CONTIGUOUS attribute. */
1691 59391 : if (r1->attr.contiguous != r2->attr.contiguous)
1692 : {
1693 1 : snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1694 : "function result");
1695 1 : return false;
1696 : }
1697 :
1698 : /* Check PROCEDURE POINTER attribute. */
1699 59390 : if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1700 : {
1701 3 : snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1702 : "function result");
1703 3 : return false;
1704 : }
1705 :
1706 : /* Check string length. */
1707 59387 : if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1708 : {
1709 2235 : if (r1->ts.deferred != r2->ts.deferred)
1710 : {
1711 0 : snprintf (errmsg, err_len, "Character length mismatch "
1712 : "in function result");
1713 0 : return false;
1714 : }
1715 :
1716 2235 : if (r1->ts.u.cl->length && r2->ts.u.cl->length)
1717 : {
1718 1647 : int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1719 : r2->ts.u.cl->length);
1720 1647 : switch (compval)
1721 : {
1722 3 : case -1:
1723 3 : case 1:
1724 3 : case -3:
1725 3 : snprintf (errmsg, err_len, "Character length mismatch "
1726 : "in function result");
1727 3 : return false;
1728 :
1729 75 : case -2:
1730 75 : if (r1->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1731 : {
1732 0 : snprintf (errmsg, err_len,
1733 : "Function declared with a non-constant character "
1734 : "length referenced with a constant length");
1735 0 : return false;
1736 : }
1737 75 : else if (r2->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1738 : {
1739 3 : snprintf (errmsg, err_len,
1740 : "Function declared with a constant character "
1741 : "length referenced with a non-constant length");
1742 3 : return false;
1743 : }
1744 : /* Warn if length expression types are different, except for
1745 : possibly false positives where complex expressions might have
1746 : been used. */
1747 72 : else if ((r1->ts.u.cl->length->expr_type
1748 : != r2->ts.u.cl->length->expr_type)
1749 4 : && (r1->ts.u.cl->length->expr_type != EXPR_OP
1750 2 : || r2->ts.u.cl->length->expr_type != EXPR_OP))
1751 4 : gfc_warning (0, "Possible character length mismatch in "
1752 : "function result between %L and %L",
1753 : &r1->declared_at, &r2->declared_at);
1754 : break;
1755 :
1756 : case 0:
1757 : break;
1758 :
1759 0 : default:
1760 0 : gfc_internal_error ("check_result_characteristics (1): Unexpected "
1761 : "result %i of gfc_dep_compare_expr", compval);
1762 : break;
1763 : }
1764 : }
1765 : }
1766 :
1767 : /* Check array shape. */
1768 59381 : if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1769 : {
1770 989 : int i, compval;
1771 989 : gfc_expr *shape1, *shape2;
1772 :
1773 989 : if (r1->as->type != r2->as->type)
1774 : {
1775 0 : snprintf (errmsg, err_len, "Shape mismatch in function result");
1776 0 : return false;
1777 : }
1778 :
1779 989 : if (r1->as->type == AS_EXPLICIT)
1780 2493 : for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1781 : {
1782 1505 : shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1783 1505 : gfc_copy_expr (r1->as->lower[i]));
1784 1505 : shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1785 1505 : gfc_copy_expr (r2->as->lower[i]));
1786 1505 : compval = gfc_dep_compare_expr (shape1, shape2);
1787 1505 : gfc_free_expr (shape1);
1788 1505 : gfc_free_expr (shape2);
1789 1505 : switch (compval)
1790 : {
1791 1 : case -1:
1792 1 : case 1:
1793 1 : case -3:
1794 1 : snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1795 : "function result", i + 1);
1796 1 : return false;
1797 :
1798 : case -2:
1799 : /* FIXME: Implement a warning for this case.
1800 : gfc_warning (0, "Possible shape mismatch in return value");*/
1801 : break;
1802 :
1803 : case 0:
1804 : break;
1805 :
1806 0 : default:
1807 0 : gfc_internal_error ("check_result_characteristics (2): "
1808 : "Unexpected result %i of "
1809 : "gfc_dep_compare_expr", compval);
1810 1504 : break;
1811 : }
1812 : }
1813 : }
1814 :
1815 : return true;
1816 : }
1817 :
1818 :
1819 : /* 'Compare' two formal interfaces associated with a pair of symbols.
1820 : We return true if there exists an actual argument list that
1821 : would be ambiguous between the two interfaces, zero otherwise.
1822 : 'strict_flag' specifies whether all the characteristics are
1823 : required to match, which is not the case for ambiguity checks.
1824 : 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1825 :
1826 : bool
1827 895740 : gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1828 : int generic_flag, int strict_flag,
1829 : char *errmsg, int err_len,
1830 : const char *p1, const char *p2,
1831 : bool *bad_result_characteristics)
1832 : {
1833 895740 : gfc_formal_arglist *f1, *f2;
1834 :
1835 895740 : gcc_assert (name2 != NULL);
1836 :
1837 895740 : if (bad_result_characteristics)
1838 15001 : *bad_result_characteristics = false;
1839 :
1840 895740 : if (s1->attr.function && (s2->attr.subroutine
1841 797348 : || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1842 5 : && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1843 : {
1844 3 : if (errmsg != NULL)
1845 3 : snprintf (errmsg, err_len, "'%s' is not a function", name2);
1846 : return false;
1847 : }
1848 :
1849 895737 : if (s1->attr.subroutine && s2->attr.function)
1850 : {
1851 6 : if (errmsg != NULL)
1852 6 : snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1853 : return false;
1854 : }
1855 :
1856 895731 : if (s2->attr.subroutine && s1->attr.flavor == FL_VARIABLE)
1857 : {
1858 2 : if (errmsg != NULL)
1859 2 : snprintf (errmsg, err_len, "subroutine proc pointer '%s' passed "
1860 : "to dummy variable '%s'", name2, s1->name);
1861 : return false;
1862 : }
1863 :
1864 : /* Do strict checks on all characteristics
1865 : (for dummy procedures and procedure pointer assignments). */
1866 895729 : if (!generic_flag && strict_flag)
1867 : {
1868 64126 : if (s1->attr.function && s2->attr.function)
1869 : {
1870 : /* If both are functions, check result characteristics. */
1871 29300 : if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
1872 29300 : || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
1873 : {
1874 30 : if (bad_result_characteristics)
1875 6 : *bad_result_characteristics = true;
1876 : return false;
1877 : }
1878 : }
1879 :
1880 64096 : if (s1->attr.pure && !s2->attr.pure)
1881 : {
1882 2 : snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1883 2 : return false;
1884 : }
1885 64094 : if (s1->attr.elemental && !s2->attr.elemental)
1886 : {
1887 0 : snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1888 0 : return false;
1889 : }
1890 : }
1891 :
1892 895697 : if (s1->attr.if_source == IFSRC_UNKNOWN
1893 879994 : || s2->attr.if_source == IFSRC_UNKNOWN)
1894 : return true;
1895 :
1896 879918 : f1 = gfc_sym_get_dummy_args (s1);
1897 879918 : f2 = gfc_sym_get_dummy_args (s2);
1898 :
1899 : /* Special case: No arguments. */
1900 879918 : if (f1 == NULL && f2 == NULL)
1901 : return true;
1902 :
1903 877796 : if (generic_flag)
1904 : {
1905 828608 : if (count_types_test (f1, f2, p1, p2)
1906 828608 : || count_types_test (f2, f1, p2, p1))
1907 : return false;
1908 :
1909 : /* Special case: alternate returns. If both f1->sym and f2->sym are
1910 : NULL, then the leading formal arguments are alternate returns.
1911 : The previous conditional should catch argument lists with
1912 : different number of argument. */
1913 34356 : if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
1914 : return true;
1915 :
1916 34353 : if (generic_correspondence (f1, f2, p1, p2)
1917 34353 : || generic_correspondence (f2, f1, p2, p1))
1918 34328 : return false;
1919 : }
1920 : else
1921 : /* Perform the abbreviated correspondence test for operators (the
1922 : arguments cannot be optional and are always ordered correctly).
1923 : This is also done when comparing interfaces for dummy procedures and in
1924 : procedure pointer assignments. */
1925 :
1926 174714 : for (; f1 || f2; f1 = f1->next, f2 = f2->next)
1927 : {
1928 : /* Check existence. */
1929 128558 : if (f1 == NULL || f2 == NULL)
1930 : {
1931 11 : if (errmsg != NULL)
1932 7 : snprintf (errmsg, err_len, "'%s' has the wrong number of "
1933 : "arguments", name2);
1934 : return false;
1935 : }
1936 :
1937 128547 : if (strict_flag)
1938 : {
1939 : /* Check all characteristics. */
1940 125240 : if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
1941 : errmsg, err_len))
1942 : return false;
1943 : }
1944 : else
1945 : {
1946 : /* Operators: Only check type and rank of arguments. */
1947 3307 : if (!compare_type (f2->sym, f1->sym))
1948 : {
1949 2975 : if (errmsg != NULL)
1950 0 : snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
1951 0 : "(%s/%s)", f1->sym->name,
1952 0 : gfc_typename (&f1->sym->ts),
1953 0 : gfc_typename (&f2->sym->ts));
1954 : return false;
1955 : }
1956 332 : if (!compare_rank (f2->sym, f1->sym))
1957 : {
1958 4 : if (errmsg != NULL)
1959 0 : snprintf (errmsg, err_len, "Rank mismatch in argument "
1960 0 : "'%s' (%i/%i)", f1->sym->name,
1961 0 : gfc_symbol_rank (f1->sym), gfc_symbol_rank (f2->sym));
1962 : return false;
1963 : }
1964 328 : if ((gfc_option.allow_std & GFC_STD_F2008)
1965 328 : && (compare_ptr_alloc(f1->sym, f2->sym)
1966 327 : || compare_ptr_alloc(f2->sym, f1->sym)))
1967 : {
1968 2 : if (errmsg != NULL)
1969 0 : snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE "
1970 : "attribute in argument '%s' ", f1->sym->name);
1971 : return false;
1972 : }
1973 : }
1974 : }
1975 :
1976 : return true;
1977 : }
1978 :
1979 :
1980 : /* Given a pointer to an interface pointer, remove duplicate
1981 : interfaces and make sure that all symbols are either functions
1982 : or subroutines, and all of the same kind. Returns true if
1983 : something goes wrong. */
1984 :
1985 : static bool
1986 9917775 : check_interface0 (gfc_interface *p, const char *interface_name)
1987 : {
1988 9917775 : gfc_interface *psave, *q, *qlast;
1989 :
1990 9917775 : psave = p;
1991 10123850 : for (; p; p = p->next)
1992 : {
1993 : /* Make sure all symbols in the interface have been defined as
1994 : functions or subroutines. */
1995 206091 : if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1996 168252 : || !p->sym->attr.if_source)
1997 37842 : && !gfc_fl_struct (p->sym->attr.flavor))
1998 : {
1999 12 : const char *guessed
2000 12 : = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
2001 :
2002 12 : if (p->sym->attr.external)
2003 5 : if (guessed)
2004 5 : gfc_error ("Procedure %qs in %s at %L has no explicit interface"
2005 : "; did you mean %qs?",
2006 : p->sym->name, interface_name, &p->sym->declared_at,
2007 : guessed);
2008 : else
2009 0 : gfc_error ("Procedure %qs in %s at %L has no explicit interface",
2010 : p->sym->name, interface_name, &p->sym->declared_at);
2011 : else
2012 7 : if (guessed)
2013 4 : gfc_error ("Procedure %qs in %s at %L is neither function nor "
2014 : "subroutine; did you mean %qs?", p->sym->name,
2015 : interface_name, &p->sym->declared_at, guessed);
2016 : else
2017 3 : gfc_error ("Procedure %qs in %s at %L is neither function nor "
2018 : "subroutine", p->sym->name, interface_name,
2019 : &p->sym->declared_at);
2020 : return true;
2021 : }
2022 :
2023 : /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
2024 206079 : if ((psave->sym->attr.function && !p->sym->attr.function
2025 306 : && !gfc_fl_struct (p->sym->attr.flavor))
2026 206077 : || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
2027 : {
2028 3 : if (!gfc_fl_struct (p->sym->attr.flavor))
2029 3 : gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
2030 : " or all FUNCTIONs", interface_name,
2031 : &p->sym->declared_at);
2032 0 : else if (p->sym->attr.flavor == FL_DERIVED)
2033 0 : gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
2034 : "generic name is also the name of a derived type",
2035 : interface_name, &p->sym->declared_at);
2036 : return true;
2037 : }
2038 :
2039 : /* F2003, C1207. F2008, C1207. */
2040 206076 : if (p->sym->attr.proc == PROC_INTERNAL
2041 206076 : && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
2042 : "%qs in %s at %L", p->sym->name,
2043 : interface_name, &p->sym->declared_at))
2044 : return true;
2045 : }
2046 : p = psave;
2047 :
2048 : /* Remove duplicate interfaces in this interface list. */
2049 10118786 : for (; p; p = p->next)
2050 : {
2051 201027 : qlast = p;
2052 :
2053 633361 : for (q = p->next; q;)
2054 : {
2055 432334 : if (p->sym != q->sym)
2056 : {
2057 427290 : qlast = q;
2058 427290 : q = q->next;
2059 : }
2060 : else
2061 : {
2062 : /* Duplicate interface. */
2063 5044 : qlast->next = q->next;
2064 5044 : free (q);
2065 5044 : q = qlast->next;
2066 : }
2067 : }
2068 : }
2069 :
2070 : return false;
2071 : }
2072 :
2073 :
2074 : /* Check lists of interfaces to make sure that no two interfaces are
2075 : ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
2076 :
2077 : static bool
2078 17951666 : check_interface1 (gfc_interface *p, gfc_interface *q0,
2079 : int generic_flag, const char *interface_name,
2080 : bool referenced)
2081 : {
2082 17951666 : gfc_interface *q;
2083 18155896 : for (; p; p = p->next)
2084 1236890 : for (q = q0; q; q = q->next)
2085 : {
2086 1032660 : if (p->sym == q->sym)
2087 200989 : continue; /* Duplicates OK here. */
2088 :
2089 831671 : if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
2090 128 : continue;
2091 :
2092 831543 : if (!gfc_fl_struct (p->sym->attr.flavor)
2093 831197 : && !gfc_fl_struct (q->sym->attr.flavor)
2094 830855 : && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
2095 : generic_flag, 0, NULL, 0, NULL, NULL))
2096 : {
2097 30 : if (referenced)
2098 27 : gfc_error ("Ambiguous interfaces in %s for %qs at %L "
2099 : "and %qs at %L", interface_name,
2100 27 : q->sym->name, &q->sym->declared_at,
2101 27 : p->sym->name, &p->sym->declared_at);
2102 3 : else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
2103 1 : gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
2104 : "and %qs at %L", interface_name,
2105 : q->sym->name, &q->sym->declared_at,
2106 : p->sym->name, &p->sym->declared_at);
2107 : else
2108 2 : gfc_warning (0, "Although not referenced, %qs has ambiguous "
2109 : "interfaces at %L", interface_name, &p->where);
2110 : return true;
2111 : }
2112 : }
2113 : return false;
2114 : }
2115 :
2116 :
2117 : /* Check the generic and operator interfaces of symbols to make sure
2118 : that none of the interfaces conflict. The check has to be done
2119 : after all of the symbols are actually loaded. */
2120 :
2121 : static void
2122 1961291 : check_sym_interfaces (gfc_symbol *sym)
2123 : {
2124 : /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */
2125 1961291 : char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")];
2126 1961291 : gfc_interface *p;
2127 :
2128 1961291 : if (sym->ns != gfc_current_ns)
2129 62865 : return;
2130 :
2131 1898444 : if (sym->generic != NULL)
2132 : {
2133 85465 : size_t len = strlen (sym->name) + sizeof("generic interface ''");
2134 85465 : gcc_assert (len < sizeof (interface_name));
2135 85465 : sprintf (interface_name, "generic interface '%s'", sym->name);
2136 85465 : if (check_interface0 (sym->generic, interface_name))
2137 : return;
2138 :
2139 282485 : for (p = sym->generic; p; p = p->next)
2140 : {
2141 197038 : if (p->sym->attr.mod_proc
2142 1224 : && !p->sym->attr.module_procedure
2143 1218 : && (p->sym->attr.if_source != IFSRC_DECL
2144 1214 : || p->sym->attr.procedure))
2145 : {
2146 4 : gfc_error ("%qs at %L is not a module procedure",
2147 : p->sym->name, &p->where);
2148 4 : return;
2149 : }
2150 : }
2151 :
2152 : /* Originally, this test was applied to host interfaces too;
2153 : this is incorrect since host associated symbols, from any
2154 : source, cannot be ambiguous with local symbols. */
2155 85447 : check_interface1 (sym->generic, sym->generic, 1, interface_name,
2156 85447 : sym->attr.referenced || !sym->attr.use_assoc);
2157 : }
2158 : }
2159 :
2160 :
2161 : static void
2162 403 : check_uop_interfaces (gfc_user_op *uop)
2163 : {
2164 403 : char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")];
2165 403 : gfc_user_op *uop2;
2166 403 : gfc_namespace *ns;
2167 :
2168 403 : sprintf (interface_name, "operator interface '%s'", uop->name);
2169 403 : if (check_interface0 (uop->op, interface_name))
2170 2 : return;
2171 :
2172 840 : for (ns = gfc_current_ns; ns; ns = ns->parent)
2173 : {
2174 439 : uop2 = gfc_find_uop (uop->name, ns);
2175 439 : if (uop2 == NULL)
2176 22 : continue;
2177 :
2178 417 : check_interface1 (uop->op, uop2->op, 0,
2179 : interface_name, true);
2180 : }
2181 : }
2182 :
2183 : /* Given an intrinsic op, return an equivalent op if one exists,
2184 : or INTRINSIC_NONE otherwise. */
2185 :
2186 : gfc_intrinsic_op
2187 12368707 : gfc_equivalent_op (gfc_intrinsic_op op)
2188 : {
2189 12368707 : switch(op)
2190 : {
2191 : case INTRINSIC_EQ:
2192 : return INTRINSIC_EQ_OS;
2193 :
2194 : case INTRINSIC_EQ_OS:
2195 : return INTRINSIC_EQ;
2196 :
2197 : case INTRINSIC_NE:
2198 : return INTRINSIC_NE_OS;
2199 :
2200 : case INTRINSIC_NE_OS:
2201 : return INTRINSIC_NE;
2202 :
2203 : case INTRINSIC_GT:
2204 : return INTRINSIC_GT_OS;
2205 :
2206 : case INTRINSIC_GT_OS:
2207 : return INTRINSIC_GT;
2208 :
2209 : case INTRINSIC_GE:
2210 : return INTRINSIC_GE_OS;
2211 :
2212 : case INTRINSIC_GE_OS:
2213 : return INTRINSIC_GE;
2214 :
2215 : case INTRINSIC_LT:
2216 : return INTRINSIC_LT_OS;
2217 :
2218 : case INTRINSIC_LT_OS:
2219 : return INTRINSIC_LT;
2220 :
2221 : case INTRINSIC_LE:
2222 : return INTRINSIC_LE_OS;
2223 :
2224 : case INTRINSIC_LE_OS:
2225 : return INTRINSIC_LE;
2226 :
2227 : default:
2228 : return INTRINSIC_NONE;
2229 : }
2230 : }
2231 :
2232 : /* For the namespace, check generic, user operator and intrinsic
2233 : operator interfaces for consistency and to remove duplicate
2234 : interfaces. We traverse the whole namespace, counting on the fact
2235 : that most symbols will not have generic or operator interfaces. */
2236 :
2237 : void
2238 364147 : gfc_check_interfaces (gfc_namespace *ns)
2239 : {
2240 364147 : gfc_namespace *old_ns, *ns2;
2241 364147 : char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")];
2242 364147 : int i;
2243 :
2244 364147 : old_ns = gfc_current_ns;
2245 364147 : gfc_current_ns = ns;
2246 :
2247 364147 : gfc_traverse_ns (ns, check_sym_interfaces);
2248 :
2249 364147 : gfc_traverse_user_op (ns, check_uop_interfaces);
2250 :
2251 10924342 : for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2252 : {
2253 10196051 : if (i == INTRINSIC_USER)
2254 364144 : continue;
2255 :
2256 9831907 : if (i == INTRINSIC_ASSIGN)
2257 364144 : strcpy (interface_name, "intrinsic assignment operator");
2258 : else
2259 9467763 : sprintf (interface_name, "intrinsic '%s' operator",
2260 : gfc_op2string ((gfc_intrinsic_op) i));
2261 :
2262 9831907 : if (check_interface0 (ns->op[i], interface_name))
2263 0 : continue;
2264 :
2265 9831907 : if (ns->op[i])
2266 2484 : gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
2267 : ns->op[i]->where);
2268 :
2269 22200542 : for (ns2 = ns; ns2; ns2 = ns2->parent)
2270 : {
2271 12368638 : gfc_intrinsic_op other_op;
2272 :
2273 12368638 : if (check_interface1 (ns->op[i], ns2->op[i], 0,
2274 : interface_name, true))
2275 3 : goto done;
2276 :
2277 : /* i should be gfc_intrinsic_op, but has to be int with this cast
2278 : here for stupid C++ compatibility rules. */
2279 12368635 : other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
2280 12368635 : if (other_op != INTRINSIC_NONE
2281 12368635 : && check_interface1 (ns->op[i], ns2->op[other_op],
2282 : 0, interface_name, true))
2283 0 : goto done;
2284 : }
2285 : }
2286 :
2287 364144 : done:
2288 364147 : gfc_current_ns = old_ns;
2289 364147 : }
2290 :
2291 :
2292 : /* Given a symbol of a formal argument list and an expression, if the
2293 : formal argument is allocatable, check that the actual argument is
2294 : allocatable. Returns true if compatible, zero if not compatible. */
2295 :
2296 : static bool
2297 259638 : compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
2298 : {
2299 259638 : if (formal->attr.allocatable
2300 256528 : || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
2301 : {
2302 4050 : symbol_attribute attr = gfc_expr_attr (actual);
2303 4050 : if (actual->ts.type == BT_CLASS && !attr.class_ok)
2304 23 : return true;
2305 4036 : else if (!attr.allocatable)
2306 : return false;
2307 : }
2308 :
2309 : return true;
2310 : }
2311 :
2312 :
2313 : /* Given a symbol of a formal argument list and an expression, if the
2314 : formal argument is a pointer, see if the actual argument is a
2315 : pointer. Returns nonzero if compatible, zero if not compatible. */
2316 :
2317 : static int
2318 259659 : compare_pointer (gfc_symbol *formal, gfc_expr *actual)
2319 : {
2320 259659 : symbol_attribute attr;
2321 :
2322 259659 : if (formal->attr.pointer
2323 254838 : || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
2324 14502 : && CLASS_DATA (formal)->attr.class_pointer))
2325 : {
2326 5779 : attr = gfc_expr_attr (actual);
2327 :
2328 : /* Fortran 2008 allows non-pointer actual arguments. */
2329 5779 : if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
2330 : return 2;
2331 :
2332 5374 : if (!attr.pointer)
2333 12 : return 0;
2334 : }
2335 :
2336 : return 1;
2337 : }
2338 :
2339 :
2340 : /* Emit clear error messages for rank mismatch. */
2341 :
2342 : static void
2343 153 : argument_rank_mismatch (const char *name, locus *where,
2344 : int rank1, int rank2, locus *where_formal)
2345 : {
2346 :
2347 : /* TS 29113, C407b. */
2348 153 : if (where_formal == NULL)
2349 : {
2350 143 : if (rank2 == -1)
2351 10 : gfc_error ("The assumed-rank array at %L requires that the dummy "
2352 : "argument %qs has assumed-rank", where, name);
2353 133 : else if (rank1 == 0)
2354 22 : gfc_error_opt (0, "Rank mismatch in argument %qs "
2355 : "at %L (scalar and rank-%d)", name, where, rank2);
2356 111 : else if (rank2 == 0)
2357 104 : gfc_error_opt (0, "Rank mismatch in argument %qs "
2358 : "at %L (rank-%d and scalar)", name, where, rank1);
2359 : else
2360 7 : gfc_error_opt (0, "Rank mismatch in argument %qs "
2361 : "at %L (rank-%d and rank-%d)", name, where, rank1,
2362 : rank2);
2363 : }
2364 : else
2365 : {
2366 10 : if (rank2 == -1)
2367 : /* This is an assumed rank-actual passed to a function without
2368 : an explicit interface, which is already diagnosed in
2369 : gfc_procedure_use. */
2370 : return;
2371 8 : if (rank1 == 0)
2372 6 : gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2373 : "and actual argument at %L (scalar and rank-%d)",
2374 : where, where_formal, rank2);
2375 2 : else if (rank2 == 0)
2376 2 : gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2377 : "and actual argument at %L (rank-%d and scalar)",
2378 : where, where_formal, rank1);
2379 : else
2380 0 : gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2381 : "and actual argument at %L (rank-%d and rank-%d)", where,
2382 : where_formal, rank1, rank2);
2383 : }
2384 : }
2385 :
2386 :
2387 : /* Under certain conditions, a scalar actual argument can be passed
2388 : to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
2389 : This function returns true for these conditions so that an error
2390 : or warning for this can be suppressed later. Always return false
2391 : for expressions with rank > 0. */
2392 :
2393 : bool
2394 3088 : maybe_dummy_array_arg (gfc_expr *e)
2395 : {
2396 3088 : gfc_symbol *s;
2397 3088 : gfc_ref *ref;
2398 3088 : bool array_pointer = false;
2399 3088 : bool assumed_shape = false;
2400 3088 : bool scalar_ref = true;
2401 :
2402 3088 : if (e->rank > 0)
2403 : return false;
2404 :
2405 3082 : if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
2406 : return true;
2407 :
2408 : /* If this comes from a constructor, it has been an array element
2409 : originally. */
2410 :
2411 2933 : if (e->expr_type == EXPR_CONSTANT)
2412 693 : return e->from_constructor;
2413 :
2414 2240 : if (e->expr_type != EXPR_VARIABLE)
2415 : return false;
2416 :
2417 2132 : s = e->symtree->n.sym;
2418 :
2419 2132 : if (s->attr.dimension)
2420 : {
2421 235 : scalar_ref = false;
2422 235 : array_pointer = s->attr.pointer;
2423 : }
2424 :
2425 2132 : if (s->as && s->as->type == AS_ASSUMED_SHAPE)
2426 2132 : assumed_shape = true;
2427 :
2428 2396 : for (ref=e->ref; ref; ref=ref->next)
2429 : {
2430 264 : if (ref->type == REF_COMPONENT)
2431 : {
2432 20 : symbol_attribute *attr;
2433 20 : attr = &ref->u.c.component->attr;
2434 20 : if (attr->dimension)
2435 : {
2436 2 : array_pointer = attr->pointer;
2437 2 : assumed_shape = false;
2438 2 : scalar_ref = false;
2439 : }
2440 : else
2441 : scalar_ref = true;
2442 : }
2443 : }
2444 :
2445 2132 : return !(scalar_ref || array_pointer || assumed_shape);
2446 : }
2447 :
2448 : /* Given a symbol of a formal argument list and an expression, see if
2449 : the two are compatible as arguments. Returns true if
2450 : compatible, false if not compatible. */
2451 :
2452 : static bool
2453 366888 : compare_parameter (gfc_symbol *formal, gfc_expr *actual,
2454 : int ranks_must_agree, int is_elemental, locus *where)
2455 : {
2456 366888 : gfc_ref *ref;
2457 366888 : bool rank_check, is_pointer;
2458 366888 : char err[200];
2459 366888 : gfc_component *ppc;
2460 366888 : bool codimension = false;
2461 366888 : gfc_array_spec *formal_as;
2462 366888 : const char *actual_name;
2463 :
2464 : /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2465 : procs c_f_pointer or c_f_procpointer, and we need to accept most
2466 : pointers the user could give us. This should allow that. */
2467 366888 : if (formal->ts.type == BT_VOID)
2468 : return true;
2469 :
2470 366888 : if (formal->ts.type == BT_DERIVED
2471 30191 : && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
2472 4414 : && actual->ts.type == BT_DERIVED
2473 4404 : && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
2474 : {
2475 4404 : if (formal->ts.u.derived->intmod_sym_id
2476 4404 : != actual->ts.u.derived->intmod_sym_id)
2477 : return false;
2478 :
2479 4303 : if (ranks_must_agree
2480 136 : && gfc_symbol_rank (formal) != actual->rank
2481 4363 : && gfc_symbol_rank (formal) != -1)
2482 : {
2483 42 : if (where)
2484 0 : argument_rank_mismatch (formal->name, &actual->where,
2485 : gfc_symbol_rank (formal), actual->rank,
2486 : NULL);
2487 : return false;
2488 : }
2489 : return true;
2490 : }
2491 :
2492 362484 : if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
2493 : /* Make sure the vtab symbol is present when
2494 : the module variables are generated. */
2495 7545 : gfc_find_derived_vtab (actual->ts.u.derived);
2496 :
2497 362484 : if (actual->ts.type == BT_PROCEDURE)
2498 : {
2499 1997 : gfc_symbol *act_sym = actual->symtree->n.sym;
2500 :
2501 1997 : if (formal->attr.flavor != FL_PROCEDURE && !act_sym->ts.interface)
2502 : {
2503 4 : if (where)
2504 2 : gfc_error ("Invalid procedure argument at %L", &actual->where);
2505 : return false;
2506 : }
2507 1993 : else if (act_sym->ts.interface
2508 1993 : && !gfc_compare_interfaces (formal, act_sym->ts.interface,
2509 : act_sym->name, 0, 1, err,
2510 : sizeof(err),NULL, NULL))
2511 : {
2512 1 : if (where)
2513 : {
2514 : /* Artificially generated symbol names would only confuse. */
2515 1 : if (formal->attr.artificial)
2516 0 : gfc_error_opt (0, "Interface mismatch in dummy procedure "
2517 : "at %L conflicts with %L: %s", &actual->where,
2518 : &formal->declared_at, err);
2519 : else
2520 1 : gfc_error_opt (0, "Interface mismatch in dummy procedure %qs "
2521 : "at %L: %s", formal->name, &actual->where, err);
2522 : }
2523 : return false;
2524 : }
2525 :
2526 1992 : if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
2527 : sizeof(err), NULL, NULL))
2528 : {
2529 40 : if (where)
2530 : {
2531 40 : if (formal->attr.artificial)
2532 1 : gfc_error_opt (0, "Interface mismatch in dummy procedure "
2533 : "at %L conflicts with %L: %s", &actual->where,
2534 : &formal->declared_at, err);
2535 : else
2536 39 : gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at "
2537 : "%L: %s", formal->name, &actual->where, err);
2538 :
2539 : }
2540 : return false;
2541 : }
2542 :
2543 : /* The actual symbol may disagree with a global symbol. If so, issue an
2544 : error, but only if no previous error has been reported on the formal
2545 : argument. */
2546 1952 : actual_name = act_sym->name;
2547 1952 : if (!formal->error && actual_name)
2548 : {
2549 1952 : gfc_gsymbol *gsym;
2550 1952 : gsym = gfc_find_gsymbol (gfc_gsym_root, actual_name);
2551 1952 : if (gsym != NULL)
2552 : {
2553 180 : if (gsym->type == GSYM_SUBROUTINE && formal->attr.function)
2554 : {
2555 1 : gfc_error ("Passing global subroutine %qs declared at %L "
2556 : "as function at %L", actual_name, &gsym->where,
2557 : &actual->where);
2558 1 : return false;
2559 : }
2560 179 : if (gsym->type == GSYM_FUNCTION && formal->attr.subroutine)
2561 : {
2562 1 : gfc_error ("Passing global function %qs declared at %L "
2563 : "as subroutine at %L", actual_name, &gsym->where,
2564 : &actual->where);
2565 1 : return false;
2566 : }
2567 178 : if (gsym->type == GSYM_FUNCTION)
2568 : {
2569 99 : gfc_symbol *global_asym;
2570 99 : gfc_find_symbol (actual_name, gsym->ns, 0, &global_asym);
2571 99 : if (global_asym != NULL)
2572 : {
2573 99 : if (formal->attr.subroutine)
2574 : {
2575 0 : gfc_error ("Mismatch between subroutine and "
2576 : "function at %L", &actual->where);
2577 1 : return false;
2578 : }
2579 99 : else if (formal->attr.function)
2580 : {
2581 98 : gfc_typespec ts;
2582 :
2583 98 : if (global_asym->result)
2584 97 : ts = global_asym->result->ts;
2585 : else
2586 1 : ts = global_asym->ts;
2587 :
2588 98 : if (!gfc_compare_types (&ts,
2589 : &formal->ts))
2590 : {
2591 2 : gfc_error ("Type mismatch at %L passing global "
2592 : "function %qs declared at %L (%s/%s)",
2593 : &actual->where, actual_name,
2594 : &gsym->where,
2595 1 : gfc_typename (&global_asym->ts),
2596 : gfc_dummy_typename (&formal->ts));
2597 1 : return false;
2598 : }
2599 : }
2600 : else
2601 : {
2602 : /* The global symbol is a function. Set the formal
2603 : argument accordingly. */
2604 1 : formal->attr.function = 1;
2605 1 : formal->ts = global_asym->ts;
2606 : }
2607 : }
2608 : }
2609 : }
2610 : }
2611 :
2612 1949 : if (formal->attr.function && !act_sym->attr.function)
2613 : {
2614 5 : gfc_add_function (&act_sym->attr, act_sym->name,
2615 : &act_sym->declared_at);
2616 5 : if (act_sym->ts.type == BT_UNKNOWN
2617 5 : && !gfc_set_default_type (act_sym, 1, act_sym->ns))
2618 : return false;
2619 : }
2620 1944 : else if (formal->attr.subroutine && !act_sym->attr.subroutine)
2621 50 : gfc_add_subroutine (&act_sym->attr, act_sym->name,
2622 : &act_sym->declared_at);
2623 :
2624 1949 : return true;
2625 : }
2626 360487 : ppc = gfc_get_proc_ptr_comp (actual);
2627 360487 : if (ppc && ppc->ts.interface)
2628 : {
2629 496 : if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
2630 : err, sizeof(err), NULL, NULL))
2631 : {
2632 2 : if (where)
2633 2 : gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2634 : " %s", formal->name, &actual->where, err);
2635 : return false;
2636 : }
2637 : }
2638 :
2639 : /* F2008, C1241. */
2640 5336 : if (formal->attr.pointer && formal->attr.contiguous
2641 360520 : && !gfc_is_simply_contiguous (actual, true, false))
2642 : {
2643 4 : if (where)
2644 4 : gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2645 : "must be simply contiguous", formal->name, &actual->where);
2646 : return false;
2647 : }
2648 :
2649 360481 : symbol_attribute actual_attr = gfc_expr_attr (actual);
2650 360481 : if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
2651 : return true;
2652 :
2653 825 : if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
2654 360148 : && actual->ts.type != BT_HOLLERITH
2655 360129 : && formal->ts.type != BT_ASSUMED
2656 356662 : && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2657 356662 : && !gfc_compare_types (&formal->ts, &actual->ts)
2658 466194 : && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
2659 2 : && gfc_compare_derived_types (formal->ts.u.derived,
2660 2 : CLASS_DATA (actual)->ts.u.derived)))
2661 : {
2662 105768 : if (where)
2663 : {
2664 68 : if (formal->attr.artificial)
2665 : {
2666 19 : if (!flag_allow_argument_mismatch || !formal->error)
2667 14 : gfc_error_opt (0, "Type mismatch between actual argument at %L "
2668 : "and actual argument at %L (%s/%s).",
2669 : &actual->where,
2670 : &formal->declared_at,
2671 : gfc_typename (actual),
2672 : gfc_dummy_typename (&formal->ts));
2673 :
2674 19 : formal->error = 1;
2675 : }
2676 : else
2677 49 : gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
2678 : "to %s", formal->name, where, gfc_typename (actual),
2679 : gfc_dummy_typename (&formal->ts));
2680 : }
2681 : return false;
2682 : }
2683 :
2684 254656 : if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
2685 : {
2686 3 : if (where)
2687 1 : gfc_error ("Assumed-type actual argument at %L requires that dummy "
2688 : "argument %qs is of assumed type", &actual->where,
2689 : formal->name);
2690 : return false;
2691 : }
2692 :
2693 : /* TS29113 C407c; F2018 C711. */
2694 254653 : if (actual->ts.type == BT_ASSUMED
2695 326 : && gfc_symbol_rank (formal) == -1
2696 27 : && actual->rank != -1
2697 254660 : && !(actual->symtree->n.sym->as
2698 5 : && actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))
2699 : {
2700 4 : if (where)
2701 4 : gfc_error ("Assumed-type actual argument at %L corresponding to "
2702 : "assumed-rank dummy argument %qs must be "
2703 : "assumed-shape or assumed-rank",
2704 : &actual->where, formal->name);
2705 : return false;
2706 : }
2707 :
2708 : /* F2008, 12.5.2.5; IR F08/0073. */
2709 254649 : if (formal->ts.type == BT_CLASS && formal->attr.class_ok
2710 14512 : && actual->expr_type != EXPR_NULL
2711 14512 : && ((CLASS_DATA (formal)->attr.class_pointer
2712 935 : && formal->attr.intent != INTENT_IN)
2713 14260 : || CLASS_DATA (formal)->attr.allocatable))
2714 : {
2715 1180 : if (actual->ts.type != BT_CLASS)
2716 : {
2717 2 : if (where)
2718 2 : gfc_error ("Actual argument to %qs at %L must be polymorphic",
2719 : formal->name, &actual->where);
2720 : return false;
2721 : }
2722 :
2723 1178 : if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
2724 787 : && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
2725 787 : CLASS_DATA (formal)->ts.u.derived))
2726 : {
2727 1 : if (where)
2728 1 : gfc_error ("Actual argument to %qs at %L must have the same "
2729 : "declared type", formal->name, &actual->where);
2730 : return false;
2731 : }
2732 : }
2733 :
2734 : /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2735 : is necessary also for F03, so retain error for both.
2736 : NOTE: Other type/kind errors pre-empt this error. Since they are F03
2737 : compatible, no attempt has been made to channel to this one. */
2738 254646 : if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
2739 1670 : && (CLASS_DATA (formal)->attr.allocatable
2740 1670 : ||CLASS_DATA (formal)->attr.class_pointer))
2741 : {
2742 0 : if (where)
2743 0 : gfc_error ("Actual argument to %qs at %L must be unlimited "
2744 : "polymorphic since the formal argument is a "
2745 : "pointer or allocatable unlimited polymorphic "
2746 : "entity [F2008: 12.5.2.5]", formal->name,
2747 : &actual->where);
2748 : return false;
2749 : }
2750 :
2751 254646 : if (formal->ts.type == BT_CLASS && formal->attr.class_ok)
2752 14509 : codimension = CLASS_DATA (formal)->attr.codimension;
2753 : else
2754 240137 : codimension = formal->attr.codimension;
2755 :
2756 254646 : if (codimension && !gfc_is_coarray (actual))
2757 : {
2758 4 : if (where)
2759 4 : gfc_error ("Actual argument to %qs at %L must be a coarray",
2760 : formal->name, &actual->where);
2761 : return false;
2762 : }
2763 :
2764 240134 : formal_as = (formal->ts.type == BT_CLASS
2765 254642 : ? CLASS_DATA (formal)->as : formal->as);
2766 :
2767 254642 : if (codimension && formal->attr.allocatable)
2768 : {
2769 27 : gfc_ref *last = NULL;
2770 :
2771 54 : for (ref = actual->ref; ref; ref = ref->next)
2772 27 : if (ref->type == REF_COMPONENT)
2773 0 : last = ref;
2774 :
2775 : /* F2008, 12.5.2.6. */
2776 27 : if ((last && last->u.c.component->as->corank != formal->as->corank)
2777 : || (!last
2778 27 : && actual->symtree->n.sym->as->corank != formal->as->corank))
2779 : {
2780 1 : if (where)
2781 1 : gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2782 1 : formal->name, &actual->where, formal->as->corank,
2783 0 : last ? last->u.c.component->as->corank
2784 1 : : actual->symtree->n.sym->as->corank);
2785 : return false;
2786 : }
2787 : }
2788 :
2789 417 : if (codimension)
2790 : {
2791 : /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2792 : /* F2018, 12.5.2.8. */
2793 417 : if (formal->attr.dimension
2794 162 : && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
2795 103 : && actual_attr.dimension
2796 519 : && !gfc_is_simply_contiguous (actual, true, true))
2797 : {
2798 2 : if (where)
2799 2 : gfc_error ("Actual argument to %qs at %L must be simply "
2800 : "contiguous or an element of such an array",
2801 : formal->name, &actual->where);
2802 : return false;
2803 : }
2804 :
2805 : /* F2008, C1303 and C1304. */
2806 415 : if (formal->attr.intent != INTENT_INOUT
2807 406 : && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2808 203 : && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2809 1 : && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2810 405 : || formal->attr.lock_comp))
2811 :
2812 : {
2813 1 : if (where)
2814 1 : gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2815 : "which is LOCK_TYPE or has a LOCK_TYPE component",
2816 : formal->name, &actual->where);
2817 : return false;
2818 : }
2819 :
2820 : /* TS18508, C702/C703. */
2821 414 : if (formal->attr.intent != INTENT_INOUT
2822 405 : && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2823 202 : && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2824 0 : && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
2825 405 : || formal->attr.event_comp))
2826 :
2827 : {
2828 0 : if (where)
2829 0 : gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2830 : "which is EVENT_TYPE or has a EVENT_TYPE component",
2831 : formal->name, &actual->where);
2832 : return false;
2833 : }
2834 : }
2835 :
2836 : /* F2008, C1239/C1240. */
2837 254638 : if (actual->expr_type == EXPR_VARIABLE
2838 105304 : && (actual->symtree->n.sym->attr.asynchronous
2839 105259 : || actual->symtree->n.sym->attr.volatile_)
2840 3300 : && (formal->attr.asynchronous || formal->attr.volatile_)
2841 91 : && actual->rank
2842 87 : && ((formal->ts.type == BT_CLASS
2843 16 : && formal->ts.u.derived->attr.is_class
2844 16 : && CLASS_DATA (formal)->as
2845 16 : && !(CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE
2846 : || CLASS_DATA (formal)->as->type == AS_ASSUMED_RANK)
2847 8 : && !CLASS_DATA (formal)->attr.class_pointer)
2848 79 : || (formal->as
2849 70 : && !(formal->as->type == AS_ASSUMED_SHAPE
2850 : || formal->as->type == AS_ASSUMED_RANK)
2851 24 : && !formal->attr.pointer)
2852 61 : || formal->attr.contiguous)
2853 254690 : && !gfc_is_simply_contiguous (actual, true, false))
2854 : {
2855 38 : if (where)
2856 38 : gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2857 : "assumed-rank array without CONTIGUOUS attribute - as actual"
2858 : " argument at %L is not simply contiguous and both are "
2859 : "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
2860 : return false;
2861 : }
2862 :
2863 254600 : if (formal->attr.allocatable && !codimension
2864 3206 : && actual_attr.codimension)
2865 : {
2866 5 : if (formal->attr.intent == INTENT_OUT)
2867 : {
2868 1 : if (where)
2869 1 : gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2870 : "INTENT(OUT) dummy argument %qs", &actual->where,
2871 : formal->name);
2872 : return false;
2873 : }
2874 4 : else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
2875 1 : gfc_warning (OPT_Wsurprising,
2876 : "Passing coarray at %L to allocatable, noncoarray dummy "
2877 : "argument %qs, which is invalid if the allocation status"
2878 : " is modified", &actual->where, formal->name);
2879 : }
2880 :
2881 : /* If the rank is the same or the formal argument has assumed-rank. */
2882 254599 : if (gfc_symbol_rank (formal) == actual->rank || gfc_symbol_rank (formal) == -1)
2883 : return true;
2884 :
2885 1866 : rank_check = where != NULL && !is_elemental && formal_as
2886 1833 : && (formal_as->type == AS_ASSUMED_SHAPE
2887 1833 : || formal_as->type == AS_DEFERRED)
2888 8330 : && !(actual->expr_type == EXPR_NULL
2889 98 : && actual->ts.type == BT_UNKNOWN);
2890 :
2891 : /* Skip rank checks for NO_ARG_CHECK. */
2892 8167 : if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2893 : return true;
2894 :
2895 : /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2896 7829 : if (rank_check || ranks_must_agree
2897 7671 : || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2898 7671 : || (actual->rank != 0
2899 6832 : && !(is_elemental || formal->attr.dimension
2900 118 : || (formal->ts.type == BT_CLASS
2901 85 : && CLASS_DATA (formal)->attr.dimension)))
2902 7638 : || (actual->rank == 0
2903 839 : && ((formal->ts.type == BT_CLASS
2904 1 : && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2905 839 : || (formal->ts.type != BT_CLASS
2906 838 : && formal->as->type == AS_ASSUMED_SHAPE))
2907 13 : && actual->expr_type != EXPR_NULL)
2908 7638 : || (actual->rank == 0
2909 839 : && (formal->attr.dimension
2910 1 : || (formal->ts.type == BT_CLASS
2911 1 : && CLASS_DATA (formal)->attr.dimension))
2912 839 : && gfc_is_coindexed (actual))
2913 : /* Assumed-rank actual argument; F2018 C838. */
2914 15464 : || actual->rank == -1)
2915 : {
2916 199 : if (where
2917 199 : && (!formal->attr.artificial || (!formal->maybe_array
2918 8 : && !maybe_dummy_array_arg (actual))))
2919 : {
2920 104 : locus *where_formal;
2921 104 : if (formal->attr.artificial)
2922 8 : where_formal = &formal->declared_at;
2923 : else
2924 : where_formal = NULL;
2925 :
2926 104 : argument_rank_mismatch (formal->name, &actual->where,
2927 : gfc_symbol_rank (formal), actual->rank,
2928 : where_formal);
2929 : }
2930 : return false;
2931 : }
2932 7630 : else if (actual->rank != 0
2933 6794 : && (is_elemental || formal->attr.dimension
2934 85 : || (formal->ts.type == BT_CLASS
2935 85 : && CLASS_DATA (formal)->attr.dimension)))
2936 : return true;
2937 :
2938 : /* At this point, we are considering a scalar passed to an array. This
2939 : is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2940 : - if the actual argument is (a substring of) an element of a
2941 : non-assumed-shape/non-pointer/non-polymorphic array; or
2942 : - (F2003) if the actual argument is of type character of default/c_char
2943 : kind.
2944 : - (F2018) if the dummy argument is type(*). */
2945 :
2946 1672 : is_pointer = actual->expr_type == EXPR_VARIABLE
2947 836 : ? actual->symtree->n.sym->attr.pointer : false;
2948 :
2949 859 : for (ref = actual->ref; ref; ref = ref->next)
2950 : {
2951 463 : if (ref->type == REF_COMPONENT)
2952 12 : is_pointer = ref->u.c.component->attr.pointer;
2953 451 : else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2954 444 : && ref->u.ar.dimen > 0
2955 441 : && (!ref->next
2956 9 : || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2957 : break;
2958 : }
2959 :
2960 836 : if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2961 : {
2962 0 : if (where)
2963 0 : gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2964 : "at %L", formal->name, &actual->where);
2965 : return false;
2966 : }
2967 :
2968 836 : if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2969 391 : && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2970 : {
2971 10 : if (where)
2972 : {
2973 10 : if (formal->attr.artificial)
2974 3 : gfc_error ("Element of assumed-shape or pointer array "
2975 : "as actual argument at %L cannot correspond to "
2976 : "actual argument at %L",
2977 : &actual->where, &formal->declared_at);
2978 : else
2979 7 : gfc_error ("Element of assumed-shape or pointer "
2980 : "array passed to array dummy argument %qs at %L",
2981 : formal->name, &actual->where);
2982 : }
2983 : return false;
2984 : }
2985 :
2986 826 : if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2987 292 : && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2988 : {
2989 275 : if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2990 : {
2991 0 : if (where)
2992 0 : gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2993 : "CHARACTER actual argument with array dummy argument "
2994 : "%qs at %L", formal->name, &actual->where);
2995 : return false;
2996 : }
2997 :
2998 275 : if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2999 : {
3000 50 : gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
3001 : "array dummy argument %qs at %L",
3002 : formal->name, &actual->where);
3003 50 : return false;
3004 : }
3005 : else
3006 225 : return ((gfc_option.allow_std & GFC_STD_F2003) != 0);
3007 : }
3008 :
3009 534 : if (ref == NULL && actual->expr_type != EXPR_NULL)
3010 : {
3011 53 : if (actual->rank == 0
3012 53 : && formal->ts.type == BT_ASSUMED
3013 3 : && formal->as
3014 3 : && formal->as->type == AS_ASSUMED_SIZE)
3015 : /* This is new in F2018, type(*) is new in TS29113, but gfortran does
3016 : not differentiate. Thus, if type(*) exists, it is valid;
3017 : otherwise, type(*) is already rejected. */
3018 : return true;
3019 50 : if (where
3020 50 : && (!formal->attr.artificial || (!formal->maybe_array
3021 3 : && !maybe_dummy_array_arg (actual))))
3022 : {
3023 49 : locus *where_formal;
3024 49 : if (formal->attr.artificial)
3025 2 : where_formal = &formal->declared_at;
3026 : else
3027 : where_formal = NULL;
3028 :
3029 49 : argument_rank_mismatch (formal->name, &actual->where,
3030 : gfc_symbol_rank (formal), actual->rank,
3031 : where_formal);
3032 : }
3033 : return false;
3034 : }
3035 :
3036 : return true;
3037 : }
3038 :
3039 :
3040 : /* Returns the storage size of a symbol (formal argument) or sets argument
3041 : size_known to false if it cannot be determined. */
3042 :
3043 : static unsigned long
3044 245746 : get_sym_storage_size (gfc_symbol *sym, bool *size_known)
3045 : {
3046 245746 : int i;
3047 245746 : unsigned long strlen, elements;
3048 :
3049 245746 : *size_known = false;
3050 :
3051 245746 : if (sym->ts.type == BT_CHARACTER)
3052 : {
3053 33933 : if (sym->ts.u.cl && sym->ts.u.cl->length
3054 7278 : && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
3055 6267 : && sym->ts.u.cl->length->ts.type == BT_INTEGER)
3056 6265 : strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
3057 : else
3058 : return 0;
3059 : }
3060 : else
3061 : strlen = 1;
3062 :
3063 218078 : if (gfc_symbol_rank (sym) == 0)
3064 : {
3065 184017 : *size_known = true;
3066 184017 : return strlen;
3067 : }
3068 :
3069 34061 : elements = 1;
3070 34061 : if (sym->as->type != AS_EXPLICIT)
3071 : return 0;
3072 14907 : for (i = 0; i < sym->as->rank; i++)
3073 : {
3074 9812 : if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
3075 6604 : || sym->as->lower[i]->expr_type != EXPR_CONSTANT
3076 6604 : || sym->as->upper[i]->ts.type != BT_INTEGER
3077 6603 : || sym->as->lower[i]->ts.type != BT_INTEGER)
3078 : return 0;
3079 :
3080 6601 : elements *= mpz_get_si (sym->as->upper[i]->value.integer)
3081 6601 : - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
3082 : }
3083 :
3084 5095 : *size_known = true;
3085 :
3086 5095 : return strlen*elements;
3087 : }
3088 :
3089 :
3090 : /* Returns the storage size of an expression (actual argument) or sets argument
3091 : size_known to false if it cannot be determined. For an array element, it
3092 : returns the remaining size as the element sequence consists of all storage
3093 : units of the actual argument up to the end of the array. */
3094 :
3095 : static unsigned long
3096 245746 : get_expr_storage_size (gfc_expr *e, bool *size_known, long int *charlen)
3097 : {
3098 245746 : int i;
3099 245746 : long int strlen, elements;
3100 245746 : long int substrlen = 0;
3101 245746 : bool is_str_storage = false;
3102 245746 : gfc_ref *ref;
3103 :
3104 245746 : *size_known = false;
3105 245746 : *charlen = -1;
3106 :
3107 245746 : if (e == NULL)
3108 : return 0;
3109 :
3110 245746 : if (e->ts.type == BT_CHARACTER)
3111 : {
3112 34326 : if (e->ts.u.cl && e->ts.u.cl->length
3113 11942 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3114 11048 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
3115 11047 : strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
3116 23279 : else if (e->expr_type == EXPR_CONSTANT
3117 19653 : && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
3118 19653 : strlen = e->value.character.length;
3119 : else
3120 : return 0;
3121 30700 : *charlen = strlen;
3122 : }
3123 : else
3124 : strlen = 1; /* Length per element. */
3125 :
3126 242120 : if (e->rank == 0 && !e->ref)
3127 : {
3128 196157 : *size_known = true;
3129 196157 : return strlen;
3130 : }
3131 :
3132 45963 : elements = 1;
3133 45963 : if (!e->ref)
3134 : {
3135 6812 : if (!e->shape)
3136 : return 0;
3137 12315 : for (i = 0; i < e->rank; i++)
3138 6705 : elements *= mpz_get_si (e->shape[i]);
3139 5610 : {
3140 5610 : *size_known = true;
3141 5610 : return elements*strlen;
3142 : }
3143 : }
3144 :
3145 64308 : for (ref = e->ref; ref; ref = ref->next)
3146 : {
3147 40741 : if (ref->type == REF_SUBSTRING && ref->u.ss.start
3148 182 : && ref->u.ss.start->expr_type == EXPR_CONSTANT)
3149 : {
3150 176 : if (is_str_storage)
3151 : {
3152 : /* The string length is the substring length.
3153 : Set now to full string length. */
3154 5 : if (!ref->u.ss.length || !ref->u.ss.length->length
3155 4 : || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
3156 : return 0;
3157 :
3158 4 : strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
3159 : }
3160 175 : substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
3161 175 : continue;
3162 : }
3163 :
3164 40565 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3165 11679 : for (i = 0; i < ref->u.ar.dimen; i++)
3166 : {
3167 7209 : long int start, end, stride;
3168 7209 : stride = 1;
3169 :
3170 7209 : if (ref->u.ar.stride[i])
3171 : {
3172 2864 : if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT
3173 2701 : && ref->u.ar.stride[i]->ts.type == BT_INTEGER)
3174 2701 : stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
3175 : else
3176 : return 0;
3177 : }
3178 :
3179 7046 : if (ref->u.ar.start[i])
3180 : {
3181 4067 : if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT
3182 3672 : && ref->u.ar.start[i]->ts.type == BT_INTEGER)
3183 3672 : start = mpz_get_si (ref->u.ar.start[i]->value.integer);
3184 : else
3185 : return 0;
3186 : }
3187 2979 : else if (ref->u.ar.as->lower[i]
3188 2659 : && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
3189 2659 : && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER)
3190 2659 : start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
3191 : else
3192 : return 0;
3193 :
3194 6331 : if (ref->u.ar.end[i])
3195 : {
3196 4947 : if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT
3197 4828 : && ref->u.ar.end[i]->ts.type == BT_INTEGER)
3198 4828 : end = mpz_get_si (ref->u.ar.end[i]->value.integer);
3199 : else
3200 : return 0;
3201 : }
3202 1384 : else if (ref->u.ar.as->upper[i]
3203 1118 : && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
3204 1084 : && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
3205 1083 : end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
3206 : else
3207 : return 0;
3208 :
3209 5911 : elements *= (end - start)/stride + 1L;
3210 : }
3211 34797 : else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
3212 50097 : for (i = 0; i < ref->u.ar.as->rank; i++)
3213 : {
3214 33760 : if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
3215 23587 : && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
3216 23538 : && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER
3217 23538 : && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
3218 21902 : && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
3219 21902 : elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
3220 21902 : - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
3221 21902 : + 1L;
3222 : else
3223 : return 0;
3224 : }
3225 6602 : else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
3226 4114 : && e->expr_type == EXPR_VARIABLE)
3227 : {
3228 4114 : if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
3229 3908 : || e->symtree->n.sym->attr.pointer)
3230 : {
3231 247 : elements = 1;
3232 247 : continue;
3233 : }
3234 :
3235 : /* Determine the number of remaining elements in the element
3236 : sequence for array element designators. */
3237 3867 : is_str_storage = true;
3238 5406 : for (i = ref->u.ar.dimen - 1; i >= 0; i--)
3239 : {
3240 3965 : if (ref->u.ar.start[i] == NULL
3241 3965 : || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
3242 2137 : || ref->u.ar.as->upper[i] == NULL
3243 1566 : || ref->u.ar.as->lower[i] == NULL
3244 1566 : || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
3245 1539 : || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT
3246 1539 : || ref->u.ar.as->upper[i]->ts.type != BT_INTEGER
3247 1539 : || ref->u.ar.as->lower[i]->ts.type != BT_INTEGER)
3248 : return 0;
3249 :
3250 1539 : elements
3251 1539 : = elements
3252 1539 : * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
3253 1539 : - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
3254 1539 : + 1L)
3255 1539 : - (mpz_get_si (ref->u.ar.start[i]->value.integer)
3256 1539 : - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
3257 : }
3258 : }
3259 2488 : else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
3260 91 : && ref->u.c.component->attr.proc_pointer
3261 91 : && ref->u.c.component->attr.dimension)
3262 : {
3263 : /* Array-valued procedure-pointer components. */
3264 8 : gfc_array_spec *as = ref->u.c.component->as;
3265 15 : for (i = 0; i < as->rank; i++)
3266 : {
3267 8 : if (!as->upper[i] || !as->lower[i]
3268 8 : || as->upper[i]->expr_type != EXPR_CONSTANT
3269 7 : || as->lower[i]->expr_type != EXPR_CONSTANT
3270 7 : || as->upper[i]->ts.type != BT_INTEGER
3271 7 : || as->lower[i]->ts.type != BT_INTEGER)
3272 : return 0;
3273 :
3274 7 : elements = elements
3275 7 : * (mpz_get_si (as->upper[i]->value.integer)
3276 7 : - mpz_get_si (as->lower[i]->value.integer) + 1L);
3277 : }
3278 : }
3279 : }
3280 :
3281 23567 : *size_known = true;
3282 :
3283 23567 : if (substrlen)
3284 145 : return (is_str_storage) ? substrlen + (elements-1)*strlen
3285 145 : : elements*strlen;
3286 : else
3287 23422 : return elements*strlen;
3288 : }
3289 :
3290 :
3291 : /* Given an expression, check whether it is an array section
3292 : which has a vector subscript. */
3293 :
3294 : bool
3295 15849 : gfc_has_vector_subscript (gfc_expr *e)
3296 : {
3297 15849 : int i;
3298 15849 : gfc_ref *ref;
3299 :
3300 15849 : if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
3301 : return false;
3302 :
3303 17149 : for (ref = e->ref; ref; ref = ref->next)
3304 10211 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3305 1846 : for (i = 0; i < ref->u.ar.dimen; i++)
3306 1076 : if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
3307 : return true;
3308 :
3309 : return false;
3310 : }
3311 :
3312 :
3313 : static bool
3314 27 : is_procptr_result (gfc_expr *expr)
3315 : {
3316 27 : gfc_component *c = gfc_get_proc_ptr_comp (expr);
3317 27 : if (c)
3318 1 : return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1));
3319 : else
3320 26 : return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
3321 26 : && (expr->symtree->n.sym->result->attr.proc_pointer == 1));
3322 : }
3323 :
3324 :
3325 : /* Recursively append candidate argument ARG to CANDIDATES. Store the
3326 : number of total candidates in CANDIDATES_LEN. */
3327 :
3328 : static void
3329 1 : lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
3330 : char **&candidates,
3331 : size_t &candidates_len)
3332 : {
3333 2 : for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
3334 1 : vec_push (candidates, candidates_len, p->sym->name);
3335 1 : }
3336 :
3337 :
3338 : /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
3339 :
3340 : static const char*
3341 1 : lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
3342 : {
3343 1 : char **candidates = NULL;
3344 1 : size_t candidates_len = 0;
3345 1 : lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
3346 1 : return gfc_closest_fuzzy_match (arg, candidates);
3347 : }
3348 :
3349 :
3350 : static gfc_dummy_arg *
3351 372603 : get_nonintrinsic_dummy_arg (gfc_formal_arglist *formal)
3352 : {
3353 0 : gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg ();
3354 :
3355 372603 : dummy_arg->intrinsicness = GFC_NON_INTRINSIC_DUMMY_ARG;
3356 372603 : dummy_arg->u.non_intrinsic = formal;
3357 :
3358 372603 : return dummy_arg;
3359 : }
3360 :
3361 :
3362 : /* Given formal and actual argument lists, see if they are compatible.
3363 : If they are compatible, the actual argument list is sorted to
3364 : correspond with the formal list, and elements for missing optional
3365 : arguments are inserted. If WHERE pointer is nonnull, then we issue
3366 : errors when things don't match instead of just returning the status
3367 : code. */
3368 :
3369 : bool
3370 198317 : gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
3371 : int ranks_must_agree, int is_elemental,
3372 : bool in_statement_function, locus *where)
3373 : {
3374 198317 : gfc_actual_arglist **new_arg, *a, *actual;
3375 198317 : gfc_formal_arglist *f;
3376 198317 : int i, n, na;
3377 198317 : unsigned long actual_size, formal_size;
3378 198317 : long int charlen;
3379 198317 : bool full_array = false;
3380 198317 : gfc_array_ref *actual_arr_ref;
3381 198317 : gfc_array_spec *fas, *aas;
3382 198317 : bool pointer_dummy, pointer_arg, allocatable_arg;
3383 198317 : bool procptr_dummy, optional_dummy, allocatable_dummy;
3384 198317 : bool actual_size_known = false;
3385 198317 : bool formal_size_known = false;
3386 198317 : bool ok = true;
3387 :
3388 198317 : actual = *ap;
3389 :
3390 198317 : if (actual == NULL && formal == NULL)
3391 : return true;
3392 :
3393 : n = 0;
3394 552972 : for (f = formal; f; f = f->next)
3395 373020 : n++;
3396 :
3397 179952 : new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
3398 :
3399 552972 : for (i = 0; i < n; i++)
3400 373020 : new_arg[i] = NULL;
3401 :
3402 : na = 0;
3403 : f = formal;
3404 : i = 0;
3405 :
3406 547063 : for (a = actual; a; a = a->next, f = f->next)
3407 : {
3408 368312 : if (a->name != NULL && in_statement_function)
3409 : {
3410 1 : gfc_error ("Keyword argument %qs at %L is invalid in "
3411 1 : "a statement function", a->name, &a->expr->where);
3412 1 : return false;
3413 : }
3414 :
3415 : /* Look for keywords but ignore g77 extensions like %VAL. */
3416 368311 : if (a->name != NULL && a->name[0] != '%')
3417 : {
3418 : i = 0;
3419 12511 : for (f = formal; f; f = f->next, i++)
3420 : {
3421 12477 : if (f->sym == NULL)
3422 0 : continue;
3423 12477 : if (strcmp (f->sym->name, a->name) == 0)
3424 : break;
3425 : }
3426 :
3427 3620 : if (f == NULL)
3428 : {
3429 34 : if (where)
3430 : {
3431 1 : const char *guessed = lookup_arg_fuzzy (a->name, formal);
3432 1 : if (guessed)
3433 1 : gfc_error ("Keyword argument %qs at %L is not in "
3434 : "the procedure; did you mean %qs?",
3435 1 : a->name, &a->expr->where, guessed);
3436 : else
3437 0 : gfc_error ("Keyword argument %qs at %L is not in "
3438 0 : "the procedure", a->name, &a->expr->where);
3439 : }
3440 : return false;
3441 : }
3442 :
3443 3620 : if (new_arg[i] != NULL)
3444 : {
3445 0 : if (where)
3446 0 : gfc_error ("Keyword argument %qs at %L is already associated "
3447 : "with another actual argument", a->name,
3448 0 : &a->expr->where);
3449 : return false;
3450 : }
3451 : }
3452 :
3453 368277 : if (f == NULL)
3454 : {
3455 1158 : if (where)
3456 8 : gfc_error ("More actual than formal arguments in procedure "
3457 : "call at %L", where);
3458 : return false;
3459 : }
3460 :
3461 367119 : if (f->sym == NULL && a->expr == NULL)
3462 210 : goto match;
3463 :
3464 366909 : if (f->sym == NULL)
3465 : {
3466 : /* These errors have to be issued, otherwise an ICE can occur.
3467 : See PR 78865. */
3468 6 : if (where)
3469 6 : gfc_error_now ("Missing alternate return specifier in subroutine "
3470 : "call at %L", where);
3471 : return false;
3472 : }
3473 : else
3474 : {
3475 366903 : if (a->associated_dummy)
3476 124375 : free (a->associated_dummy);
3477 366903 : a->associated_dummy = get_nonintrinsic_dummy_arg (f);
3478 : }
3479 :
3480 366903 : if (a->expr == NULL)
3481 : {
3482 8 : if (f->sym->attr.optional)
3483 6 : continue;
3484 : else
3485 : {
3486 2 : if (where)
3487 1 : gfc_error_now ("Unexpected alternate return specifier in "
3488 : "subroutine call at %L", where);
3489 : return false;
3490 : }
3491 : }
3492 :
3493 : /* Make sure that intrinsic vtables exist for calls to unlimited
3494 : polymorphic formal arguments. */
3495 366895 : if (UNLIMITED_POLY (f->sym)
3496 3011 : && a->expr->ts.type != BT_DERIVED
3497 : && a->expr->ts.type != BT_CLASS
3498 : && a->expr->ts.type != BT_ASSUMED)
3499 977 : gfc_find_vtab (&a->expr->ts);
3500 :
3501 : /* Interp J3/22-146:
3502 : "If the context of the reference to NULL is an <actual argument>
3503 : corresponding to an <assumed-rank> dummy argument, MOLD shall be
3504 : present." */
3505 366895 : if (a->expr->expr_type == EXPR_NULL
3506 844 : && a->expr->ts.type == BT_UNKNOWN
3507 282 : && f->sym->as
3508 109 : && f->sym->as->type == AS_ASSUMED_RANK)
3509 : {
3510 1 : gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument at %L "
3511 : "passed to assumed-rank dummy %qs",
3512 : &a->expr->where, f->sym->name);
3513 1 : ok = false;
3514 1 : goto match;
3515 : }
3516 :
3517 366894 : if (warn_surprising
3518 1281 : && a->expr->expr_type == EXPR_VARIABLE
3519 620 : && a->expr->symtree->n.sym->as
3520 265 : && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
3521 153 : && f->sym->as
3522 153 : && f->sym->as->type == AS_ASSUMED_RANK)
3523 1 : gfc_warning (0, "The assumed-size dummy %qs is being passed at %L to "
3524 : "an assumed-rank dummy %qs", a->expr->symtree->name,
3525 : &a->expr->where, f->sym->name);
3526 :
3527 366894 : if (a->expr->expr_type == EXPR_NULL
3528 843 : && a->expr->ts.type == BT_UNKNOWN
3529 281 : && f->sym->ts.type == BT_CHARACTER
3530 83 : && !f->sym->ts.deferred
3531 46 : && f->sym->ts.u.cl
3532 46 : && f->sym->ts.u.cl->length == NULL)
3533 : {
3534 1 : gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument at %L "
3535 : "passed to assumed-length dummy %qs",
3536 : &a->expr->where, f->sym->name);
3537 1 : ok = false;
3538 1 : goto match;
3539 : }
3540 :
3541 : /* Allow passing of NULL() as disassociated pointer, procedure
3542 : pointer, or unallocated allocatable (F2008+) to a respective dummy
3543 : argument. */
3544 733786 : pointer_dummy = ((f->sym->ts.type != BT_CLASS
3545 351572 : && f->sym->attr.pointer)
3546 713085 : || (f->sym->ts.type == BT_CLASS
3547 15321 : && CLASS_DATA (f->sym)->attr.class_pointer));
3548 :
3549 733786 : procptr_dummy = ((f->sym->ts.type != BT_CLASS
3550 351572 : && f->sym->attr.proc_pointer)
3551 718253 : || (f->sym->ts.type == BT_CLASS
3552 15321 : && CLASS_DATA (f->sym)->attr.proc_pointer));
3553 :
3554 366893 : optional_dummy = f->sym->attr.optional;
3555 :
3556 733786 : allocatable_dummy = ((f->sym->ts.type != BT_CLASS
3557 351572 : && f->sym->attr.allocatable)
3558 715198 : || (f->sym->ts.type == BT_CLASS
3559 15321 : && CLASS_DATA (f->sym)->attr.allocatable));
3560 :
3561 366893 : if (a->expr->expr_type == EXPR_NULL
3562 : && !pointer_dummy
3563 842 : && !procptr_dummy
3564 356 : && !(optional_dummy
3565 293 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3566 66 : && !(allocatable_dummy
3567 62 : && (gfc_option.allow_std & GFC_STD_F2008) != 0))
3568 : {
3569 5 : if (where
3570 4 : && (!f->sym->attr.optional
3571 2 : || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
3572 1 : || (f->sym->ts.type == BT_CLASS
3573 0 : && CLASS_DATA (f->sym)->attr.allocatable)))
3574 3 : gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
3575 : where, f->sym->name);
3576 1 : else if (where)
3577 1 : gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3578 : "dummy %qs", where, f->sym->name);
3579 5 : ok = false;
3580 5 : goto match;
3581 : }
3582 :
3583 366888 : if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
3584 : is_elemental, where))
3585 : {
3586 106331 : ok = false;
3587 106331 : goto match;
3588 : }
3589 :
3590 : /* TS 29113, 6.3p2; F2018 15.5.2.4. */
3591 260557 : if (f->sym->ts.type == BT_ASSUMED
3592 3473 : && (a->expr->ts.type == BT_DERIVED
3593 3029 : || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
3594 : {
3595 651 : gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED
3596 : ? a->expr->ts.u.derived
3597 207 : : CLASS_DATA (a->expr)->ts.u.derived);
3598 651 : gfc_namespace *f2k_derived = derived->f2k_derived;
3599 651 : if (derived->attr.pdt_type
3600 650 : || (f2k_derived
3601 585 : && (f2k_derived->finalizers || f2k_derived->tb_sym_root)))
3602 : {
3603 5 : gfc_error ("Actual argument at %L to assumed-type dummy "
3604 : "has type parameters or is of "
3605 : "derived type with type-bound or FINAL procedures",
3606 : &a->expr->where);
3607 5 : ok = false;
3608 5 : goto match;
3609 : }
3610 : }
3611 :
3612 260552 : if (UNLIMITED_POLY (a->expr)
3613 1315 : && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym)))
3614 : {
3615 1 : gfc_error ("Unlimited polymorphic actual argument at %L is not "
3616 : "matched with either an unlimited polymorphic or "
3617 : "assumed type dummy argument", &a->expr->where);
3618 1 : ok = false;
3619 1 : goto match;
3620 : }
3621 :
3622 : /* Special case for character arguments. For allocatable, pointer
3623 : and assumed-shape dummies, the string length needs to match
3624 : exactly. */
3625 260551 : if (a->expr->ts.type == BT_CHARACTER
3626 34519 : && a->expr->ts.u.cl && a->expr->ts.u.cl->length
3627 12082 : && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
3628 11188 : && a->expr->ts.u.cl->length->ts.type == BT_INTEGER
3629 11187 : && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl
3630 10856 : && f->sym->ts.u.cl->length
3631 5693 : && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
3632 4822 : && f->sym->ts.u.cl->length->ts.type == BT_INTEGER
3633 4820 : && (f->sym->attr.pointer || f->sym->attr.allocatable
3634 4410 : || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3635 1026 : && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
3636 1026 : f->sym->ts.u.cl->length->value.integer) != 0))
3637 : {
3638 14 : long actual_len, formal_len;
3639 14 : actual_len = mpz_get_si (a->expr->ts.u.cl->length->value.integer);
3640 14 : formal_len = mpz_get_si (f->sym->ts.u.cl->length->value.integer);
3641 :
3642 14 : if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
3643 : {
3644 : /* Emit a warning for -std=legacy and an error otherwise. */
3645 5 : if (gfc_option.warn_std == 0)
3646 4 : gfc_warning (0, "Character length mismatch (%ld/%ld) between "
3647 : "actual argument and pointer or allocatable "
3648 : "dummy argument %qs at %L", actual_len, formal_len,
3649 : f->sym->name, &a->expr->where);
3650 : else
3651 1 : gfc_error ("Character length mismatch (%ld/%ld) between "
3652 : "actual argument and pointer or allocatable "
3653 : "dummy argument %qs at %L", actual_len, formal_len,
3654 : f->sym->name, &a->expr->where);
3655 : }
3656 9 : else if (where)
3657 : {
3658 : /* Emit a warning for -std=legacy and an error otherwise. */
3659 9 : if (gfc_option.warn_std == 0)
3660 0 : gfc_warning (0, "Character length mismatch (%ld/%ld) between "
3661 : "actual argument and assumed-shape dummy argument "
3662 : "%qs at %L", actual_len, formal_len,
3663 : f->sym->name, &a->expr->where);
3664 : else
3665 9 : gfc_error ("Character length mismatch (%ld/%ld) between "
3666 : "actual argument and assumed-shape dummy argument "
3667 : "%qs at %L", actual_len, formal_len,
3668 : f->sym->name, &a->expr->where);
3669 :
3670 : }
3671 14 : ok = false;
3672 14 : goto match;
3673 : }
3674 :
3675 260537 : if ((f->sym->attr.pointer || f->sym->attr.allocatable)
3676 8477 : && f->sym->ts.deferred != a->expr->ts.deferred
3677 38 : && a->expr->ts.type == BT_CHARACTER)
3678 : {
3679 1 : if (where)
3680 1 : gfc_error ("Actual argument at %L to allocatable or "
3681 : "pointer dummy argument %qs must have a deferred "
3682 : "length type parameter if and only if the dummy has one",
3683 : &a->expr->where, f->sym->name);
3684 1 : ok = false;
3685 1 : goto match;
3686 : }
3687 :
3688 260536 : if (f->sym->ts.type == BT_CLASS)
3689 14515 : goto skip_size_check;
3690 :
3691 : /* Skip size check for NULL() actual without MOLD argument. */
3692 246021 : if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
3693 275 : goto skip_size_check;
3694 :
3695 245746 : actual_size = get_expr_storage_size (a->expr, &actual_size_known, &charlen);
3696 245746 : formal_size = get_sym_storage_size (f->sym, &formal_size_known);
3697 :
3698 : /* If the formal is a scalar character variable, use the charlen of the
3699 : actual. */
3700 245746 : if (actual_size_known && formal_size_known && charlen >= 0
3701 4361 : && a->expr->ts.type == BT_CHARACTER
3702 4361 : && f->sym->attr.flavor != FL_PROCEDURE
3703 4361 : && !f->sym->attr.dimension)
3704 3796 : actual_size = charlen;
3705 :
3706 245746 : if (actual_size_known && formal_size_known
3707 184430 : && actual_size != formal_size
3708 3958 : && a->expr->ts.type == BT_CHARACTER
3709 292 : && f->sym->attr.flavor != FL_PROCEDURE)
3710 : {
3711 : /* F2018:15.5.2.4:
3712 : (3) "The length type parameter values of a present actual argument
3713 : shall agree with the corresponding ones of the dummy argument that
3714 : are not assumed, except for the case of the character length
3715 : parameter of an actual argument of type character with default
3716 : kind or C character kind associated with a dummy argument that is
3717 : not assumed-shape or assumed-rank."
3718 :
3719 : (4) "If a present scalar dummy argument is of type character with
3720 : default kind or C character kind, the length len of the dummy
3721 : argument shall be less than or equal to the length of the actual
3722 : argument. The dummy argument becomes associated with the leftmost
3723 : len characters of the actual argument. If a present array dummy
3724 : argument is of type character with default kind or C character
3725 : kind and is not assumed-shape or assumed-rank, it becomes
3726 : associated with the leftmost characters of the actual argument
3727 : element sequence."
3728 :
3729 : As an extension we treat kind=4 character similarly to kind=1. */
3730 :
3731 292 : if (actual_size > formal_size)
3732 : {
3733 211 : if (a->expr->ts.type == BT_CHARACTER && where
3734 211 : && (!f->sym->as || f->sym->as->type == AS_EXPLICIT))
3735 211 : gfc_warning (OPT_Wcharacter_truncation,
3736 : "Character length of actual argument longer "
3737 : "than of dummy argument %qs (%lu/%lu) at %L",
3738 : f->sym->name, actual_size, formal_size,
3739 : &a->expr->where);
3740 211 : goto skip_size_check;
3741 : }
3742 :
3743 81 : if (a->expr->ts.type == BT_CHARACTER && where && !f->sym->as)
3744 : {
3745 : /* Emit warning for -std=legacy/gnu and an error otherwise. */
3746 57 : if (gfc_notification_std (GFC_STD_LEGACY) == ERROR)
3747 : {
3748 11 : gfc_error ("Character length of actual argument shorter "
3749 : "than of dummy argument %qs (%lu/%lu) at %L",
3750 11 : f->sym->name, actual_size, formal_size,
3751 11 : &a->expr->where);
3752 11 : ok = false;
3753 11 : goto match;
3754 : }
3755 : else
3756 46 : gfc_warning (0, "Character length of actual argument shorter "
3757 : "than of dummy argument %qs (%lu/%lu) at %L",
3758 46 : f->sym->name, actual_size, formal_size,
3759 46 : &a->expr->where);
3760 46 : goto skip_size_check;
3761 : }
3762 : }
3763 :
3764 245478 : if (actual_size_known && formal_size_known
3765 184162 : && actual_size < formal_size
3766 54 : && f->sym->as
3767 48 : && a->expr->ts.type != BT_PROCEDURE
3768 48 : && f->sym->attr.flavor != FL_PROCEDURE)
3769 : {
3770 48 : if (where)
3771 : {
3772 : /* Emit a warning for -std=legacy and an error otherwise. */
3773 48 : if (gfc_option.warn_std == 0)
3774 0 : gfc_warning (0, "Actual argument contains too few "
3775 : "elements for dummy argument %qs (%lu/%lu) "
3776 : "at %L", f->sym->name, actual_size,
3777 : formal_size, &a->expr->where);
3778 : else
3779 48 : gfc_error_now ("Actual argument contains too few "
3780 : "elements for dummy argument %qs (%lu/%lu) "
3781 : "at %L", f->sym->name, actual_size,
3782 : formal_size, &a->expr->where);
3783 : }
3784 48 : ok = false;
3785 48 : goto match;
3786 : }
3787 :
3788 245430 : skip_size_check:
3789 :
3790 : /* Satisfy either: F03:12.4.1.3 by ensuring that a procedure pointer
3791 : actual argument is provided for a procedure pointer formal argument;
3792 : or: F08:12.5.2.9 (F18:15.5.2.10) by ensuring that the effective
3793 : argument shall be an external, internal, module, or dummy procedure.
3794 : The interfaces are checked elsewhere. */
3795 260477 : if (f->sym->attr.proc_pointer
3796 260477 : && !((a->expr->expr_type == EXPR_VARIABLE
3797 200 : && (a->expr->symtree->n.sym->attr.proc_pointer
3798 31 : || gfc_is_proc_ptr_comp (a->expr)))
3799 16 : || (a->expr->ts.type == BT_PROCEDURE
3800 10 : && f->sym->ts.interface)
3801 6 : || (a->expr->expr_type == EXPR_FUNCTION
3802 6 : && is_procptr_result (a->expr))))
3803 : {
3804 0 : if (where)
3805 0 : gfc_error ("Expected a procedure pointer for argument %qs at %L",
3806 0 : f->sym->name, &a->expr->where);
3807 0 : ok = false;
3808 0 : goto match;
3809 : }
3810 :
3811 : /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3812 : provided for a procedure formal argument. */
3813 260477 : if (f->sym->attr.flavor == FL_PROCEDURE
3814 260477 : && !((a->expr->expr_type == EXPR_VARIABLE
3815 1974 : && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
3816 32 : || a->expr->symtree->n.sym->attr.proc_pointer
3817 32 : || gfc_is_proc_ptr_comp (a->expr)))
3818 30 : || (a->expr->expr_type == EXPR_FUNCTION
3819 21 : && is_procptr_result (a->expr))))
3820 : {
3821 12 : if (where)
3822 6 : gfc_error ("Expected a procedure for argument %qs at %L",
3823 6 : f->sym->name, &a->expr->where);
3824 12 : ok = false;
3825 12 : goto match;
3826 : }
3827 :
3828 : /* F23:15.5.2.5, para 2: A procedure pointer actual argument cannot correspond
3829 : to a data-object dummy argument (reverse of the two checks above).
3830 : Only flag EXPR_VARIABLE to avoid false positives on function calls
3831 : through procedure pointer components (e.g. o%f(args)). */
3832 260465 : if (!f->sym->attr.proc_pointer
3833 260259 : && f->sym->attr.flavor != FL_PROCEDURE
3834 258476 : && a->expr->expr_type == EXPR_VARIABLE
3835 368059 : && (a->expr->symtree->n.sym->attr.proc_pointer
3836 107587 : || gfc_is_proc_ptr_comp (a->expr)))
3837 : {
3838 8 : if (where)
3839 2 : gfc_error ("Procedure pointer actual argument at %L cannot "
3840 : "be passed to data-object dummy argument %qs",
3841 2 : &a->expr->where, f->sym->name);
3842 8 : ok = false;
3843 8 : goto match;
3844 : }
3845 :
3846 : /* Class array variables and expressions store array info in a
3847 : different place from non-class objects; consolidate the logic
3848 : to access it here instead of repeating it below. Note that
3849 : pointer_arg and allocatable_arg are not fully general and are
3850 : only used in a specific situation below with an assumed-rank
3851 : argument. */
3852 260457 : if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym))
3853 : {
3854 14515 : gfc_component *classdata = CLASS_DATA (f->sym);
3855 14515 : fas = classdata->as;
3856 14515 : pointer_dummy = classdata->attr.class_pointer;
3857 14515 : }
3858 : else
3859 : {
3860 245942 : fas = f->sym->as;
3861 245942 : pointer_dummy = f->sym->attr.pointer;
3862 : }
3863 :
3864 260457 : if (a->expr->expr_type != EXPR_VARIABLE
3865 150900 : && !(a->expr->expr_type == EXPR_NULL
3866 776 : && a->expr->ts.type != BT_UNKNOWN))
3867 : {
3868 : aas = NULL;
3869 : pointer_arg = false;
3870 : allocatable_arg = false;
3871 : }
3872 110058 : else if (a->expr->ts.type == BT_CLASS
3873 6889 : && a->expr->symtree->n.sym
3874 6889 : && CLASS_DATA (a->expr->symtree->n.sym))
3875 : {
3876 6886 : gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym);
3877 6886 : aas = classdata->as;
3878 6886 : pointer_arg = classdata->attr.class_pointer;
3879 6886 : allocatable_arg = classdata->attr.allocatable;
3880 6886 : }
3881 : else
3882 : {
3883 103172 : aas = a->expr->symtree->n.sym->as;
3884 103172 : pointer_arg = a->expr->symtree->n.sym->attr.pointer;
3885 103172 : allocatable_arg = a->expr->symtree->n.sym->attr.allocatable;
3886 : }
3887 :
3888 : /* F2018:9.5.2(2) permits assumed-size whole array expressions as
3889 : actual arguments only if the shape is not required; thus it
3890 : cannot be passed to an assumed-shape array dummy.
3891 : F2018:15.5.2.(2) permits passing a nonpointer actual to an
3892 : intent(in) pointer dummy argument and this is accepted by
3893 : the compare_pointer check below, but this also requires shape
3894 : information.
3895 : There's more discussion of this in PR94110. */
3896 260457 : if (fas
3897 44386 : && (fas->type == AS_ASSUMED_SHAPE
3898 44386 : || fas->type == AS_DEFERRED
3899 22113 : || (fas->type == AS_ASSUMED_RANK && pointer_dummy))
3900 23347 : && aas
3901 18376 : && aas->type == AS_ASSUMED_SIZE
3902 14 : && (a->expr->ref == NULL
3903 14 : || (a->expr->ref->type == REF_ARRAY
3904 14 : && a->expr->ref->u.ar.type == AR_FULL)))
3905 : {
3906 10 : if (where)
3907 10 : gfc_error ("Actual argument for %qs cannot be an assumed-size"
3908 : " array at %L", f->sym->name, where);
3909 10 : ok = false;
3910 10 : goto match;
3911 : }
3912 :
3913 : /* Diagnose F2018 C839 (TS29113 C535c). Here the problem is
3914 : passing an assumed-size array to an INTENT(OUT) assumed-rank
3915 : dummy when it doesn't have the size information needed to run
3916 : initializers and finalizers. */
3917 260447 : if (f->sym->attr.intent == INTENT_OUT
3918 6825 : && fas
3919 1283 : && fas->type == AS_ASSUMED_RANK
3920 276 : && aas
3921 223 : && ((aas->type == AS_ASSUMED_SIZE
3922 61 : && (a->expr->ref == NULL
3923 61 : || (a->expr->ref->type == REF_ARRAY
3924 61 : && a->expr->ref->u.ar.type == AR_FULL)))
3925 173 : || (aas->type == AS_ASSUMED_RANK
3926 : && !pointer_arg
3927 34 : && !allocatable_arg))
3928 260515 : && (a->expr->ts.type == BT_CLASS
3929 62 : || (a->expr->ts.type == BT_DERIVED
3930 16 : && (gfc_is_finalizable (a->expr->ts.u.derived, NULL)
3931 14 : || gfc_has_ultimate_allocatable (a->expr)
3932 12 : || gfc_has_default_initializer
3933 12 : (a->expr->ts.u.derived)))))
3934 : {
3935 12 : if (where)
3936 12 : gfc_error ("Actual argument to assumed-rank INTENT(OUT) "
3937 : "dummy %qs at %L cannot be of unknown size",
3938 12 : f->sym->name, where);
3939 12 : ok = false;
3940 12 : goto match;
3941 : }
3942 :
3943 260435 : if (a->expr->expr_type != EXPR_NULL)
3944 : {
3945 259659 : int cmp = compare_pointer (f->sym, a->expr);
3946 259659 : bool pre2008 = ((gfc_option.allow_std & GFC_STD_F2008) == 0);
3947 :
3948 259659 : if (pre2008 && cmp == 0)
3949 : {
3950 1 : if (where)
3951 1 : gfc_error ("Actual argument for %qs at %L must be a pointer",
3952 1 : f->sym->name, &a->expr->where);
3953 1 : ok = false;
3954 1 : goto match;
3955 : }
3956 :
3957 259658 : if (pre2008 && cmp == 2)
3958 : {
3959 3 : if (where)
3960 3 : gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3961 3 : "pointer dummy %qs", &a->expr->where, f->sym->name);
3962 3 : ok = false;
3963 3 : goto match;
3964 : }
3965 :
3966 259655 : if (!pre2008 && cmp == 0)
3967 : {
3968 11 : if (where)
3969 5 : gfc_error ("Actual argument for %qs at %L must be a pointer "
3970 : "or a valid target for the dummy pointer in a "
3971 : "pointer assignment statement",
3972 5 : f->sym->name, &a->expr->where);
3973 11 : ok = false;
3974 11 : goto match;
3975 : }
3976 : }
3977 :
3978 :
3979 : /* Fortran 2008, C1242. */
3980 260420 : if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
3981 : {
3982 2 : if (where)
3983 2 : gfc_error ("Coindexed actual argument at %L to pointer "
3984 : "dummy %qs",
3985 2 : &a->expr->where, f->sym->name);
3986 2 : ok = false;
3987 2 : goto match;
3988 : }
3989 :
3990 : /* Fortran 2008, 12.5.2.5 (no constraint). */
3991 260418 : if (a->expr->expr_type == EXPR_VARIABLE
3992 109519 : && f->sym->attr.intent != INTENT_IN
3993 62575 : && f->sym->attr.allocatable
3994 263345 : && gfc_is_coindexed (a->expr))
3995 : {
3996 1 : if (where)
3997 1 : gfc_error ("Coindexed actual argument at %L to allocatable "
3998 : "dummy %qs requires INTENT(IN)",
3999 1 : &a->expr->where, f->sym->name);
4000 1 : ok = false;
4001 1 : goto match;
4002 : }
4003 :
4004 : /* Fortran 2008, C1237. */
4005 260417 : if (a->expr->expr_type == EXPR_VARIABLE
4006 109518 : && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
4007 65 : && gfc_is_coindexed (a->expr)
4008 260419 : && (a->expr->symtree->n.sym->attr.volatile_
4009 1 : || a->expr->symtree->n.sym->attr.asynchronous))
4010 : {
4011 2 : if (where)
4012 2 : gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
4013 : "%L requires that dummy %qs has neither "
4014 : "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
4015 2 : f->sym->name);
4016 2 : ok = false;
4017 2 : goto match;
4018 : }
4019 :
4020 : /* Fortran 2008, 12.5.2.4 (no constraint). */
4021 260415 : if (a->expr->expr_type == EXPR_VARIABLE
4022 109516 : && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
4023 57904 : && gfc_is_coindexed (a->expr)
4024 260426 : && gfc_has_ultimate_allocatable (a->expr))
4025 : {
4026 1 : if (where)
4027 1 : gfc_error ("Coindexed actual argument at %L with allocatable "
4028 : "ultimate component to dummy %qs requires either VALUE "
4029 1 : "or INTENT(IN)", &a->expr->where, f->sym->name);
4030 1 : ok = false;
4031 1 : goto match;
4032 : }
4033 :
4034 260414 : if (f->sym->ts.type == BT_CLASS
4035 14507 : && CLASS_DATA (f->sym)->attr.allocatable
4036 940 : && gfc_is_class_array_ref (a->expr, &full_array)
4037 260871 : && !full_array)
4038 : {
4039 0 : if (where)
4040 0 : gfc_error ("Actual CLASS array argument for %qs must be a full "
4041 0 : "array at %L", f->sym->name, &a->expr->where);
4042 0 : ok = false;
4043 0 : goto match;
4044 : }
4045 :
4046 :
4047 260414 : if (a->expr->expr_type != EXPR_NULL
4048 260414 : && !compare_allocatable (f->sym, a->expr))
4049 : {
4050 9 : if (where)
4051 9 : gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
4052 9 : f->sym->name, &a->expr->where);
4053 9 : ok = false;
4054 9 : goto match;
4055 : }
4056 :
4057 260405 : if (a->expr->expr_type == EXPR_FUNCTION
4058 15335 : && a->expr->value.function.esym
4059 5147 : && f->sym->attr.allocatable)
4060 : {
4061 4 : if (where)
4062 4 : gfc_error ("Actual argument for %qs at %L is a function result "
4063 : "and the dummy argument is ALLOCATABLE",
4064 : f->sym->name, &a->expr->where);
4065 4 : ok = false;
4066 4 : goto match;
4067 : }
4068 :
4069 : /* Check intent = OUT/INOUT for definable actual argument. */
4070 260401 : if (!in_statement_function
4071 259926 : && (f->sym->attr.intent == INTENT_OUT
4072 253115 : || f->sym->attr.intent == INTENT_INOUT))
4073 : {
4074 11130 : const char* context = (where
4075 11130 : ? _("actual argument to INTENT = OUT/INOUT")
4076 : : NULL);
4077 :
4078 2945 : if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
4079 2945 : && CLASS_DATA (f->sym)->attr.class_pointer)
4080 11110 : || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
4081 11320 : && !gfc_check_vardef_context (a->expr, true, false, false, context))
4082 : {
4083 6 : ok = false;
4084 6 : goto match;
4085 : }
4086 11124 : if (!gfc_check_vardef_context (a->expr, false, false, false, context))
4087 : {
4088 21 : ok = false;
4089 21 : goto match;
4090 : }
4091 : }
4092 : /* F2023: 15.5.2.5 Ordinary dummy variables:
4093 : "(21) If the procedure is nonelemental, the dummy argument does not
4094 : have the VALUE attribute, and the actual argument is an array section
4095 : having a vector subscript, the dummy argument is not definable and
4096 : shall not have the ASYNCHRONOUS, INTENT (OUT), INTENT (INOUT), or
4097 : VOLATILE attributes."
4098 : */
4099 260374 : if ((f->sym->attr.intent == INTENT_OUT
4100 253571 : || f->sym->attr.intent == INTENT_INOUT
4101 249269 : || f->sym->attr.volatile_
4102 249233 : || f->sym->attr.asynchronous)
4103 11169 : && !f->sym->attr.value
4104 11169 : && !is_elemental
4105 267818 : && gfc_has_vector_subscript (a->expr))
4106 : {
4107 3 : if (where)
4108 3 : gfc_error ("Array-section actual argument with vector "
4109 : "subscripts at %L is incompatible with INTENT(OUT), "
4110 : "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
4111 : "of the dummy argument %qs",
4112 3 : &a->expr->where, f->sym->name);
4113 3 : ok = false;
4114 3 : goto match;
4115 : }
4116 :
4117 : /* C1232 (R1221) For an actual argument which is an array section or
4118 : an assumed-shape array, the dummy argument shall be an assumed-
4119 : shape array, if the dummy argument has the VOLATILE attribute. */
4120 :
4121 260371 : if (f->sym->attr.volatile_
4122 37 : && a->expr->expr_type == EXPR_VARIABLE
4123 34 : && a->expr->symtree->n.sym->as
4124 29 : && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
4125 2 : && !(fas && fas->type == AS_ASSUMED_SHAPE))
4126 : {
4127 1 : if (where)
4128 1 : gfc_error ("Assumed-shape actual argument at %L is "
4129 : "incompatible with the non-assumed-shape "
4130 : "dummy argument %qs due to VOLATILE attribute",
4131 : &a->expr->where,f->sym->name);
4132 1 : ok = false;
4133 1 : goto match;
4134 : }
4135 :
4136 : /* Find the last array_ref. */
4137 260370 : actual_arr_ref = NULL;
4138 260370 : if (a->expr->ref)
4139 47103 : actual_arr_ref = gfc_find_array_ref (a->expr, true);
4140 :
4141 260370 : if (f->sym->attr.volatile_
4142 36 : && actual_arr_ref && actual_arr_ref->type == AR_SECTION
4143 5 : && !(fas && fas->type == AS_ASSUMED_SHAPE))
4144 : {
4145 1 : if (where)
4146 1 : gfc_error ("Array-section actual argument at %L is "
4147 : "incompatible with the non-assumed-shape "
4148 : "dummy argument %qs due to VOLATILE attribute",
4149 1 : &a->expr->where, f->sym->name);
4150 1 : ok = false;
4151 1 : goto match;
4152 : }
4153 :
4154 : /* C1233 (R1221) For an actual argument which is a pointer array, the
4155 : dummy argument shall be an assumed-shape or pointer array, if the
4156 : dummy argument has the VOLATILE attribute. */
4157 :
4158 260369 : if (f->sym->attr.volatile_
4159 35 : && a->expr->expr_type == EXPR_VARIABLE
4160 32 : && a->expr->symtree->n.sym->attr.pointer
4161 17 : && a->expr->symtree->n.sym->as
4162 17 : && !(fas
4163 17 : && (fas->type == AS_ASSUMED_SHAPE
4164 6 : || f->sym->attr.pointer)))
4165 : {
4166 3 : if (where)
4167 2 : gfc_error ("Pointer-array actual argument at %L requires "
4168 : "an assumed-shape or pointer-array dummy "
4169 : "argument %qs due to VOLATILE attribute",
4170 : &a->expr->where,f->sym->name);
4171 3 : ok = false;
4172 3 : goto match;
4173 : }
4174 :
4175 : /* C_LOC/C_FUNLOC from ISO_C_BINDING as actual argument can only be
4176 : passed to a dummy argument of matching type C_PTR/C_FUNPTR. */
4177 260366 : if (a->expr->expr_type == EXPR_FUNCTION
4178 15328 : && a->expr->ts.type == BT_VOID
4179 5 : && a->expr->symtree->n.sym
4180 5 : && a->expr->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
4181 5 : && (f->sym->ts.type != BT_DERIVED
4182 3 : || f->sym->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
4183 3 : || !((a->expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_FUNLOC
4184 1 : && f->sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)
4185 : || (a->expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_LOC
4186 2 : && f->sym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR))))
4187 : {
4188 3 : if (where)
4189 0 : gfc_error ("ISO_C_BINDING function actual argument at %L "
4190 : "requires dummy argument %qs to have a matching "
4191 : "type from ISO_C_BINDING",
4192 : &a->expr->where,f->sym->name);
4193 3 : ok = false;
4194 3 : goto match;
4195 : }
4196 :
4197 260363 : match:
4198 367105 : if (a == actual)
4199 178574 : na = i;
4200 :
4201 367105 : new_arg[i++] = a;
4202 : }
4203 :
4204 : /* Give up now if we saw any bad argument. */
4205 178751 : if (!ok)
4206 : return false;
4207 :
4208 : /* Make sure missing actual arguments are optional. */
4209 : i = 0;
4210 362352 : for (f = formal; f; f = f->next, i++)
4211 : {
4212 249718 : if (new_arg[i] != NULL)
4213 243930 : continue;
4214 5788 : if (f->sym == NULL)
4215 : {
4216 1 : if (where)
4217 1 : gfc_error ("Missing alternate return spec in subroutine call "
4218 : "at %L", where);
4219 : return false;
4220 : }
4221 : /* For CLASS, the optional attribute might be set at either location. */
4222 5787 : if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional)
4223 5787 : && !f->sym->attr.optional)
4224 5701 : || (in_statement_function
4225 1 : && (f->sym->attr.optional
4226 0 : || (f->sym->ts.type == BT_CLASS
4227 0 : && CLASS_DATA (f->sym)->attr.optional))))
4228 : {
4229 87 : if (where)
4230 4 : gfc_error ("Missing actual argument for argument %qs at %L",
4231 : f->sym->name, where);
4232 : return false;
4233 : }
4234 : }
4235 :
4236 : /* We should have handled the cases where the formal arglist is null
4237 : already. */
4238 112634 : gcc_assert (n > 0);
4239 :
4240 : /* The argument lists are compatible. We now relink a new actual
4241 : argument list with null arguments in the right places. The head
4242 : of the list remains the head. */
4243 362185 : for (f = formal, i = 0; f; f = f->next, i++)
4244 249551 : if (new_arg[i] == NULL)
4245 : {
4246 5700 : new_arg[i] = gfc_get_actual_arglist ();
4247 5700 : new_arg[i]->associated_dummy = get_nonintrinsic_dummy_arg (f);
4248 : }
4249 :
4250 112634 : if (na != 0)
4251 : {
4252 439 : std::swap (*new_arg[0], *actual);
4253 439 : std::swap (new_arg[0], new_arg[na]);
4254 : }
4255 :
4256 249551 : for (i = 0; i < n - 1; i++)
4257 136917 : new_arg[i]->next = new_arg[i + 1];
4258 :
4259 112634 : new_arg[i]->next = NULL;
4260 :
4261 112634 : if (*ap == NULL && n > 0)
4262 814 : *ap = new_arg[0];
4263 :
4264 112634 : if (!in_statement_function)
4265 361426 : for (f = formal, i = 0; f; f = f->next, i++)
4266 : {
4267 249076 : if (new_arg[i]->expr)
4268 : {
4269 243167 : gfc_expr *e = new_arg[i]->expr;
4270 :
4271 243167 : if (f->sym->attr.value)
4272 : {
4273 22237 : gfc_value_used_expr (e, VALUE_VALUE_ARG);
4274 22237 : continue;
4275 : }
4276 220930 : switch (f->sym->attr.intent)
4277 : {
4278 6676 : case INTENT_OUT:
4279 6676 : {
4280 6676 : gfc_expr_set_at (e, &e->where, VALUE_INTENT_OUT);
4281 6676 : if (f->sym->attr.allocatable)
4282 419 : gfc_used_in_allocate_expr (e, &e->where, ALLOCATED_ARG);
4283 :
4284 : }
4285 : break;
4286 :
4287 116625 : case INTENT_IN:
4288 116625 : gfc_value_used_expr (e, VALUE_INTENT_IN);
4289 116625 : break;
4290 :
4291 97629 : case INTENT_INOUT:
4292 97629 : case INTENT_UNKNOWN:
4293 97629 : gfc_value_set_and_used (e, &e->where, VALUE_ARG,
4294 : VALUE_MAYBE_USED);
4295 :
4296 97629 : if (f->sym->attr.allocatable)
4297 2576 : gfc_used_in_allocate_expr (e, &e->where, ALLOCATED_ARG);
4298 : break;
4299 : }
4300 : }
4301 : }
4302 :
4303 : return true;
4304 : }
4305 :
4306 :
4307 : typedef struct
4308 : {
4309 : gfc_formal_arglist *f;
4310 : gfc_actual_arglist *a;
4311 : }
4312 : argpair;
4313 :
4314 : /* qsort comparison function for argument pairs, with the following
4315 : order:
4316 : - p->a->expr == NULL
4317 : - p->a->expr->expr_type != EXPR_VARIABLE
4318 : - by gfc_symbol pointer value (larger first). */
4319 :
4320 : static int
4321 2345 : pair_cmp (const void *p1, const void *p2)
4322 : {
4323 2345 : const gfc_actual_arglist *a1, *a2;
4324 :
4325 : /* *p1 and *p2 are elements of the to-be-sorted array. */
4326 2345 : a1 = ((const argpair *) p1)->a;
4327 2345 : a2 = ((const argpair *) p2)->a;
4328 2345 : if (!a1->expr)
4329 : {
4330 23 : if (!a2->expr)
4331 : return 0;
4332 23 : return -1;
4333 : }
4334 2322 : if (!a2->expr)
4335 : return 1;
4336 2313 : if (a1->expr->expr_type != EXPR_VARIABLE)
4337 : {
4338 1658 : if (a2->expr->expr_type != EXPR_VARIABLE)
4339 : return 0;
4340 1110 : return -1;
4341 : }
4342 655 : if (a2->expr->expr_type != EXPR_VARIABLE)
4343 : return 1;
4344 195 : if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym)
4345 : return -1;
4346 77 : return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
4347 : }
4348 :
4349 :
4350 : /* Given two expressions from some actual arguments, test whether they
4351 : refer to the same expression. The analysis is conservative.
4352 : Returning false will produce no warning. */
4353 :
4354 : static bool
4355 43 : compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
4356 : {
4357 43 : const gfc_ref *r1, *r2;
4358 :
4359 43 : if (!e1 || !e2
4360 43 : || e1->expr_type != EXPR_VARIABLE
4361 43 : || e2->expr_type != EXPR_VARIABLE
4362 43 : || e1->symtree->n.sym != e2->symtree->n.sym)
4363 : return false;
4364 :
4365 : /* TODO: improve comparison, see expr.cc:show_ref(). */
4366 4 : for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
4367 : {
4368 1 : if (r1->type != r2->type)
4369 : return false;
4370 1 : switch (r1->type)
4371 : {
4372 0 : case REF_ARRAY:
4373 0 : if (r1->u.ar.type != r2->u.ar.type)
4374 : return false;
4375 : /* TODO: At the moment, consider only full arrays;
4376 : we could do better. */
4377 0 : if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
4378 : return false;
4379 : break;
4380 :
4381 0 : case REF_COMPONENT:
4382 0 : if (r1->u.c.component != r2->u.c.component)
4383 : return false;
4384 : break;
4385 :
4386 : case REF_SUBSTRING:
4387 : return false;
4388 :
4389 1 : case REF_INQUIRY:
4390 1 : if (e1->symtree->n.sym->ts.type == BT_COMPLEX
4391 1 : && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL
4392 1 : && r1->u.i != r2->u.i)
4393 : return false;
4394 : break;
4395 :
4396 0 : default:
4397 0 : gfc_internal_error ("compare_actual_expr(): Bad component code");
4398 : }
4399 : }
4400 3 : if (!r1 && !r2)
4401 : return true;
4402 : return false;
4403 : }
4404 :
4405 :
4406 : /* Given formal and actual argument lists that correspond to one
4407 : another, check that identical actual arguments aren't not
4408 : associated with some incompatible INTENTs. */
4409 :
4410 : static bool
4411 740 : check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
4412 : {
4413 740 : sym_intent f1_intent, f2_intent;
4414 740 : gfc_formal_arglist *f1;
4415 740 : gfc_actual_arglist *a1;
4416 740 : size_t n, i, j;
4417 740 : argpair *p;
4418 740 : bool t = true;
4419 :
4420 740 : n = 0;
4421 740 : for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
4422 : {
4423 1939 : if (f1 == NULL && a1 == NULL)
4424 : break;
4425 1199 : if (f1 == NULL || a1 == NULL)
4426 0 : gfc_internal_error ("check_some_aliasing(): List mismatch");
4427 1199 : n++;
4428 : }
4429 740 : if (n == 0)
4430 : return t;
4431 657 : p = XALLOCAVEC (argpair, n);
4432 :
4433 1856 : for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
4434 : {
4435 1199 : p[i].f = f1;
4436 1199 : p[i].a = a1;
4437 : }
4438 :
4439 657 : qsort (p, n, sizeof (argpair), pair_cmp);
4440 :
4441 2513 : for (i = 0; i < n; i++)
4442 : {
4443 1199 : if (!p[i].a->expr
4444 1194 : || p[i].a->expr->expr_type != EXPR_VARIABLE
4445 572 : || p[i].a->expr->ts.type == BT_PROCEDURE)
4446 628 : continue;
4447 571 : f1_intent = p[i].f->sym->attr.intent;
4448 574 : for (j = i + 1; j < n; j++)
4449 : {
4450 : /* Expected order after the sort. */
4451 43 : if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
4452 0 : gfc_internal_error ("check_some_aliasing(): corrupted data");
4453 :
4454 : /* Are the expression the same? */
4455 43 : if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
4456 : break;
4457 3 : f2_intent = p[j].f->sym->attr.intent;
4458 3 : if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
4459 2 : || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
4460 1 : || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
4461 : {
4462 3 : gfc_warning (0, "Same actual argument associated with INTENT(%s) "
4463 : "argument %qs and INTENT(%s) argument %qs at %L",
4464 3 : gfc_intent_string (f1_intent), p[i].f->sym->name,
4465 : gfc_intent_string (f2_intent), p[j].f->sym->name,
4466 : &p[i].a->expr->where);
4467 3 : t = false;
4468 : }
4469 : }
4470 : }
4471 :
4472 : return t;
4473 : }
4474 :
4475 :
4476 : /* Given formal and actual argument lists that correspond to one
4477 : another, check that they are compatible in the sense that intents
4478 : are not mismatched. */
4479 :
4480 : static bool
4481 116524 : check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
4482 : {
4483 338426 : sym_intent f_intent;
4484 :
4485 560328 : for (;; f = f->next, a = a->next)
4486 : {
4487 338426 : gfc_expr *expr;
4488 :
4489 338426 : if (f == NULL && a == NULL)
4490 : break;
4491 221906 : if (f == NULL || a == NULL)
4492 0 : gfc_internal_error ("check_intents(): List mismatch");
4493 :
4494 221906 : if (a->expr && a->expr->expr_type == EXPR_FUNCTION
4495 12870 : && a->expr->value.function.isym
4496 7697 : && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
4497 0 : expr = a->expr->value.function.actual->expr;
4498 : else
4499 : expr = a->expr;
4500 :
4501 221906 : if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
4502 128452 : continue;
4503 :
4504 93454 : f_intent = f->sym->attr.intent;
4505 :
4506 93454 : if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
4507 : {
4508 412 : if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
4509 16 : && CLASS_DATA (f->sym)->attr.class_pointer)
4510 411 : || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
4511 : {
4512 2 : gfc_error ("Procedure argument at %L is local to a PURE "
4513 : "procedure and has the POINTER attribute",
4514 : &expr->where);
4515 2 : return false;
4516 : }
4517 : }
4518 :
4519 : /* Fortran 2008, C1283. */
4520 93452 : if (gfc_pure (NULL) && gfc_is_coindexed (expr))
4521 : {
4522 1 : if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
4523 : {
4524 1 : gfc_error ("Coindexed actual argument at %L in PURE procedure "
4525 : "is passed to an INTENT(%s) argument",
4526 : &expr->where, gfc_intent_string (f_intent));
4527 1 : return false;
4528 : }
4529 :
4530 0 : if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
4531 0 : && CLASS_DATA (f->sym)->attr.class_pointer)
4532 0 : || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
4533 : {
4534 0 : gfc_error ("Coindexed actual argument at %L in PURE procedure "
4535 : "is passed to a POINTER dummy argument",
4536 : &expr->where);
4537 0 : return false;
4538 : }
4539 : }
4540 :
4541 : /* F2008, Section 12.5.2.4. */
4542 6754 : if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
4543 99427 : && gfc_is_coindexed (expr))
4544 : {
4545 1 : gfc_error ("Coindexed polymorphic actual argument at %L is passed "
4546 : "polymorphic dummy argument %qs",
4547 1 : &expr->where, f->sym->name);
4548 1 : return false;
4549 : }
4550 221902 : }
4551 :
4552 : return true;
4553 : }
4554 :
4555 :
4556 : /* Check how a procedure is used against its interface. If all goes
4557 : well, the actual argument list will also end up being properly
4558 : sorted. */
4559 :
4560 : bool
4561 106532 : gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
4562 : {
4563 106532 : gfc_actual_arglist *a;
4564 106532 : gfc_formal_arglist *dummy_args;
4565 106532 : bool implicit = false;
4566 :
4567 : /* Warn about calls with an implicit interface. Special case
4568 : for calling a ISO_C_BINDING because c_loc and c_funloc
4569 : are pseudo-unknown. Additionally, warn about procedures not
4570 : explicitly declared at all if requested. */
4571 106532 : if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
4572 : {
4573 16509 : bool has_implicit_none_export = false;
4574 16509 : implicit = true;
4575 16509 : if (sym->attr.proc == PROC_UNKNOWN)
4576 23379 : for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
4577 11784 : if (ns->has_implicit_none_export)
4578 : {
4579 : has_implicit_none_export = true;
4580 : break;
4581 : }
4582 11599 : if (has_implicit_none_export)
4583 : {
4584 4 : const char *guessed
4585 4 : = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
4586 4 : if (guessed)
4587 1 : gfc_error ("Procedure %qs called at %L is not explicitly declared"
4588 : "; did you mean %qs?",
4589 : sym->name, where, guessed);
4590 : else
4591 3 : gfc_error ("Procedure %qs called at %L is not explicitly declared",
4592 : sym->name, where);
4593 : return false;
4594 : }
4595 16505 : if (warn_implicit_interface)
4596 0 : gfc_warning (OPT_Wimplicit_interface,
4597 : "Procedure %qs called with an implicit interface at %L",
4598 : sym->name, where);
4599 16505 : else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
4600 1 : gfc_warning (OPT_Wimplicit_procedure,
4601 : "Procedure %qs called at %L is not explicitly declared",
4602 : sym->name, where);
4603 16505 : gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1;
4604 : }
4605 :
4606 106528 : if (sym->attr.if_source == IFSRC_UNKNOWN)
4607 : {
4608 16505 : if (sym->attr.pointer)
4609 : {
4610 1 : gfc_error ("The pointer object %qs at %L must have an explicit "
4611 : "function interface or be declared as array",
4612 : sym->name, where);
4613 1 : return false;
4614 : }
4615 :
4616 16504 : if (sym->attr.allocatable && !sym->attr.external)
4617 : {
4618 1 : gfc_error ("The allocatable object %qs at %L must have an explicit "
4619 : "function interface or be declared as array",
4620 : sym->name, where);
4621 1 : return false;
4622 : }
4623 :
4624 16503 : if (sym->attr.allocatable)
4625 : {
4626 1 : gfc_error ("Allocatable function %qs at %L must have an explicit "
4627 : "function interface", sym->name, where);
4628 1 : return false;
4629 : }
4630 :
4631 46989 : for (a = *ap; a; a = a->next)
4632 : {
4633 30502 : if (a->expr && a->expr->error)
4634 : return false;
4635 :
4636 : /* F2018, 15.4.2.2 Explicit interface is required for a
4637 : polymorphic dummy argument, so there is no way to
4638 : legally have a class appear in an argument with an
4639 : implicit interface. */
4640 :
4641 30502 : if (implicit && a->expr && a->expr->ts.type == BT_CLASS)
4642 : {
4643 3 : gfc_error ("Explicit interface required for polymorphic "
4644 : "argument at %L",&a->expr->where);
4645 3 : a->expr->error = 1;
4646 3 : break;
4647 : }
4648 :
4649 : /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4650 30499 : if (a->name != NULL && a->name[0] != '%')
4651 : {
4652 2 : gfc_error ("Keyword argument requires explicit interface "
4653 : "for procedure %qs at %L", sym->name, &a->expr->where);
4654 2 : break;
4655 : }
4656 :
4657 : /* TS 29113, 6.2. */
4658 30497 : if (a->expr && a->expr->ts.type == BT_ASSUMED
4659 3 : && sym->intmod_sym_id != ISOCBINDING_LOC)
4660 : {
4661 3 : gfc_error ("Assumed-type argument %s at %L requires an explicit "
4662 3 : "interface", a->expr->symtree->n.sym->name,
4663 : &a->expr->where);
4664 3 : a->expr->error = 1;
4665 3 : break;
4666 : }
4667 :
4668 : /* F2008, C1303 and C1304. */
4669 30494 : if (a->expr
4670 30319 : && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
4671 73 : && a->expr->ts.u.derived
4672 30565 : && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
4673 1 : && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
4674 71 : || gfc_expr_attr (a->expr).lock_comp))
4675 : {
4676 1 : gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
4677 : "component at %L requires an explicit interface for "
4678 1 : "procedure %qs", &a->expr->where, sym->name);
4679 1 : a->expr->error = 1;
4680 1 : break;
4681 : }
4682 :
4683 30493 : if (a->expr
4684 30318 : && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
4685 72 : && a->expr->ts.u.derived
4686 30563 : && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
4687 0 : && a->expr->ts.u.derived->intmod_sym_id
4688 : == ISOFORTRAN_EVENT_TYPE)
4689 70 : || gfc_expr_attr (a->expr).event_comp))
4690 : {
4691 0 : gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
4692 : "component at %L requires an explicit interface for "
4693 0 : "procedure %qs", &a->expr->where, sym->name);
4694 0 : a->expr->error = 1;
4695 0 : break;
4696 : }
4697 :
4698 30493 : if (a->expr && a->expr->expr_type == EXPR_NULL
4699 2 : && a->expr->ts.type == BT_UNKNOWN)
4700 : {
4701 1 : gfc_error ("MOLD argument to NULL required at %L",
4702 : &a->expr->where);
4703 1 : a->expr->error = 1;
4704 1 : return false;
4705 : }
4706 :
4707 30492 : if (a->expr && a->expr->expr_type == EXPR_NULL)
4708 : {
4709 1 : gfc_error ("Passing intrinsic NULL as actual argument at %L "
4710 : "requires an explicit interface", &a->expr->where);
4711 1 : a->expr->error = 1;
4712 1 : return false;
4713 : }
4714 :
4715 : /* TS 29113, C407b. */
4716 30316 : if (a->expr && a->expr->expr_type == EXPR_VARIABLE
4717 43802 : && gfc_symbol_rank (a->expr->symtree->n.sym) == -1)
4718 : {
4719 4 : gfc_error ("Assumed-rank argument requires an explicit interface "
4720 4 : "at %L", &a->expr->where);
4721 4 : a->expr->error = 1;
4722 4 : return false;
4723 : }
4724 : }
4725 :
4726 16496 : if (implicit)
4727 46992 : for (a = *ap; a; a = a->next)
4728 30496 : if (a->expr)
4729 30321 : gfc_value_set_and_used (a->expr, &a->expr->where, VALUE_ARG,
4730 : VALUE_MAYBE_USED);
4731 :
4732 : return true;
4733 : }
4734 :
4735 90023 : dummy_args = gfc_sym_get_dummy_args (sym);
4736 :
4737 : /* For a statement function, check that types and type parameters of actual
4738 : arguments and dummy arguments match. */
4739 90023 : if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
4740 90023 : sym->attr.proc == PROC_ST_FUNCTION, where))
4741 : return false;
4742 :
4743 89568 : if (!check_intents (dummy_args, *ap))
4744 : return false;
4745 :
4746 89564 : if (warn_aliasing)
4747 728 : check_some_aliasing (dummy_args, *ap);
4748 :
4749 : return true;
4750 : }
4751 :
4752 :
4753 : /* Check how a procedure pointer component is used against its interface.
4754 : If all goes well, the actual argument list will also end up being properly
4755 : sorted. Completely analogous to gfc_procedure_use. */
4756 :
4757 : void
4758 595 : gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
4759 : {
4760 : /* Warn about calls with an implicit interface. Special case
4761 : for calling a ISO_C_BINDING because c_loc and c_funloc
4762 : are pseudo-unknown. */
4763 595 : if (warn_implicit_interface
4764 0 : && comp->attr.if_source == IFSRC_UNKNOWN
4765 0 : && !comp->attr.is_iso_c)
4766 0 : gfc_warning (OPT_Wimplicit_interface,
4767 : "Procedure pointer component %qs called with an implicit "
4768 : "interface at %L", comp->name, where);
4769 :
4770 595 : if (comp->attr.if_source == IFSRC_UNKNOWN)
4771 : {
4772 60 : gfc_actual_arglist *a;
4773 105 : for (a = *ap; a; a = a->next)
4774 : {
4775 : /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4776 45 : if (a->name != NULL && a->name[0] != '%')
4777 : {
4778 0 : gfc_error ("Keyword argument requires explicit interface "
4779 : "for procedure pointer component %qs at %L",
4780 0 : comp->name, &a->expr->where);
4781 0 : break;
4782 : }
4783 : }
4784 :
4785 : return;
4786 : }
4787 :
4788 535 : if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0,
4789 535 : comp->attr.elemental, false, where))
4790 : return;
4791 :
4792 535 : check_intents (comp->ts.interface->formal, *ap);
4793 535 : if (warn_aliasing)
4794 0 : check_some_aliasing (comp->ts.interface->formal, *ap);
4795 : }
4796 :
4797 :
4798 : /* Try if an actual argument list matches the formal list of a symbol,
4799 : respecting the symbol's attributes like ELEMENTAL. This is used for
4800 : GENERIC resolution. */
4801 :
4802 : bool
4803 93212 : gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
4804 : {
4805 93212 : gfc_formal_arglist *dummy_args;
4806 93212 : bool r;
4807 :
4808 93212 : if (sym->attr.flavor != FL_PROCEDURE)
4809 : return false;
4810 :
4811 93208 : dummy_args = gfc_sym_get_dummy_args (sym);
4812 :
4813 93208 : r = !sym->attr.elemental;
4814 93208 : if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL))
4815 : {
4816 26421 : check_intents (dummy_args, *args);
4817 26421 : if (warn_aliasing)
4818 12 : check_some_aliasing (dummy_args, *args);
4819 : return true;
4820 : }
4821 :
4822 : return false;
4823 : }
4824 :
4825 :
4826 : /* Given an interface pointer and an actual argument list, search for
4827 : a formal argument list that matches the actual. If found, returns
4828 : a pointer to the symbol of the correct interface. Returns NULL if
4829 : not found. */
4830 :
4831 : gfc_symbol *
4832 47041 : gfc_search_interface (gfc_interface *intr, int sub_flag,
4833 : gfc_actual_arglist **ap)
4834 : {
4835 47041 : gfc_symbol *elem_sym = NULL;
4836 47041 : gfc_symbol *null_sym = NULL;
4837 47041 : locus null_expr_loc;
4838 47041 : gfc_actual_arglist *a;
4839 47041 : bool has_null_arg = false;
4840 :
4841 130783 : for (a = *ap; a; a = a->next)
4842 83871 : if (a->expr && a->expr->expr_type == EXPR_NULL
4843 178 : && a->expr->ts.type == BT_UNKNOWN)
4844 : {
4845 129 : has_null_arg = true;
4846 129 : null_expr_loc = a->expr->where;
4847 129 : break;
4848 : }
4849 :
4850 133722 : for (; intr; intr = intr->next)
4851 : {
4852 98112 : if (gfc_fl_struct (intr->sym->attr.flavor))
4853 6973 : continue;
4854 91139 : if (sub_flag && intr->sym->attr.function)
4855 0 : continue;
4856 84111 : if (!sub_flag && intr->sym->attr.subroutine)
4857 0 : continue;
4858 :
4859 91139 : if (gfc_arglist_matches_symbol (ap, intr->sym))
4860 : {
4861 25154 : if (has_null_arg && null_sym)
4862 : {
4863 2 : gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
4864 : "between specific functions %s and %s",
4865 2 : &null_expr_loc, null_sym->name, intr->sym->name);
4866 2 : return NULL;
4867 : }
4868 25152 : else if (has_null_arg)
4869 : {
4870 4 : null_sym = intr->sym;
4871 4 : continue;
4872 : }
4873 :
4874 : /* Satisfy 12.4.4.1 such that an elemental match has lower
4875 : weight than a non-elemental match. */
4876 25148 : if (intr->sym->attr.elemental)
4877 : {
4878 13719 : elem_sym = intr->sym;
4879 13719 : continue;
4880 : }
4881 : return intr->sym;
4882 : }
4883 : }
4884 :
4885 35610 : if (null_sym)
4886 2 : return null_sym;
4887 :
4888 : return elem_sym ? elem_sym : NULL;
4889 : }
4890 :
4891 :
4892 : /* Do a brute force recursive search for a symbol. */
4893 :
4894 : static gfc_symtree *
4895 58878 : find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
4896 : {
4897 113816 : gfc_symtree * st;
4898 :
4899 113816 : if (root == NULL || root->n.sym == sym)
4900 : return root;
4901 :
4902 112775 : st = NULL;
4903 112775 : if (root->left)
4904 57771 : st = find_symtree0 (root->left, sym);
4905 112775 : if (root->right && ! st)
4906 : st = find_symtree0 (root->right, sym);
4907 : return st;
4908 : }
4909 :
4910 :
4911 : /* Find a symtree for a symbol. */
4912 :
4913 : gfc_symtree *
4914 5759 : gfc_find_sym_in_symtree (gfc_symbol *sym)
4915 : {
4916 5759 : gfc_symtree *st;
4917 5759 : gfc_namespace *ns;
4918 :
4919 : /* First try to find it by name. */
4920 5759 : gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
4921 5759 : if (st && st->n.sym == sym)
4922 : return st;
4923 :
4924 : /* If it's been renamed, resort to a brute-force search. */
4925 : /* TODO: avoid having to do this search. If the symbol doesn't exist
4926 : in the symtree for the current namespace, it should probably be added. */
4927 1104 : for (ns = gfc_current_ns; ns; ns = ns->parent)
4928 : {
4929 1104 : st = find_symtree0 (ns->sym_root, sym);
4930 1104 : if (st)
4931 : return st;
4932 :
4933 : /* Search user-defined operators. */
4934 66 : if (ns->uop_root && sym->attr.function)
4935 : {
4936 3 : st = find_symtree0 (ns->uop_root, sym);
4937 3 : if (st)
4938 : return st;
4939 : }
4940 : }
4941 0 : gfc_internal_error ("Unable to find symbol %qs", sym->name);
4942 : /* Not reached. */
4943 : }
4944 :
4945 :
4946 : /* See if the arglist to an operator-call contains a derived-type argument
4947 : with a matching type-bound operator. If so, return the matching specific
4948 : procedure defined as operator-target as well as the base-object to use
4949 : (which is the found derived-type argument with operator). The generic
4950 : name, if any, is transmitted to the final expression via 'gname'. */
4951 :
4952 : static gfc_typebound_proc*
4953 14019 : matching_typebound_op (gfc_expr** tb_base,
4954 : gfc_actual_arglist* args,
4955 : gfc_intrinsic_op op, const char* uop,
4956 : const char ** gname)
4957 : {
4958 14019 : gfc_actual_arglist* base;
4959 :
4960 40284 : for (base = args; base; base = base->next)
4961 27099 : if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
4962 : {
4963 : gfc_typebound_proc* tb;
4964 : gfc_symbol* derived;
4965 : bool result;
4966 :
4967 23064 : while (base->expr->expr_type == EXPR_OP
4968 23064 : && base->expr->value.op.op == INTRINSIC_PARENTHESES)
4969 123 : base->expr = base->expr->value.op.op1;
4970 :
4971 22941 : if (base->expr->ts.type == BT_CLASS)
4972 : {
4973 2045 : if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL
4974 4091 : || !gfc_expr_attr (base->expr).class_ok)
4975 87 : continue;
4976 1959 : derived = CLASS_DATA (base->expr)->ts.u.derived;
4977 : }
4978 : else
4979 20895 : derived = base->expr->ts.u.derived;
4980 :
4981 : /* A use associated derived type is resolvable during parsing. */
4982 22854 : if (derived && derived->attr.use_assoc && !gfc_current_ns->resolved)
4983 4187 : gfc_resolve_symbol (derived);
4984 :
4985 22854 : if (op == INTRINSIC_USER)
4986 : {
4987 228 : gfc_symtree* tb_uop;
4988 :
4989 228 : gcc_assert (uop);
4990 228 : tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
4991 : false, NULL);
4992 :
4993 228 : if (tb_uop)
4994 84 : tb = tb_uop->n.tb;
4995 : else
4996 : tb = NULL;
4997 : }
4998 : else
4999 22626 : tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
5000 : false, NULL);
5001 :
5002 : /* This means we hit a PRIVATE operator which is use-associated and
5003 : should thus not be seen. */
5004 22854 : if (!result)
5005 21870 : tb = NULL;
5006 :
5007 : /* Look through the super-type hierarchy for a matching specific
5008 : binding. */
5009 23004 : for (; tb; tb = tb->overridden)
5010 : {
5011 984 : gfc_tbp_generic* g;
5012 :
5013 984 : gcc_assert (tb->is_generic);
5014 1556 : for (g = tb->u.generic; g; g = g->next)
5015 : {
5016 1406 : gfc_symbol* target;
5017 1406 : gfc_actual_arglist* argcopy;
5018 1406 : bool matches;
5019 :
5020 : /* If expression matching comes here during parsing, eg. when
5021 : parsing ASSOCIATE, generic TBPs have not yet been resolved
5022 : and g->specific will not have been set. Wait for expression
5023 : resolution by returning NULL. */
5024 1406 : if (!g->specific && !gfc_current_ns->resolved)
5025 834 : return NULL;
5026 :
5027 1406 : gcc_assert (g->specific);
5028 1406 : if (g->specific->error)
5029 0 : continue;
5030 :
5031 1406 : target = g->specific->u.specific->n.sym;
5032 :
5033 : /* Check if this arglist matches the formal. */
5034 1406 : argcopy = gfc_copy_actual_arglist (args);
5035 1406 : matches = gfc_arglist_matches_symbol (&argcopy, target);
5036 1406 : gfc_free_actual_arglist (argcopy);
5037 :
5038 : /* Return if we found a match. */
5039 1406 : if (matches)
5040 : {
5041 834 : *tb_base = base->expr;
5042 834 : *gname = g->specific_st->name;
5043 834 : return g->specific;
5044 : }
5045 : }
5046 : }
5047 : }
5048 :
5049 : return NULL;
5050 : }
5051 :
5052 :
5053 : /* For the 'actual arglist' of an operator call and a specific typebound
5054 : procedure that has been found the target of a type-bound operator, build the
5055 : appropriate EXPR_COMPCALL and resolve it. We take this indirection over
5056 : type-bound procedures rather than resolving type-bound operators 'directly'
5057 : so that we can reuse the existing logic. */
5058 :
5059 : static void
5060 834 : build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
5061 : gfc_expr* base, gfc_typebound_proc* target,
5062 : const char *gname)
5063 : {
5064 834 : e->expr_type = EXPR_COMPCALL;
5065 834 : e->value.compcall.tbp = target;
5066 834 : e->value.compcall.name = gname ? gname : "$op";
5067 834 : e->value.compcall.actual = actual;
5068 834 : e->value.compcall.base_object = base;
5069 834 : e->value.compcall.ignore_pass = 1;
5070 834 : e->value.compcall.assign = 0;
5071 834 : if (e->ts.type == BT_UNKNOWN
5072 816 : && target->function)
5073 : {
5074 361 : if (target->is_generic)
5075 0 : e->ts = target->u.generic->specific->u.specific->n.sym->ts;
5076 : else
5077 361 : e->ts = target->u.specific->n.sym->ts;
5078 : }
5079 834 : }
5080 :
5081 :
5082 : /* This subroutine is called when an expression is being resolved.
5083 : The expression node in question is either a user defined operator
5084 : or an intrinsic operator with arguments that aren't compatible
5085 : with the operator. This subroutine builds an actual argument list
5086 : corresponding to the operands, then searches for a compatible
5087 : interface. If one is found, the expression node is replaced with
5088 : the appropriate function call. We use the 'match' enum to specify
5089 : whether a replacement has been made or not, or if an error occurred. */
5090 :
5091 : match
5092 2233 : gfc_extend_expr (gfc_expr *e)
5093 : {
5094 2233 : gfc_actual_arglist *actual;
5095 2233 : gfc_symbol *sym;
5096 2233 : gfc_namespace *ns;
5097 2233 : gfc_user_op *uop;
5098 2233 : gfc_intrinsic_op i;
5099 2233 : const char *gname;
5100 2233 : gfc_typebound_proc* tbo;
5101 2233 : gfc_expr* tb_base;
5102 :
5103 2233 : sym = NULL;
5104 :
5105 2233 : actual = gfc_get_actual_arglist ();
5106 2233 : actual->expr = e->value.op.op1;
5107 :
5108 2233 : gname = NULL;
5109 :
5110 2233 : if (e->value.op.op2 != NULL)
5111 : {
5112 2006 : actual->next = gfc_get_actual_arglist ();
5113 2006 : actual->next->expr = e->value.op.op2;
5114 : }
5115 :
5116 2233 : i = fold_unary_intrinsic (e->value.op.op);
5117 :
5118 : /* See if we find a matching type-bound operator. */
5119 2219 : if (i == INTRINSIC_USER)
5120 329 : tbo = matching_typebound_op (&tb_base, actual,
5121 329 : i, e->value.op.uop->name, &gname);
5122 : else
5123 1904 : switch (i)
5124 : {
5125 : #define CHECK_OS_COMPARISON(comp) \
5126 : case INTRINSIC_##comp: \
5127 : case INTRINSIC_##comp##_OS: \
5128 : tbo = matching_typebound_op (&tb_base, actual, \
5129 : INTRINSIC_##comp, NULL, &gname); \
5130 : if (!tbo) \
5131 : tbo = matching_typebound_op (&tb_base, actual, \
5132 : INTRINSIC_##comp##_OS, NULL, &gname); \
5133 : break;
5134 193 : CHECK_OS_COMPARISON(EQ)
5135 828 : CHECK_OS_COMPARISON(NE)
5136 41 : CHECK_OS_COMPARISON(GT)
5137 40 : CHECK_OS_COMPARISON(GE)
5138 78 : CHECK_OS_COMPARISON(LT)
5139 40 : CHECK_OS_COMPARISON(LE)
5140 : #undef CHECK_OS_COMPARISON
5141 :
5142 684 : default:
5143 684 : tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
5144 684 : break;
5145 : }
5146 :
5147 : /* If there is a matching typebound-operator, replace the expression with
5148 : a call to it and succeed. */
5149 2229 : if (tbo)
5150 : {
5151 379 : gcc_assert (tb_base);
5152 379 : build_compcall_for_operator (e, actual, tb_base, tbo, gname);
5153 :
5154 379 : if (!gfc_resolve_expr (e))
5155 : return MATCH_ERROR;
5156 : else
5157 377 : return MATCH_YES;
5158 : }
5159 :
5160 1854 : if (i == INTRINSIC_USER)
5161 : {
5162 279 : for (ns = gfc_current_ns; ns; ns = ns->parent)
5163 : {
5164 269 : uop = gfc_find_uop (e->value.op.uop->name, ns);
5165 269 : if (uop == NULL)
5166 6 : continue;
5167 :
5168 263 : sym = gfc_search_interface (uop->op, 0, &actual);
5169 263 : if (sym != NULL)
5170 : break;
5171 : }
5172 : }
5173 : else
5174 : {
5175 1923 : for (ns = gfc_current_ns; ns; ns = ns->parent)
5176 : {
5177 : /* Due to the distinction between '==' and '.eq.' and friends, one has
5178 : to check if either is defined. */
5179 1683 : switch (i)
5180 : {
5181 : #define CHECK_OS_COMPARISON(comp) \
5182 : case INTRINSIC_##comp: \
5183 : case INTRINSIC_##comp##_OS: \
5184 : sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
5185 : if (!sym) \
5186 : sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
5187 : break;
5188 196 : CHECK_OS_COMPARISON(EQ)
5189 872 : CHECK_OS_COMPARISON(NE)
5190 41 : CHECK_OS_COMPARISON(GT)
5191 40 : CHECK_OS_COMPARISON(GE)
5192 65 : CHECK_OS_COMPARISON(LT)
5193 40 : CHECK_OS_COMPARISON(LE)
5194 : #undef CHECK_OS_COMPARISON
5195 :
5196 429 : default:
5197 429 : sym = gfc_search_interface (ns->op[i], 0, &actual);
5198 : }
5199 :
5200 1449 : if (sym != NULL)
5201 : break;
5202 : }
5203 :
5204 : /* F2018(15.4.3.4.2) requires that the use of unlimited polymorphic
5205 : formal arguments does not override the intrinsic uses. */
5206 1608 : gfc_push_suppress_errors ();
5207 1608 : if (sym
5208 1368 : && (UNLIMITED_POLY (sym->formal->sym)
5209 1358 : || (sym->formal->next
5210 1332 : && UNLIMITED_POLY (sym->formal->next->sym)))
5211 1618 : && !gfc_check_operator_interface (sym, e->value.op.op, e->where))
5212 0 : sym = NULL;
5213 1608 : gfc_pop_suppress_errors ();
5214 : }
5215 :
5216 : /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
5217 : found rather than just taking the first one and not checking further. */
5218 :
5219 1854 : if (sym == NULL)
5220 : {
5221 : /* Don't use gfc_free_actual_arglist(). */
5222 250 : free (actual->next);
5223 250 : free (actual);
5224 250 : return MATCH_NO;
5225 : }
5226 :
5227 : /* Change the expression node to a function call. */
5228 1604 : e->expr_type = EXPR_FUNCTION;
5229 1604 : e->symtree = gfc_find_sym_in_symtree (sym);
5230 1604 : e->value.function.actual = actual;
5231 1604 : e->value.function.esym = NULL;
5232 1604 : e->value.function.isym = NULL;
5233 1604 : e->value.function.name = NULL;
5234 1604 : e->user_operator = 1;
5235 :
5236 1604 : if (!gfc_resolve_expr (e))
5237 0 : return MATCH_ERROR;
5238 :
5239 : return MATCH_YES;
5240 : }
5241 :
5242 :
5243 : /* Tries to replace an assignment code node with a subroutine call to the
5244 : subroutine associated with the assignment operator. Return true if the node
5245 : was replaced. On false, no error is generated. */
5246 :
5247 : bool
5248 290202 : gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
5249 : {
5250 290202 : gfc_actual_arglist *actual;
5251 290202 : gfc_expr *lhs, *rhs, *tb_base;
5252 290202 : gfc_symbol *sym = NULL;
5253 290202 : const char *gname = NULL;
5254 290202 : gfc_typebound_proc* tbo;
5255 :
5256 290202 : lhs = c->expr1;
5257 290202 : rhs = c->expr2;
5258 :
5259 : /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
5260 290202 : if (c->op == EXEC_ASSIGN
5261 290202 : && c->expr1->expr_type == EXPR_VARIABLE
5262 290202 : && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ)
5263 : return false;
5264 :
5265 : /* Don't allow an intrinsic assignment to be replaced. */
5266 281921 : if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
5267 280752 : && (rhs->rank == 0 || rhs->rank == lhs->rank)
5268 570927 : && (lhs->ts.type == rhs->ts.type
5269 6982 : || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
5270 : return false;
5271 :
5272 10570 : actual = gfc_get_actual_arglist ();
5273 10570 : actual->expr = lhs;
5274 :
5275 10570 : actual->next = gfc_get_actual_arglist ();
5276 10570 : actual->next->expr = rhs;
5277 :
5278 : /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
5279 :
5280 : /* See if we find a matching type-bound assignment. */
5281 10570 : tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
5282 : NULL, &gname);
5283 :
5284 10570 : if (tbo)
5285 : {
5286 : /* Success: Replace the expression with a type-bound call. */
5287 455 : gcc_assert (tb_base);
5288 455 : c->expr1 = gfc_get_expr ();
5289 455 : build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
5290 455 : c->expr1->value.compcall.assign = 1;
5291 455 : c->expr1->where = c->loc;
5292 455 : c->expr2 = NULL;
5293 455 : c->op = EXEC_COMPCALL;
5294 455 : return true;
5295 : }
5296 :
5297 : /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
5298 23636 : for (; ns; ns = ns->parent)
5299 : {
5300 13990 : sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
5301 13990 : if (sym != NULL)
5302 : break;
5303 : }
5304 :
5305 10115 : if (sym)
5306 : {
5307 : /* Success: Replace the assignment with the call. */
5308 469 : c->op = EXEC_ASSIGN_CALL;
5309 469 : c->symtree = gfc_find_sym_in_symtree (sym);
5310 469 : c->expr1 = NULL;
5311 469 : c->expr2 = NULL;
5312 469 : c->ext.actual = actual;
5313 469 : return true;
5314 : }
5315 :
5316 : /* Failure: No assignment procedure found. */
5317 9646 : free (actual->next);
5318 9646 : free (actual);
5319 9646 : return false;
5320 : }
5321 :
5322 :
5323 : /* Make sure that the interface just parsed is not already present in
5324 : the given interface list. Ambiguity isn't checked yet since module
5325 : procedures can be present without interfaces. */
5326 :
5327 : bool
5328 10395 : gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
5329 : {
5330 10395 : gfc_interface *ip;
5331 :
5332 20240 : for (ip = base; ip; ip = ip->next)
5333 : {
5334 9852 : if (ip->sym == new_sym)
5335 : {
5336 7 : gfc_error ("Entity %qs at %L is already present in the interface",
5337 : new_sym->name, &loc);
5338 7 : return false;
5339 : }
5340 : }
5341 :
5342 : return true;
5343 : }
5344 :
5345 :
5346 : /* Add a symbol to the current interface. */
5347 :
5348 : bool
5349 19100 : gfc_add_interface (gfc_symbol *new_sym)
5350 : {
5351 19100 : gfc_interface **head, *intr;
5352 19100 : gfc_namespace *ns;
5353 19100 : gfc_symbol *sym;
5354 :
5355 19100 : switch (current_interface.type)
5356 : {
5357 : case INTERFACE_NAMELESS:
5358 : case INTERFACE_ABSTRACT:
5359 : return true;
5360 :
5361 672 : case INTERFACE_INTRINSIC_OP:
5362 1347 : for (ns = current_interface.ns; ns; ns = ns->parent)
5363 678 : switch (current_interface.op)
5364 : {
5365 75 : case INTRINSIC_EQ:
5366 75 : case INTRINSIC_EQ_OS:
5367 75 : if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
5368 : gfc_current_locus)
5369 75 : || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
5370 : new_sym, gfc_current_locus))
5371 : return false;
5372 : break;
5373 :
5374 44 : case INTRINSIC_NE:
5375 44 : case INTRINSIC_NE_OS:
5376 44 : if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
5377 : gfc_current_locus)
5378 44 : || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
5379 : new_sym, gfc_current_locus))
5380 : return false;
5381 : break;
5382 :
5383 19 : case INTRINSIC_GT:
5384 19 : case INTRINSIC_GT_OS:
5385 19 : if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
5386 : new_sym, gfc_current_locus)
5387 19 : || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
5388 : new_sym, gfc_current_locus))
5389 : return false;
5390 : break;
5391 :
5392 17 : case INTRINSIC_GE:
5393 17 : case INTRINSIC_GE_OS:
5394 17 : if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
5395 : new_sym, gfc_current_locus)
5396 17 : || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
5397 : new_sym, gfc_current_locus))
5398 : return false;
5399 : break;
5400 :
5401 29 : case INTRINSIC_LT:
5402 29 : case INTRINSIC_LT_OS:
5403 29 : if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
5404 : new_sym, gfc_current_locus)
5405 29 : || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
5406 : new_sym, gfc_current_locus))
5407 : return false;
5408 : break;
5409 :
5410 17 : case INTRINSIC_LE:
5411 17 : case INTRINSIC_LE_OS:
5412 17 : if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
5413 : new_sym, gfc_current_locus)
5414 17 : || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
5415 : new_sym, gfc_current_locus))
5416 : return false;
5417 : break;
5418 :
5419 477 : default:
5420 477 : if (!gfc_check_new_interface (ns->op[current_interface.op],
5421 : new_sym, gfc_current_locus))
5422 : return false;
5423 : }
5424 :
5425 669 : head = ¤t_interface.ns->op[current_interface.op];
5426 669 : break;
5427 :
5428 8974 : case INTERFACE_GENERIC:
5429 8974 : case INTERFACE_DTIO:
5430 17957 : for (ns = current_interface.ns; ns; ns = ns->parent)
5431 : {
5432 8984 : gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
5433 8984 : if (sym == NULL)
5434 11 : continue;
5435 :
5436 8973 : if (!gfc_check_new_interface (sym->generic,
5437 : new_sym, gfc_current_locus))
5438 : return false;
5439 : }
5440 :
5441 8973 : head = ¤t_interface.sym->generic;
5442 8973 : break;
5443 :
5444 169 : case INTERFACE_USER_OP:
5445 169 : if (!gfc_check_new_interface (current_interface.uop->op,
5446 : new_sym, gfc_current_locus))
5447 : return false;
5448 :
5449 168 : head = ¤t_interface.uop->op;
5450 168 : break;
5451 :
5452 0 : default:
5453 0 : gfc_internal_error ("gfc_add_interface(): Bad interface type");
5454 : }
5455 :
5456 9810 : intr = gfc_get_interface ();
5457 9810 : intr->sym = new_sym;
5458 9810 : intr->where = gfc_current_locus;
5459 :
5460 9810 : intr->next = *head;
5461 9810 : *head = intr;
5462 :
5463 9810 : return true;
5464 : }
5465 :
5466 :
5467 : gfc_interface *&
5468 95383 : gfc_current_interface_head (void)
5469 : {
5470 95383 : switch (current_interface.type)
5471 : {
5472 12183 : case INTERFACE_INTRINSIC_OP:
5473 12183 : return current_interface.ns->op[current_interface.op];
5474 :
5475 80300 : case INTERFACE_GENERIC:
5476 80300 : case INTERFACE_DTIO:
5477 80300 : return current_interface.sym->generic;
5478 :
5479 2900 : case INTERFACE_USER_OP:
5480 2900 : return current_interface.uop->op;
5481 :
5482 0 : default:
5483 0 : gcc_unreachable ();
5484 : }
5485 : }
5486 :
5487 :
5488 : void
5489 3 : gfc_set_current_interface_head (gfc_interface *i)
5490 : {
5491 3 : switch (current_interface.type)
5492 : {
5493 0 : case INTERFACE_INTRINSIC_OP:
5494 0 : current_interface.ns->op[current_interface.op] = i;
5495 0 : break;
5496 :
5497 3 : case INTERFACE_GENERIC:
5498 3 : case INTERFACE_DTIO:
5499 3 : current_interface.sym->generic = i;
5500 3 : break;
5501 :
5502 0 : case INTERFACE_USER_OP:
5503 0 : current_interface.uop->op = i;
5504 0 : break;
5505 :
5506 0 : default:
5507 0 : gcc_unreachable ();
5508 : }
5509 3 : }
5510 :
5511 :
5512 : /* Gets rid of a formal argument list. We do not free symbols.
5513 : Symbols are freed when a namespace is freed. */
5514 :
5515 : void
5516 6512031 : gfc_free_formal_arglist (gfc_formal_arglist *p)
5517 : {
5518 6512031 : gfc_formal_arglist *q;
5519 :
5520 7288154 : for (; p; p = q)
5521 : {
5522 776123 : q = p->next;
5523 776123 : free (p);
5524 : }
5525 6512031 : }
5526 :
5527 :
5528 : /* Check that it is ok for the type-bound procedure 'proc' to override the
5529 : procedure 'old', cf. F08:4.5.7.3. */
5530 :
5531 : bool
5532 1218 : gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
5533 : {
5534 1218 : locus where;
5535 1218 : gfc_symbol *proc_target, *old_target;
5536 1218 : unsigned proc_pass_arg, old_pass_arg, argpos;
5537 1218 : gfc_formal_arglist *proc_formal, *old_formal;
5538 1218 : bool check_type;
5539 1218 : char err[200];
5540 :
5541 : /* This procedure should only be called for non-GENERIC proc. */
5542 1218 : gcc_assert (!proc->n.tb->is_generic);
5543 :
5544 : /* If the overwritten procedure is GENERIC, this is an error. */
5545 1218 : if (old->n.tb->is_generic)
5546 : {
5547 1 : gfc_error ("Cannot overwrite GENERIC %qs at %L",
5548 : old->name, &proc->n.tb->where);
5549 1 : return false;
5550 : }
5551 :
5552 1217 : where = proc->n.tb->where;
5553 1217 : proc_target = proc->n.tb->u.specific->n.sym;
5554 1217 : old_target = old->n.tb->u.specific->n.sym;
5555 :
5556 : /* Check that overridden binding is not NON_OVERRIDABLE. */
5557 1217 : if (old->n.tb->non_overridable)
5558 : {
5559 1 : gfc_error ("%qs at %L overrides a procedure binding declared"
5560 : " NON_OVERRIDABLE", proc->name, &where);
5561 1 : return false;
5562 : }
5563 :
5564 : /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
5565 1216 : if (!old->n.tb->deferred && proc->n.tb->deferred)
5566 : {
5567 1 : gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
5568 : " non-DEFERRED binding", proc->name, &where);
5569 1 : return false;
5570 : }
5571 :
5572 : /* If the overridden binding is PURE, the overriding must be, too. */
5573 1215 : if (old_target->attr.pure && !proc_target->attr.pure)
5574 : {
5575 2 : gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
5576 : proc->name, &where);
5577 2 : return false;
5578 : }
5579 :
5580 : /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
5581 : is not, the overriding must not be either. */
5582 1213 : if (old_target->attr.elemental && !proc_target->attr.elemental)
5583 : {
5584 0 : gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
5585 : " ELEMENTAL", proc->name, &where);
5586 0 : return false;
5587 : }
5588 1213 : if (!old_target->attr.elemental && proc_target->attr.elemental)
5589 : {
5590 1 : gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
5591 : " be ELEMENTAL, either", proc->name, &where);
5592 1 : return false;
5593 : }
5594 :
5595 : /* If the overridden binding is a SUBROUTINE, the overriding must also be a
5596 : SUBROUTINE. */
5597 1212 : if (old_target->attr.subroutine && !proc_target->attr.subroutine)
5598 : {
5599 1 : gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
5600 : " SUBROUTINE", proc->name, &where);
5601 1 : return false;
5602 : }
5603 :
5604 : /* If the overridden binding is a FUNCTION, the overriding must also be a
5605 : FUNCTION and have the same characteristics. */
5606 1211 : if (old_target->attr.function)
5607 : {
5608 661 : if (!proc_target->attr.function)
5609 : {
5610 1 : gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
5611 : " FUNCTION", proc->name, &where);
5612 1 : return false;
5613 : }
5614 :
5615 660 : if (!gfc_check_result_characteristics (proc_target, old_target,
5616 : err, sizeof(err)))
5617 : {
5618 6 : gfc_error ("Result mismatch for the overriding procedure "
5619 : "%qs at %L: %s", proc->name, &where, err);
5620 6 : return false;
5621 : }
5622 : }
5623 :
5624 : /* If the overridden binding is PUBLIC, the overriding one must not be
5625 : PRIVATE. */
5626 1204 : if (old->n.tb->access == ACCESS_PUBLIC
5627 1179 : && proc->n.tb->access == ACCESS_PRIVATE)
5628 : {
5629 1 : gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
5630 : " PRIVATE", proc->name, &where);
5631 1 : return false;
5632 : }
5633 :
5634 : /* Compare the formal argument lists of both procedures. This is also abused
5635 : to find the position of the passed-object dummy arguments of both
5636 : bindings as at least the overridden one might not yet be resolved and we
5637 : need those positions in the check below. */
5638 1203 : proc_pass_arg = old_pass_arg = 0;
5639 1203 : if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
5640 1203 : proc_pass_arg = 1;
5641 1203 : if (!old->n.tb->nopass && !old->n.tb->pass_arg)
5642 1203 : old_pass_arg = 1;
5643 1203 : argpos = 1;
5644 1203 : proc_formal = gfc_sym_get_dummy_args (proc_target);
5645 1203 : old_formal = gfc_sym_get_dummy_args (old_target);
5646 4342 : for ( ; proc_formal && old_formal;
5647 1936 : proc_formal = proc_formal->next, old_formal = old_formal->next)
5648 : {
5649 1943 : if (proc->n.tb->pass_arg
5650 493 : && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
5651 1943 : proc_pass_arg = argpos;
5652 1943 : if (old->n.tb->pass_arg
5653 495 : && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
5654 1943 : old_pass_arg = argpos;
5655 :
5656 : /* Check that the names correspond. */
5657 1943 : if (strcmp (proc_formal->sym->name, old_formal->sym->name))
5658 : {
5659 1 : gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
5660 : " to match the corresponding argument of the overridden"
5661 : " procedure", proc_formal->sym->name, proc->name, &where,
5662 : old_formal->sym->name);
5663 1 : return false;
5664 : }
5665 :
5666 1942 : check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
5667 1942 : if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
5668 : check_type, err, sizeof(err)))
5669 : {
5670 6 : gfc_error_opt (0, "Argument mismatch for the overriding procedure "
5671 : "%qs at %L: %s", proc->name, &where, err);
5672 6 : return false;
5673 : }
5674 :
5675 1936 : ++argpos;
5676 : }
5677 1196 : if (proc_formal || old_formal)
5678 : {
5679 1 : gfc_error ("%qs at %L must have the same number of formal arguments as"
5680 : " the overridden procedure", proc->name, &where);
5681 1 : return false;
5682 : }
5683 :
5684 : /* If the overridden binding is NOPASS, the overriding one must also be
5685 : NOPASS. */
5686 1195 : if (old->n.tb->nopass && !proc->n.tb->nopass)
5687 : {
5688 1 : gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
5689 : " NOPASS", proc->name, &where);
5690 1 : return false;
5691 : }
5692 :
5693 : /* If the overridden binding is PASS(x), the overriding one must also be
5694 : PASS and the passed-object dummy arguments must correspond. */
5695 1194 : if (!old->n.tb->nopass)
5696 : {
5697 1160 : if (proc->n.tb->nopass)
5698 : {
5699 1 : gfc_error ("%qs at %L overrides a binding with PASS and must also be"
5700 : " PASS", proc->name, &where);
5701 1 : return false;
5702 : }
5703 :
5704 1159 : if (proc_pass_arg != old_pass_arg)
5705 : {
5706 1 : gfc_error ("Passed-object dummy argument of %qs at %L must be at"
5707 : " the same position as the passed-object dummy argument of"
5708 : " the overridden procedure", proc->name, &where);
5709 1 : return false;
5710 : }
5711 : }
5712 :
5713 : return true;
5714 : }
5715 :
5716 :
5717 : /* The following three functions check that the formal arguments
5718 : of user defined derived type IO procedures are compliant with
5719 : the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
5720 :
5721 : static void
5722 4572 : check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
5723 : int kind, int rank, sym_intent intent)
5724 : {
5725 4572 : if (fsym->ts.type != type)
5726 : {
5727 3 : gfc_error ("DTIO dummy argument at %L must be of type %s",
5728 : &fsym->declared_at, gfc_basic_typename (type));
5729 3 : return;
5730 : }
5731 :
5732 4569 : if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
5733 3767 : && fsym->ts.kind != kind)
5734 1 : gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
5735 : &fsym->declared_at, kind);
5736 :
5737 4569 : if (!typebound
5738 4569 : && rank == 0
5739 1148 : && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
5740 950 : || ((type != BT_CLASS) && fsym->attr.dimension)))
5741 0 : gfc_error ("DTIO dummy argument at %L must be a scalar",
5742 : &fsym->declared_at);
5743 4569 : else if (rank == 1
5744 677 : && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
5745 1 : gfc_error ("DTIO dummy argument at %L must be an "
5746 : "ASSUMED SHAPE ARRAY", &fsym->declared_at);
5747 :
5748 4569 : if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)
5749 1 : gfc_error ("DTIO character argument at %L must have assumed length",
5750 : &fsym->declared_at);
5751 :
5752 4569 : if (fsym->attr.intent != intent)
5753 1 : gfc_error ("DTIO dummy argument at %L must have INTENT %s",
5754 : &fsym->declared_at, gfc_code2string (intents, (int)intent));
5755 : return;
5756 : }
5757 :
5758 :
5759 : static void
5760 889 : check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
5761 : bool typebound, bool formatted, int code)
5762 : {
5763 889 : gfc_symbol *dtio_sub, *generic_proc, *fsym;
5764 889 : gfc_typebound_proc *tb_io_proc, *specific_proc;
5765 889 : gfc_interface *intr;
5766 889 : gfc_formal_arglist *formal;
5767 889 : int arg_num;
5768 :
5769 889 : bool read = ((dtio_codes)code == DTIO_RF)
5770 889 : || ((dtio_codes)code == DTIO_RUF);
5771 889 : bt type;
5772 889 : sym_intent intent;
5773 889 : int kind;
5774 :
5775 889 : dtio_sub = NULL;
5776 889 : if (typebound)
5777 : {
5778 : /* Typebound DTIO binding. */
5779 559 : tb_io_proc = tb_io_st->n.tb;
5780 559 : if (tb_io_proc == NULL)
5781 : return;
5782 :
5783 559 : gcc_assert (tb_io_proc->is_generic);
5784 :
5785 559 : specific_proc = tb_io_proc->u.generic->specific;
5786 559 : if (specific_proc == NULL || specific_proc->is_generic)
5787 : return;
5788 :
5789 559 : dtio_sub = specific_proc->u.specific->n.sym;
5790 : }
5791 : else
5792 : {
5793 330 : generic_proc = tb_io_st->n.sym;
5794 330 : if (generic_proc == NULL || generic_proc->generic == NULL)
5795 : return;
5796 :
5797 407 : for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
5798 : {
5799 334 : if (intr->sym && intr->sym->formal && intr->sym->formal->sym
5800 330 : && ((intr->sym->formal->sym->ts.type == BT_CLASS
5801 231 : && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
5802 : == derived)
5803 127 : || (intr->sym->formal->sym->ts.type == BT_DERIVED
5804 99 : && intr->sym->formal->sym->ts.u.derived == derived)))
5805 : {
5806 : dtio_sub = intr->sym;
5807 : break;
5808 : }
5809 80 : else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
5810 : {
5811 1 : gfc_error ("Alternate return at %L is not permitted in a DTIO "
5812 : "procedure", &intr->sym->declared_at);
5813 1 : return;
5814 : }
5815 : }
5816 :
5817 327 : if (dtio_sub == NULL)
5818 : return;
5819 : }
5820 :
5821 559 : gcc_assert (dtio_sub);
5822 813 : if (!dtio_sub->attr.subroutine)
5823 0 : gfc_error ("DTIO procedure %qs at %L must be a subroutine",
5824 : dtio_sub->name, &dtio_sub->declared_at);
5825 :
5826 813 : if (!dtio_sub->resolve_symbol_called)
5827 1 : gfc_resolve_formal_arglist (dtio_sub);
5828 :
5829 813 : arg_num = 0;
5830 5416 : for (formal = dtio_sub->formal; formal; formal = formal->next)
5831 4603 : arg_num++;
5832 :
5833 944 : if (arg_num < (formatted ? 6 : 4))
5834 : {
5835 5 : gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
5836 : dtio_sub->name, &dtio_sub->declared_at);
5837 5 : return;
5838 : }
5839 :
5840 808 : if (arg_num > (formatted ? 6 : 4))
5841 : {
5842 3 : gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
5843 : dtio_sub->name, &dtio_sub->declared_at);
5844 3 : return;
5845 : }
5846 :
5847 : /* Now go through the formal arglist. */
5848 : arg_num = 1;
5849 5377 : for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
5850 : {
5851 4573 : if (!formatted && arg_num == 3)
5852 128 : arg_num = 5;
5853 4573 : fsym = formal->sym;
5854 :
5855 4573 : if (fsym == NULL)
5856 : {
5857 1 : gfc_error ("Alternate return at %L is not permitted in a DTIO "
5858 : "procedure", &dtio_sub->declared_at);
5859 1 : return;
5860 : }
5861 :
5862 4572 : switch (arg_num)
5863 : {
5864 805 : case(1): /* DTV */
5865 805 : type = derived->attr.sequence || derived->attr.is_bind_c ?
5866 : BT_DERIVED : BT_CLASS;
5867 805 : kind = 0;
5868 805 : intent = read ? INTENT_INOUT : INTENT_IN;
5869 805 : check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5870 : 0, intent);
5871 805 : break;
5872 :
5873 805 : case(2): /* UNIT */
5874 805 : type = BT_INTEGER;
5875 805 : kind = gfc_default_integer_kind;
5876 805 : intent = INTENT_IN;
5877 805 : check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5878 : 0, intent);
5879 805 : break;
5880 677 : case(3): /* IOTYPE */
5881 677 : type = BT_CHARACTER;
5882 677 : kind = gfc_default_character_kind;
5883 677 : intent = INTENT_IN;
5884 677 : check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5885 : 0, intent);
5886 677 : break;
5887 677 : case(4): /* VLIST */
5888 677 : type = BT_INTEGER;
5889 677 : kind = gfc_default_integer_kind;
5890 677 : intent = INTENT_IN;
5891 677 : check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5892 : 1, intent);
5893 677 : break;
5894 804 : case(5): /* IOSTAT */
5895 804 : type = BT_INTEGER;
5896 804 : kind = gfc_default_integer_kind;
5897 804 : intent = INTENT_OUT;
5898 804 : check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5899 : 0, intent);
5900 804 : break;
5901 804 : case(6): /* IOMSG */
5902 804 : type = BT_CHARACTER;
5903 804 : kind = gfc_default_character_kind;
5904 804 : intent = INTENT_INOUT;
5905 804 : check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5906 : 0, intent);
5907 804 : break;
5908 0 : default:
5909 0 : gcc_unreachable ();
5910 : }
5911 : }
5912 804 : derived->attr.has_dtio_procs = 1;
5913 804 : return;
5914 : }
5915 :
5916 : void
5917 97710 : gfc_check_dtio_interfaces (gfc_symbol *derived)
5918 : {
5919 97710 : gfc_symtree *tb_io_st;
5920 97710 : bool t = false;
5921 97710 : int code;
5922 97710 : bool formatted;
5923 :
5924 97710 : if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
5925 38450 : return;
5926 :
5927 : /* Check typebound DTIO bindings. */
5928 296300 : for (code = 0; code < 4; code++)
5929 : {
5930 237040 : formatted = ((dtio_codes)code == DTIO_RF)
5931 : || ((dtio_codes)code == DTIO_WF);
5932 :
5933 237040 : tb_io_st = gfc_find_typebound_proc (derived, &t,
5934 : gfc_code2string (dtio_procs, code),
5935 : true, &derived->declared_at);
5936 237040 : if (tb_io_st != NULL)
5937 559 : check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
5938 : }
5939 :
5940 : /* Check generic DTIO interfaces. */
5941 296300 : for (code = 0; code < 4; code++)
5942 : {
5943 237040 : formatted = ((dtio_codes)code == DTIO_RF)
5944 : || ((dtio_codes)code == DTIO_WF);
5945 :
5946 237040 : tb_io_st = gfc_find_symtree (derived->ns->sym_root,
5947 : gfc_code2string (dtio_procs, code));
5948 237040 : if (tb_io_st != NULL)
5949 330 : check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
5950 : }
5951 : }
5952 :
5953 :
5954 : gfc_symtree*
5955 4403 : gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
5956 : {
5957 4403 : gfc_symtree *tb_io_st = NULL;
5958 4403 : bool t = false;
5959 :
5960 4403 : if (!derived || !derived->resolve_symbol_called
5961 4403 : || derived->attr.flavor != FL_DERIVED)
5962 : return NULL;
5963 :
5964 : /* Try to find a typebound DTIO binding. */
5965 4397 : if (formatted == true)
5966 : {
5967 4152 : if (write == true)
5968 1947 : tb_io_st = gfc_find_typebound_proc (derived, &t,
5969 : gfc_code2string (dtio_procs,
5970 : DTIO_WF),
5971 : true,
5972 : &derived->declared_at);
5973 : else
5974 2205 : tb_io_st = gfc_find_typebound_proc (derived, &t,
5975 : gfc_code2string (dtio_procs,
5976 : DTIO_RF),
5977 : true,
5978 : &derived->declared_at);
5979 : }
5980 : else
5981 : {
5982 245 : if (write == true)
5983 109 : tb_io_st = gfc_find_typebound_proc (derived, &t,
5984 : gfc_code2string (dtio_procs,
5985 : DTIO_WUF),
5986 : true,
5987 : &derived->declared_at);
5988 : else
5989 136 : tb_io_st = gfc_find_typebound_proc (derived, &t,
5990 : gfc_code2string (dtio_procs,
5991 : DTIO_RUF),
5992 : true,
5993 : &derived->declared_at);
5994 : }
5995 : return tb_io_st;
5996 : }
5997 :
5998 :
5999 : gfc_symbol *
6000 2943 : gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
6001 : {
6002 2943 : gfc_symtree *tb_io_st = NULL;
6003 2943 : gfc_symbol *dtio_sub = NULL;
6004 2943 : gfc_symbol *extended;
6005 2943 : gfc_typebound_proc *tb_io_proc, *specific_proc;
6006 :
6007 2943 : tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted);
6008 :
6009 2943 : if (tb_io_st != NULL)
6010 : {
6011 860 : const char *genname;
6012 860 : gfc_symtree *st;
6013 :
6014 860 : tb_io_proc = tb_io_st->n.tb;
6015 860 : gcc_assert (tb_io_proc != NULL);
6016 860 : gcc_assert (tb_io_proc->is_generic);
6017 860 : gcc_assert (tb_io_proc->u.generic->next == NULL);
6018 :
6019 860 : specific_proc = tb_io_proc->u.generic->specific;
6020 860 : gcc_assert (!specific_proc->is_generic);
6021 :
6022 : /* Go back and make sure that we have the right specific procedure.
6023 : Here we most likely have a procedure from the parent type, which
6024 : can be overridden in extensions. */
6025 860 : genname = tb_io_proc->u.generic->specific_st->name;
6026 860 : st = gfc_find_typebound_proc (derived, NULL, genname,
6027 : true, &tb_io_proc->where);
6028 860 : if (st)
6029 860 : dtio_sub = st->n.tb->u.specific->n.sym;
6030 : else
6031 0 : dtio_sub = specific_proc->u.specific->n.sym;
6032 :
6033 860 : goto finish;
6034 : }
6035 :
6036 : /* If there is not a typebound binding, look for a generic
6037 : DTIO interface. */
6038 4245 : for (extended = derived; extended;
6039 2162 : extended = gfc_get_derived_super_type (extended))
6040 : {
6041 2162 : if (extended == NULL || extended->ns == NULL
6042 2162 : || extended->attr.flavor == FL_UNKNOWN)
6043 : return NULL;
6044 :
6045 2162 : if (formatted == true)
6046 : {
6047 2075 : if (write == true)
6048 940 : tb_io_st = gfc_find_symtree (extended->ns->sym_root,
6049 : gfc_code2string (dtio_procs,
6050 : DTIO_WF));
6051 : else
6052 1135 : tb_io_st = gfc_find_symtree (extended->ns->sym_root,
6053 : gfc_code2string (dtio_procs,
6054 : DTIO_RF));
6055 : }
6056 : else
6057 : {
6058 87 : if (write == true)
6059 37 : tb_io_st = gfc_find_symtree (extended->ns->sym_root,
6060 : gfc_code2string (dtio_procs,
6061 : DTIO_WUF));
6062 : else
6063 50 : tb_io_st = gfc_find_symtree (extended->ns->sym_root,
6064 : gfc_code2string (dtio_procs,
6065 : DTIO_RUF));
6066 : }
6067 :
6068 2162 : if (tb_io_st != NULL
6069 269 : && tb_io_st->n.sym
6070 269 : && tb_io_st->n.sym->generic)
6071 : {
6072 26 : for (gfc_interface *intr = tb_io_st->n.sym->generic;
6073 295 : intr && intr->sym; intr = intr->next)
6074 : {
6075 273 : if (intr->sym->formal)
6076 : {
6077 268 : gfc_symbol *fsym = intr->sym->formal->sym;
6078 268 : if ((fsym->ts.type == BT_CLASS
6079 218 : && CLASS_DATA (fsym)->ts.u.derived == extended)
6080 71 : || (fsym->ts.type == BT_DERIVED
6081 50 : && fsym->ts.u.derived == extended))
6082 : {
6083 : dtio_sub = intr->sym;
6084 : break;
6085 : }
6086 : }
6087 : }
6088 : }
6089 : }
6090 :
6091 2083 : finish:
6092 2943 : if (dtio_sub
6093 1107 : && dtio_sub->formal->sym->ts.type == BT_CLASS
6094 1057 : && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
6095 97 : gfc_find_derived_vtab (derived);
6096 :
6097 : return dtio_sub;
6098 : }
6099 :
6100 : /* Helper function - if we do not find an interface for a procedure,
6101 : construct it from the actual arglist. Luckily, this can only
6102 : happen for call by reference, so the information we actually need
6103 : to provide (and which would be impossible to guess from the call
6104 : itself) is not actually needed. */
6105 :
6106 : void
6107 2004 : gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
6108 : gfc_actual_arglist *actual_args)
6109 : {
6110 2004 : gfc_actual_arglist *a;
6111 2004 : gfc_formal_arglist **f;
6112 2004 : gfc_symbol *s;
6113 2004 : char name[GFC_MAX_SYMBOL_LEN + 1];
6114 2004 : static int var_num;
6115 :
6116 : /* Do not infer the formal from actual arguments if we are dealing with
6117 : classes. */
6118 :
6119 2004 : if (sym->ts.type == BT_CLASS)
6120 1 : return;
6121 :
6122 2003 : f = &sym->formal;
6123 6008 : for (a = actual_args; a != NULL; a = a->next)
6124 : {
6125 4005 : (*f) = gfc_get_formal_arglist ();
6126 4005 : if (a->expr)
6127 : {
6128 3997 : snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
6129 3997 : gfc_get_symbol (name, gfc_current_ns, &s);
6130 3997 : if (a->expr->ts.type == BT_PROCEDURE)
6131 : {
6132 44 : gfc_symbol *asym = a->expr->symtree->n.sym;
6133 44 : s->attr.flavor = FL_PROCEDURE;
6134 44 : if (asym->attr.function)
6135 : {
6136 24 : s->attr.function = 1;
6137 24 : s->ts = asym->ts;
6138 : }
6139 44 : s->attr.subroutine = asym->attr.subroutine;
6140 : }
6141 : else
6142 : {
6143 3953 : s->ts = a->expr->ts;
6144 :
6145 3953 : if (s->ts.type == BT_CHARACTER)
6146 180 : s->ts.u.cl = gfc_get_charlen ();
6147 :
6148 3953 : s->ts.deferred = 0;
6149 3953 : s->ts.is_iso_c = 0;
6150 3953 : s->ts.is_c_interop = 0;
6151 3953 : s->attr.flavor = FL_VARIABLE;
6152 3953 : if (a->expr->rank > 0)
6153 : {
6154 876 : s->attr.dimension = 1;
6155 876 : s->as = gfc_get_array_spec ();
6156 876 : s->as->rank = 1;
6157 1752 : s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
6158 876 : &a->expr->where, 1);
6159 876 : s->as->upper[0] = NULL;
6160 876 : s->as->type = AS_ASSUMED_SIZE;
6161 : }
6162 : else
6163 3077 : s->maybe_array = maybe_dummy_array_arg (a->expr);
6164 : }
6165 3997 : s->attr.dummy = 1;
6166 3997 : s->attr.artificial = 1;
6167 3997 : s->declared_at = a->expr->where;
6168 3997 : s->attr.intent = INTENT_UNKNOWN;
6169 3997 : (*f)->sym = s;
6170 3997 : gfc_commit_symbol (s);
6171 : }
6172 : else /* If a->expr is NULL, this is an alternate rerturn. */
6173 8 : (*f)->sym = NULL;
6174 :
6175 4005 : f = &((*f)->next);
6176 : }
6177 :
6178 : }
6179 :
6180 :
6181 : const char *
6182 241 : gfc_dummy_arg_get_name (gfc_dummy_arg & dummy_arg)
6183 : {
6184 241 : switch (dummy_arg.intrinsicness)
6185 : {
6186 241 : case GFC_INTRINSIC_DUMMY_ARG:
6187 241 : return dummy_arg.u.intrinsic->name;
6188 :
6189 0 : case GFC_NON_INTRINSIC_DUMMY_ARG:
6190 0 : return dummy_arg.u.non_intrinsic->sym->name;
6191 :
6192 0 : default:
6193 0 : gcc_unreachable ();
6194 : }
6195 : }
6196 :
6197 :
6198 : const gfc_typespec &
6199 2460 : gfc_dummy_arg_get_typespec (gfc_dummy_arg & dummy_arg)
6200 : {
6201 2460 : switch (dummy_arg.intrinsicness)
6202 : {
6203 1352 : case GFC_INTRINSIC_DUMMY_ARG:
6204 1352 : return dummy_arg.u.intrinsic->ts;
6205 :
6206 1108 : case GFC_NON_INTRINSIC_DUMMY_ARG:
6207 1108 : return dummy_arg.u.non_intrinsic->sym->ts;
6208 :
6209 0 : default:
6210 0 : gcc_unreachable ();
6211 : }
6212 : }
6213 :
6214 :
6215 : bool
6216 26468 : gfc_dummy_arg_is_optional (gfc_dummy_arg & dummy_arg)
6217 : {
6218 26468 : switch (dummy_arg.intrinsicness)
6219 : {
6220 12464 : case GFC_INTRINSIC_DUMMY_ARG:
6221 12464 : return dummy_arg.u.intrinsic->optional;
6222 :
6223 14004 : case GFC_NON_INTRINSIC_DUMMY_ARG:
6224 14004 : return dummy_arg.u.non_intrinsic->sym->attr.optional;
6225 :
6226 0 : default:
6227 0 : gcc_unreachable ();
6228 : }
6229 : }
|
