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