1 /* Deal with interfaces.
2 Copyright (C) 2000-2020 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_dummy_typename (&s1->ts),
1334 gfc_dummy_typename (&s2->ts));
1335 return false;
1336 }
1337 if (!compare_rank (s1, s2))
1338 {
1339 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
1340 s1->name, symbol_rank (s1), symbol_rank (s2));
1341 return false;
1342 }
1343 }
1344
1345 /* Check INTENT. */
1346 if (s1->attr.intent != s2->attr.intent)
1347 {
1348 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1349 s1->name);
1350 return false;
1351 }
1352
1353 /* Check OPTIONAL attribute. */
1354 if (s1->attr.optional != s2->attr.optional)
1355 {
1356 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1357 s1->name);
1358 return false;
1359 }
1360
1361 /* Check ALLOCATABLE attribute. */
1362 if (s1->attr.allocatable != s2->attr.allocatable)
1363 {
1364 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1365 s1->name);
1366 return false;
1367 }
1368
1369 /* Check POINTER attribute. */
1370 if (s1->attr.pointer != s2->attr.pointer)
1371 {
1372 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1373 s1->name);
1374 return false;
1375 }
1376
1377 /* Check TARGET attribute. */
1378 if (s1->attr.target != s2->attr.target)
1379 {
1380 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1381 s1->name);
1382 return false;
1383 }
1384
1385 /* Check ASYNCHRONOUS attribute. */
1386 if (s1->attr.asynchronous != s2->attr.asynchronous)
1387 {
1388 snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
1389 s1->name);
1390 return false;
1391 }
1392
1393 /* Check CONTIGUOUS attribute. */
1394 if (s1->attr.contiguous != s2->attr.contiguous)
1395 {
1396 snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
1397 s1->name);
1398 return false;
1399 }
1400
1401 /* Check VALUE attribute. */
1402 if (s1->attr.value != s2->attr.value)
1403 {
1404 snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
1405 s1->name);
1406 return false;
1407 }
1408
1409 /* Check VOLATILE attribute. */
1410 if (s1->attr.volatile_ != s2->attr.volatile_)
1411 {
1412 snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
1413 s1->name);
1414 return false;
1415 }
1416
1417 /* Check interface of dummy procedures. */
1418 if (s1->attr.flavor == FL_PROCEDURE)
1419 {
1420 char err[200];
1421 if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
1422 NULL, NULL))
1423 {
1424 snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
1425 "'%s': %s", s1->name, err);
1426 return false;
1427 }
1428 }
1429
1430 /* Check string length. */
1431 if (s1->ts.type == BT_CHARACTER
1432 && s1->ts.u.cl && s1->ts.u.cl->length
1433 && s2->ts.u.cl && s2->ts.u.cl->length)
1434 {
1435 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1436 s2->ts.u.cl->length);
1437 switch (compval)
1438 {
1439 case -1:
1440 case 1:
1441 case -3:
1442 snprintf (errmsg, err_len, "Character length mismatch "
1443 "in argument '%s'", s1->name);
1444 return false;
1445
1446 case -2:
1447 /* FIXME: Implement a warning for this case.
1448 gfc_warning (0, "Possible character length mismatch in argument %qs",
1449 s1->name);*/
1450 break;
1451
1452 case 0:
1453 break;
1454
1455 default:
1456 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1457 "%i of gfc_dep_compare_expr", compval);
1458 break;
1459 }
1460 }
1461
1462 /* Check array shape. */
1463 if (s1->as && s2->as)
1464 {
1465 int i, compval;
1466 gfc_expr *shape1, *shape2;
1467
1468 if (s1->as->type != s2->as->type)
1469 {
1470 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1471 s1->name);
1472 return false;
1473 }
1474
1475 if (s1->as->corank != s2->as->corank)
1476 {
1477 snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
1478 s1->name, s1->as->corank, s2->as->corank);
1479 return false;
1480 }
1481
1482 if (s1->as->type == AS_EXPLICIT)
1483 for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++)
1484 {
1485 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1486 gfc_copy_expr (s1->as->lower[i]));
1487 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1488 gfc_copy_expr (s2->as->lower[i]));
1489 compval = gfc_dep_compare_expr (shape1, shape2);
1490 gfc_free_expr (shape1);
1491 gfc_free_expr (shape2);
1492 switch (compval)
1493 {
1494 case -1:
1495 case 1:
1496 case -3:
1497 if (i < s1->as->rank)
1498 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
1499 " argument '%s'", i + 1, s1->name);
1500 else
1501 snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
1502 "of argument '%s'", i - s1->as->rank + 1, s1->name);
1503 return false;
1504
1505 case -2:
1506 /* FIXME: Implement a warning for this case.
1507 gfc_warning (0, "Possible shape mismatch in argument %qs",
1508 s1->name);*/
1509 break;
1510
1511 case 0:
1512 break;
1513
1514 default:
1515 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1516 "result %i of gfc_dep_compare_expr",
1517 compval);
1518 break;
1519 }
1520 }
1521 }
1522
1523 return true;
1524 }
1525
1526
1527 /* Check if the characteristics of two function results match,
1528 cf. F08:12.3.3. */
1529
1530 bool
gfc_check_result_characteristics(gfc_symbol * s1,gfc_symbol * s2,char * errmsg,int err_len)1531 gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1532 char *errmsg, int err_len)
1533 {
1534 gfc_symbol *r1, *r2;
1535
1536 if (s1->ts.interface && s1->ts.interface->result)
1537 r1 = s1->ts.interface->result;
1538 else
1539 r1 = s1->result ? s1->result : s1;
1540
1541 if (s2->ts.interface && s2->ts.interface->result)
1542 r2 = s2->ts.interface->result;
1543 else
1544 r2 = s2->result ? s2->result : s2;
1545
1546 if (r1->ts.type == BT_UNKNOWN)
1547 return true;
1548
1549 /* Check type and rank. */
1550 if (!compare_type_characteristics (r1, r2))
1551 {
1552 snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
1553 gfc_typename (&r1->ts), gfc_typename (&r2->ts));
1554 return false;
1555 }
1556 if (!compare_rank (r1, r2))
1557 {
1558 snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
1559 symbol_rank (r1), symbol_rank (r2));
1560 return false;
1561 }
1562
1563 /* Check ALLOCATABLE attribute. */
1564 if (r1->attr.allocatable != r2->attr.allocatable)
1565 {
1566 snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1567 "function result");
1568 return false;
1569 }
1570
1571 /* Check POINTER attribute. */
1572 if (r1->attr.pointer != r2->attr.pointer)
1573 {
1574 snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1575 "function result");
1576 return false;
1577 }
1578
1579 /* Check CONTIGUOUS attribute. */
1580 if (r1->attr.contiguous != r2->attr.contiguous)
1581 {
1582 snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1583 "function result");
1584 return false;
1585 }
1586
1587 /* Check PROCEDURE POINTER attribute. */
1588 if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1589 {
1590 snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1591 "function result");
1592 return false;
1593 }
1594
1595 /* Check string length. */
1596 if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1597 {
1598 if (r1->ts.deferred != r2->ts.deferred)
1599 {
1600 snprintf (errmsg, err_len, "Character length mismatch "
1601 "in function result");
1602 return false;
1603 }
1604
1605 if (r1->ts.u.cl->length && r2->ts.u.cl->length)
1606 {
1607 int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1608 r2->ts.u.cl->length);
1609 switch (compval)
1610 {
1611 case -1:
1612 case 1:
1613 case -3:
1614 snprintf (errmsg, err_len, "Character length mismatch "
1615 "in function result");
1616 return false;
1617
1618 case -2:
1619 /* FIXME: Implement a warning for this case.
1620 snprintf (errmsg, err_len, "Possible character length mismatch "
1621 "in function result");*/
1622 break;
1623
1624 case 0:
1625 break;
1626
1627 default:
1628 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1629 "result %i of gfc_dep_compare_expr", compval);
1630 break;
1631 }
1632 }
1633 }
1634
1635 /* Check array shape. */
1636 if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1637 {
1638 int i, compval;
1639 gfc_expr *shape1, *shape2;
1640
1641 if (r1->as->type != r2->as->type)
1642 {
1643 snprintf (errmsg, err_len, "Shape mismatch in function result");
1644 return false;
1645 }
1646
1647 if (r1->as->type == AS_EXPLICIT)
1648 for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1649 {
1650 shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1651 gfc_copy_expr (r1->as->lower[i]));
1652 shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1653 gfc_copy_expr (r2->as->lower[i]));
1654 compval = gfc_dep_compare_expr (shape1, shape2);
1655 gfc_free_expr (shape1);
1656 gfc_free_expr (shape2);
1657 switch (compval)
1658 {
1659 case -1:
1660 case 1:
1661 case -3:
1662 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1663 "function result", i + 1);
1664 return false;
1665
1666 case -2:
1667 /* FIXME: Implement a warning for this case.
1668 gfc_warning (0, "Possible shape mismatch in return value");*/
1669 break;
1670
1671 case 0:
1672 break;
1673
1674 default:
1675 gfc_internal_error ("check_result_characteristics (2): "
1676 "Unexpected result %i of "
1677 "gfc_dep_compare_expr", compval);
1678 break;
1679 }
1680 }
1681 }
1682
1683 return true;
1684 }
1685
1686
1687 /* 'Compare' two formal interfaces associated with a pair of symbols.
1688 We return true if there exists an actual argument list that
1689 would be ambiguous between the two interfaces, zero otherwise.
1690 'strict_flag' specifies whether all the characteristics are
1691 required to match, which is not the case for ambiguity checks.
1692 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1693
1694 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,bool * bad_result_characteristics)1695 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1696 int generic_flag, int strict_flag,
1697 char *errmsg, int err_len,
1698 const char *p1, const char *p2,
1699 bool *bad_result_characteristics)
1700 {
1701 gfc_formal_arglist *f1, *f2;
1702
1703 gcc_assert (name2 != NULL);
1704
1705 if (bad_result_characteristics)
1706 *bad_result_characteristics = false;
1707
1708 if (s1->attr.function && (s2->attr.subroutine
1709 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1710 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1711 {
1712 if (errmsg != NULL)
1713 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1714 return false;
1715 }
1716
1717 if (s1->attr.subroutine && s2->attr.function)
1718 {
1719 if (errmsg != NULL)
1720 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1721 return false;
1722 }
1723
1724 /* Do strict checks on all characteristics
1725 (for dummy procedures and procedure pointer assignments). */
1726 if (!generic_flag && strict_flag)
1727 {
1728 if (s1->attr.function && s2->attr.function)
1729 {
1730 /* If both are functions, check result characteristics. */
1731 if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
1732 || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
1733 {
1734 if (bad_result_characteristics)
1735 *bad_result_characteristics = true;
1736 return false;
1737 }
1738 }
1739
1740 if (s1->attr.pure && !s2->attr.pure)
1741 {
1742 snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1743 return false;
1744 }
1745 if (s1->attr.elemental && !s2->attr.elemental)
1746 {
1747 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1748 return false;
1749 }
1750 }
1751
1752 if (s1->attr.if_source == IFSRC_UNKNOWN
1753 || s2->attr.if_source == IFSRC_UNKNOWN)
1754 return true;
1755
1756 f1 = gfc_sym_get_dummy_args (s1);
1757 f2 = gfc_sym_get_dummy_args (s2);
1758
1759 /* Special case: No arguments. */
1760 if (f1 == NULL && f2 == NULL)
1761 return true;
1762
1763 if (generic_flag)
1764 {
1765 if (count_types_test (f1, f2, p1, p2)
1766 || count_types_test (f2, f1, p2, p1))
1767 return false;
1768
1769 /* Special case: alternate returns. If both f1->sym and f2->sym are
1770 NULL, then the leading formal arguments are alternate returns.
1771 The previous conditional should catch argument lists with
1772 different number of argument. */
1773 if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
1774 return true;
1775
1776 if (generic_correspondence (f1, f2, p1, p2)
1777 || generic_correspondence (f2, f1, p2, p1))
1778 return false;
1779 }
1780 else
1781 /* Perform the abbreviated correspondence test for operators (the
1782 arguments cannot be optional and are always ordered correctly).
1783 This is also done when comparing interfaces for dummy procedures and in
1784 procedure pointer assignments. */
1785
1786 for (; f1 || f2; f1 = f1->next, f2 = f2->next)
1787 {
1788 /* Check existence. */
1789 if (f1 == NULL || f2 == NULL)
1790 {
1791 if (errmsg != NULL)
1792 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1793 "arguments", name2);
1794 return false;
1795 }
1796
1797 if (strict_flag)
1798 {
1799 /* Check all characteristics. */
1800 if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
1801 errmsg, err_len))
1802 return false;
1803 }
1804 else
1805 {
1806 /* Operators: Only check type and rank of arguments. */
1807 if (!compare_type (f2->sym, f1->sym))
1808 {
1809 if (errmsg != NULL)
1810 snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
1811 "(%s/%s)", f1->sym->name,
1812 gfc_typename (&f1->sym->ts),
1813 gfc_typename (&f2->sym->ts));
1814 return false;
1815 }
1816 if (!compare_rank (f2->sym, f1->sym))
1817 {
1818 if (errmsg != NULL)
1819 snprintf (errmsg, err_len, "Rank mismatch in argument "
1820 "'%s' (%i/%i)", f1->sym->name,
1821 symbol_rank (f1->sym), symbol_rank (f2->sym));
1822 return false;
1823 }
1824 if ((gfc_option.allow_std & GFC_STD_F2008)
1825 && (compare_ptr_alloc(f1->sym, f2->sym)
1826 || compare_ptr_alloc(f2->sym, f1->sym)))
1827 {
1828 if (errmsg != NULL)
1829 snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE "
1830 "attribute in argument '%s' ", f1->sym->name);
1831 return false;
1832 }
1833 }
1834 }
1835
1836 return true;
1837 }
1838
1839
1840 /* Given a pointer to an interface pointer, remove duplicate
1841 interfaces and make sure that all symbols are either functions
1842 or subroutines, and all of the same kind. Returns true if
1843 something goes wrong. */
1844
1845 static bool
check_interface0(gfc_interface * p,const char * interface_name)1846 check_interface0 (gfc_interface *p, const char *interface_name)
1847 {
1848 gfc_interface *psave, *q, *qlast;
1849
1850 psave = p;
1851 for (; p; p = p->next)
1852 {
1853 /* Make sure all symbols in the interface have been defined as
1854 functions or subroutines. */
1855 if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1856 || !p->sym->attr.if_source)
1857 && !gfc_fl_struct (p->sym->attr.flavor))
1858 {
1859 const char *guessed
1860 = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
1861
1862 if (p->sym->attr.external)
1863 if (guessed)
1864 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1865 "; did you mean %qs?",
1866 p->sym->name, interface_name, &p->sym->declared_at,
1867 guessed);
1868 else
1869 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1870 p->sym->name, interface_name, &p->sym->declared_at);
1871 else
1872 if (guessed)
1873 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1874 "subroutine; did you mean %qs?", p->sym->name,
1875 interface_name, &p->sym->declared_at, guessed);
1876 else
1877 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1878 "subroutine", p->sym->name, interface_name,
1879 &p->sym->declared_at);
1880 return true;
1881 }
1882
1883 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1884 if ((psave->sym->attr.function && !p->sym->attr.function
1885 && !gfc_fl_struct (p->sym->attr.flavor))
1886 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1887 {
1888 if (!gfc_fl_struct (p->sym->attr.flavor))
1889 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1890 " or all FUNCTIONs", interface_name,
1891 &p->sym->declared_at);
1892 else if (p->sym->attr.flavor == FL_DERIVED)
1893 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1894 "generic name is also the name of a derived type",
1895 interface_name, &p->sym->declared_at);
1896 return true;
1897 }
1898
1899 /* F2003, C1207. F2008, C1207. */
1900 if (p->sym->attr.proc == PROC_INTERNAL
1901 && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1902 "%qs in %s at %L", p->sym->name,
1903 interface_name, &p->sym->declared_at))
1904 return true;
1905 }
1906 p = psave;
1907
1908 /* Remove duplicate interfaces in this interface list. */
1909 for (; p; p = p->next)
1910 {
1911 qlast = p;
1912
1913 for (q = p->next; q;)
1914 {
1915 if (p->sym != q->sym)
1916 {
1917 qlast = q;
1918 q = q->next;
1919 }
1920 else
1921 {
1922 /* Duplicate interface. */
1923 qlast->next = q->next;
1924 free (q);
1925 q = qlast->next;
1926 }
1927 }
1928 }
1929
1930 return false;
1931 }
1932
1933
1934 /* Check lists of interfaces to make sure that no two interfaces are
1935 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1936
1937 static bool
check_interface1(gfc_interface * p,gfc_interface * q0,int generic_flag,const char * interface_name,bool referenced)1938 check_interface1 (gfc_interface *p, gfc_interface *q0,
1939 int generic_flag, const char *interface_name,
1940 bool referenced)
1941 {
1942 gfc_interface *q;
1943 for (; p; p = p->next)
1944 for (q = q0; q; q = q->next)
1945 {
1946 if (p->sym == q->sym)
1947 continue; /* Duplicates OK here. */
1948
1949 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1950 continue;
1951
1952 if (!gfc_fl_struct (p->sym->attr.flavor)
1953 && !gfc_fl_struct (q->sym->attr.flavor)
1954 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1955 generic_flag, 0, NULL, 0, NULL, NULL))
1956 {
1957 if (referenced)
1958 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1959 "and %qs at %L", interface_name,
1960 q->sym->name, &q->sym->declared_at,
1961 p->sym->name, &p->sym->declared_at);
1962 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1963 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1964 "and %qs at %L", interface_name,
1965 q->sym->name, &q->sym->declared_at,
1966 p->sym->name, &p->sym->declared_at);
1967 else
1968 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1969 "interfaces at %L", interface_name, &p->where);
1970 return true;
1971 }
1972 }
1973 return false;
1974 }
1975
1976
1977 /* Check the generic and operator interfaces of symbols to make sure
1978 that none of the interfaces conflict. The check has to be done
1979 after all of the symbols are actually loaded. */
1980
1981 static void
check_sym_interfaces(gfc_symbol * sym)1982 check_sym_interfaces (gfc_symbol *sym)
1983 {
1984 /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */
1985 char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")];
1986 gfc_interface *p;
1987
1988 if (sym->ns != gfc_current_ns)
1989 return;
1990
1991 if (sym->generic != NULL)
1992 {
1993 size_t len = strlen (sym->name) + sizeof("generic interface ''");
1994 gcc_assert (len < sizeof (interface_name));
1995 sprintf (interface_name, "generic interface '%s'", sym->name);
1996 if (check_interface0 (sym->generic, interface_name))
1997 return;
1998
1999 for (p = sym->generic; p; p = p->next)
2000 {
2001 if (p->sym->attr.mod_proc
2002 && !p->sym->attr.module_procedure
2003 && (p->sym->attr.if_source != IFSRC_DECL
2004 || p->sym->attr.procedure))
2005 {
2006 gfc_error ("%qs at %L is not a module procedure",
2007 p->sym->name, &p->where);
2008 return;
2009 }
2010 }
2011
2012 /* Originally, this test was applied to host interfaces too;
2013 this is incorrect since host associated symbols, from any
2014 source, cannot be ambiguous with local symbols. */
2015 check_interface1 (sym->generic, sym->generic, 1, interface_name,
2016 sym->attr.referenced || !sym->attr.use_assoc);
2017 }
2018 }
2019
2020
2021 static void
check_uop_interfaces(gfc_user_op * uop)2022 check_uop_interfaces (gfc_user_op *uop)
2023 {
2024 char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")];
2025 gfc_user_op *uop2;
2026 gfc_namespace *ns;
2027
2028 sprintf (interface_name, "operator interface '%s'", uop->name);
2029 if (check_interface0 (uop->op, interface_name))
2030 return;
2031
2032 for (ns = gfc_current_ns; ns; ns = ns->parent)
2033 {
2034 uop2 = gfc_find_uop (uop->name, ns);
2035 if (uop2 == NULL)
2036 continue;
2037
2038 check_interface1 (uop->op, uop2->op, 0,
2039 interface_name, true);
2040 }
2041 }
2042
2043 /* Given an intrinsic op, return an equivalent op if one exists,
2044 or INTRINSIC_NONE otherwise. */
2045
2046 gfc_intrinsic_op
gfc_equivalent_op(gfc_intrinsic_op op)2047 gfc_equivalent_op (gfc_intrinsic_op op)
2048 {
2049 switch(op)
2050 {
2051 case INTRINSIC_EQ:
2052 return INTRINSIC_EQ_OS;
2053
2054 case INTRINSIC_EQ_OS:
2055 return INTRINSIC_EQ;
2056
2057 case INTRINSIC_NE:
2058 return INTRINSIC_NE_OS;
2059
2060 case INTRINSIC_NE_OS:
2061 return INTRINSIC_NE;
2062
2063 case INTRINSIC_GT:
2064 return INTRINSIC_GT_OS;
2065
2066 case INTRINSIC_GT_OS:
2067 return INTRINSIC_GT;
2068
2069 case INTRINSIC_GE:
2070 return INTRINSIC_GE_OS;
2071
2072 case INTRINSIC_GE_OS:
2073 return INTRINSIC_GE;
2074
2075 case INTRINSIC_LT:
2076 return INTRINSIC_LT_OS;
2077
2078 case INTRINSIC_LT_OS:
2079 return INTRINSIC_LT;
2080
2081 case INTRINSIC_LE:
2082 return INTRINSIC_LE_OS;
2083
2084 case INTRINSIC_LE_OS:
2085 return INTRINSIC_LE;
2086
2087 default:
2088 return INTRINSIC_NONE;
2089 }
2090 }
2091
2092 /* For the namespace, check generic, user operator and intrinsic
2093 operator interfaces for consistency and to remove duplicate
2094 interfaces. We traverse the whole namespace, counting on the fact
2095 that most symbols will not have generic or operator interfaces. */
2096
2097 void
gfc_check_interfaces(gfc_namespace * ns)2098 gfc_check_interfaces (gfc_namespace *ns)
2099 {
2100 gfc_namespace *old_ns, *ns2;
2101 char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")];
2102 int i;
2103
2104 old_ns = gfc_current_ns;
2105 gfc_current_ns = ns;
2106
2107 gfc_traverse_ns (ns, check_sym_interfaces);
2108
2109 gfc_traverse_user_op (ns, check_uop_interfaces);
2110
2111 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2112 {
2113 if (i == INTRINSIC_USER)
2114 continue;
2115
2116 if (i == INTRINSIC_ASSIGN)
2117 strcpy (interface_name, "intrinsic assignment operator");
2118 else
2119 sprintf (interface_name, "intrinsic '%s' operator",
2120 gfc_op2string ((gfc_intrinsic_op) i));
2121
2122 if (check_interface0 (ns->op[i], interface_name))
2123 continue;
2124
2125 if (ns->op[i])
2126 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
2127 ns->op[i]->where);
2128
2129 for (ns2 = ns; ns2; ns2 = ns2->parent)
2130 {
2131 gfc_intrinsic_op other_op;
2132
2133 if (check_interface1 (ns->op[i], ns2->op[i], 0,
2134 interface_name, true))
2135 goto done;
2136
2137 /* i should be gfc_intrinsic_op, but has to be int with this cast
2138 here for stupid C++ compatibility rules. */
2139 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
2140 if (other_op != INTRINSIC_NONE
2141 && check_interface1 (ns->op[i], ns2->op[other_op],
2142 0, interface_name, true))
2143 goto done;
2144 }
2145 }
2146
2147 done:
2148 gfc_current_ns = old_ns;
2149 }
2150
2151
2152 /* Given a symbol of a formal argument list and an expression, if the
2153 formal argument is allocatable, check that the actual argument is
2154 allocatable. Returns true if compatible, zero if not compatible. */
2155
2156 static bool
compare_allocatable(gfc_symbol * formal,gfc_expr * actual)2157 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
2158 {
2159 if (formal->attr.allocatable
2160 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
2161 {
2162 symbol_attribute attr = gfc_expr_attr (actual);
2163 if (actual->ts.type == BT_CLASS && !attr.class_ok)
2164 return true;
2165 else if (!attr.allocatable)
2166 return false;
2167 }
2168
2169 return true;
2170 }
2171
2172
2173 /* Given a symbol of a formal argument list and an expression, if the
2174 formal argument is a pointer, see if the actual argument is a
2175 pointer. Returns nonzero if compatible, zero if not compatible. */
2176
2177 static int
compare_pointer(gfc_symbol * formal,gfc_expr * actual)2178 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
2179 {
2180 symbol_attribute attr;
2181
2182 if (formal->attr.pointer
2183 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
2184 && CLASS_DATA (formal)->attr.class_pointer))
2185 {
2186 attr = gfc_expr_attr (actual);
2187
2188 /* Fortran 2008 allows non-pointer actual arguments. */
2189 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
2190 return 2;
2191
2192 if (!attr.pointer)
2193 return 0;
2194 }
2195
2196 return 1;
2197 }
2198
2199
2200 /* Emit clear error messages for rank mismatch. */
2201
2202 static void
argument_rank_mismatch(const char * name,locus * where,int rank1,int rank2,locus * where_formal)2203 argument_rank_mismatch (const char *name, locus *where,
2204 int rank1, int rank2, locus *where_formal)
2205 {
2206
2207 /* TS 29113, C407b. */
2208 if (where_formal == NULL)
2209 {
2210 if (rank2 == -1)
2211 gfc_error ("The assumed-rank array at %L requires that the dummy "
2212 "argument %qs has assumed-rank", where, name);
2213 else if (rank1 == 0)
2214 gfc_error_opt (0, "Rank mismatch in argument %qs "
2215 "at %L (scalar and rank-%d)", name, where, rank2);
2216 else if (rank2 == 0)
2217 gfc_error_opt (0, "Rank mismatch in argument %qs "
2218 "at %L (rank-%d and scalar)", name, where, rank1);
2219 else
2220 gfc_error_opt (0, "Rank mismatch in argument %qs "
2221 "at %L (rank-%d and rank-%d)", name, where, rank1,
2222 rank2);
2223 }
2224 else
2225 {
2226 gcc_assert (rank2 != -1);
2227 if (rank1 == 0)
2228 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2229 "and actual argument at %L (scalar and rank-%d)",
2230 where, where_formal, rank2);
2231 else if (rank2 == 0)
2232 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2233 "and actual argument at %L (rank-%d and scalar)",
2234 where, where_formal, rank1);
2235 else
2236 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2237 "and actual argument at %L (rank-%d and rank-%d)", where,
2238 where_formal, rank1, rank2);
2239 }
2240 }
2241
2242
2243 /* Under certain conditions, a scalar actual argument can be passed
2244 to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
2245 This function returns true for these conditions so that an error
2246 or warning for this can be suppressed later. Always return false
2247 for expressions with rank > 0. */
2248
2249 bool
maybe_dummy_array_arg(gfc_expr * e)2250 maybe_dummy_array_arg (gfc_expr *e)
2251 {
2252 gfc_symbol *s;
2253 gfc_ref *ref;
2254 bool array_pointer = false;
2255 bool assumed_shape = false;
2256 bool scalar_ref = true;
2257
2258 if (e->rank > 0)
2259 return false;
2260
2261 if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
2262 return true;
2263
2264 /* If this comes from a constructor, it has been an array element
2265 originally. */
2266
2267 if (e->expr_type == EXPR_CONSTANT)
2268 return e->from_constructor;
2269
2270 if (e->expr_type != EXPR_VARIABLE)
2271 return false;
2272
2273 s = e->symtree->n.sym;
2274
2275 if (s->attr.dimension)
2276 {
2277 scalar_ref = false;
2278 array_pointer = s->attr.pointer;
2279 }
2280
2281 if (s->as && s->as->type == AS_ASSUMED_SHAPE)
2282 assumed_shape = true;
2283
2284 for (ref=e->ref; ref; ref=ref->next)
2285 {
2286 if (ref->type == REF_COMPONENT)
2287 {
2288 symbol_attribute *attr;
2289 attr = &ref->u.c.component->attr;
2290 if (attr->dimension)
2291 {
2292 array_pointer = attr->pointer;
2293 assumed_shape = false;
2294 scalar_ref = false;
2295 }
2296 else
2297 scalar_ref = true;
2298 }
2299 }
2300
2301 return !(scalar_ref || array_pointer || assumed_shape);
2302 }
2303
2304 /* Given a symbol of a formal argument list and an expression, see if
2305 the two are compatible as arguments. Returns true if
2306 compatible, false if not compatible. */
2307
2308 static bool
compare_parameter(gfc_symbol * formal,gfc_expr * actual,int ranks_must_agree,int is_elemental,locus * where)2309 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
2310 int ranks_must_agree, int is_elemental, locus *where)
2311 {
2312 gfc_ref *ref;
2313 bool rank_check, is_pointer;
2314 char err[200];
2315 gfc_component *ppc;
2316
2317 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2318 procs c_f_pointer or c_f_procpointer, and we need to accept most
2319 pointers the user could give us. This should allow that. */
2320 if (formal->ts.type == BT_VOID)
2321 return true;
2322
2323 if (formal->ts.type == BT_DERIVED
2324 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
2325 && actual->ts.type == BT_DERIVED
2326 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
2327 return true;
2328
2329 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
2330 /* Make sure the vtab symbol is present when
2331 the module variables are generated. */
2332 gfc_find_derived_vtab (actual->ts.u.derived);
2333
2334 if (actual->ts.type == BT_PROCEDURE)
2335 {
2336 gfc_symbol *act_sym = actual->symtree->n.sym;
2337
2338 if (formal->attr.flavor != FL_PROCEDURE)
2339 {
2340 if (where)
2341 gfc_error ("Invalid procedure argument at %L", &actual->where);
2342 return false;
2343 }
2344
2345 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
2346 sizeof(err), NULL, NULL))
2347 {
2348 if (where)
2349 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2350 " %s", formal->name, &actual->where, err);
2351 return false;
2352 }
2353
2354 if (formal->attr.function && !act_sym->attr.function)
2355 {
2356 gfc_add_function (&act_sym->attr, act_sym->name,
2357 &act_sym->declared_at);
2358 if (act_sym->ts.type == BT_UNKNOWN
2359 && !gfc_set_default_type (act_sym, 1, act_sym->ns))
2360 return false;
2361 }
2362 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
2363 gfc_add_subroutine (&act_sym->attr, act_sym->name,
2364 &act_sym->declared_at);
2365
2366 return true;
2367 }
2368
2369 ppc = gfc_get_proc_ptr_comp (actual);
2370 if (ppc && ppc->ts.interface)
2371 {
2372 if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
2373 err, sizeof(err), NULL, NULL))
2374 {
2375 if (where)
2376 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2377 " %s", formal->name, &actual->where, err);
2378 return false;
2379 }
2380 }
2381
2382 /* F2008, C1241. */
2383 if (formal->attr.pointer && formal->attr.contiguous
2384 && !gfc_is_simply_contiguous (actual, true, false))
2385 {
2386 if (where)
2387 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2388 "must be simply contiguous", formal->name, &actual->where);
2389 return false;
2390 }
2391
2392 symbol_attribute actual_attr = gfc_expr_attr (actual);
2393 if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
2394 return true;
2395
2396 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
2397 && actual->ts.type != BT_HOLLERITH
2398 && formal->ts.type != BT_ASSUMED
2399 && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2400 && !gfc_compare_types (&formal->ts, &actual->ts)
2401 && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
2402 && gfc_compare_derived_types (formal->ts.u.derived,
2403 CLASS_DATA (actual)->ts.u.derived)))
2404 {
2405 if (where)
2406 {
2407 if (formal->attr.artificial)
2408 {
2409 if (!flag_allow_argument_mismatch || !formal->error)
2410 gfc_error_opt (0, "Type mismatch between actual argument at %L "
2411 "and actual argument at %L (%s/%s).",
2412 &actual->where,
2413 &formal->declared_at,
2414 gfc_typename (actual),
2415 gfc_dummy_typename (&formal->ts));
2416
2417 formal->error = 1;
2418 }
2419 else
2420 gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
2421 "to %s", formal->name, where, gfc_typename (actual),
2422 gfc_dummy_typename (&formal->ts));
2423 }
2424 return false;
2425 }
2426
2427 if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
2428 {
2429 if (where)
2430 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2431 "argument %qs is of assumed type", &actual->where,
2432 formal->name);
2433 return false;
2434 }
2435
2436 /* F2008, 12.5.2.5; IR F08/0073. */
2437 if (formal->ts.type == BT_CLASS && formal->attr.class_ok
2438 && actual->expr_type != EXPR_NULL
2439 && ((CLASS_DATA (formal)->attr.class_pointer
2440 && formal->attr.intent != INTENT_IN)
2441 || CLASS_DATA (formal)->attr.allocatable))
2442 {
2443 if (actual->ts.type != BT_CLASS)
2444 {
2445 if (where)
2446 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2447 formal->name, &actual->where);
2448 return false;
2449 }
2450
2451 if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
2452 && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
2453 CLASS_DATA (formal)->ts.u.derived))
2454 {
2455 if (where)
2456 gfc_error ("Actual argument to %qs at %L must have the same "
2457 "declared type", formal->name, &actual->where);
2458 return false;
2459 }
2460 }
2461
2462 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2463 is necessary also for F03, so retain error for both.
2464 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2465 compatible, no attempt has been made to channel to this one. */
2466 if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
2467 && (CLASS_DATA (formal)->attr.allocatable
2468 ||CLASS_DATA (formal)->attr.class_pointer))
2469 {
2470 if (where)
2471 gfc_error ("Actual argument to %qs at %L must be unlimited "
2472 "polymorphic since the formal argument is a "
2473 "pointer or allocatable unlimited polymorphic "
2474 "entity [F2008: 12.5.2.5]", formal->name,
2475 &actual->where);
2476 return false;
2477 }
2478
2479 if (formal->attr.codimension && !gfc_is_coarray (actual))
2480 {
2481 if (where)
2482 gfc_error ("Actual argument to %qs at %L must be a coarray",
2483 formal->name, &actual->where);
2484 return false;
2485 }
2486
2487 if (formal->attr.codimension && formal->attr.allocatable)
2488 {
2489 gfc_ref *last = NULL;
2490
2491 for (ref = actual->ref; ref; ref = ref->next)
2492 if (ref->type == REF_COMPONENT)
2493 last = ref;
2494
2495 /* F2008, 12.5.2.6. */
2496 if ((last && last->u.c.component->as->corank != formal->as->corank)
2497 || (!last
2498 && actual->symtree->n.sym->as->corank != formal->as->corank))
2499 {
2500 if (where)
2501 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2502 formal->name, &actual->where, formal->as->corank,
2503 last ? last->u.c.component->as->corank
2504 : actual->symtree->n.sym->as->corank);
2505 return false;
2506 }
2507 }
2508
2509 if (formal->attr.codimension)
2510 {
2511 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2512 /* F2018, 12.5.2.8. */
2513 if (formal->attr.dimension
2514 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
2515 && actual_attr.dimension
2516 && !gfc_is_simply_contiguous (actual, true, true))
2517 {
2518 if (where)
2519 gfc_error ("Actual argument to %qs at %L must be simply "
2520 "contiguous or an element of such an array",
2521 formal->name, &actual->where);
2522 return false;
2523 }
2524
2525 /* F2008, C1303 and C1304. */
2526 if (formal->attr.intent != INTENT_INOUT
2527 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2528 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2529 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2530 || formal->attr.lock_comp))
2531
2532 {
2533 if (where)
2534 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2535 "which is LOCK_TYPE or has a LOCK_TYPE component",
2536 formal->name, &actual->where);
2537 return false;
2538 }
2539
2540 /* TS18508, C702/C703. */
2541 if (formal->attr.intent != INTENT_INOUT
2542 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2543 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2544 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
2545 || formal->attr.event_comp))
2546
2547 {
2548 if (where)
2549 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2550 "which is EVENT_TYPE or has a EVENT_TYPE component",
2551 formal->name, &actual->where);
2552 return false;
2553 }
2554 }
2555
2556 /* F2008, C1239/C1240. */
2557 if (actual->expr_type == EXPR_VARIABLE
2558 && (actual->symtree->n.sym->attr.asynchronous
2559 || actual->symtree->n.sym->attr.volatile_)
2560 && (formal->attr.asynchronous || formal->attr.volatile_)
2561 && actual->rank && formal->as
2562 && !gfc_is_simply_contiguous (actual, true, false)
2563 && ((formal->as->type != AS_ASSUMED_SHAPE
2564 && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
2565 || formal->attr.contiguous))
2566 {
2567 if (where)
2568 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2569 "assumed-rank array without CONTIGUOUS attribute - as actual"
2570 " argument at %L is not simply contiguous and both are "
2571 "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
2572 return false;
2573 }
2574
2575 if (formal->attr.allocatable && !formal->attr.codimension
2576 && actual_attr.codimension)
2577 {
2578 if (formal->attr.intent == INTENT_OUT)
2579 {
2580 if (where)
2581 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2582 "INTENT(OUT) dummy argument %qs", &actual->where,
2583 formal->name);
2584 return false;
2585 }
2586 else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
2587 gfc_warning (OPT_Wsurprising,
2588 "Passing coarray at %L to allocatable, noncoarray dummy "
2589 "argument %qs, which is invalid if the allocation status"
2590 " is modified", &actual->where, formal->name);
2591 }
2592
2593 /* If the rank is the same or the formal argument has assumed-rank. */
2594 if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
2595 return true;
2596
2597 rank_check = where != NULL && !is_elemental && formal->as
2598 && (formal->as->type == AS_ASSUMED_SHAPE
2599 || formal->as->type == AS_DEFERRED)
2600 && actual->expr_type != EXPR_NULL;
2601
2602 /* Skip rank checks for NO_ARG_CHECK. */
2603 if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2604 return true;
2605
2606 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2607 if (rank_check || ranks_must_agree
2608 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2609 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
2610 || (actual->rank == 0
2611 && ((formal->ts.type == BT_CLASS
2612 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2613 || (formal->ts.type != BT_CLASS
2614 && formal->as->type == AS_ASSUMED_SHAPE))
2615 && actual->expr_type != EXPR_NULL)
2616 || (actual->rank == 0 && formal->attr.dimension
2617 && gfc_is_coindexed (actual)))
2618 {
2619 if (where
2620 && (!formal->attr.artificial || (!formal->maybe_array
2621 && !maybe_dummy_array_arg (actual))))
2622 {
2623 locus *where_formal;
2624 if (formal->attr.artificial)
2625 where_formal = &formal->declared_at;
2626 else
2627 where_formal = NULL;
2628
2629 argument_rank_mismatch (formal->name, &actual->where,
2630 symbol_rank (formal), actual->rank,
2631 where_formal);
2632 }
2633 return false;
2634 }
2635 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
2636 return true;
2637
2638 /* At this point, we are considering a scalar passed to an array. This
2639 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2640 - if the actual argument is (a substring of) an element of a
2641 non-assumed-shape/non-pointer/non-polymorphic array; or
2642 - (F2003) if the actual argument is of type character of default/c_char
2643 kind. */
2644
2645 is_pointer = actual->expr_type == EXPR_VARIABLE
2646 ? actual->symtree->n.sym->attr.pointer : false;
2647
2648 for (ref = actual->ref; ref; ref = ref->next)
2649 {
2650 if (ref->type == REF_COMPONENT)
2651 is_pointer = ref->u.c.component->attr.pointer;
2652 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2653 && ref->u.ar.dimen > 0
2654 && (!ref->next
2655 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2656 break;
2657 }
2658
2659 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2660 {
2661 if (where)
2662 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2663 "at %L", formal->name, &actual->where);
2664 return false;
2665 }
2666
2667 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2668 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2669 {
2670 if (where)
2671 {
2672 if (formal->attr.artificial)
2673 gfc_error ("Element of assumed-shape or pointer array "
2674 "as actual argument at %L cannot correspond to "
2675 "actual argument at %L",
2676 &actual->where, &formal->declared_at);
2677 else
2678 gfc_error ("Element of assumed-shape or pointer "
2679 "array passed to array dummy argument %qs at %L",
2680 formal->name, &actual->where);
2681 }
2682 return false;
2683 }
2684
2685 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2686 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2687 {
2688 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2689 {
2690 if (where)
2691 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2692 "CHARACTER actual argument with array dummy argument "
2693 "%qs at %L", formal->name, &actual->where);
2694 return false;
2695 }
2696
2697 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2698 {
2699 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2700 "array dummy argument %qs at %L",
2701 formal->name, &actual->where);
2702 return false;
2703 }
2704 else
2705 return ((gfc_option.allow_std & GFC_STD_F2003) != 0);
2706 }
2707
2708 if (ref == NULL && actual->expr_type != EXPR_NULL)
2709 {
2710 if (where
2711 && (!formal->attr.artificial || (!formal->maybe_array
2712 && !maybe_dummy_array_arg (actual))))
2713 {
2714 locus *where_formal;
2715 if (formal->attr.artificial)
2716 where_formal = &formal->declared_at;
2717 else
2718 where_formal = NULL;
2719
2720 argument_rank_mismatch (formal->name, &actual->where,
2721 symbol_rank (formal), actual->rank,
2722 where_formal);
2723 }
2724 return false;
2725 }
2726
2727 return true;
2728 }
2729
2730
2731 /* Returns the storage size of a symbol (formal argument) or
2732 zero if it cannot be determined. */
2733
2734 static unsigned long
get_sym_storage_size(gfc_symbol * sym)2735 get_sym_storage_size (gfc_symbol *sym)
2736 {
2737 int i;
2738 unsigned long strlen, elements;
2739
2740 if (sym->ts.type == BT_CHARACTER)
2741 {
2742 if (sym->ts.u.cl && sym->ts.u.cl->length
2743 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2744 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
2745 else
2746 return 0;
2747 }
2748 else
2749 strlen = 1;
2750
2751 if (symbol_rank (sym) == 0)
2752 return strlen;
2753
2754 elements = 1;
2755 if (sym->as->type != AS_EXPLICIT)
2756 return 0;
2757 for (i = 0; i < sym->as->rank; i++)
2758 {
2759 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
2760 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2761 return 0;
2762
2763 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2764 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2765 }
2766
2767 return strlen*elements;
2768 }
2769
2770
2771 /* Returns the storage size of an expression (actual argument) or
2772 zero if it cannot be determined. For an array element, it returns
2773 the remaining size as the element sequence consists of all storage
2774 units of the actual argument up to the end of the array. */
2775
2776 static unsigned long
get_expr_storage_size(gfc_expr * e)2777 get_expr_storage_size (gfc_expr *e)
2778 {
2779 int i;
2780 long int strlen, elements;
2781 long int substrlen = 0;
2782 bool is_str_storage = false;
2783 gfc_ref *ref;
2784
2785 if (e == NULL)
2786 return 0;
2787
2788 if (e->ts.type == BT_CHARACTER)
2789 {
2790 if (e->ts.u.cl && e->ts.u.cl->length
2791 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2792 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2793 else if (e->expr_type == EXPR_CONSTANT
2794 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2795 strlen = e->value.character.length;
2796 else
2797 return 0;
2798 }
2799 else
2800 strlen = 1; /* Length per element. */
2801
2802 if (e->rank == 0 && !e->ref)
2803 return strlen;
2804
2805 elements = 1;
2806 if (!e->ref)
2807 {
2808 if (!e->shape)
2809 return 0;
2810 for (i = 0; i < e->rank; i++)
2811 elements *= mpz_get_si (e->shape[i]);
2812 return elements*strlen;
2813 }
2814
2815 for (ref = e->ref; ref; ref = ref->next)
2816 {
2817 if (ref->type == REF_SUBSTRING && ref->u.ss.start
2818 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2819 {
2820 if (is_str_storage)
2821 {
2822 /* The string length is the substring length.
2823 Set now to full string length. */
2824 if (!ref->u.ss.length || !ref->u.ss.length->length
2825 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2826 return 0;
2827
2828 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2829 }
2830 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2831 continue;
2832 }
2833
2834 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2835 for (i = 0; i < ref->u.ar.dimen; i++)
2836 {
2837 long int start, end, stride;
2838 stride = 1;
2839
2840 if (ref->u.ar.stride[i])
2841 {
2842 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2843 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2844 else
2845 return 0;
2846 }
2847
2848 if (ref->u.ar.start[i])
2849 {
2850 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2851 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2852 else
2853 return 0;
2854 }
2855 else if (ref->u.ar.as->lower[i]
2856 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2857 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2858 else
2859 return 0;
2860
2861 if (ref->u.ar.end[i])
2862 {
2863 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2864 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2865 else
2866 return 0;
2867 }
2868 else if (ref->u.ar.as->upper[i]
2869 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2870 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2871 else
2872 return 0;
2873
2874 elements *= (end - start)/stride + 1L;
2875 }
2876 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
2877 for (i = 0; i < ref->u.ar.as->rank; i++)
2878 {
2879 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2880 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2881 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER
2882 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
2883 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
2884 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2885 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2886 + 1L;
2887 else
2888 return 0;
2889 }
2890 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2891 && e->expr_type == EXPR_VARIABLE)
2892 {
2893 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2894 || e->symtree->n.sym->attr.pointer)
2895 {
2896 elements = 1;
2897 continue;
2898 }
2899
2900 /* Determine the number of remaining elements in the element
2901 sequence for array element designators. */
2902 is_str_storage = true;
2903 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2904 {
2905 if (ref->u.ar.start[i] == NULL
2906 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2907 || ref->u.ar.as->upper[i] == NULL
2908 || ref->u.ar.as->lower[i] == NULL
2909 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2910 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2911 return 0;
2912
2913 elements
2914 = elements
2915 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2916 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2917 + 1L)
2918 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2919 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2920 }
2921 }
2922 else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
2923 && ref->u.c.component->attr.proc_pointer
2924 && ref->u.c.component->attr.dimension)
2925 {
2926 /* Array-valued procedure-pointer components. */
2927 gfc_array_spec *as = ref->u.c.component->as;
2928 for (i = 0; i < as->rank; i++)
2929 {
2930 if (!as->upper[i] || !as->lower[i]
2931 || as->upper[i]->expr_type != EXPR_CONSTANT
2932 || as->lower[i]->expr_type != EXPR_CONSTANT)
2933 return 0;
2934
2935 elements = elements
2936 * (mpz_get_si (as->upper[i]->value.integer)
2937 - mpz_get_si (as->lower[i]->value.integer) + 1L);
2938 }
2939 }
2940 }
2941
2942 if (substrlen)
2943 return (is_str_storage) ? substrlen + (elements-1)*strlen
2944 : elements*strlen;
2945 else
2946 return elements*strlen;
2947 }
2948
2949
2950 /* Given an expression, check whether it is an array section
2951 which has a vector subscript. */
2952
2953 bool
gfc_has_vector_subscript(gfc_expr * e)2954 gfc_has_vector_subscript (gfc_expr *e)
2955 {
2956 int i;
2957 gfc_ref *ref;
2958
2959 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2960 return false;
2961
2962 for (ref = e->ref; ref; ref = ref->next)
2963 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2964 for (i = 0; i < ref->u.ar.dimen; i++)
2965 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2966 return true;
2967
2968 return false;
2969 }
2970
2971
2972 static bool
is_procptr_result(gfc_expr * expr)2973 is_procptr_result (gfc_expr *expr)
2974 {
2975 gfc_component *c = gfc_get_proc_ptr_comp (expr);
2976 if (c)
2977 return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1));
2978 else
2979 return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
2980 && (expr->symtree->n.sym->result->attr.proc_pointer == 1));
2981 }
2982
2983
2984 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2985 number of total candidates in CANDIDATES_LEN. */
2986
2987 static void
lookup_arg_fuzzy_find_candidates(gfc_formal_arglist * arg,char ** & candidates,size_t & candidates_len)2988 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
2989 char **&candidates,
2990 size_t &candidates_len)
2991 {
2992 for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
2993 vec_push (candidates, candidates_len, p->sym->name);
2994 }
2995
2996
2997 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2998
2999 static const char*
lookup_arg_fuzzy(const char * arg,gfc_formal_arglist * arguments)3000 lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
3001 {
3002 char **candidates = NULL;
3003 size_t candidates_len = 0;
3004 lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
3005 return gfc_closest_fuzzy_match (arg, candidates);
3006 }
3007
3008
3009 /* Given formal and actual argument lists, see if they are compatible.
3010 If they are compatible, the actual argument list is sorted to
3011 correspond with the formal list, and elements for missing optional
3012 arguments are inserted. If WHERE pointer is nonnull, then we issue
3013 errors when things don't match instead of just returning the status
3014 code. */
3015
3016 bool
gfc_compare_actual_formal(gfc_actual_arglist ** ap,gfc_formal_arglist * formal,int ranks_must_agree,int is_elemental,bool in_statement_function,locus * where)3017 gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
3018 int ranks_must_agree, int is_elemental,
3019 bool in_statement_function, locus *where)
3020 {
3021 gfc_actual_arglist **new_arg, *a, *actual;
3022 gfc_formal_arglist *f;
3023 int i, n, na;
3024 unsigned long actual_size, formal_size;
3025 bool full_array = false;
3026 gfc_array_ref *actual_arr_ref;
3027
3028 actual = *ap;
3029
3030 if (actual == NULL && formal == NULL)
3031 return true;
3032
3033 n = 0;
3034 for (f = formal; f; f = f->next)
3035 n++;
3036
3037 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
3038
3039 for (i = 0; i < n; i++)
3040 new_arg[i] = NULL;
3041
3042 na = 0;
3043 f = formal;
3044 i = 0;
3045
3046 for (a = actual; a; a = a->next, f = f->next)
3047 {
3048 if (a->name != NULL && in_statement_function)
3049 {
3050 gfc_error ("Keyword argument %qs at %L is invalid in "
3051 "a statement function", a->name, &a->expr->where);
3052 return false;
3053 }
3054
3055 /* Look for keywords but ignore g77 extensions like %VAL. */
3056 if (a->name != NULL && a->name[0] != '%')
3057 {
3058 i = 0;
3059 for (f = formal; f; f = f->next, i++)
3060 {
3061 if (f->sym == NULL)
3062 continue;
3063 if (strcmp (f->sym->name, a->name) == 0)
3064 break;
3065 }
3066
3067 if (f == NULL)
3068 {
3069 if (where)
3070 {
3071 const char *guessed = lookup_arg_fuzzy (a->name, formal);
3072 if (guessed)
3073 gfc_error ("Keyword argument %qs at %L is not in "
3074 "the procedure; did you mean %qs?",
3075 a->name, &a->expr->where, guessed);
3076 else
3077 gfc_error ("Keyword argument %qs at %L is not in "
3078 "the procedure", a->name, &a->expr->where);
3079 }
3080 return false;
3081 }
3082
3083 if (new_arg[i] != NULL)
3084 {
3085 if (where)
3086 gfc_error ("Keyword argument %qs at %L is already associated "
3087 "with another actual argument", a->name,
3088 &a->expr->where);
3089 return false;
3090 }
3091 }
3092
3093 if (f == NULL)
3094 {
3095 if (where)
3096 gfc_error ("More actual than formal arguments in procedure "
3097 "call at %L", where);
3098
3099 return false;
3100 }
3101
3102 if (f->sym == NULL && a->expr == NULL)
3103 goto match;
3104
3105 if (f->sym == NULL)
3106 {
3107 /* These errors have to be issued, otherwise an ICE can occur.
3108 See PR 78865. */
3109 if (where)
3110 gfc_error_now ("Missing alternate return specifier in subroutine "
3111 "call at %L", where);
3112 return false;
3113 }
3114
3115 if (a->expr == NULL)
3116 {
3117 if (f->sym->attr.optional)
3118 continue;
3119 else
3120 {
3121 if (where)
3122 gfc_error_now ("Unexpected alternate return specifier in "
3123 "subroutine call at %L", where);
3124 return false;
3125 }
3126 }
3127
3128 /* Make sure that intrinsic vtables exist for calls to unlimited
3129 polymorphic formal arguments. */
3130 if (UNLIMITED_POLY (f->sym)
3131 && a->expr->ts.type != BT_DERIVED
3132 && a->expr->ts.type != BT_CLASS
3133 && a->expr->ts.type != BT_ASSUMED)
3134 gfc_find_vtab (&a->expr->ts);
3135
3136 if (a->expr->expr_type == EXPR_NULL
3137 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
3138 && (f->sym->attr.allocatable || !f->sym->attr.optional
3139 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
3140 || (f->sym->ts.type == BT_CLASS
3141 && !CLASS_DATA (f->sym)->attr.class_pointer
3142 && (CLASS_DATA (f->sym)->attr.allocatable
3143 || !f->sym->attr.optional
3144 || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
3145 {
3146 if (where
3147 && (!f->sym->attr.optional
3148 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
3149 || (f->sym->ts.type == BT_CLASS
3150 && CLASS_DATA (f->sym)->attr.allocatable)))
3151 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
3152 where, f->sym->name);
3153 else if (where)
3154 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3155 "dummy %qs", where, f->sym->name);
3156
3157 return false;
3158 }
3159
3160 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
3161 is_elemental, where))
3162 return false;
3163
3164 /* TS 29113, 6.3p2. */
3165 if (f->sym->ts.type == BT_ASSUMED
3166 && (a->expr->ts.type == BT_DERIVED
3167 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
3168 {
3169 gfc_namespace *f2k_derived;
3170
3171 f2k_derived = a->expr->ts.type == BT_DERIVED
3172 ? a->expr->ts.u.derived->f2k_derived
3173 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
3174
3175 if (f2k_derived
3176 && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
3177 {
3178 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3179 "derived type with type-bound or FINAL procedures",
3180 &a->expr->where);
3181 return false;
3182 }
3183 }
3184
3185 /* Special case for character arguments. For allocatable, pointer
3186 and assumed-shape dummies, the string length needs to match
3187 exactly. */
3188 if (a->expr->ts.type == BT_CHARACTER
3189 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
3190 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
3191 && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl
3192 && f->sym->ts.u.cl->length
3193 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
3194 && (f->sym->attr.pointer || f->sym->attr.allocatable
3195 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3196 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
3197 f->sym->ts.u.cl->length->value.integer) != 0))
3198 {
3199 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
3200 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
3201 "argument and pointer or allocatable dummy argument "
3202 "%qs at %L",
3203 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
3204 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
3205 f->sym->name, &a->expr->where);
3206 else if (where)
3207 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
3208 "argument and assumed-shape dummy argument %qs "
3209 "at %L",
3210 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
3211 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
3212 f->sym->name, &a->expr->where);
3213 return false;
3214 }
3215
3216 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
3217 && f->sym->ts.deferred != a->expr->ts.deferred
3218 && a->expr->ts.type == BT_CHARACTER)
3219 {
3220 if (where)
3221 gfc_error ("Actual argument at %L to allocatable or "
3222 "pointer dummy argument %qs must have a deferred "
3223 "length type parameter if and only if the dummy has one",
3224 &a->expr->where, f->sym->name);
3225 return false;
3226 }
3227
3228 if (f->sym->ts.type == BT_CLASS)
3229 goto skip_size_check;
3230
3231 actual_size = get_expr_storage_size (a->expr);
3232 formal_size = get_sym_storage_size (f->sym);
3233 if (actual_size != 0 && actual_size < formal_size
3234 && a->expr->ts.type != BT_PROCEDURE
3235 && f->sym->attr.flavor != FL_PROCEDURE)
3236 {
3237 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
3238 gfc_warning (0, "Character length of actual argument shorter "
3239 "than of dummy argument %qs (%lu/%lu) at %L",
3240 f->sym->name, actual_size, formal_size,
3241 &a->expr->where);
3242 else if (where)
3243 {
3244 /* Emit a warning for -std=legacy and an error otherwise. */
3245 if (gfc_option.warn_std == 0)
3246 gfc_warning (0, "Actual argument contains too few "
3247 "elements for dummy argument %qs (%lu/%lu) "
3248 "at %L", f->sym->name, actual_size,
3249 formal_size, &a->expr->where);
3250 else
3251 gfc_error_now ("Actual argument contains too few "
3252 "elements for dummy argument %qs (%lu/%lu) "
3253 "at %L", f->sym->name, actual_size,
3254 formal_size, &a->expr->where);
3255 }
3256 return false;
3257 }
3258
3259 skip_size_check:
3260
3261 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3262 argument is provided for a procedure pointer formal argument. */
3263 if (f->sym->attr.proc_pointer
3264 && !((a->expr->expr_type == EXPR_VARIABLE
3265 && (a->expr->symtree->n.sym->attr.proc_pointer
3266 || gfc_is_proc_ptr_comp (a->expr)))
3267 || (a->expr->expr_type == EXPR_FUNCTION
3268 && is_procptr_result (a->expr))))
3269 {
3270 if (where)
3271 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3272 f->sym->name, &a->expr->where);
3273 return false;
3274 }
3275
3276 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3277 provided for a procedure formal argument. */
3278 if (f->sym->attr.flavor == FL_PROCEDURE
3279 && !((a->expr->expr_type == EXPR_VARIABLE
3280 && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
3281 || a->expr->symtree->n.sym->attr.proc_pointer
3282 || gfc_is_proc_ptr_comp (a->expr)))
3283 || (a->expr->expr_type == EXPR_FUNCTION
3284 && is_procptr_result (a->expr))))
3285 {
3286 if (where)
3287 gfc_error ("Expected a procedure for argument %qs at %L",
3288 f->sym->name, &a->expr->where);
3289 return false;
3290 }
3291
3292 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
3293 && a->expr->expr_type == EXPR_VARIABLE
3294 && a->expr->symtree->n.sym->as
3295 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
3296 && (a->expr->ref == NULL
3297 || (a->expr->ref->type == REF_ARRAY
3298 && a->expr->ref->u.ar.type == AR_FULL)))
3299 {
3300 if (where)
3301 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3302 " array at %L", f->sym->name, where);
3303 return false;
3304 }
3305
3306 if (a->expr->expr_type != EXPR_NULL
3307 && compare_pointer (f->sym, a->expr) == 0)
3308 {
3309 if (where)
3310 gfc_error ("Actual argument for %qs must be a pointer at %L",
3311 f->sym->name, &a->expr->where);
3312 return false;
3313 }
3314
3315 if (a->expr->expr_type != EXPR_NULL
3316 && (gfc_option.allow_std & GFC_STD_F2008) == 0
3317 && compare_pointer (f->sym, a->expr) == 2)
3318 {
3319 if (where)
3320 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3321 "pointer dummy %qs", &a->expr->where,f->sym->name);
3322 return false;
3323 }
3324
3325
3326 /* Fortran 2008, C1242. */
3327 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
3328 {
3329 if (where)
3330 gfc_error ("Coindexed actual argument at %L to pointer "
3331 "dummy %qs",
3332 &a->expr->where, f->sym->name);
3333 return false;
3334 }
3335
3336 /* Fortran 2008, 12.5.2.5 (no constraint). */
3337 if (a->expr->expr_type == EXPR_VARIABLE
3338 && f->sym->attr.intent != INTENT_IN
3339 && f->sym->attr.allocatable
3340 && gfc_is_coindexed (a->expr))
3341 {
3342 if (where)
3343 gfc_error ("Coindexed actual argument at %L to allocatable "
3344 "dummy %qs requires INTENT(IN)",
3345 &a->expr->where, f->sym->name);
3346 return false;
3347 }
3348
3349 /* Fortran 2008, C1237. */
3350 if (a->expr->expr_type == EXPR_VARIABLE
3351 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
3352 && gfc_is_coindexed (a->expr)
3353 && (a->expr->symtree->n.sym->attr.volatile_
3354 || a->expr->symtree->n.sym->attr.asynchronous))
3355 {
3356 if (where)
3357 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3358 "%L requires that dummy %qs has neither "
3359 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
3360 f->sym->name);
3361 return false;
3362 }
3363
3364 /* Fortran 2008, 12.5.2.4 (no constraint). */
3365 if (a->expr->expr_type == EXPR_VARIABLE
3366 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
3367 && gfc_is_coindexed (a->expr)
3368 && gfc_has_ultimate_allocatable (a->expr))
3369 {
3370 if (where)
3371 gfc_error ("Coindexed actual argument at %L with allocatable "
3372 "ultimate component to dummy %qs requires either VALUE "
3373 "or INTENT(IN)", &a->expr->where, f->sym->name);
3374 return false;
3375 }
3376
3377 if (f->sym->ts.type == BT_CLASS
3378 && CLASS_DATA (f->sym)->attr.allocatable
3379 && gfc_is_class_array_ref (a->expr, &full_array)
3380 && !full_array)
3381 {
3382 if (where)
3383 gfc_error ("Actual CLASS array argument for %qs must be a full "
3384 "array at %L", f->sym->name, &a->expr->where);
3385 return false;
3386 }
3387
3388
3389 if (a->expr->expr_type != EXPR_NULL
3390 && !compare_allocatable (f->sym, a->expr))
3391 {
3392 if (where)
3393 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3394 f->sym->name, &a->expr->where);
3395 return false;
3396 }
3397
3398 /* Check intent = OUT/INOUT for definable actual argument. */
3399 if (!in_statement_function
3400 && (f->sym->attr.intent == INTENT_OUT
3401 || f->sym->attr.intent == INTENT_INOUT))
3402 {
3403 const char* context = (where
3404 ? _("actual argument to INTENT = OUT/INOUT")
3405 : NULL);
3406
3407 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3408 && CLASS_DATA (f->sym)->attr.class_pointer)
3409 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3410 && !gfc_check_vardef_context (a->expr, true, false, false, context))
3411 return false;
3412 if (!gfc_check_vardef_context (a->expr, false, false, false, context))
3413 return false;
3414 }
3415
3416 if ((f->sym->attr.intent == INTENT_OUT
3417 || f->sym->attr.intent == INTENT_INOUT
3418 || f->sym->attr.volatile_
3419 || f->sym->attr.asynchronous)
3420 && gfc_has_vector_subscript (a->expr))
3421 {
3422 if (where)
3423 gfc_error ("Array-section actual argument with vector "
3424 "subscripts at %L is incompatible with INTENT(OUT), "
3425 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3426 "of the dummy argument %qs",
3427 &a->expr->where, f->sym->name);
3428 return false;
3429 }
3430
3431 /* C1232 (R1221) For an actual argument which is an array section or
3432 an assumed-shape array, the dummy argument shall be an assumed-
3433 shape array, if the dummy argument has the VOLATILE attribute. */
3434
3435 if (f->sym->attr.volatile_
3436 && a->expr->expr_type == EXPR_VARIABLE
3437 && a->expr->symtree->n.sym->as
3438 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
3439 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3440 {
3441 if (where)
3442 gfc_error ("Assumed-shape actual argument at %L is "
3443 "incompatible with the non-assumed-shape "
3444 "dummy argument %qs due to VOLATILE attribute",
3445 &a->expr->where,f->sym->name);
3446 return false;
3447 }
3448
3449 /* Find the last array_ref. */
3450 actual_arr_ref = NULL;
3451 if (a->expr->ref)
3452 actual_arr_ref = gfc_find_array_ref (a->expr, true);
3453
3454 if (f->sym->attr.volatile_
3455 && actual_arr_ref && actual_arr_ref->type == AR_SECTION
3456 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3457 {
3458 if (where)
3459 gfc_error ("Array-section actual argument at %L is "
3460 "incompatible with the non-assumed-shape "
3461 "dummy argument %qs due to VOLATILE attribute",
3462 &a->expr->where, f->sym->name);
3463 return false;
3464 }
3465
3466 /* C1233 (R1221) For an actual argument which is a pointer array, the
3467 dummy argument shall be an assumed-shape or pointer array, if the
3468 dummy argument has the VOLATILE attribute. */
3469
3470 if (f->sym->attr.volatile_
3471 && a->expr->expr_type == EXPR_VARIABLE
3472 && a->expr->symtree->n.sym->attr.pointer
3473 && a->expr->symtree->n.sym->as
3474 && !(f->sym->as
3475 && (f->sym->as->type == AS_ASSUMED_SHAPE
3476 || f->sym->attr.pointer)))
3477 {
3478 if (where)
3479 gfc_error ("Pointer-array actual argument at %L requires "
3480 "an assumed-shape or pointer-array dummy "
3481 "argument %qs due to VOLATILE attribute",
3482 &a->expr->where,f->sym->name);
3483 return false;
3484 }
3485
3486 match:
3487 if (a == actual)
3488 na = i;
3489
3490 new_arg[i++] = a;
3491 }
3492
3493 /* Make sure missing actual arguments are optional. */
3494 i = 0;
3495 for (f = formal; f; f = f->next, i++)
3496 {
3497 if (new_arg[i] != NULL)
3498 continue;
3499 if (f->sym == NULL)
3500 {
3501 if (where)
3502 gfc_error ("Missing alternate return spec in subroutine call "
3503 "at %L", where);
3504 return false;
3505 }
3506 if (!f->sym->attr.optional
3507 || (in_statement_function && f->sym->attr.optional))
3508 {
3509 if (where)
3510 gfc_error ("Missing actual argument for argument %qs at %L",
3511 f->sym->name, where);
3512 return false;
3513 }
3514 }
3515
3516 /* The argument lists are compatible. We now relink a new actual
3517 argument list with null arguments in the right places. The head
3518 of the list remains the head. */
3519 for (i = 0; i < n; i++)
3520 if (new_arg[i] == NULL)
3521 new_arg[i] = gfc_get_actual_arglist ();
3522
3523 if (na != 0)
3524 {
3525 std::swap (*new_arg[0], *actual);
3526 std::swap (new_arg[0], new_arg[na]);
3527 }
3528
3529 for (i = 0; i < n - 1; i++)
3530 new_arg[i]->next = new_arg[i + 1];
3531
3532 new_arg[i]->next = NULL;
3533
3534 if (*ap == NULL && n > 0)
3535 *ap = new_arg[0];
3536
3537 /* Note the types of omitted optional arguments. */
3538 for (a = *ap, f = formal; a; a = a->next, f = f->next)
3539 if (a->expr == NULL && a->label == NULL)
3540 a->missing_arg_type = f->sym->ts.type;
3541
3542 return true;
3543 }
3544
3545
3546 typedef struct
3547 {
3548 gfc_formal_arglist *f;
3549 gfc_actual_arglist *a;
3550 }
3551 argpair;
3552
3553 /* qsort comparison function for argument pairs, with the following
3554 order:
3555 - p->a->expr == NULL
3556 - p->a->expr->expr_type != EXPR_VARIABLE
3557 - by gfc_symbol pointer value (larger first). */
3558
3559 static int
pair_cmp(const void * p1,const void * p2)3560 pair_cmp (const void *p1, const void *p2)
3561 {
3562 const gfc_actual_arglist *a1, *a2;
3563
3564 /* *p1 and *p2 are elements of the to-be-sorted array. */
3565 a1 = ((const argpair *) p1)->a;
3566 a2 = ((const argpair *) p2)->a;
3567 if (!a1->expr)
3568 {
3569 if (!a2->expr)
3570 return 0;
3571 return -1;
3572 }
3573 if (!a2->expr)
3574 return 1;
3575 if (a1->expr->expr_type != EXPR_VARIABLE)
3576 {
3577 if (a2->expr->expr_type != EXPR_VARIABLE)
3578 return 0;
3579 return -1;
3580 }
3581 if (a2->expr->expr_type != EXPR_VARIABLE)
3582 return 1;
3583 if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym)
3584 return -1;
3585 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
3586 }
3587
3588
3589 /* Given two expressions from some actual arguments, test whether they
3590 refer to the same expression. The analysis is conservative.
3591 Returning false will produce no warning. */
3592
3593 static bool
compare_actual_expr(gfc_expr * e1,gfc_expr * e2)3594 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
3595 {
3596 const gfc_ref *r1, *r2;
3597
3598 if (!e1 || !e2
3599 || e1->expr_type != EXPR_VARIABLE
3600 || e2->expr_type != EXPR_VARIABLE
3601 || e1->symtree->n.sym != e2->symtree->n.sym)
3602 return false;
3603
3604 /* TODO: improve comparison, see expr.c:show_ref(). */
3605 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
3606 {
3607 if (r1->type != r2->type)
3608 return false;
3609 switch (r1->type)
3610 {
3611 case REF_ARRAY:
3612 if (r1->u.ar.type != r2->u.ar.type)
3613 return false;
3614 /* TODO: At the moment, consider only full arrays;
3615 we could do better. */
3616 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
3617 return false;
3618 break;
3619
3620 case REF_COMPONENT:
3621 if (r1->u.c.component != r2->u.c.component)
3622 return false;
3623 break;
3624
3625 case REF_SUBSTRING:
3626 return false;
3627
3628 case REF_INQUIRY:
3629 if (e1->symtree->n.sym->ts.type == BT_COMPLEX
3630 && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL
3631 && r1->u.i != r2->u.i)
3632 return false;
3633 break;
3634
3635 default:
3636 gfc_internal_error ("compare_actual_expr(): Bad component code");
3637 }
3638 }
3639 if (!r1 && !r2)
3640 return true;
3641 return false;
3642 }
3643
3644
3645 /* Given formal and actual argument lists that correspond to one
3646 another, check that identical actual arguments aren't not
3647 associated with some incompatible INTENTs. */
3648
3649 static bool
check_some_aliasing(gfc_formal_arglist * f,gfc_actual_arglist * a)3650 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
3651 {
3652 sym_intent f1_intent, f2_intent;
3653 gfc_formal_arglist *f1;
3654 gfc_actual_arglist *a1;
3655 size_t n, i, j;
3656 argpair *p;
3657 bool t = true;
3658
3659 n = 0;
3660 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
3661 {
3662 if (f1 == NULL && a1 == NULL)
3663 break;
3664 if (f1 == NULL || a1 == NULL)
3665 gfc_internal_error ("check_some_aliasing(): List mismatch");
3666 n++;
3667 }
3668 if (n == 0)
3669 return t;
3670 p = XALLOCAVEC (argpair, n);
3671
3672 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
3673 {
3674 p[i].f = f1;
3675 p[i].a = a1;
3676 }
3677
3678 qsort (p, n, sizeof (argpair), pair_cmp);
3679
3680 for (i = 0; i < n; i++)
3681 {
3682 if (!p[i].a->expr
3683 || p[i].a->expr->expr_type != EXPR_VARIABLE
3684 || p[i].a->expr->ts.type == BT_PROCEDURE)
3685 continue;
3686 f1_intent = p[i].f->sym->attr.intent;
3687 for (j = i + 1; j < n; j++)
3688 {
3689 /* Expected order after the sort. */
3690 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
3691 gfc_internal_error ("check_some_aliasing(): corrupted data");
3692
3693 /* Are the expression the same? */
3694 if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
3695 break;
3696 f2_intent = p[j].f->sym->attr.intent;
3697 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
3698 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
3699 || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
3700 {
3701 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3702 "argument %qs and INTENT(%s) argument %qs at %L",
3703 gfc_intent_string (f1_intent), p[i].f->sym->name,
3704 gfc_intent_string (f2_intent), p[j].f->sym->name,
3705 &p[i].a->expr->where);
3706 t = false;
3707 }
3708 }
3709 }
3710
3711 return t;
3712 }
3713
3714
3715 /* Given formal and actual argument lists that correspond to one
3716 another, check that they are compatible in the sense that intents
3717 are not mismatched. */
3718
3719 static bool
check_intents(gfc_formal_arglist * f,gfc_actual_arglist * a)3720 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
3721 {
3722 sym_intent f_intent;
3723
3724 for (;; f = f->next, a = a->next)
3725 {
3726 gfc_expr *expr;
3727
3728 if (f == NULL && a == NULL)
3729 break;
3730 if (f == NULL || a == NULL)
3731 gfc_internal_error ("check_intents(): List mismatch");
3732
3733 if (a->expr && a->expr->expr_type == EXPR_FUNCTION
3734 && a->expr->value.function.isym
3735 && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
3736 expr = a->expr->value.function.actual->expr;
3737 else
3738 expr = a->expr;
3739
3740 if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
3741 continue;
3742
3743 f_intent = f->sym->attr.intent;
3744
3745 if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
3746 {
3747 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3748 && CLASS_DATA (f->sym)->attr.class_pointer)
3749 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3750 {
3751 gfc_error ("Procedure argument at %L is local to a PURE "
3752 "procedure and has the POINTER attribute",
3753 &expr->where);
3754 return false;
3755 }
3756 }
3757
3758 /* Fortran 2008, C1283. */
3759 if (gfc_pure (NULL) && gfc_is_coindexed (expr))
3760 {
3761 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
3762 {
3763 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3764 "is passed to an INTENT(%s) argument",
3765 &expr->where, gfc_intent_string (f_intent));
3766 return false;
3767 }
3768
3769 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3770 && CLASS_DATA (f->sym)->attr.class_pointer)
3771 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3772 {
3773 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3774 "is passed to a POINTER dummy argument",
3775 &expr->where);
3776 return false;
3777 }
3778 }
3779
3780 /* F2008, Section 12.5.2.4. */
3781 if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
3782 && gfc_is_coindexed (expr))
3783 {
3784 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3785 "polymorphic dummy argument %qs",
3786 &expr->where, f->sym->name);
3787 return false;
3788 }
3789 }
3790
3791 return true;
3792 }
3793
3794
3795 /* Check how a procedure is used against its interface. If all goes
3796 well, the actual argument list will also end up being properly
3797 sorted. */
3798
3799 bool
gfc_procedure_use(gfc_symbol * sym,gfc_actual_arglist ** ap,locus * where)3800 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
3801 {
3802 gfc_actual_arglist *a;
3803 gfc_formal_arglist *dummy_args;
3804 bool implicit = false;
3805
3806 /* Warn about calls with an implicit interface. Special case
3807 for calling a ISO_C_BINDING because c_loc and c_funloc
3808 are pseudo-unknown. Additionally, warn about procedures not
3809 explicitly declared at all if requested. */
3810 if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
3811 {
3812 bool has_implicit_none_export = false;
3813 implicit = true;
3814 if (sym->attr.proc == PROC_UNKNOWN)
3815 for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
3816 if (ns->has_implicit_none_export)
3817 {
3818 has_implicit_none_export = true;
3819 break;
3820 }
3821 if (has_implicit_none_export)
3822 {
3823 const char *guessed
3824 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3825 if (guessed)
3826 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3827 "; did you mean %qs?",
3828 sym->name, where, guessed);
3829 else
3830 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3831 sym->name, where);
3832 return false;
3833 }
3834 if (warn_implicit_interface)
3835 gfc_warning (OPT_Wimplicit_interface,
3836 "Procedure %qs called with an implicit interface at %L",
3837 sym->name, where);
3838 else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
3839 gfc_warning (OPT_Wimplicit_procedure,
3840 "Procedure %qs called at %L is not explicitly declared",
3841 sym->name, where);
3842 gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1;
3843 }
3844
3845 if (sym->attr.if_source == IFSRC_UNKNOWN)
3846 {
3847 if (sym->attr.pointer)
3848 {
3849 gfc_error ("The pointer object %qs at %L must have an explicit "
3850 "function interface or be declared as array",
3851 sym->name, where);
3852 return false;
3853 }
3854
3855 if (sym->attr.allocatable && !sym->attr.external)
3856 {
3857 gfc_error ("The allocatable object %qs at %L must have an explicit "
3858 "function interface or be declared as array",
3859 sym->name, where);
3860 return false;
3861 }
3862
3863 if (sym->attr.allocatable)
3864 {
3865 gfc_error ("Allocatable function %qs at %L must have an explicit "
3866 "function interface", sym->name, where);
3867 return false;
3868 }
3869
3870 for (a = *ap; a; a = a->next)
3871 {
3872 if (a->expr && a->expr->error)
3873 return false;
3874
3875 /* F2018, 15.4.2.2 Explicit interface is required for a
3876 polymorphic dummy argument, so there is no way to
3877 legally have a class appear in an argument with an
3878 implicit interface. */
3879
3880 if (implicit && a->expr && a->expr->ts.type == BT_CLASS)
3881 {
3882 gfc_error ("Explicit interface required for polymorphic "
3883 "argument at %L",&a->expr->where);
3884 a->expr->error = 1;
3885 break;
3886 }
3887
3888 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3889 if (a->name != NULL && a->name[0] != '%')
3890 {
3891 gfc_error ("Keyword argument requires explicit interface "
3892 "for procedure %qs at %L", sym->name, &a->expr->where);
3893 break;
3894 }
3895
3896 /* TS 29113, 6.2. */
3897 if (a->expr && a->expr->ts.type == BT_ASSUMED
3898 && sym->intmod_sym_id != ISOCBINDING_LOC)
3899 {
3900 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3901 "interface", a->expr->symtree->n.sym->name,
3902 &a->expr->where);
3903 a->expr->error = 1;
3904 break;
3905 }
3906
3907 /* F2008, C1303 and C1304. */
3908 if (a->expr
3909 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3910 && a->expr->ts.u.derived
3911 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3912 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3913 || gfc_expr_attr (a->expr).lock_comp))
3914 {
3915 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3916 "component at %L requires an explicit interface for "
3917 "procedure %qs", &a->expr->where, sym->name);
3918 a->expr->error = 1;
3919 break;
3920 }
3921
3922 if (a->expr
3923 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3924 && a->expr->ts.u.derived
3925 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3926 && a->expr->ts.u.derived->intmod_sym_id
3927 == ISOFORTRAN_EVENT_TYPE)
3928 || gfc_expr_attr (a->expr).event_comp))
3929 {
3930 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3931 "component at %L requires an explicit interface for "
3932 "procedure %qs", &a->expr->where, sym->name);
3933 a->expr->error = 1;
3934 break;
3935 }
3936
3937 if (a->expr && a->expr->expr_type == EXPR_NULL
3938 && a->expr->ts.type == BT_UNKNOWN)
3939 {
3940 gfc_error ("MOLD argument to NULL required at %L",
3941 &a->expr->where);
3942 a->expr->error = 1;
3943 return false;
3944 }
3945
3946 /* TS 29113, C407b. */
3947 if (a->expr && a->expr->expr_type == EXPR_VARIABLE
3948 && symbol_rank (a->expr->symtree->n.sym) == -1)
3949 {
3950 gfc_error ("Assumed-rank argument requires an explicit interface "
3951 "at %L", &a->expr->where);
3952 a->expr->error = 1;
3953 return false;
3954 }
3955 }
3956
3957 return true;
3958 }
3959
3960 dummy_args = gfc_sym_get_dummy_args (sym);
3961
3962 /* For a statement function, check that types and type parameters of actual
3963 arguments and dummy arguments match. */
3964 if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
3965 sym->attr.proc == PROC_ST_FUNCTION, where))
3966 return false;
3967
3968 if (!check_intents (dummy_args, *ap))
3969 return false;
3970
3971 if (warn_aliasing)
3972 check_some_aliasing (dummy_args, *ap);
3973
3974 return true;
3975 }
3976
3977
3978 /* Check how a procedure pointer component is used against its interface.
3979 If all goes well, the actual argument list will also end up being properly
3980 sorted. Completely analogous to gfc_procedure_use. */
3981
3982 void
gfc_ppc_use(gfc_component * comp,gfc_actual_arglist ** ap,locus * where)3983 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
3984 {
3985 /* Warn about calls with an implicit interface. Special case
3986 for calling a ISO_C_BINDING because c_loc and c_funloc
3987 are pseudo-unknown. */
3988 if (warn_implicit_interface
3989 && comp->attr.if_source == IFSRC_UNKNOWN
3990 && !comp->attr.is_iso_c)
3991 gfc_warning (OPT_Wimplicit_interface,
3992 "Procedure pointer component %qs called with an implicit "
3993 "interface at %L", comp->name, where);
3994
3995 if (comp->attr.if_source == IFSRC_UNKNOWN)
3996 {
3997 gfc_actual_arglist *a;
3998 for (a = *ap; a; a = a->next)
3999 {
4000 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4001 if (a->name != NULL && a->name[0] != '%')
4002 {
4003 gfc_error ("Keyword argument requires explicit interface "
4004 "for procedure pointer component %qs at %L",
4005 comp->name, &a->expr->where);
4006 break;
4007 }
4008 }
4009
4010 return;
4011 }
4012
4013 if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0,
4014 comp->attr.elemental, false, where))
4015 return;
4016
4017 check_intents (comp->ts.interface->formal, *ap);
4018 if (warn_aliasing)
4019 check_some_aliasing (comp->ts.interface->formal, *ap);
4020 }
4021
4022
4023 /* Try if an actual argument list matches the formal list of a symbol,
4024 respecting the symbol's attributes like ELEMENTAL. This is used for
4025 GENERIC resolution. */
4026
4027 bool
gfc_arglist_matches_symbol(gfc_actual_arglist ** args,gfc_symbol * sym)4028 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
4029 {
4030 gfc_formal_arglist *dummy_args;
4031 bool r;
4032
4033 if (sym->attr.flavor != FL_PROCEDURE)
4034 return false;
4035
4036 dummy_args = gfc_sym_get_dummy_args (sym);
4037
4038 r = !sym->attr.elemental;
4039 if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL))
4040 {
4041 check_intents (dummy_args, *args);
4042 if (warn_aliasing)
4043 check_some_aliasing (dummy_args, *args);
4044 return true;
4045 }
4046
4047 return false;
4048 }
4049
4050
4051 /* Given an interface pointer and an actual argument list, search for
4052 a formal argument list that matches the actual. If found, returns
4053 a pointer to the symbol of the correct interface. Returns NULL if
4054 not found. */
4055
4056 gfc_symbol *
gfc_search_interface(gfc_interface * intr,int sub_flag,gfc_actual_arglist ** ap)4057 gfc_search_interface (gfc_interface *intr, int sub_flag,
4058 gfc_actual_arglist **ap)
4059 {
4060 gfc_symbol *elem_sym = NULL;
4061 gfc_symbol *null_sym = NULL;
4062 locus null_expr_loc;
4063 gfc_actual_arglist *a;
4064 bool has_null_arg = false;
4065
4066 for (a = *ap; a; a = a->next)
4067 if (a->expr && a->expr->expr_type == EXPR_NULL
4068 && a->expr->ts.type == BT_UNKNOWN)
4069 {
4070 has_null_arg = true;
4071 null_expr_loc = a->expr->where;
4072 break;
4073 }
4074
4075 for (; intr; intr = intr->next)
4076 {
4077 if (gfc_fl_struct (intr->sym->attr.flavor))
4078 continue;
4079 if (sub_flag && intr->sym->attr.function)
4080 continue;
4081 if (!sub_flag && intr->sym->attr.subroutine)
4082 continue;
4083
4084 if (gfc_arglist_matches_symbol (ap, intr->sym))
4085 {
4086 if (has_null_arg && null_sym)
4087 {
4088 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
4089 "between specific functions %s and %s",
4090 &null_expr_loc, null_sym->name, intr->sym->name);
4091 return NULL;
4092 }
4093 else if (has_null_arg)
4094 {
4095 null_sym = intr->sym;
4096 continue;
4097 }
4098
4099 /* Satisfy 12.4.4.1 such that an elemental match has lower
4100 weight than a non-elemental match. */
4101 if (intr->sym->attr.elemental)
4102 {
4103 elem_sym = intr->sym;
4104 continue;
4105 }
4106 return intr->sym;
4107 }
4108 }
4109
4110 if (null_sym)
4111 return null_sym;
4112
4113 return elem_sym ? elem_sym : NULL;
4114 }
4115
4116
4117 /* Do a brute force recursive search for a symbol. */
4118
4119 static gfc_symtree *
find_symtree0(gfc_symtree * root,gfc_symbol * sym)4120 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
4121 {
4122 gfc_symtree * st;
4123
4124 if (root->n.sym == sym)
4125 return root;
4126
4127 st = NULL;
4128 if (root->left)
4129 st = find_symtree0 (root->left, sym);
4130 if (root->right && ! st)
4131 st = find_symtree0 (root->right, sym);
4132 return st;
4133 }
4134
4135
4136 /* Find a symtree for a symbol. */
4137
4138 gfc_symtree *
gfc_find_sym_in_symtree(gfc_symbol * sym)4139 gfc_find_sym_in_symtree (gfc_symbol *sym)
4140 {
4141 gfc_symtree *st;
4142 gfc_namespace *ns;
4143
4144 /* First try to find it by name. */
4145 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
4146 if (st && st->n.sym == sym)
4147 return st;
4148
4149 /* If it's been renamed, resort to a brute-force search. */
4150 /* TODO: avoid having to do this search. If the symbol doesn't exist
4151 in the symtree for the current namespace, it should probably be added. */
4152 for (ns = gfc_current_ns; ns; ns = ns->parent)
4153 {
4154 st = find_symtree0 (ns->sym_root, sym);
4155 if (st)
4156 return st;
4157 }
4158 gfc_internal_error ("Unable to find symbol %qs", sym->name);
4159 /* Not reached. */
4160 }
4161
4162
4163 /* See if the arglist to an operator-call contains a derived-type argument
4164 with a matching type-bound operator. If so, return the matching specific
4165 procedure defined as operator-target as well as the base-object to use
4166 (which is the found derived-type argument with operator). The generic
4167 name, if any, is transmitted to the final expression via 'gname'. */
4168
4169 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)4170 matching_typebound_op (gfc_expr** tb_base,
4171 gfc_actual_arglist* args,
4172 gfc_intrinsic_op op, const char* uop,
4173 const char ** gname)
4174 {
4175 gfc_actual_arglist* base;
4176
4177 for (base = args; base; base = base->next)
4178 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
4179 {
4180 gfc_typebound_proc* tb;
4181 gfc_symbol* derived;
4182 bool result;
4183
4184 while (base->expr->expr_type == EXPR_OP
4185 && base->expr->value.op.op == INTRINSIC_PARENTHESES)
4186 base->expr = base->expr->value.op.op1;
4187
4188 if (base->expr->ts.type == BT_CLASS)
4189 {
4190 if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL
4191 || !gfc_expr_attr (base->expr).class_ok)
4192 continue;
4193 derived = CLASS_DATA (base->expr)->ts.u.derived;
4194 }
4195 else
4196 derived = base->expr->ts.u.derived;
4197
4198 if (op == INTRINSIC_USER)
4199 {
4200 gfc_symtree* tb_uop;
4201
4202 gcc_assert (uop);
4203 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
4204 false, NULL);
4205
4206 if (tb_uop)
4207 tb = tb_uop->n.tb;
4208 else
4209 tb = NULL;
4210 }
4211 else
4212 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
4213 false, NULL);
4214
4215 /* This means we hit a PRIVATE operator which is use-associated and
4216 should thus not be seen. */
4217 if (!result)
4218 tb = NULL;
4219
4220 /* Look through the super-type hierarchy for a matching specific
4221 binding. */
4222 for (; tb; tb = tb->overridden)
4223 {
4224 gfc_tbp_generic* g;
4225
4226 gcc_assert (tb->is_generic);
4227 for (g = tb->u.generic; g; g = g->next)
4228 {
4229 gfc_symbol* target;
4230 gfc_actual_arglist* argcopy;
4231 bool matches;
4232
4233 gcc_assert (g->specific);
4234 if (g->specific->error)
4235 continue;
4236
4237 target = g->specific->u.specific->n.sym;
4238
4239 /* Check if this arglist matches the formal. */
4240 argcopy = gfc_copy_actual_arglist (args);
4241 matches = gfc_arglist_matches_symbol (&argcopy, target);
4242 gfc_free_actual_arglist (argcopy);
4243
4244 /* Return if we found a match. */
4245 if (matches)
4246 {
4247 *tb_base = base->expr;
4248 *gname = g->specific_st->name;
4249 return g->specific;
4250 }
4251 }
4252 }
4253 }
4254
4255 return NULL;
4256 }
4257
4258
4259 /* For the 'actual arglist' of an operator call and a specific typebound
4260 procedure that has been found the target of a type-bound operator, build the
4261 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4262 type-bound procedures rather than resolving type-bound operators 'directly'
4263 so that we can reuse the existing logic. */
4264
4265 static void
build_compcall_for_operator(gfc_expr * e,gfc_actual_arglist * actual,gfc_expr * base,gfc_typebound_proc * target,const char * gname)4266 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
4267 gfc_expr* base, gfc_typebound_proc* target,
4268 const char *gname)
4269 {
4270 e->expr_type = EXPR_COMPCALL;
4271 e->value.compcall.tbp = target;
4272 e->value.compcall.name = gname ? gname : "$op";
4273 e->value.compcall.actual = actual;
4274 e->value.compcall.base_object = base;
4275 e->value.compcall.ignore_pass = 1;
4276 e->value.compcall.assign = 0;
4277 if (e->ts.type == BT_UNKNOWN
4278 && target->function)
4279 {
4280 if (target->is_generic)
4281 e->ts = target->u.generic->specific->u.specific->n.sym->ts;
4282 else
4283 e->ts = target->u.specific->n.sym->ts;
4284 }
4285 }
4286
4287
4288 /* This subroutine is called when an expression is being resolved.
4289 The expression node in question is either a user defined operator
4290 or an intrinsic operator with arguments that aren't compatible
4291 with the operator. This subroutine builds an actual argument list
4292 corresponding to the operands, then searches for a compatible
4293 interface. If one is found, the expression node is replaced with
4294 the appropriate function call. We use the 'match' enum to specify
4295 whether a replacement has been made or not, or if an error occurred. */
4296
4297 match
gfc_extend_expr(gfc_expr * e)4298 gfc_extend_expr (gfc_expr *e)
4299 {
4300 gfc_actual_arglist *actual;
4301 gfc_symbol *sym;
4302 gfc_namespace *ns;
4303 gfc_user_op *uop;
4304 gfc_intrinsic_op i;
4305 const char *gname;
4306 gfc_typebound_proc* tbo;
4307 gfc_expr* tb_base;
4308
4309 sym = NULL;
4310
4311 actual = gfc_get_actual_arglist ();
4312 actual->expr = e->value.op.op1;
4313
4314 gname = NULL;
4315
4316 if (e->value.op.op2 != NULL)
4317 {
4318 actual->next = gfc_get_actual_arglist ();
4319 actual->next->expr = e->value.op.op2;
4320 }
4321
4322 i = fold_unary_intrinsic (e->value.op.op);
4323
4324 /* See if we find a matching type-bound operator. */
4325 if (i == INTRINSIC_USER)
4326 tbo = matching_typebound_op (&tb_base, actual,
4327 i, e->value.op.uop->name, &gname);
4328 else
4329 switch (i)
4330 {
4331 #define CHECK_OS_COMPARISON(comp) \
4332 case INTRINSIC_##comp: \
4333 case INTRINSIC_##comp##_OS: \
4334 tbo = matching_typebound_op (&tb_base, actual, \
4335 INTRINSIC_##comp, NULL, &gname); \
4336 if (!tbo) \
4337 tbo = matching_typebound_op (&tb_base, actual, \
4338 INTRINSIC_##comp##_OS, NULL, &gname); \
4339 break;
4340 CHECK_OS_COMPARISON(EQ)
4341 CHECK_OS_COMPARISON(NE)
4342 CHECK_OS_COMPARISON(GT)
4343 CHECK_OS_COMPARISON(GE)
4344 CHECK_OS_COMPARISON(LT)
4345 CHECK_OS_COMPARISON(LE)
4346 #undef CHECK_OS_COMPARISON
4347
4348 default:
4349 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
4350 break;
4351 }
4352
4353 /* If there is a matching typebound-operator, replace the expression with
4354 a call to it and succeed. */
4355 if (tbo)
4356 {
4357 gcc_assert (tb_base);
4358 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
4359
4360 if (!gfc_resolve_expr (e))
4361 return MATCH_ERROR;
4362 else
4363 return MATCH_YES;
4364 }
4365
4366 if (i == INTRINSIC_USER)
4367 {
4368 for (ns = gfc_current_ns; ns; ns = ns->parent)
4369 {
4370 uop = gfc_find_uop (e->value.op.uop->name, ns);
4371 if (uop == NULL)
4372 continue;
4373
4374 sym = gfc_search_interface (uop->op, 0, &actual);
4375 if (sym != NULL)
4376 break;
4377 }
4378 }
4379 else
4380 {
4381 for (ns = gfc_current_ns; ns; ns = ns->parent)
4382 {
4383 /* Due to the distinction between '==' and '.eq.' and friends, one has
4384 to check if either is defined. */
4385 switch (i)
4386 {
4387 #define CHECK_OS_COMPARISON(comp) \
4388 case INTRINSIC_##comp: \
4389 case INTRINSIC_##comp##_OS: \
4390 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4391 if (!sym) \
4392 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4393 break;
4394 CHECK_OS_COMPARISON(EQ)
4395 CHECK_OS_COMPARISON(NE)
4396 CHECK_OS_COMPARISON(GT)
4397 CHECK_OS_COMPARISON(GE)
4398 CHECK_OS_COMPARISON(LT)
4399 CHECK_OS_COMPARISON(LE)
4400 #undef CHECK_OS_COMPARISON
4401
4402 default:
4403 sym = gfc_search_interface (ns->op[i], 0, &actual);
4404 }
4405
4406 if (sym != NULL)
4407 break;
4408 }
4409 }
4410
4411 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4412 found rather than just taking the first one and not checking further. */
4413
4414 if (sym == NULL)
4415 {
4416 /* Don't use gfc_free_actual_arglist(). */
4417 free (actual->next);
4418 free (actual);
4419 return MATCH_NO;
4420 }
4421
4422 /* Change the expression node to a function call. */
4423 e->expr_type = EXPR_FUNCTION;
4424 e->symtree = gfc_find_sym_in_symtree (sym);
4425 e->value.function.actual = actual;
4426 e->value.function.esym = NULL;
4427 e->value.function.isym = NULL;
4428 e->value.function.name = NULL;
4429 e->user_operator = 1;
4430
4431 if (!gfc_resolve_expr (e))
4432 return MATCH_ERROR;
4433
4434 return MATCH_YES;
4435 }
4436
4437
4438 /* Tries to replace an assignment code node with a subroutine call to the
4439 subroutine associated with the assignment operator. Return true if the node
4440 was replaced. On false, no error is generated. */
4441
4442 bool
gfc_extend_assign(gfc_code * c,gfc_namespace * ns)4443 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
4444 {
4445 gfc_actual_arglist *actual;
4446 gfc_expr *lhs, *rhs, *tb_base;
4447 gfc_symbol *sym = NULL;
4448 const char *gname = NULL;
4449 gfc_typebound_proc* tbo;
4450
4451 lhs = c->expr1;
4452 rhs = c->expr2;
4453
4454 /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
4455 if (c->op == EXEC_ASSIGN
4456 && c->expr1->expr_type == EXPR_VARIABLE
4457 && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ)
4458 return false;
4459
4460 /* Don't allow an intrinsic assignment to be replaced. */
4461 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
4462 && (rhs->rank == 0 || rhs->rank == lhs->rank)
4463 && (lhs->ts.type == rhs->ts.type
4464 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
4465 return false;
4466
4467 actual = gfc_get_actual_arglist ();
4468 actual->expr = lhs;
4469
4470 actual->next = gfc_get_actual_arglist ();
4471 actual->next->expr = rhs;
4472
4473 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4474
4475 /* See if we find a matching type-bound assignment. */
4476 tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
4477 NULL, &gname);
4478
4479 if (tbo)
4480 {
4481 /* Success: Replace the expression with a type-bound call. */
4482 gcc_assert (tb_base);
4483 c->expr1 = gfc_get_expr ();
4484 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
4485 c->expr1->value.compcall.assign = 1;
4486 c->expr1->where = c->loc;
4487 c->expr2 = NULL;
4488 c->op = EXEC_COMPCALL;
4489 return true;
4490 }
4491
4492 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4493 for (; ns; ns = ns->parent)
4494 {
4495 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
4496 if (sym != NULL)
4497 break;
4498 }
4499
4500 if (sym)
4501 {
4502 /* Success: Replace the assignment with the call. */
4503 c->op = EXEC_ASSIGN_CALL;
4504 c->symtree = gfc_find_sym_in_symtree (sym);
4505 c->expr1 = NULL;
4506 c->expr2 = NULL;
4507 c->ext.actual = actual;
4508 return true;
4509 }
4510
4511 /* Failure: No assignment procedure found. */
4512 free (actual->next);
4513 free (actual);
4514 return false;
4515 }
4516
4517
4518 /* Make sure that the interface just parsed is not already present in
4519 the given interface list. Ambiguity isn't checked yet since module
4520 procedures can be present without interfaces. */
4521
4522 bool
gfc_check_new_interface(gfc_interface * base,gfc_symbol * new_sym,locus loc)4523 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
4524 {
4525 gfc_interface *ip;
4526
4527 for (ip = base; ip; ip = ip->next)
4528 {
4529 if (ip->sym == new_sym)
4530 {
4531 gfc_error ("Entity %qs at %L is already present in the interface",
4532 new_sym->name, &loc);
4533 return false;
4534 }
4535 }
4536
4537 return true;
4538 }
4539
4540
4541 /* Add a symbol to the current interface. */
4542
4543 bool
gfc_add_interface(gfc_symbol * new_sym)4544 gfc_add_interface (gfc_symbol *new_sym)
4545 {
4546 gfc_interface **head, *intr;
4547 gfc_namespace *ns;
4548 gfc_symbol *sym;
4549
4550 switch (current_interface.type)
4551 {
4552 case INTERFACE_NAMELESS:
4553 case INTERFACE_ABSTRACT:
4554 return true;
4555
4556 case INTERFACE_INTRINSIC_OP:
4557 for (ns = current_interface.ns; ns; ns = ns->parent)
4558 switch (current_interface.op)
4559 {
4560 case INTRINSIC_EQ:
4561 case INTRINSIC_EQ_OS:
4562 if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
4563 gfc_current_locus)
4564 || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
4565 new_sym, gfc_current_locus))
4566 return false;
4567 break;
4568
4569 case INTRINSIC_NE:
4570 case INTRINSIC_NE_OS:
4571 if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
4572 gfc_current_locus)
4573 || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
4574 new_sym, gfc_current_locus))
4575 return false;
4576 break;
4577
4578 case INTRINSIC_GT:
4579 case INTRINSIC_GT_OS:
4580 if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
4581 new_sym, gfc_current_locus)
4582 || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
4583 new_sym, gfc_current_locus))
4584 return false;
4585 break;
4586
4587 case INTRINSIC_GE:
4588 case INTRINSIC_GE_OS:
4589 if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
4590 new_sym, gfc_current_locus)
4591 || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
4592 new_sym, gfc_current_locus))
4593 return false;
4594 break;
4595
4596 case INTRINSIC_LT:
4597 case INTRINSIC_LT_OS:
4598 if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
4599 new_sym, gfc_current_locus)
4600 || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
4601 new_sym, gfc_current_locus))
4602 return false;
4603 break;
4604
4605 case INTRINSIC_LE:
4606 case INTRINSIC_LE_OS:
4607 if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
4608 new_sym, gfc_current_locus)
4609 || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
4610 new_sym, gfc_current_locus))
4611 return false;
4612 break;
4613
4614 default:
4615 if (!gfc_check_new_interface (ns->op[current_interface.op],
4616 new_sym, gfc_current_locus))
4617 return false;
4618 }
4619
4620 head = ¤t_interface.ns->op[current_interface.op];
4621 break;
4622
4623 case INTERFACE_GENERIC:
4624 case INTERFACE_DTIO:
4625 for (ns = current_interface.ns; ns; ns = ns->parent)
4626 {
4627 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
4628 if (sym == NULL)
4629 continue;
4630
4631 if (!gfc_check_new_interface (sym->generic,
4632 new_sym, gfc_current_locus))
4633 return false;
4634 }
4635
4636 head = ¤t_interface.sym->generic;
4637 break;
4638
4639 case INTERFACE_USER_OP:
4640 if (!gfc_check_new_interface (current_interface.uop->op,
4641 new_sym, gfc_current_locus))
4642 return false;
4643
4644 head = ¤t_interface.uop->op;
4645 break;
4646
4647 default:
4648 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4649 }
4650
4651 intr = gfc_get_interface ();
4652 intr->sym = new_sym;
4653 intr->where = gfc_current_locus;
4654
4655 intr->next = *head;
4656 *head = intr;
4657
4658 return true;
4659 }
4660
4661
4662 gfc_interface *
gfc_current_interface_head(void)4663 gfc_current_interface_head (void)
4664 {
4665 switch (current_interface.type)
4666 {
4667 case INTERFACE_INTRINSIC_OP:
4668 return current_interface.ns->op[current_interface.op];
4669
4670 case INTERFACE_GENERIC:
4671 case INTERFACE_DTIO:
4672 return current_interface.sym->generic;
4673
4674 case INTERFACE_USER_OP:
4675 return current_interface.uop->op;
4676
4677 default:
4678 gcc_unreachable ();
4679 }
4680 }
4681
4682
4683 void
gfc_set_current_interface_head(gfc_interface * i)4684 gfc_set_current_interface_head (gfc_interface *i)
4685 {
4686 switch (current_interface.type)
4687 {
4688 case INTERFACE_INTRINSIC_OP:
4689 current_interface.ns->op[current_interface.op] = i;
4690 break;
4691
4692 case INTERFACE_GENERIC:
4693 case INTERFACE_DTIO:
4694 current_interface.sym->generic = i;
4695 break;
4696
4697 case INTERFACE_USER_OP:
4698 current_interface.uop->op = i;
4699 break;
4700
4701 default:
4702 gcc_unreachable ();
4703 }
4704 }
4705
4706
4707 /* Gets rid of a formal argument list. We do not free symbols.
4708 Symbols are freed when a namespace is freed. */
4709
4710 void
gfc_free_formal_arglist(gfc_formal_arglist * p)4711 gfc_free_formal_arglist (gfc_formal_arglist *p)
4712 {
4713 gfc_formal_arglist *q;
4714
4715 for (; p; p = q)
4716 {
4717 q = p->next;
4718 free (p);
4719 }
4720 }
4721
4722
4723 /* Check that it is ok for the type-bound procedure 'proc' to override the
4724 procedure 'old', cf. F08:4.5.7.3. */
4725
4726 bool
gfc_check_typebound_override(gfc_symtree * proc,gfc_symtree * old)4727 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
4728 {
4729 locus where;
4730 gfc_symbol *proc_target, *old_target;
4731 unsigned proc_pass_arg, old_pass_arg, argpos;
4732 gfc_formal_arglist *proc_formal, *old_formal;
4733 bool check_type;
4734 char err[200];
4735
4736 /* This procedure should only be called for non-GENERIC proc. */
4737 gcc_assert (!proc->n.tb->is_generic);
4738
4739 /* If the overwritten procedure is GENERIC, this is an error. */
4740 if (old->n.tb->is_generic)
4741 {
4742 gfc_error ("Cannot overwrite GENERIC %qs at %L",
4743 old->name, &proc->n.tb->where);
4744 return false;
4745 }
4746
4747 where = proc->n.tb->where;
4748 proc_target = proc->n.tb->u.specific->n.sym;
4749 old_target = old->n.tb->u.specific->n.sym;
4750
4751 /* Check that overridden binding is not NON_OVERRIDABLE. */
4752 if (old->n.tb->non_overridable)
4753 {
4754 gfc_error ("%qs at %L overrides a procedure binding declared"
4755 " NON_OVERRIDABLE", proc->name, &where);
4756 return false;
4757 }
4758
4759 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4760 if (!old->n.tb->deferred && proc->n.tb->deferred)
4761 {
4762 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4763 " non-DEFERRED binding", proc->name, &where);
4764 return false;
4765 }
4766
4767 /* If the overridden binding is PURE, the overriding must be, too. */
4768 if (old_target->attr.pure && !proc_target->attr.pure)
4769 {
4770 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4771 proc->name, &where);
4772 return false;
4773 }
4774
4775 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4776 is not, the overriding must not be either. */
4777 if (old_target->attr.elemental && !proc_target->attr.elemental)
4778 {
4779 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4780 " ELEMENTAL", proc->name, &where);
4781 return false;
4782 }
4783 if (!old_target->attr.elemental && proc_target->attr.elemental)
4784 {
4785 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4786 " be ELEMENTAL, either", proc->name, &where);
4787 return false;
4788 }
4789
4790 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4791 SUBROUTINE. */
4792 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
4793 {
4794 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4795 " SUBROUTINE", proc->name, &where);
4796 return false;
4797 }
4798
4799 /* If the overridden binding is a FUNCTION, the overriding must also be a
4800 FUNCTION and have the same characteristics. */
4801 if (old_target->attr.function)
4802 {
4803 if (!proc_target->attr.function)
4804 {
4805 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4806 " FUNCTION", proc->name, &where);
4807 return false;
4808 }
4809
4810 if (!gfc_check_result_characteristics (proc_target, old_target,
4811 err, sizeof(err)))
4812 {
4813 gfc_error ("Result mismatch for the overriding procedure "
4814 "%qs at %L: %s", proc->name, &where, err);
4815 return false;
4816 }
4817 }
4818
4819 /* If the overridden binding is PUBLIC, the overriding one must not be
4820 PRIVATE. */
4821 if (old->n.tb->access == ACCESS_PUBLIC
4822 && proc->n.tb->access == ACCESS_PRIVATE)
4823 {
4824 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4825 " PRIVATE", proc->name, &where);
4826 return false;
4827 }
4828
4829 /* Compare the formal argument lists of both procedures. This is also abused
4830 to find the position of the passed-object dummy arguments of both
4831 bindings as at least the overridden one might not yet be resolved and we
4832 need those positions in the check below. */
4833 proc_pass_arg = old_pass_arg = 0;
4834 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
4835 proc_pass_arg = 1;
4836 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
4837 old_pass_arg = 1;
4838 argpos = 1;
4839 proc_formal = gfc_sym_get_dummy_args (proc_target);
4840 old_formal = gfc_sym_get_dummy_args (old_target);
4841 for ( ; proc_formal && old_formal;
4842 proc_formal = proc_formal->next, old_formal = old_formal->next)
4843 {
4844 if (proc->n.tb->pass_arg
4845 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
4846 proc_pass_arg = argpos;
4847 if (old->n.tb->pass_arg
4848 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
4849 old_pass_arg = argpos;
4850
4851 /* Check that the names correspond. */
4852 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
4853 {
4854 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4855 " to match the corresponding argument of the overridden"
4856 " procedure", proc_formal->sym->name, proc->name, &where,
4857 old_formal->sym->name);
4858 return false;
4859 }
4860
4861 check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
4862 if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
4863 check_type, err, sizeof(err)))
4864 {
4865 gfc_error_opt (0, "Argument mismatch for the overriding procedure "
4866 "%qs at %L: %s", proc->name, &where, err);
4867 return false;
4868 }
4869
4870 ++argpos;
4871 }
4872 if (proc_formal || old_formal)
4873 {
4874 gfc_error ("%qs at %L must have the same number of formal arguments as"
4875 " the overridden procedure", proc->name, &where);
4876 return false;
4877 }
4878
4879 /* If the overridden binding is NOPASS, the overriding one must also be
4880 NOPASS. */
4881 if (old->n.tb->nopass && !proc->n.tb->nopass)
4882 {
4883 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4884 " NOPASS", proc->name, &where);
4885 return false;
4886 }
4887
4888 /* If the overridden binding is PASS(x), the overriding one must also be
4889 PASS and the passed-object dummy arguments must correspond. */
4890 if (!old->n.tb->nopass)
4891 {
4892 if (proc->n.tb->nopass)
4893 {
4894 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4895 " PASS", proc->name, &where);
4896 return false;
4897 }
4898
4899 if (proc_pass_arg != old_pass_arg)
4900 {
4901 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4902 " the same position as the passed-object dummy argument of"
4903 " the overridden procedure", proc->name, &where);
4904 return false;
4905 }
4906 }
4907
4908 return true;
4909 }
4910
4911
4912 /* The following three functions check that the formal arguments
4913 of user defined derived type IO procedures are compliant with
4914 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4915
4916 static void
check_dtio_arg_TKR_intent(gfc_symbol * fsym,bool typebound,bt type,int kind,int rank,sym_intent intent)4917 check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
4918 int kind, int rank, sym_intent intent)
4919 {
4920 if (fsym->ts.type != type)
4921 {
4922 gfc_error ("DTIO dummy argument at %L must be of type %s",
4923 &fsym->declared_at, gfc_basic_typename (type));
4924 return;
4925 }
4926
4927 if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
4928 && fsym->ts.kind != kind)
4929 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4930 &fsym->declared_at, kind);
4931
4932 if (!typebound
4933 && rank == 0
4934 && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
4935 || ((type != BT_CLASS) && fsym->attr.dimension)))
4936 gfc_error ("DTIO dummy argument at %L must be a scalar",
4937 &fsym->declared_at);
4938 else if (rank == 1
4939 && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
4940 gfc_error ("DTIO dummy argument at %L must be an "
4941 "ASSUMED SHAPE ARRAY", &fsym->declared_at);
4942
4943 if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)
4944 gfc_error ("DTIO character argument at %L must have assumed length",
4945 &fsym->declared_at);
4946
4947 if (fsym->attr.intent != intent)
4948 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4949 &fsym->declared_at, gfc_code2string (intents, (int)intent));
4950 return;
4951 }
4952
4953
4954 static void
check_dtio_interface1(gfc_symbol * derived,gfc_symtree * tb_io_st,bool typebound,bool formatted,int code)4955 check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
4956 bool typebound, bool formatted, int code)
4957 {
4958 gfc_symbol *dtio_sub, *generic_proc, *fsym;
4959 gfc_typebound_proc *tb_io_proc, *specific_proc;
4960 gfc_interface *intr;
4961 gfc_formal_arglist *formal;
4962 int arg_num;
4963
4964 bool read = ((dtio_codes)code == DTIO_RF)
4965 || ((dtio_codes)code == DTIO_RUF);
4966 bt type;
4967 sym_intent intent;
4968 int kind;
4969
4970 dtio_sub = NULL;
4971 if (typebound)
4972 {
4973 /* Typebound DTIO binding. */
4974 tb_io_proc = tb_io_st->n.tb;
4975 if (tb_io_proc == NULL)
4976 return;
4977
4978 gcc_assert (tb_io_proc->is_generic);
4979
4980 specific_proc = tb_io_proc->u.generic->specific;
4981 if (specific_proc == NULL || specific_proc->is_generic)
4982 return;
4983
4984 dtio_sub = specific_proc->u.specific->n.sym;
4985 }
4986 else
4987 {
4988 generic_proc = tb_io_st->n.sym;
4989 if (generic_proc == NULL || generic_proc->generic == NULL)
4990 return;
4991
4992 for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
4993 {
4994 if (intr->sym && intr->sym->formal && intr->sym->formal->sym
4995 && ((intr->sym->formal->sym->ts.type == BT_CLASS
4996 && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
4997 == derived)
4998 || (intr->sym->formal->sym->ts.type == BT_DERIVED
4999 && intr->sym->formal->sym->ts.u.derived == derived)))
5000 {
5001 dtio_sub = intr->sym;
5002 break;
5003 }
5004 else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
5005 {
5006 gfc_error ("Alternate return at %L is not permitted in a DTIO "
5007 "procedure", &intr->sym->declared_at);
5008 return;
5009 }
5010 }
5011
5012 if (dtio_sub == NULL)
5013 return;
5014 }
5015
5016 gcc_assert (dtio_sub);
5017 if (!dtio_sub->attr.subroutine)
5018 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
5019 dtio_sub->name, &dtio_sub->declared_at);
5020
5021 if (!dtio_sub->resolve_symbol_called)
5022 gfc_resolve_formal_arglist (dtio_sub);
5023
5024 arg_num = 0;
5025 for (formal = dtio_sub->formal; formal; formal = formal->next)
5026 arg_num++;
5027
5028 if (arg_num < (formatted ? 6 : 4))
5029 {
5030 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
5031 dtio_sub->name, &dtio_sub->declared_at);
5032 return;
5033 }
5034
5035 if (arg_num > (formatted ? 6 : 4))
5036 {
5037 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
5038 dtio_sub->name, &dtio_sub->declared_at);
5039 return;
5040 }
5041
5042 /* Now go through the formal arglist. */
5043 arg_num = 1;
5044 for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
5045 {
5046 if (!formatted && arg_num == 3)
5047 arg_num = 5;
5048 fsym = formal->sym;
5049
5050 if (fsym == NULL)
5051 {
5052 gfc_error ("Alternate return at %L is not permitted in a DTIO "
5053 "procedure", &dtio_sub->declared_at);
5054 return;
5055 }
5056
5057 switch (arg_num)
5058 {
5059 case(1): /* DTV */
5060 type = derived->attr.sequence || derived->attr.is_bind_c ?
5061 BT_DERIVED : BT_CLASS;
5062 kind = 0;
5063 intent = read ? INTENT_INOUT : INTENT_IN;
5064 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5065 0, intent);
5066 break;
5067
5068 case(2): /* UNIT */
5069 type = BT_INTEGER;
5070 kind = gfc_default_integer_kind;
5071 intent = INTENT_IN;
5072 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5073 0, intent);
5074 break;
5075 case(3): /* IOTYPE */
5076 type = BT_CHARACTER;
5077 kind = gfc_default_character_kind;
5078 intent = INTENT_IN;
5079 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5080 0, intent);
5081 break;
5082 case(4): /* VLIST */
5083 type = BT_INTEGER;
5084 kind = gfc_default_integer_kind;
5085 intent = INTENT_IN;
5086 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5087 1, intent);
5088 break;
5089 case(5): /* IOSTAT */
5090 type = BT_INTEGER;
5091 kind = gfc_default_integer_kind;
5092 intent = INTENT_OUT;
5093 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5094 0, intent);
5095 break;
5096 case(6): /* IOMSG */
5097 type = BT_CHARACTER;
5098 kind = gfc_default_character_kind;
5099 intent = INTENT_INOUT;
5100 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
5101 0, intent);
5102 break;
5103 default:
5104 gcc_unreachable ();
5105 }
5106 }
5107 derived->attr.has_dtio_procs = 1;
5108 return;
5109 }
5110
5111 void
gfc_check_dtio_interfaces(gfc_symbol * derived)5112 gfc_check_dtio_interfaces (gfc_symbol *derived)
5113 {
5114 gfc_symtree *tb_io_st;
5115 bool t = false;
5116 int code;
5117 bool formatted;
5118
5119 if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
5120 return;
5121
5122 /* Check typebound DTIO bindings. */
5123 for (code = 0; code < 4; code++)
5124 {
5125 formatted = ((dtio_codes)code == DTIO_RF)
5126 || ((dtio_codes)code == DTIO_WF);
5127
5128 tb_io_st = gfc_find_typebound_proc (derived, &t,
5129 gfc_code2string (dtio_procs, code),
5130 true, &derived->declared_at);
5131 if (tb_io_st != NULL)
5132 check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
5133 }
5134
5135 /* Check generic DTIO interfaces. */
5136 for (code = 0; code < 4; code++)
5137 {
5138 formatted = ((dtio_codes)code == DTIO_RF)
5139 || ((dtio_codes)code == DTIO_WF);
5140
5141 tb_io_st = gfc_find_symtree (derived->ns->sym_root,
5142 gfc_code2string (dtio_procs, code));
5143 if (tb_io_st != NULL)
5144 check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
5145 }
5146 }
5147
5148
5149 gfc_symtree*
gfc_find_typebound_dtio_proc(gfc_symbol * derived,bool write,bool formatted)5150 gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
5151 {
5152 gfc_symtree *tb_io_st = NULL;
5153 bool t = false;
5154
5155 if (!derived || !derived->resolve_symbol_called
5156 || derived->attr.flavor != FL_DERIVED)
5157 return NULL;
5158
5159 /* Try to find a typebound DTIO binding. */
5160 if (formatted == true)
5161 {
5162 if (write == true)
5163 tb_io_st = gfc_find_typebound_proc (derived, &t,
5164 gfc_code2string (dtio_procs,
5165 DTIO_WF),
5166 true,
5167 &derived->declared_at);
5168 else
5169 tb_io_st = gfc_find_typebound_proc (derived, &t,
5170 gfc_code2string (dtio_procs,
5171 DTIO_RF),
5172 true,
5173 &derived->declared_at);
5174 }
5175 else
5176 {
5177 if (write == true)
5178 tb_io_st = gfc_find_typebound_proc (derived, &t,
5179 gfc_code2string (dtio_procs,
5180 DTIO_WUF),
5181 true,
5182 &derived->declared_at);
5183 else
5184 tb_io_st = gfc_find_typebound_proc (derived, &t,
5185 gfc_code2string (dtio_procs,
5186 DTIO_RUF),
5187 true,
5188 &derived->declared_at);
5189 }
5190 return tb_io_st;
5191 }
5192
5193
5194 gfc_symbol *
gfc_find_specific_dtio_proc(gfc_symbol * derived,bool write,bool formatted)5195 gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
5196 {
5197 gfc_symtree *tb_io_st = NULL;
5198 gfc_symbol *dtio_sub = NULL;
5199 gfc_symbol *extended;
5200 gfc_typebound_proc *tb_io_proc, *specific_proc;
5201
5202 tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted);
5203
5204 if (tb_io_st != NULL)
5205 {
5206 const char *genname;
5207 gfc_symtree *st;
5208
5209 tb_io_proc = tb_io_st->n.tb;
5210 gcc_assert (tb_io_proc != NULL);
5211 gcc_assert (tb_io_proc->is_generic);
5212 gcc_assert (tb_io_proc->u.generic->next == NULL);
5213
5214 specific_proc = tb_io_proc->u.generic->specific;
5215 gcc_assert (!specific_proc->is_generic);
5216
5217 /* Go back and make sure that we have the right specific procedure.
5218 Here we most likely have a procedure from the parent type, which
5219 can be overridden in extensions. */
5220 genname = tb_io_proc->u.generic->specific_st->name;
5221 st = gfc_find_typebound_proc (derived, NULL, genname,
5222 true, &tb_io_proc->where);
5223 if (st)
5224 dtio_sub = st->n.tb->u.specific->n.sym;
5225 else
5226 dtio_sub = specific_proc->u.specific->n.sym;
5227
5228 goto finish;
5229 }
5230
5231 /* If there is not a typebound binding, look for a generic
5232 DTIO interface. */
5233 for (extended = derived; extended;
5234 extended = gfc_get_derived_super_type (extended))
5235 {
5236 if (extended == NULL || extended->ns == NULL
5237 || extended->attr.flavor == FL_UNKNOWN)
5238 return NULL;
5239
5240 if (formatted == true)
5241 {
5242 if (write == true)
5243 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5244 gfc_code2string (dtio_procs,
5245 DTIO_WF));
5246 else
5247 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5248 gfc_code2string (dtio_procs,
5249 DTIO_RF));
5250 }
5251 else
5252 {
5253 if (write == true)
5254 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5255 gfc_code2string (dtio_procs,
5256 DTIO_WUF));
5257 else
5258 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
5259 gfc_code2string (dtio_procs,
5260 DTIO_RUF));
5261 }
5262
5263 if (tb_io_st != NULL
5264 && tb_io_st->n.sym
5265 && tb_io_st->n.sym->generic)
5266 {
5267 for (gfc_interface *intr = tb_io_st->n.sym->generic;
5268 intr && intr->sym; intr = intr->next)
5269 {
5270 if (intr->sym->formal)
5271 {
5272 gfc_symbol *fsym = intr->sym->formal->sym;
5273 if ((fsym->ts.type == BT_CLASS
5274 && CLASS_DATA (fsym)->ts.u.derived == extended)
5275 || (fsym->ts.type == BT_DERIVED
5276 && fsym->ts.u.derived == extended))
5277 {
5278 dtio_sub = intr->sym;
5279 break;
5280 }
5281 }
5282 }
5283 }
5284 }
5285
5286 finish:
5287 if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
5288 gfc_find_derived_vtab (derived);
5289
5290 return dtio_sub;
5291 }
5292
5293 /* Helper function - if we do not find an interface for a procedure,
5294 construct it from the actual arglist. Luckily, this can only
5295 happen for call by reference, so the information we actually need
5296 to provide (and which would be impossible to guess from the call
5297 itself) is not actually needed. */
5298
5299 void
gfc_get_formal_from_actual_arglist(gfc_symbol * sym,gfc_actual_arglist * actual_args)5300 gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
5301 gfc_actual_arglist *actual_args)
5302 {
5303 gfc_actual_arglist *a;
5304 gfc_formal_arglist **f;
5305 gfc_symbol *s;
5306 char name[GFC_MAX_SYMBOL_LEN + 1];
5307 static int var_num;
5308
5309 f = &sym->formal;
5310 for (a = actual_args; a != NULL; a = a->next)
5311 {
5312 (*f) = gfc_get_formal_arglist ();
5313 if (a->expr)
5314 {
5315 snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
5316 gfc_get_symbol (name, gfc_current_ns, &s);
5317 if (a->expr->ts.type == BT_PROCEDURE)
5318 {
5319 s->attr.flavor = FL_PROCEDURE;
5320 }
5321 else
5322 {
5323 s->ts = a->expr->ts;
5324
5325 if (s->ts.type == BT_CHARACTER)
5326 s->ts.u.cl = gfc_get_charlen ();
5327
5328 s->ts.deferred = 0;
5329 s->ts.is_iso_c = 0;
5330 s->ts.is_c_interop = 0;
5331 s->attr.flavor = FL_VARIABLE;
5332 if (a->expr->rank > 0)
5333 {
5334 s->attr.dimension = 1;
5335 s->as = gfc_get_array_spec ();
5336 s->as->rank = 1;
5337 s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5338 &a->expr->where, 1);
5339 s->as->upper[0] = NULL;
5340 s->as->type = AS_ASSUMED_SIZE;
5341 }
5342 else
5343 s->maybe_array = maybe_dummy_array_arg (a->expr);
5344 }
5345 s->attr.dummy = 1;
5346 s->attr.artificial = 1;
5347 s->declared_at = a->expr->where;
5348 s->attr.intent = INTENT_UNKNOWN;
5349 (*f)->sym = s;
5350 }
5351 else /* If a->expr is NULL, this is an alternate rerturn. */
5352 (*f)->sym = NULL;
5353
5354 f = &((*f)->next);
5355 }
5356 }
5357