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