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