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