1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Deal with interfaces. An explicit interface is represented as a
25 singly linked list of formal argument structures attached to the
26 relevant symbols. For an implicit interface, the arguments don't
27 point to symbols. Explicit interfaces point to namespaces that
28 contain the symbols within that interface.
30 Implicit interfaces are linked together in a singly linked list
31 along the next_if member of symbol nodes. Since a particular
32 symbol can only have a single explicit interface, the symbol cannot
33 be part of multiple lists and a single next-member suffices.
35 This is not the case for general classes, though. An operator
36 definition is independent of just about all other uses and has it's
40 Nameless interfaces create symbols with explicit interfaces within
41 the current namespace. They are otherwise unlinked.
44 The generic name points to a linked list of symbols. Each symbol
45 has an explicit interface. Each explicit interface has its own
46 namespace containing the arguments. Module procedures are symbols in
47 which the interface is added later when the module procedure is parsed.
50 User-defined operators are stored in a their own set of symtrees
51 separate from regular symbols. The symtrees point to gfc_user_op
52 structures which in turn head up a list of relevant interfaces.
54 Extended intrinsics and assignment:
55 The head of these interface lists are stored in the containing namespace.
58 An implicit interface is represented as a singly linked list of
59 formal argument list structures that don't point to any symbol
60 nodes -- they just contain types.
63 When a subprogram is defined, the program unit's name points to an
64 interface as usual, but the link to the namespace is NULL and the
65 formal argument list points to symbols within the same namespace as
66 the program unit name. */
70 #include "coretypes.h"
75 /* The current_interface structure holds information about the
76 interface currently being parsed. This structure is saved and
77 restored during recursive interfaces. */
79 gfc_interface_info current_interface
;
82 /* Free a singly linked list of gfc_interface structures. */
85 gfc_free_interface (gfc_interface
*intr
)
89 for (; intr
; intr
= next
)
97 /* Change the operators unary plus and minus into binary plus and
98 minus respectively, leaving the rest unchanged. */
100 static gfc_intrinsic_op
101 fold_unary_intrinsic (gfc_intrinsic_op op
)
105 case INTRINSIC_UPLUS
:
108 case INTRINSIC_UMINUS
:
109 op
= INTRINSIC_MINUS
;
119 /* Match a generic specification. Depending on which type of
120 interface is found, the 'name' or 'op' pointers may be set.
121 This subroutine doesn't return MATCH_NO. */
124 gfc_match_generic_spec (interface_type
*type
,
126 gfc_intrinsic_op
*op
)
128 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
132 if (gfc_match (" assignment ( = )") == MATCH_YES
)
134 *type
= INTERFACE_INTRINSIC_OP
;
135 *op
= INTRINSIC_ASSIGN
;
139 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
141 *type
= INTERFACE_INTRINSIC_OP
;
142 *op
= fold_unary_intrinsic (i
);
146 *op
= INTRINSIC_NONE
;
147 if (gfc_match (" operator ( ") == MATCH_YES
)
149 m
= gfc_match_defined_op_name (buffer
, 1);
155 m
= gfc_match_char (')');
161 strcpy (name
, buffer
);
162 *type
= INTERFACE_USER_OP
;
166 if (gfc_match_name (buffer
) == MATCH_YES
)
168 strcpy (name
, buffer
);
169 *type
= INTERFACE_GENERIC
;
173 *type
= INTERFACE_NAMELESS
;
177 gfc_error ("Syntax error in generic specification at %C");
182 /* Match one of the five F95 forms of an interface statement. The
183 matcher for the abstract interface follows. */
186 gfc_match_interface (void)
188 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
194 m
= gfc_match_space ();
196 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
199 /* If we're not looking at the end of the statement now, or if this
200 is not a nameless interface but we did not see a space, punt. */
201 if (gfc_match_eos () != MATCH_YES
202 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
204 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
209 current_interface
.type
= type
;
213 case INTERFACE_GENERIC
:
214 if (gfc_get_symbol (name
, NULL
, &sym
))
217 if (!sym
->attr
.generic
218 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
223 gfc_error ("Dummy procedure '%s' at %C cannot have a "
224 "generic interface", sym
->name
);
228 current_interface
.sym
= gfc_new_block
= sym
;
231 case INTERFACE_USER_OP
:
232 current_interface
.uop
= gfc_get_uop (name
);
235 case INTERFACE_INTRINSIC_OP
:
236 current_interface
.op
= op
;
239 case INTERFACE_NAMELESS
:
240 case INTERFACE_ABSTRACT
:
249 /* Match a F2003 abstract interface. */
252 gfc_match_abstract_interface (void)
256 if (gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C")
260 m
= gfc_match_eos ();
264 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
268 current_interface
.type
= INTERFACE_ABSTRACT
;
274 /* Match the different sort of generic-specs that can be present after
275 the END INTERFACE itself. */
278 gfc_match_end_interface (void)
280 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
285 m
= gfc_match_space ();
287 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
290 /* If we're not looking at the end of the statement now, or if this
291 is not a nameless interface but we did not see a space, punt. */
292 if (gfc_match_eos () != MATCH_YES
293 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
295 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
302 switch (current_interface
.type
)
304 case INTERFACE_NAMELESS
:
305 case INTERFACE_ABSTRACT
:
306 if (type
!= INTERFACE_NAMELESS
)
308 gfc_error ("Expected a nameless interface at %C");
314 case INTERFACE_INTRINSIC_OP
:
315 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
318 if (current_interface
.op
== INTRINSIC_ASSIGN
)
321 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
326 s1
= gfc_op2string (current_interface
.op
);
327 s2
= gfc_op2string (op
);
329 /* The following if-statements are used to enforce C1202
331 if ((strcmp(s1
, "==") == 0 && strcmp(s2
, ".eq.") == 0)
332 || (strcmp(s1
, ".eq.") == 0 && strcmp(s2
, "==") == 0))
334 if ((strcmp(s1
, "/=") == 0 && strcmp(s2
, ".ne.") == 0)
335 || (strcmp(s1
, ".ne.") == 0 && strcmp(s2
, "/=") == 0))
337 if ((strcmp(s1
, "<=") == 0 && strcmp(s2
, ".le.") == 0)
338 || (strcmp(s1
, ".le.") == 0 && strcmp(s2
, "<=") == 0))
340 if ((strcmp(s1
, "<") == 0 && strcmp(s2
, ".lt.") == 0)
341 || (strcmp(s1
, ".lt.") == 0 && strcmp(s2
, "<") == 0))
343 if ((strcmp(s1
, ">=") == 0 && strcmp(s2
, ".ge.") == 0)
344 || (strcmp(s1
, ".ge.") == 0 && strcmp(s2
, ">=") == 0))
346 if ((strcmp(s1
, ">") == 0 && strcmp(s2
, ".gt.") == 0)
347 || (strcmp(s1
, ".gt.") == 0 && strcmp(s2
, ">") == 0))
351 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
352 "but got %s", s1
, s2
);
359 case INTERFACE_USER_OP
:
360 /* Comparing the symbol node names is OK because only use-associated
361 symbols can be renamed. */
362 if (type
!= current_interface
.type
363 || strcmp (current_interface
.uop
->name
, name
) != 0)
365 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
366 current_interface
.uop
->name
);
372 case INTERFACE_GENERIC
:
373 if (type
!= current_interface
.type
374 || strcmp (current_interface
.sym
->name
, name
) != 0)
376 gfc_error ("Expecting 'END INTERFACE %s' at %C",
377 current_interface
.sym
->name
);
388 /* Compare two derived types using the criteria in 4.4.2 of the standard,
389 recursing through gfc_compare_types for the components. */
392 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
394 gfc_component
*dt1
, *dt2
;
396 if (derived1
== derived2
)
399 /* Special case for comparing derived types across namespaces. If the
400 true names and module names are the same and the module name is
401 nonnull, then they are equal. */
402 if (derived1
!= NULL
&& derived2
!= NULL
403 && strcmp (derived1
->name
, derived2
->name
) == 0
404 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
405 && strcmp (derived1
->module
, derived2
->module
) == 0)
408 /* Compare type via the rules of the standard. Both types must have
409 the SEQUENCE or BIND(C) attribute to be equal. */
411 if (strcmp (derived1
->name
, derived2
->name
))
414 if (derived1
->component_access
== ACCESS_PRIVATE
415 || derived2
->component_access
== ACCESS_PRIVATE
)
418 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
419 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
422 dt1
= derived1
->components
;
423 dt2
= derived2
->components
;
425 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
426 simple test can speed things up. Otherwise, lots of things have to
430 if (strcmp (dt1
->name
, dt2
->name
) != 0)
433 if (dt1
->attr
.access
!= dt2
->attr
.access
)
436 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
439 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
442 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
445 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
448 /* Make sure that link lists do not put this function into an
449 endless recursive loop! */
450 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
451 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
452 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
455 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
456 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
459 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
460 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
466 if (dt1
== NULL
&& dt2
== NULL
)
468 if (dt1
== NULL
|| dt2
== NULL
)
476 /* Compare two typespecs, recursively if necessary. */
479 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
481 /* See if one of the typespecs is a BT_VOID, which is what is being used
482 to allow the funcs like c_f_pointer to accept any pointer type.
483 TODO: Possibly should narrow this to just the one typespec coming in
484 that is for the formal arg, but oh well. */
485 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
488 if (ts1
->type
!= ts2
->type
489 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
490 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
492 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
493 return (ts1
->kind
== ts2
->kind
);
495 /* Compare derived types. */
496 if (gfc_type_compatible (ts1
, ts2
))
499 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
503 /* Given two symbols that are formal arguments, compare their ranks
504 and types. Returns nonzero if they have the same rank and type,
508 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
512 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
513 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
516 && (!s1
->as
|| s1
->as
->type
!= AS_ASSUMED_RANK
)
517 && (!s2
->as
|| s2
->as
->type
!= AS_ASSUMED_RANK
))
518 return 0; /* Ranks differ. */
520 return gfc_compare_types (&s1
->ts
, &s2
->ts
)
521 || s1
->ts
.type
== BT_ASSUMED
|| s2
->ts
.type
== BT_ASSUMED
;
525 /* Given two symbols that are formal arguments, compare their types
526 and rank and their formal interfaces if they are both dummy
527 procedures. Returns nonzero if the same, zero if different. */
530 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
532 if (s1
== NULL
|| s2
== NULL
)
533 return s1
== s2
? 1 : 0;
538 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
539 return compare_type_rank (s1
, s2
);
541 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
544 /* At this point, both symbols are procedures. It can happen that
545 external procedures are compared, where one is identified by usage
546 to be a function or subroutine but the other is not. Check TKR
547 nonetheless for these cases. */
548 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
549 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
551 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
552 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
554 /* Now the type of procedure has been identified. */
555 if (s1
->attr
.function
!= s2
->attr
.function
556 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
559 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
562 /* Originally, gfortran recursed here to check the interfaces of passed
563 procedures. This is explicitly not required by the standard. */
568 /* Given a formal argument list and a keyword name, search the list
569 for that keyword. Returns the correct symbol node if found, NULL
573 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
575 for (; f
; f
= f
->next
)
576 if (strcmp (f
->sym
->name
, name
) == 0)
583 /******** Interface checking subroutines **********/
586 /* Given an operator interface and the operator, make sure that all
587 interfaces for that operator are legal. */
590 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
593 gfc_formal_arglist
*formal
;
596 int args
, r1
, r2
, k1
, k2
;
601 t1
= t2
= BT_UNKNOWN
;
602 i1
= i2
= INTENT_UNKNOWN
;
606 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
608 gfc_symbol
*fsym
= formal
->sym
;
611 gfc_error ("Alternate return cannot appear in operator "
612 "interface at %L", &sym
->declared_at
);
618 i1
= fsym
->attr
.intent
;
619 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
625 i2
= fsym
->attr
.intent
;
626 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
632 /* Only +, - and .not. can be unary operators.
633 .not. cannot be a binary operator. */
634 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
635 && op
!= INTRINSIC_MINUS
636 && op
!= INTRINSIC_NOT
)
637 || (args
== 2 && op
== INTRINSIC_NOT
))
639 gfc_error ("Operator interface at %L has the wrong number of arguments",
644 /* Check that intrinsics are mapped to functions, except
645 INTRINSIC_ASSIGN which should map to a subroutine. */
646 if (op
== INTRINSIC_ASSIGN
)
648 if (!sym
->attr
.subroutine
)
650 gfc_error ("Assignment operator interface at %L must be "
651 "a SUBROUTINE", &sym
->declared_at
);
656 gfc_error ("Assignment operator interface at %L must have "
657 "two arguments", &sym
->declared_at
);
661 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
662 - First argument an array with different rank than second,
663 - First argument is a scalar and second an array,
664 - Types and kinds do not conform, or
665 - First argument is of derived type. */
666 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
667 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
668 && (r2
== 0 || r1
== r2
)
669 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
670 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
671 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
673 gfc_error ("Assignment operator interface at %L must not redefine "
674 "an INTRINSIC type assignment", &sym
->declared_at
);
680 if (!sym
->attr
.function
)
682 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
688 /* Check intents on operator interfaces. */
689 if (op
== INTRINSIC_ASSIGN
)
691 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
693 gfc_error ("First argument of defined assignment at %L must be "
694 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
700 gfc_error ("Second argument of defined assignment at %L must be "
701 "INTENT(IN)", &sym
->declared_at
);
709 gfc_error ("First argument of operator interface at %L must be "
710 "INTENT(IN)", &sym
->declared_at
);
714 if (args
== 2 && i2
!= INTENT_IN
)
716 gfc_error ("Second argument of operator interface at %L must be "
717 "INTENT(IN)", &sym
->declared_at
);
722 /* From now on, all we have to do is check that the operator definition
723 doesn't conflict with an intrinsic operator. The rules for this
724 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
725 as well as 12.3.2.1.1 of Fortran 2003:
727 "If the operator is an intrinsic-operator (R310), the number of
728 function arguments shall be consistent with the intrinsic uses of
729 that operator, and the types, kind type parameters, or ranks of the
730 dummy arguments shall differ from those required for the intrinsic
731 operation (7.1.2)." */
733 #define IS_NUMERIC_TYPE(t) \
734 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
736 /* Unary ops are easy, do them first. */
737 if (op
== INTRINSIC_NOT
)
739 if (t1
== BT_LOGICAL
)
745 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
747 if (IS_NUMERIC_TYPE (t1
))
753 /* Character intrinsic operators have same character kind, thus
754 operator definitions with operands of different character kinds
756 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
759 /* Intrinsic operators always perform on arguments of same rank,
760 so different ranks is also always safe. (rank == 0) is an exception
761 to that, because all intrinsic operators are elemental. */
762 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
768 case INTRINSIC_EQ_OS
:
770 case INTRINSIC_NE_OS
:
771 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
776 case INTRINSIC_MINUS
:
777 case INTRINSIC_TIMES
:
778 case INTRINSIC_DIVIDE
:
779 case INTRINSIC_POWER
:
780 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
785 case INTRINSIC_GT_OS
:
787 case INTRINSIC_GE_OS
:
789 case INTRINSIC_LT_OS
:
791 case INTRINSIC_LE_OS
:
792 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
794 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
795 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
799 case INTRINSIC_CONCAT
:
800 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
808 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
818 #undef IS_NUMERIC_TYPE
821 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
827 /* Given a pair of formal argument lists, we see if the two lists can
828 be distinguished by counting the number of nonoptional arguments of
829 a given type/rank in f1 and seeing if there are less then that
830 number of those arguments in f2 (including optional arguments).
831 Since this test is asymmetric, it has to be called twice to make it
832 symmetric. Returns nonzero if the argument lists are incompatible
833 by this test. This subroutine implements rule 1 of section F03:16.2.3.
834 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
837 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
838 const char *p1
, const char *p2
)
840 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
841 gfc_formal_arglist
*f
;
854 for (f
= f1
; f
; f
= f
->next
)
857 /* Build an array of integers that gives the same integer to
858 arguments of the same type/rank. */
859 arg
= XCNEWVEC (arginfo
, n1
);
862 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
870 for (i
= 0; i
< n1
; i
++)
872 if (arg
[i
].flag
!= -1)
875 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
876 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
877 continue; /* Skip OPTIONAL and PASS arguments. */
881 /* Find other non-optional, non-pass arguments of the same type/rank. */
882 for (j
= i
+ 1; j
< n1
; j
++)
883 if ((arg
[j
].sym
== NULL
884 || !(arg
[j
].sym
->attr
.optional
885 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
886 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
887 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
893 /* Now loop over each distinct type found in f1. */
897 for (i
= 0; i
< n1
; i
++)
899 if (arg
[i
].flag
!= k
)
903 for (j
= i
+ 1; j
< n1
; j
++)
904 if (arg
[j
].flag
== k
)
907 /* Count the number of non-pass arguments in f2 with that type,
908 including those that are optional. */
911 for (f
= f2
; f
; f
= f
->next
)
912 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
913 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
914 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
932 /* Perform the correspondence test in rule 3 of section F03:16.2.3.
933 Returns zero if no argument is found that satisfies rule 3, nonzero
934 otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
937 This test is also not symmetric in f1 and f2 and must be called
938 twice. This test finds problems caused by sorting the actual
939 argument list with keywords. For example:
943 INTEGER :: A ; REAL :: B
947 INTEGER :: A ; REAL :: B
951 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
954 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
955 const char *p1
, const char *p2
)
957 gfc_formal_arglist
*f2_save
, *g
;
964 if (f1
->sym
->attr
.optional
)
967 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
969 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
972 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
973 || compare_type_rank (f2
->sym
, f1
->sym
)))
976 /* Now search for a disambiguating keyword argument starting at
977 the current non-match. */
978 for (g
= f1
; g
; g
= g
->next
)
980 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
983 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
984 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
999 /* Check if the characteristics of two dummy arguments match,
1003 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1004 bool type_must_agree
, char *errmsg
, int err_len
)
1006 /* Check type and rank. */
1007 if (type_must_agree
&& !compare_type_rank (s2
, s1
))
1010 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1016 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1018 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1023 /* Check OPTIONAL attribute. */
1024 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1026 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1031 /* Check ALLOCATABLE attribute. */
1032 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1034 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1039 /* Check POINTER attribute. */
1040 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1042 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1047 /* Check TARGET attribute. */
1048 if (s1
->attr
.target
!= s2
->attr
.target
)
1050 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1055 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1056 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1058 /* Check string length. */
1059 if (s1
->ts
.type
== BT_CHARACTER
1060 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1061 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1063 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1064 s2
->ts
.u
.cl
->length
);
1070 snprintf (errmsg
, err_len
, "Character length mismatch "
1071 "in argument '%s'", s1
->name
);
1075 /* FIXME: Implement a warning for this case.
1076 gfc_warning ("Possible character length mismatch in argument '%s'",
1084 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1085 "%i of gfc_dep_compare_expr", compval
);
1090 /* Check array shape. */
1091 if (s1
->as
&& s2
->as
)
1094 gfc_expr
*shape1
, *shape2
;
1096 if (s1
->as
->type
!= s2
->as
->type
)
1098 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1103 if (s1
->as
->type
== AS_EXPLICIT
)
1104 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1106 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1107 gfc_copy_expr (s1
->as
->lower
[i
]));
1108 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1109 gfc_copy_expr (s2
->as
->lower
[i
]));
1110 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1111 gfc_free_expr (shape1
);
1112 gfc_free_expr (shape2
);
1118 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1119 "argument '%s'", i
+ 1, s1
->name
);
1123 /* FIXME: Implement a warning for this case.
1124 gfc_warning ("Possible shape mismatch in argument '%s'",
1132 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1133 "result %i of gfc_dep_compare_expr",
1144 /* 'Compare' two formal interfaces associated with a pair of symbols.
1145 We return nonzero if there exists an actual argument list that
1146 would be ambiguous between the two interfaces, zero otherwise.
1147 'strict_flag' specifies whether all the characteristics are
1148 required to match, which is not the case for ambiguity checks.
1149 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1152 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1153 int generic_flag
, int strict_flag
,
1154 char *errmsg
, int err_len
,
1155 const char *p1
, const char *p2
)
1157 gfc_formal_arglist
*f1
, *f2
;
1159 gcc_assert (name2
!= NULL
);
1161 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1162 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1163 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1166 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1170 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1173 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1177 /* Do strict checks on all characteristics
1178 (for dummy procedures and procedure pointer assignments). */
1179 if (!generic_flag
&& strict_flag
)
1181 if (s1
->attr
.function
&& s2
->attr
.function
)
1183 /* If both are functions, check result type. */
1184 if (s1
->ts
.type
== BT_UNKNOWN
)
1186 if (!compare_type_rank (s1
,s2
))
1189 snprintf (errmsg
, err_len
, "Type/rank mismatch in return value "
1194 /* FIXME: Check array bounds and string length of result. */
1197 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1199 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1202 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1204 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1209 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1210 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1216 if (f1
== NULL
&& f2
== NULL
)
1217 return 1; /* Special case: No arguments. */
1221 if (count_types_test (f1
, f2
, p1
, p2
)
1222 || count_types_test (f2
, f1
, p2
, p1
))
1224 if (generic_correspondence (f1
, f2
, p1
, p2
)
1225 || generic_correspondence (f2
, f1
, p2
, p1
))
1229 /* Perform the abbreviated correspondence test for operators (the
1230 arguments cannot be optional and are always ordered correctly).
1231 This is also done when comparing interfaces for dummy procedures and in
1232 procedure pointer assignments. */
1236 /* Check existence. */
1237 if (f1
== NULL
&& f2
== NULL
)
1239 if (f1
== NULL
|| f2
== NULL
)
1242 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1243 "arguments", name2
);
1249 /* Check all characteristics. */
1250 if (check_dummy_characteristics (f1
->sym
, f2
->sym
,
1251 true, errmsg
, err_len
) == FAILURE
)
1254 else if (!compare_type_rank (f2
->sym
, f1
->sym
))
1256 /* Only check type and rank. */
1258 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1271 /* Given a pointer to an interface pointer, remove duplicate
1272 interfaces and make sure that all symbols are either functions
1273 or subroutines, and all of the same kind. Returns nonzero if
1274 something goes wrong. */
1277 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1279 gfc_interface
*psave
, *q
, *qlast
;
1282 for (; p
; p
= p
->next
)
1284 /* Make sure all symbols in the interface have been defined as
1285 functions or subroutines. */
1286 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1287 || !p
->sym
->attr
.if_source
)
1288 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1290 if (p
->sym
->attr
.external
)
1291 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1292 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1294 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1295 "subroutine", p
->sym
->name
, interface_name
,
1296 &p
->sym
->declared_at
);
1300 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1301 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1302 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1303 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1305 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1306 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1307 " or all FUNCTIONs", interface_name
,
1308 &p
->sym
->declared_at
);
1310 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1311 "generic name is also the name of a derived type",
1312 interface_name
, &p
->sym
->declared_at
);
1316 /* F2003, C1207. F2008, C1207. */
1317 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1318 && gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1319 "'%s' in %s at %L", p
->sym
->name
, interface_name
,
1320 &p
->sym
->declared_at
) == FAILURE
)
1325 /* Remove duplicate interfaces in this interface list. */
1326 for (; p
; p
= p
->next
)
1330 for (q
= p
->next
; q
;)
1332 if (p
->sym
!= q
->sym
)
1339 /* Duplicate interface. */
1340 qlast
->next
= q
->next
;
1351 /* Check lists of interfaces to make sure that no two interfaces are
1352 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1355 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1356 int generic_flag
, const char *interface_name
,
1360 for (; p
; p
= p
->next
)
1361 for (q
= q0
; q
; q
= q
->next
)
1363 if (p
->sym
== q
->sym
)
1364 continue; /* Duplicates OK here. */
1366 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1369 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1370 && q
->sym
->attr
.flavor
!= FL_DERIVED
1371 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1372 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1375 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1376 p
->sym
->name
, q
->sym
->name
, interface_name
,
1378 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1379 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1380 p
->sym
->name
, q
->sym
->name
, interface_name
,
1383 gfc_warning ("Although not referenced, '%s' has ambiguous "
1384 "interfaces at %L", interface_name
, &p
->where
);
1392 /* Check the generic and operator interfaces of symbols to make sure
1393 that none of the interfaces conflict. The check has to be done
1394 after all of the symbols are actually loaded. */
1397 check_sym_interfaces (gfc_symbol
*sym
)
1399 char interface_name
[100];
1402 if (sym
->ns
!= gfc_current_ns
)
1405 if (sym
->generic
!= NULL
)
1407 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1408 if (check_interface0 (sym
->generic
, interface_name
))
1411 for (p
= sym
->generic
; p
; p
= p
->next
)
1413 if (sym
->attr
.access
!= ACCESS_PRIVATE
)
1414 p
->sym
->attr
.public_used
= 1;
1416 if (p
->sym
->attr
.mod_proc
1417 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1418 || p
->sym
->attr
.procedure
))
1420 gfc_error ("'%s' at %L is not a module procedure",
1421 p
->sym
->name
, &p
->where
);
1426 /* Originally, this test was applied to host interfaces too;
1427 this is incorrect since host associated symbols, from any
1428 source, cannot be ambiguous with local symbols. */
1429 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1430 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1436 check_uop_interfaces (gfc_user_op
*uop
)
1438 char interface_name
[100];
1443 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1444 if (check_interface0 (uop
->op
, interface_name
))
1447 if (uop
->access
!= ACCESS_PRIVATE
)
1448 for (p
= uop
->op
; p
; p
= p
->next
)
1449 p
->sym
->attr
.public_used
= 1;
1451 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1453 uop2
= gfc_find_uop (uop
->name
, ns
);
1457 check_interface1 (uop
->op
, uop2
->op
, 0,
1458 interface_name
, true);
1462 /* Given an intrinsic op, return an equivalent op if one exists,
1463 or INTRINSIC_NONE otherwise. */
1466 gfc_equivalent_op (gfc_intrinsic_op op
)
1471 return INTRINSIC_EQ_OS
;
1473 case INTRINSIC_EQ_OS
:
1474 return INTRINSIC_EQ
;
1477 return INTRINSIC_NE_OS
;
1479 case INTRINSIC_NE_OS
:
1480 return INTRINSIC_NE
;
1483 return INTRINSIC_GT_OS
;
1485 case INTRINSIC_GT_OS
:
1486 return INTRINSIC_GT
;
1489 return INTRINSIC_GE_OS
;
1491 case INTRINSIC_GE_OS
:
1492 return INTRINSIC_GE
;
1495 return INTRINSIC_LT_OS
;
1497 case INTRINSIC_LT_OS
:
1498 return INTRINSIC_LT
;
1501 return INTRINSIC_LE_OS
;
1503 case INTRINSIC_LE_OS
:
1504 return INTRINSIC_LE
;
1507 return INTRINSIC_NONE
;
1511 /* For the namespace, check generic, user operator and intrinsic
1512 operator interfaces for consistency and to remove duplicate
1513 interfaces. We traverse the whole namespace, counting on the fact
1514 that most symbols will not have generic or operator interfaces. */
1517 gfc_check_interfaces (gfc_namespace
*ns
)
1519 gfc_namespace
*old_ns
, *ns2
;
1521 char interface_name
[100];
1524 old_ns
= gfc_current_ns
;
1525 gfc_current_ns
= ns
;
1527 gfc_traverse_ns (ns
, check_sym_interfaces
);
1529 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1531 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1533 if (i
== INTRINSIC_USER
)
1536 if (i
== INTRINSIC_ASSIGN
)
1537 strcpy (interface_name
, "intrinsic assignment operator");
1539 sprintf (interface_name
, "intrinsic '%s' operator",
1540 gfc_op2string ((gfc_intrinsic_op
) i
));
1542 if (check_interface0 (ns
->op
[i
], interface_name
))
1545 for (p
= ns
->op
[i
]; p
; p
= p
->next
)
1546 p
->sym
->attr
.public_used
= 1;
1550 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1553 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1555 gfc_intrinsic_op other_op
;
1557 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1558 interface_name
, true))
1561 /* i should be gfc_intrinsic_op, but has to be int with this cast
1562 here for stupid C++ compatibility rules. */
1563 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1564 if (other_op
!= INTRINSIC_NONE
1565 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1566 0, interface_name
, true))
1572 gfc_current_ns
= old_ns
;
1577 symbol_rank (gfc_symbol
*sym
)
1579 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
1580 return CLASS_DATA (sym
)->as
->rank
;
1582 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1586 /* Given a symbol of a formal argument list and an expression, if the
1587 formal argument is allocatable, check that the actual argument is
1588 allocatable. Returns nonzero if compatible, zero if not compatible. */
1591 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1593 symbol_attribute attr
;
1595 if (formal
->attr
.allocatable
1596 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1598 attr
= gfc_expr_attr (actual
);
1599 if (!attr
.allocatable
)
1607 /* Given a symbol of a formal argument list and an expression, if the
1608 formal argument is a pointer, see if the actual argument is a
1609 pointer. Returns nonzero if compatible, zero if not compatible. */
1612 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1614 symbol_attribute attr
;
1616 if (formal
->attr
.pointer
1617 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1618 && CLASS_DATA (formal
)->attr
.class_pointer
))
1620 attr
= gfc_expr_attr (actual
);
1622 /* Fortran 2008 allows non-pointer actual arguments. */
1623 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1634 /* Emit clear error messages for rank mismatch. */
1637 argument_rank_mismatch (const char *name
, locus
*where
,
1638 int rank1
, int rank2
)
1641 /* TS 29113, C407b. */
1644 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1645 " '%s' has assumed-rank", where
, name
);
1647 else if (rank1
== 0)
1649 gfc_error ("Rank mismatch in argument '%s' at %L "
1650 "(scalar and rank-%d)", name
, where
, rank2
);
1652 else if (rank2
== 0)
1654 gfc_error ("Rank mismatch in argument '%s' at %L "
1655 "(rank-%d and scalar)", name
, where
, rank1
);
1659 gfc_error ("Rank mismatch in argument '%s' at %L "
1660 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1665 /* Given a symbol of a formal argument list and an expression, see if
1666 the two are compatible as arguments. Returns nonzero if
1667 compatible, zero if not compatible. */
1670 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1671 int ranks_must_agree
, int is_elemental
, locus
*where
)
1674 bool rank_check
, is_pointer
;
1676 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1677 procs c_f_pointer or c_f_procpointer, and we need to accept most
1678 pointers the user could give us. This should allow that. */
1679 if (formal
->ts
.type
== BT_VOID
)
1682 if (formal
->ts
.type
== BT_DERIVED
1683 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1684 && actual
->ts
.type
== BT_DERIVED
1685 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1688 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1689 /* Make sure the vtab symbol is present when
1690 the module variables are generated. */
1691 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1693 if (actual
->ts
.type
== BT_PROCEDURE
)
1696 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1698 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1701 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1705 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1706 sizeof(err
), NULL
, NULL
))
1709 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1710 formal
->name
, &actual
->where
, err
);
1714 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1716 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1717 &act_sym
->declared_at
);
1718 if (act_sym
->ts
.type
== BT_UNKNOWN
1719 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1722 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1723 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1724 &act_sym
->declared_at
);
1730 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1731 && !gfc_is_simply_contiguous (actual
, true))
1734 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1735 "must be simply contiguous", formal
->name
, &actual
->where
);
1739 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1740 && actual
->ts
.type
!= BT_HOLLERITH
1741 && formal
->ts
.type
!= BT_ASSUMED
1742 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
1743 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
1744 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
1745 CLASS_DATA (actual
)->ts
.u
.derived
)))
1748 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1749 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1750 gfc_typename (&formal
->ts
));
1754 /* F2008, 12.5.2.5; IR F08/0073. */
1755 if (formal
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
1756 && ((CLASS_DATA (formal
)->attr
.class_pointer
1757 && !formal
->attr
.intent
== INTENT_IN
)
1758 || CLASS_DATA (formal
)->attr
.allocatable
))
1760 if (actual
->ts
.type
!= BT_CLASS
)
1763 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1764 formal
->name
, &actual
->where
);
1767 if (!gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
1768 CLASS_DATA (formal
)->ts
.u
.derived
))
1771 gfc_error ("Actual argument to '%s' at %L must have the same "
1772 "declared type", formal
->name
, &actual
->where
);
1777 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
1780 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1781 formal
->name
, &actual
->where
);
1785 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
1787 gfc_ref
*last
= NULL
;
1789 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1790 if (ref
->type
== REF_COMPONENT
)
1793 /* F2008, 12.5.2.6. */
1794 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1796 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
1799 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1800 formal
->name
, &actual
->where
, formal
->as
->corank
,
1801 last
? last
->u
.c
.component
->as
->corank
1802 : actual
->symtree
->n
.sym
->as
->corank
);
1807 if (formal
->attr
.codimension
)
1809 /* F2008, 12.5.2.8. */
1810 if (formal
->attr
.dimension
1811 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1812 && gfc_expr_attr (actual
).dimension
1813 && !gfc_is_simply_contiguous (actual
, true))
1816 gfc_error ("Actual argument to '%s' at %L must be simply "
1817 "contiguous", formal
->name
, &actual
->where
);
1821 /* F2008, C1303 and C1304. */
1822 if (formal
->attr
.intent
!= INTENT_INOUT
1823 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
1824 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1825 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
1826 || formal
->attr
.lock_comp
))
1830 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1831 "which is LOCK_TYPE or has a LOCK_TYPE component",
1832 formal
->name
, &actual
->where
);
1837 /* F2008, C1239/C1240. */
1838 if (actual
->expr_type
== EXPR_VARIABLE
1839 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1840 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1841 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1842 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1843 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1844 || formal
->attr
.contiguous
))
1847 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1848 "array without CONTIGUOUS attribute - as actual argument at"
1849 " %L is not simply contiguous and both are ASYNCHRONOUS "
1850 "or VOLATILE", formal
->name
, &actual
->where
);
1854 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
1855 && gfc_expr_attr (actual
).codimension
)
1857 if (formal
->attr
.intent
== INTENT_OUT
)
1860 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
1861 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
1865 else if (gfc_option
.warn_surprising
&& where
1866 && formal
->attr
.intent
!= INTENT_IN
)
1867 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
1868 "argument '%s', which is invalid if the allocation status"
1869 " is modified", &actual
->where
, formal
->name
);
1872 /* If the rank is the same or the formal argument has assumed-rank. */
1873 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
1876 if (actual
->ts
.type
== BT_CLASS
&& CLASS_DATA (actual
)->as
1877 && CLASS_DATA (actual
)->as
->rank
== symbol_rank (formal
))
1880 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1881 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1882 || formal
->as
->type
== AS_DEFERRED
)
1883 && actual
->expr_type
!= EXPR_NULL
;
1885 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1886 if (rank_check
|| ranks_must_agree
1887 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
1888 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1889 || (actual
->rank
== 0
1890 && ((formal
->ts
.type
== BT_CLASS
1891 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
1892 || (formal
->ts
.type
!= BT_CLASS
1893 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
1894 && actual
->expr_type
!= EXPR_NULL
)
1895 || (actual
->rank
== 0 && formal
->attr
.dimension
1896 && gfc_is_coindexed (actual
)))
1899 argument_rank_mismatch (formal
->name
, &actual
->where
,
1900 symbol_rank (formal
), actual
->rank
);
1903 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1906 /* At this point, we are considering a scalar passed to an array. This
1907 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1908 - if the actual argument is (a substring of) an element of a
1909 non-assumed-shape/non-pointer/non-polymorphic array; or
1910 - (F2003) if the actual argument is of type character of default/c_char
1913 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
1914 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
1916 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1918 if (ref
->type
== REF_COMPONENT
)
1919 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
1920 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1921 && ref
->u
.ar
.dimen
> 0
1923 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
1927 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
1930 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1931 "at %L", formal
->name
, &actual
->where
);
1935 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
1936 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
1939 gfc_error ("Element of assumed-shaped or pointer "
1940 "array passed to array dummy argument '%s' at %L",
1941 formal
->name
, &actual
->where
);
1945 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
1946 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
1948 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
1951 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1952 "CHARACTER actual argument with array dummy argument "
1953 "'%s' at %L", formal
->name
, &actual
->where
);
1957 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1959 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1960 "array dummy argument '%s' at %L",
1961 formal
->name
, &actual
->where
);
1964 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1970 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
1973 argument_rank_mismatch (formal
->name
, &actual
->where
,
1974 symbol_rank (formal
), actual
->rank
);
1982 /* Returns the storage size of a symbol (formal argument) or
1983 zero if it cannot be determined. */
1985 static unsigned long
1986 get_sym_storage_size (gfc_symbol
*sym
)
1989 unsigned long strlen
, elements
;
1991 if (sym
->ts
.type
== BT_CHARACTER
)
1993 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1994 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1995 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2002 if (symbol_rank (sym
) == 0)
2006 if (sym
->as
->type
!= AS_EXPLICIT
)
2008 for (i
= 0; i
< sym
->as
->rank
; i
++)
2010 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2011 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2014 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2015 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2018 return strlen
*elements
;
2022 /* Returns the storage size of an expression (actual argument) or
2023 zero if it cannot be determined. For an array element, it returns
2024 the remaining size as the element sequence consists of all storage
2025 units of the actual argument up to the end of the array. */
2027 static unsigned long
2028 get_expr_storage_size (gfc_expr
*e
)
2031 long int strlen
, elements
;
2032 long int substrlen
= 0;
2033 bool is_str_storage
= false;
2039 if (e
->ts
.type
== BT_CHARACTER
)
2041 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2042 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2043 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2044 else if (e
->expr_type
== EXPR_CONSTANT
2045 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2046 strlen
= e
->value
.character
.length
;
2051 strlen
= 1; /* Length per element. */
2053 if (e
->rank
== 0 && !e
->ref
)
2061 for (i
= 0; i
< e
->rank
; i
++)
2062 elements
*= mpz_get_si (e
->shape
[i
]);
2063 return elements
*strlen
;
2066 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2068 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2069 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2073 /* The string length is the substring length.
2074 Set now to full string length. */
2075 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2076 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2079 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2081 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2085 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
2086 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
2087 && ref
->u
.ar
.as
->upper
)
2088 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2090 long int start
, end
, stride
;
2093 if (ref
->u
.ar
.stride
[i
])
2095 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2096 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2101 if (ref
->u
.ar
.start
[i
])
2103 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2104 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2108 else if (ref
->u
.ar
.as
->lower
[i
]
2109 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2110 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2114 if (ref
->u
.ar
.end
[i
])
2116 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2117 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2121 else if (ref
->u
.ar
.as
->upper
[i
]
2122 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2123 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2127 elements
*= (end
- start
)/stride
+ 1L;
2129 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
2130 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
2131 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2133 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2134 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2135 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2136 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2137 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2142 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2143 && e
->expr_type
== EXPR_VARIABLE
)
2145 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2146 || e
->symtree
->n
.sym
->attr
.pointer
)
2152 /* Determine the number of remaining elements in the element
2153 sequence for array element designators. */
2154 is_str_storage
= true;
2155 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2157 if (ref
->u
.ar
.start
[i
] == NULL
2158 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2159 || ref
->u
.ar
.as
->upper
[i
] == NULL
2160 || ref
->u
.ar
.as
->lower
[i
] == NULL
2161 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2162 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2167 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2168 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2170 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2171 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2177 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2180 return elements
*strlen
;
2184 /* Given an expression, check whether it is an array section
2185 which has a vector subscript. If it has, one is returned,
2189 gfc_has_vector_subscript (gfc_expr
*e
)
2194 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2197 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2198 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2199 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2200 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2207 /* Given formal and actual argument lists, see if they are compatible.
2208 If they are compatible, the actual argument list is sorted to
2209 correspond with the formal list, and elements for missing optional
2210 arguments are inserted. If WHERE pointer is nonnull, then we issue
2211 errors when things don't match instead of just returning the status
2215 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2216 int ranks_must_agree
, int is_elemental
, locus
*where
)
2218 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2219 gfc_formal_arglist
*f
;
2221 unsigned long actual_size
, formal_size
;
2222 bool full_array
= false;
2226 if (actual
== NULL
&& formal
== NULL
)
2230 for (f
= formal
; f
; f
= f
->next
)
2233 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2235 for (i
= 0; i
< n
; i
++)
2242 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2244 /* Look for keywords but ignore g77 extensions like %VAL. */
2245 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2248 for (f
= formal
; f
; f
= f
->next
, i
++)
2252 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2259 gfc_error ("Keyword argument '%s' at %L is not in "
2260 "the procedure", a
->name
, &a
->expr
->where
);
2264 if (new_arg
[i
] != NULL
)
2267 gfc_error ("Keyword argument '%s' at %L is already associated "
2268 "with another actual argument", a
->name
,
2277 gfc_error ("More actual than formal arguments in procedure "
2278 "call at %L", where
);
2283 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2289 gfc_error ("Missing alternate return spec in subroutine call "
2294 if (a
->expr
== NULL
)
2297 gfc_error ("Unexpected alternate return spec in subroutine "
2298 "call at %L", where
);
2302 if (a
->expr
->expr_type
== EXPR_NULL
2303 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2304 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2305 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2306 || (f
->sym
->ts
.type
== BT_CLASS
2307 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2308 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2309 || !f
->sym
->attr
.optional
2310 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2313 && (!f
->sym
->attr
.optional
2314 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2315 || (f
->sym
->ts
.type
== BT_CLASS
2316 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2317 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2318 where
, f
->sym
->name
);
2320 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2321 "dummy '%s'", where
, f
->sym
->name
);
2326 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2327 is_elemental
, where
))
2330 /* TS 29113, 6.3p2. */
2331 if (f
->sym
->ts
.type
== BT_ASSUMED
2332 && (a
->expr
->ts
.type
== BT_DERIVED
2333 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2335 gfc_namespace
*f2k_derived
;
2337 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2338 ? a
->expr
->ts
.u
.derived
->f2k_derived
2339 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2342 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2344 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2345 "derived type with type-bound or FINAL procedures",
2351 /* Special case for character arguments. For allocatable, pointer
2352 and assumed-shape dummies, the string length needs to match
2354 if (a
->expr
->ts
.type
== BT_CHARACTER
2355 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2356 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2357 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2358 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2359 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2360 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2361 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2362 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2364 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2365 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2366 "argument and pointer or allocatable dummy argument "
2368 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2369 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2370 f
->sym
->name
, &a
->expr
->where
);
2372 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2373 "argument and assumed-shape dummy argument '%s' "
2375 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2376 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2377 f
->sym
->name
, &a
->expr
->where
);
2381 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2382 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2383 && a
->expr
->ts
.type
== BT_CHARACTER
)
2386 gfc_error ("Actual argument at %L to allocatable or "
2387 "pointer dummy argument '%s' must have a deferred "
2388 "length type parameter if and only if the dummy has one",
2389 &a
->expr
->where
, f
->sym
->name
);
2393 if (f
->sym
->ts
.type
== BT_CLASS
)
2394 goto skip_size_check
;
2396 actual_size
= get_expr_storage_size (a
->expr
);
2397 formal_size
= get_sym_storage_size (f
->sym
);
2398 if (actual_size
!= 0 && actual_size
< formal_size
2399 && a
->expr
->ts
.type
!= BT_PROCEDURE
2400 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2402 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2403 gfc_warning ("Character length of actual argument shorter "
2404 "than of dummy argument '%s' (%lu/%lu) at %L",
2405 f
->sym
->name
, actual_size
, formal_size
,
2408 gfc_warning ("Actual argument contains too few "
2409 "elements for dummy argument '%s' (%lu/%lu) at %L",
2410 f
->sym
->name
, actual_size
, formal_size
,
2417 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2418 is provided for a procedure pointer formal argument. */
2419 if (f
->sym
->attr
.proc_pointer
2420 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2421 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2422 || (a
->expr
->expr_type
== EXPR_FUNCTION
2423 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2424 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
2427 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2428 f
->sym
->name
, &a
->expr
->where
);
2432 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2433 provided for a procedure formal argument. */
2434 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
2435 && a
->expr
->expr_type
== EXPR_VARIABLE
2436 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2439 gfc_error ("Expected a procedure for argument '%s' at %L",
2440 f
->sym
->name
, &a
->expr
->where
);
2444 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2445 && a
->expr
->expr_type
== EXPR_VARIABLE
2446 && a
->expr
->symtree
->n
.sym
->as
2447 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2448 && (a
->expr
->ref
== NULL
2449 || (a
->expr
->ref
->type
== REF_ARRAY
2450 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2453 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2454 " array at %L", f
->sym
->name
, where
);
2458 if (a
->expr
->expr_type
!= EXPR_NULL
2459 && compare_pointer (f
->sym
, a
->expr
) == 0)
2462 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2463 f
->sym
->name
, &a
->expr
->where
);
2467 if (a
->expr
->expr_type
!= EXPR_NULL
2468 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2469 && compare_pointer (f
->sym
, a
->expr
) == 2)
2472 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2473 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2478 /* Fortran 2008, C1242. */
2479 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2482 gfc_error ("Coindexed actual argument at %L to pointer "
2484 &a
->expr
->where
, f
->sym
->name
);
2488 /* Fortran 2008, 12.5.2.5 (no constraint). */
2489 if (a
->expr
->expr_type
== EXPR_VARIABLE
2490 && f
->sym
->attr
.intent
!= INTENT_IN
2491 && f
->sym
->attr
.allocatable
2492 && gfc_is_coindexed (a
->expr
))
2495 gfc_error ("Coindexed actual argument at %L to allocatable "
2496 "dummy '%s' requires INTENT(IN)",
2497 &a
->expr
->where
, f
->sym
->name
);
2501 /* Fortran 2008, C1237. */
2502 if (a
->expr
->expr_type
== EXPR_VARIABLE
2503 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2504 && gfc_is_coindexed (a
->expr
)
2505 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2506 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2509 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2510 "%L requires that dummy '%s' has neither "
2511 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2516 /* Fortran 2008, 12.5.2.4 (no constraint). */
2517 if (a
->expr
->expr_type
== EXPR_VARIABLE
2518 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2519 && gfc_is_coindexed (a
->expr
)
2520 && gfc_has_ultimate_allocatable (a
->expr
))
2523 gfc_error ("Coindexed actual argument at %L with allocatable "
2524 "ultimate component to dummy '%s' requires either VALUE "
2525 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2529 if (f
->sym
->ts
.type
== BT_CLASS
2530 && CLASS_DATA (f
->sym
)->attr
.allocatable
2531 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2535 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2536 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2541 if (a
->expr
->expr_type
!= EXPR_NULL
2542 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2545 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2546 f
->sym
->name
, &a
->expr
->where
);
2550 /* Check intent = OUT/INOUT for definable actual argument. */
2551 if ((f
->sym
->attr
.intent
== INTENT_OUT
2552 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2554 const char* context
= (where
2555 ? _("actual argument to INTENT = OUT/INOUT")
2558 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2559 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2560 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2561 && gfc_check_vardef_context (a
->expr
, true, false, context
)
2564 if (gfc_check_vardef_context (a
->expr
, false, false, context
)
2569 if ((f
->sym
->attr
.intent
== INTENT_OUT
2570 || f
->sym
->attr
.intent
== INTENT_INOUT
2571 || f
->sym
->attr
.volatile_
2572 || f
->sym
->attr
.asynchronous
)
2573 && gfc_has_vector_subscript (a
->expr
))
2576 gfc_error ("Array-section actual argument with vector "
2577 "subscripts at %L is incompatible with INTENT(OUT), "
2578 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2579 "of the dummy argument '%s'",
2580 &a
->expr
->where
, f
->sym
->name
);
2584 /* C1232 (R1221) For an actual argument which is an array section or
2585 an assumed-shape array, the dummy argument shall be an assumed-
2586 shape array, if the dummy argument has the VOLATILE attribute. */
2588 if (f
->sym
->attr
.volatile_
2589 && a
->expr
->symtree
->n
.sym
->as
2590 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2591 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2594 gfc_error ("Assumed-shape actual argument at %L is "
2595 "incompatible with the non-assumed-shape "
2596 "dummy argument '%s' due to VOLATILE attribute",
2597 &a
->expr
->where
,f
->sym
->name
);
2601 if (f
->sym
->attr
.volatile_
2602 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2603 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2606 gfc_error ("Array-section actual argument at %L is "
2607 "incompatible with the non-assumed-shape "
2608 "dummy argument '%s' due to VOLATILE attribute",
2609 &a
->expr
->where
,f
->sym
->name
);
2613 /* C1233 (R1221) For an actual argument which is a pointer array, the
2614 dummy argument shall be an assumed-shape or pointer array, if the
2615 dummy argument has the VOLATILE attribute. */
2617 if (f
->sym
->attr
.volatile_
2618 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2619 && a
->expr
->symtree
->n
.sym
->as
2621 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2622 || f
->sym
->attr
.pointer
)))
2625 gfc_error ("Pointer-array actual argument at %L requires "
2626 "an assumed-shape or pointer-array dummy "
2627 "argument '%s' due to VOLATILE attribute",
2628 &a
->expr
->where
,f
->sym
->name
);
2639 /* Make sure missing actual arguments are optional. */
2641 for (f
= formal
; f
; f
= f
->next
, i
++)
2643 if (new_arg
[i
] != NULL
)
2648 gfc_error ("Missing alternate return spec in subroutine call "
2652 if (!f
->sym
->attr
.optional
)
2655 gfc_error ("Missing actual argument for argument '%s' at %L",
2656 f
->sym
->name
, where
);
2661 /* The argument lists are compatible. We now relink a new actual
2662 argument list with null arguments in the right places. The head
2663 of the list remains the head. */
2664 for (i
= 0; i
< n
; i
++)
2665 if (new_arg
[i
] == NULL
)
2666 new_arg
[i
] = gfc_get_actual_arglist ();
2671 *new_arg
[0] = *actual
;
2675 new_arg
[0] = new_arg
[na
];
2679 for (i
= 0; i
< n
- 1; i
++)
2680 new_arg
[i
]->next
= new_arg
[i
+ 1];
2682 new_arg
[i
]->next
= NULL
;
2684 if (*ap
== NULL
&& n
> 0)
2687 /* Note the types of omitted optional arguments. */
2688 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2689 if (a
->expr
== NULL
&& a
->label
== NULL
)
2690 a
->missing_arg_type
= f
->sym
->ts
.type
;
2698 gfc_formal_arglist
*f
;
2699 gfc_actual_arglist
*a
;
2703 /* qsort comparison function for argument pairs, with the following
2705 - p->a->expr == NULL
2706 - p->a->expr->expr_type != EXPR_VARIABLE
2707 - growing p->a->expr->symbol. */
2710 pair_cmp (const void *p1
, const void *p2
)
2712 const gfc_actual_arglist
*a1
, *a2
;
2714 /* *p1 and *p2 are elements of the to-be-sorted array. */
2715 a1
= ((const argpair
*) p1
)->a
;
2716 a2
= ((const argpair
*) p2
)->a
;
2725 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2727 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2731 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2733 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2737 /* Given two expressions from some actual arguments, test whether they
2738 refer to the same expression. The analysis is conservative.
2739 Returning FAILURE will produce no warning. */
2742 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2744 const gfc_ref
*r1
, *r2
;
2747 || e1
->expr_type
!= EXPR_VARIABLE
2748 || e2
->expr_type
!= EXPR_VARIABLE
2749 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2752 /* TODO: improve comparison, see expr.c:show_ref(). */
2753 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2755 if (r1
->type
!= r2
->type
)
2760 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2762 /* TODO: At the moment, consider only full arrays;
2763 we could do better. */
2764 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2769 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2777 gfc_internal_error ("compare_actual_expr(): Bad component code");
2786 /* Given formal and actual argument lists that correspond to one
2787 another, check that identical actual arguments aren't not
2788 associated with some incompatible INTENTs. */
2791 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2793 sym_intent f1_intent
, f2_intent
;
2794 gfc_formal_arglist
*f1
;
2795 gfc_actual_arglist
*a1
;
2798 gfc_try t
= SUCCESS
;
2801 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2803 if (f1
== NULL
&& a1
== NULL
)
2805 if (f1
== NULL
|| a1
== NULL
)
2806 gfc_internal_error ("check_some_aliasing(): List mismatch");
2811 p
= XALLOCAVEC (argpair
, n
);
2813 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2819 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2821 for (i
= 0; i
< n
; i
++)
2824 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2825 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2827 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2828 for (j
= i
+ 1; j
< n
; j
++)
2830 /* Expected order after the sort. */
2831 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2832 gfc_internal_error ("check_some_aliasing(): corrupted data");
2834 /* Are the expression the same? */
2835 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2837 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2838 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2839 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2841 gfc_warning ("Same actual argument associated with INTENT(%s) "
2842 "argument '%s' and INTENT(%s) argument '%s' at %L",
2843 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2844 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2845 &p
[i
].a
->expr
->where
);
2855 /* Given formal and actual argument lists that correspond to one
2856 another, check that they are compatible in the sense that intents
2857 are not mismatched. */
2860 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2862 sym_intent f_intent
;
2864 for (;; f
= f
->next
, a
= a
->next
)
2866 if (f
== NULL
&& a
== NULL
)
2868 if (f
== NULL
|| a
== NULL
)
2869 gfc_internal_error ("check_intents(): List mismatch");
2871 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2874 f_intent
= f
->sym
->attr
.intent
;
2876 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2878 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2879 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2880 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2882 gfc_error ("Procedure argument at %L is local to a PURE "
2883 "procedure and has the POINTER attribute",
2889 /* Fortran 2008, C1283. */
2890 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
2892 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2894 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2895 "is passed to an INTENT(%s) argument",
2896 &a
->expr
->where
, gfc_intent_string (f_intent
));
2900 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2901 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2902 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2904 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2905 "is passed to a POINTER dummy argument",
2911 /* F2008, Section 12.5.2.4. */
2912 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
2913 && gfc_is_coindexed (a
->expr
))
2915 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2916 "polymorphic dummy argument '%s'",
2917 &a
->expr
->where
, f
->sym
->name
);
2926 /* Check how a procedure is used against its interface. If all goes
2927 well, the actual argument list will also end up being properly
2931 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2933 /* Warn about calls with an implicit interface. Special case
2934 for calling a ISO_C_BINDING becase c_loc and c_funloc
2935 are pseudo-unknown. Additionally, warn about procedures not
2936 explicitly declared at all if requested. */
2937 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2939 if (gfc_option
.warn_implicit_interface
)
2940 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2942 else if (gfc_option
.warn_implicit_procedure
2943 && sym
->attr
.proc
== PROC_UNKNOWN
)
2944 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2948 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2950 gfc_actual_arglist
*a
;
2952 if (sym
->attr
.pointer
)
2954 gfc_error("The pointer object '%s' at %L must have an explicit "
2955 "function interface or be declared as array",
2960 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
2962 gfc_error("The allocatable object '%s' at %L must have an explicit "
2963 "function interface or be declared as array",
2968 if (sym
->attr
.allocatable
)
2970 gfc_error("Allocatable function '%s' at %L must have an explicit "
2971 "function interface", sym
->name
, where
);
2975 for (a
= *ap
; a
; a
= a
->next
)
2977 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2978 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2980 gfc_error("Keyword argument requires explicit interface "
2981 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2985 /* TS 29113, 6.2. */
2986 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
2987 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
2989 gfc_error ("Assumed-type argument %s at %L requires an explicit "
2990 "interface", a
->expr
->symtree
->n
.sym
->name
,
2995 /* F2008, C1303 and C1304. */
2997 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
2998 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2999 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3000 || gfc_expr_attr (a
->expr
).lock_comp
))
3002 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3003 "component at %L requires an explicit interface for "
3004 "procedure '%s'", &a
->expr
->where
, sym
->name
);
3008 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3009 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3011 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3015 /* TS 29113, C407b. */
3016 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3017 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3019 gfc_error ("Assumed-rank argument requires an explicit interface "
3020 "at %L", &a
->expr
->where
);
3028 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
3031 check_intents (sym
->formal
, *ap
);
3032 if (gfc_option
.warn_aliasing
)
3033 check_some_aliasing (sym
->formal
, *ap
);
3037 /* Check how a procedure pointer component is used against its interface.
3038 If all goes well, the actual argument list will also end up being properly
3039 sorted. Completely analogous to gfc_procedure_use. */
3042 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3045 /* Warn about calls with an implicit interface. Special case
3046 for calling a ISO_C_BINDING becase c_loc and c_funloc
3047 are pseudo-unknown. */
3048 if (gfc_option
.warn_implicit_interface
3049 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3050 && !comp
->attr
.is_iso_c
)
3051 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3052 "interface at %L", comp
->name
, where
);
3054 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3056 gfc_actual_arglist
*a
;
3057 for (a
= *ap
; a
; a
= a
->next
)
3059 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3060 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3062 gfc_error("Keyword argument requires explicit interface "
3063 "for procedure pointer component '%s' at %L",
3064 comp
->name
, &a
->expr
->where
);
3072 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
3075 check_intents (comp
->formal
, *ap
);
3076 if (gfc_option
.warn_aliasing
)
3077 check_some_aliasing (comp
->formal
, *ap
);
3081 /* Try if an actual argument list matches the formal list of a symbol,
3082 respecting the symbol's attributes like ELEMENTAL. This is used for
3083 GENERIC resolution. */
3086 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3090 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3092 r
= !sym
->attr
.elemental
;
3093 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
3095 check_intents (sym
->formal
, *args
);
3096 if (gfc_option
.warn_aliasing
)
3097 check_some_aliasing (sym
->formal
, *args
);
3105 /* Given an interface pointer and an actual argument list, search for
3106 a formal argument list that matches the actual. If found, returns
3107 a pointer to the symbol of the correct interface. Returns NULL if
3111 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3112 gfc_actual_arglist
**ap
)
3114 gfc_symbol
*elem_sym
= NULL
;
3115 gfc_symbol
*null_sym
= NULL
;
3116 locus null_expr_loc
;
3117 gfc_actual_arglist
*a
;
3118 bool has_null_arg
= false;
3120 for (a
= *ap
; a
; a
= a
->next
)
3121 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3122 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3124 has_null_arg
= true;
3125 null_expr_loc
= a
->expr
->where
;
3129 for (; intr
; intr
= intr
->next
)
3131 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3133 if (sub_flag
&& intr
->sym
->attr
.function
)
3135 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3138 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3140 if (has_null_arg
&& null_sym
)
3142 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3143 "between specific functions %s and %s",
3144 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3147 else if (has_null_arg
)
3149 null_sym
= intr
->sym
;
3153 /* Satisfy 12.4.4.1 such that an elemental match has lower
3154 weight than a non-elemental match. */
3155 if (intr
->sym
->attr
.elemental
)
3157 elem_sym
= intr
->sym
;
3167 return elem_sym
? elem_sym
: NULL
;
3171 /* Do a brute force recursive search for a symbol. */
3173 static gfc_symtree
*
3174 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3178 if (root
->n
.sym
== sym
)
3183 st
= find_symtree0 (root
->left
, sym
);
3184 if (root
->right
&& ! st
)
3185 st
= find_symtree0 (root
->right
, sym
);
3190 /* Find a symtree for a symbol. */
3193 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3198 /* First try to find it by name. */
3199 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3200 if (st
&& st
->n
.sym
== sym
)
3203 /* If it's been renamed, resort to a brute-force search. */
3204 /* TODO: avoid having to do this search. If the symbol doesn't exist
3205 in the symtree for the current namespace, it should probably be added. */
3206 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3208 st
= find_symtree0 (ns
->sym_root
, sym
);
3212 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3217 /* See if the arglist to an operator-call contains a derived-type argument
3218 with a matching type-bound operator. If so, return the matching specific
3219 procedure defined as operator-target as well as the base-object to use
3220 (which is the found derived-type argument with operator). The generic
3221 name, if any, is transmitted to the final expression via 'gname'. */
3223 static gfc_typebound_proc
*
3224 matching_typebound_op (gfc_expr
** tb_base
,
3225 gfc_actual_arglist
* args
,
3226 gfc_intrinsic_op op
, const char* uop
,
3227 const char ** gname
)
3229 gfc_actual_arglist
* base
;
3231 for (base
= args
; base
; base
= base
->next
)
3232 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3234 gfc_typebound_proc
* tb
;
3235 gfc_symbol
* derived
;
3238 while (base
->expr
->expr_type
== EXPR_OP
3239 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3240 base
->expr
= base
->expr
->value
.op
.op1
;
3242 if (base
->expr
->ts
.type
== BT_CLASS
)
3244 if (CLASS_DATA (base
->expr
) == NULL
)
3246 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3249 derived
= base
->expr
->ts
.u
.derived
;
3251 if (op
== INTRINSIC_USER
)
3253 gfc_symtree
* tb_uop
;
3256 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3265 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3268 /* This means we hit a PRIVATE operator which is use-associated and
3269 should thus not be seen. */
3270 if (result
== FAILURE
)
3273 /* Look through the super-type hierarchy for a matching specific
3275 for (; tb
; tb
= tb
->overridden
)
3279 gcc_assert (tb
->is_generic
);
3280 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3283 gfc_actual_arglist
* argcopy
;
3286 gcc_assert (g
->specific
);
3287 if (g
->specific
->error
)
3290 target
= g
->specific
->u
.specific
->n
.sym
;
3292 /* Check if this arglist matches the formal. */
3293 argcopy
= gfc_copy_actual_arglist (args
);
3294 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3295 gfc_free_actual_arglist (argcopy
);
3297 /* Return if we found a match. */
3300 *tb_base
= base
->expr
;
3301 *gname
= g
->specific_st
->name
;
3312 /* For the 'actual arglist' of an operator call and a specific typebound
3313 procedure that has been found the target of a type-bound operator, build the
3314 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3315 type-bound procedures rather than resolving type-bound operators 'directly'
3316 so that we can reuse the existing logic. */
3319 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3320 gfc_expr
* base
, gfc_typebound_proc
* target
,
3323 e
->expr_type
= EXPR_COMPCALL
;
3324 e
->value
.compcall
.tbp
= target
;
3325 e
->value
.compcall
.name
= gname
? gname
: "$op";
3326 e
->value
.compcall
.actual
= actual
;
3327 e
->value
.compcall
.base_object
= base
;
3328 e
->value
.compcall
.ignore_pass
= 1;
3329 e
->value
.compcall
.assign
= 0;
3330 if (e
->ts
.type
== BT_UNKNOWN
3331 && target
->function
)
3333 if (target
->is_generic
)
3334 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3336 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3341 /* This subroutine is called when an expression is being resolved.
3342 The expression node in question is either a user defined operator
3343 or an intrinsic operator with arguments that aren't compatible
3344 with the operator. This subroutine builds an actual argument list
3345 corresponding to the operands, then searches for a compatible
3346 interface. If one is found, the expression node is replaced with
3347 the appropriate function call. We use the 'match' enum to specify
3348 whether a replacement has been made or not, or if an error occurred. */
3351 gfc_extend_expr (gfc_expr
*e
)
3353 gfc_actual_arglist
*actual
;
3362 actual
= gfc_get_actual_arglist ();
3363 actual
->expr
= e
->value
.op
.op1
;
3367 if (e
->value
.op
.op2
!= NULL
)
3369 actual
->next
= gfc_get_actual_arglist ();
3370 actual
->next
->expr
= e
->value
.op
.op2
;
3373 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3375 if (i
== INTRINSIC_USER
)
3377 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3379 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3383 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3390 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3392 /* Due to the distinction between '==' and '.eq.' and friends, one has
3393 to check if either is defined. */
3396 #define CHECK_OS_COMPARISON(comp) \
3397 case INTRINSIC_##comp: \
3398 case INTRINSIC_##comp##_OS: \
3399 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3401 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3403 CHECK_OS_COMPARISON(EQ
)
3404 CHECK_OS_COMPARISON(NE
)
3405 CHECK_OS_COMPARISON(GT
)
3406 CHECK_OS_COMPARISON(GE
)
3407 CHECK_OS_COMPARISON(LT
)
3408 CHECK_OS_COMPARISON(LE
)
3409 #undef CHECK_OS_COMPARISON
3412 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3420 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3421 found rather than just taking the first one and not checking further. */
3425 gfc_typebound_proc
* tbo
;
3428 /* See if we find a matching type-bound operator. */
3429 if (i
== INTRINSIC_USER
)
3430 tbo
= matching_typebound_op (&tb_base
, actual
,
3431 i
, e
->value
.op
.uop
->name
, &gname
);
3435 #define CHECK_OS_COMPARISON(comp) \
3436 case INTRINSIC_##comp: \
3437 case INTRINSIC_##comp##_OS: \
3438 tbo = matching_typebound_op (&tb_base, actual, \
3439 INTRINSIC_##comp, NULL, &gname); \
3441 tbo = matching_typebound_op (&tb_base, actual, \
3442 INTRINSIC_##comp##_OS, NULL, &gname); \
3444 CHECK_OS_COMPARISON(EQ
)
3445 CHECK_OS_COMPARISON(NE
)
3446 CHECK_OS_COMPARISON(GT
)
3447 CHECK_OS_COMPARISON(GE
)
3448 CHECK_OS_COMPARISON(LT
)
3449 CHECK_OS_COMPARISON(LE
)
3450 #undef CHECK_OS_COMPARISON
3453 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3457 /* If there is a matching typebound-operator, replace the expression with
3458 a call to it and succeed. */
3463 gcc_assert (tb_base
);
3464 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3466 result
= gfc_resolve_expr (e
);
3467 if (result
== FAILURE
)
3473 /* Don't use gfc_free_actual_arglist(). */
3474 free (actual
->next
);
3480 /* Change the expression node to a function call. */
3481 e
->expr_type
= EXPR_FUNCTION
;
3482 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3483 e
->value
.function
.actual
= actual
;
3484 e
->value
.function
.esym
= NULL
;
3485 e
->value
.function
.isym
= NULL
;
3486 e
->value
.function
.name
= NULL
;
3487 e
->user_operator
= 1;
3489 if (gfc_resolve_expr (e
) == FAILURE
)
3496 /* Tries to replace an assignment code node with a subroutine call to
3497 the subroutine associated with the assignment operator. Return
3498 SUCCESS if the node was replaced. On FAILURE, no error is
3502 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3504 gfc_actual_arglist
*actual
;
3505 gfc_expr
*lhs
, *rhs
;
3514 /* Don't allow an intrinsic assignment to be replaced. */
3515 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3516 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3517 && (lhs
->ts
.type
== rhs
->ts
.type
3518 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3521 actual
= gfc_get_actual_arglist ();
3524 actual
->next
= gfc_get_actual_arglist ();
3525 actual
->next
->expr
= rhs
;
3529 for (; ns
; ns
= ns
->parent
)
3531 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3536 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3540 gfc_typebound_proc
* tbo
;
3543 /* See if we find a matching type-bound assignment. */
3544 tbo
= matching_typebound_op (&tb_base
, actual
,
3545 INTRINSIC_ASSIGN
, NULL
, &gname
);
3547 /* If there is one, replace the expression with a call to it and
3551 gcc_assert (tb_base
);
3552 c
->expr1
= gfc_get_expr ();
3553 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3554 c
->expr1
->value
.compcall
.assign
= 1;
3555 c
->expr1
->where
= c
->loc
;
3557 c
->op
= EXEC_COMPCALL
;
3559 /* c is resolved from the caller, so no need to do it here. */
3564 free (actual
->next
);
3569 /* Replace the assignment with the call. */
3570 c
->op
= EXEC_ASSIGN_CALL
;
3571 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3574 c
->ext
.actual
= actual
;
3580 /* Make sure that the interface just parsed is not already present in
3581 the given interface list. Ambiguity isn't checked yet since module
3582 procedures can be present without interfaces. */
3585 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3589 for (ip
= base
; ip
; ip
= ip
->next
)
3591 if (ip
->sym
== new_sym
)
3593 gfc_error ("Entity '%s' at %L is already present in the interface",
3594 new_sym
->name
, &loc
);
3603 /* Add a symbol to the current interface. */
3606 gfc_add_interface (gfc_symbol
*new_sym
)
3608 gfc_interface
**head
, *intr
;
3612 switch (current_interface
.type
)
3614 case INTERFACE_NAMELESS
:
3615 case INTERFACE_ABSTRACT
:
3618 case INTERFACE_INTRINSIC_OP
:
3619 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3620 switch (current_interface
.op
)
3623 case INTRINSIC_EQ_OS
:
3624 if (gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3625 gfc_current_locus
) == FAILURE
3626 || gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
,
3627 gfc_current_locus
) == FAILURE
)
3632 case INTRINSIC_NE_OS
:
3633 if (gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3634 gfc_current_locus
) == FAILURE
3635 || gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
,
3636 gfc_current_locus
) == FAILURE
)
3641 case INTRINSIC_GT_OS
:
3642 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
,
3643 gfc_current_locus
) == FAILURE
3644 || gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
,
3645 gfc_current_locus
) == FAILURE
)
3650 case INTRINSIC_GE_OS
:
3651 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
,
3652 gfc_current_locus
) == FAILURE
3653 || gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
,
3654 gfc_current_locus
) == FAILURE
)
3659 case INTRINSIC_LT_OS
:
3660 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
,
3661 gfc_current_locus
) == FAILURE
3662 || gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
,
3663 gfc_current_locus
) == FAILURE
)
3668 case INTRINSIC_LE_OS
:
3669 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
,
3670 gfc_current_locus
) == FAILURE
3671 || gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
,
3672 gfc_current_locus
) == FAILURE
)
3677 if (gfc_check_new_interface (ns
->op
[current_interface
.op
], new_sym
,
3678 gfc_current_locus
) == FAILURE
)
3682 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3685 case INTERFACE_GENERIC
:
3686 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3688 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3692 if (gfc_check_new_interface (sym
->generic
, new_sym
, gfc_current_locus
)
3697 head
= ¤t_interface
.sym
->generic
;
3700 case INTERFACE_USER_OP
:
3701 if (gfc_check_new_interface (current_interface
.uop
->op
, new_sym
,
3702 gfc_current_locus
) == FAILURE
)
3705 head
= ¤t_interface
.uop
->op
;
3709 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3712 intr
= gfc_get_interface ();
3713 intr
->sym
= new_sym
;
3714 intr
->where
= gfc_current_locus
;
3724 gfc_current_interface_head (void)
3726 switch (current_interface
.type
)
3728 case INTERFACE_INTRINSIC_OP
:
3729 return current_interface
.ns
->op
[current_interface
.op
];
3732 case INTERFACE_GENERIC
:
3733 return current_interface
.sym
->generic
;
3736 case INTERFACE_USER_OP
:
3737 return current_interface
.uop
->op
;
3747 gfc_set_current_interface_head (gfc_interface
*i
)
3749 switch (current_interface
.type
)
3751 case INTERFACE_INTRINSIC_OP
:
3752 current_interface
.ns
->op
[current_interface
.op
] = i
;
3755 case INTERFACE_GENERIC
:
3756 current_interface
.sym
->generic
= i
;
3759 case INTERFACE_USER_OP
:
3760 current_interface
.uop
->op
= i
;
3769 /* Gets rid of a formal argument list. We do not free symbols.
3770 Symbols are freed when a namespace is freed. */
3773 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3775 gfc_formal_arglist
*q
;
3785 /* Check that it is ok for the type-bound procedure 'proc' to override the
3786 procedure 'old', cf. F08:4.5.7.3. */
3789 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
3792 const gfc_symbol
*proc_target
, *old_target
;
3793 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
3794 gfc_formal_arglist
*proc_formal
, *old_formal
;
3798 /* This procedure should only be called for non-GENERIC proc. */
3799 gcc_assert (!proc
->n
.tb
->is_generic
);
3801 /* If the overwritten procedure is GENERIC, this is an error. */
3802 if (old
->n
.tb
->is_generic
)
3804 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3805 old
->name
, &proc
->n
.tb
->where
);
3809 where
= proc
->n
.tb
->where
;
3810 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
3811 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
3813 /* Check that overridden binding is not NON_OVERRIDABLE. */
3814 if (old
->n
.tb
->non_overridable
)
3816 gfc_error ("'%s' at %L overrides a procedure binding declared"
3817 " NON_OVERRIDABLE", proc
->name
, &where
);
3821 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3822 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
3824 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3825 " non-DEFERRED binding", proc
->name
, &where
);
3829 /* If the overridden binding is PURE, the overriding must be, too. */
3830 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
3832 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3833 proc
->name
, &where
);
3837 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3838 is not, the overriding must not be either. */
3839 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
3841 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3842 " ELEMENTAL", proc
->name
, &where
);
3845 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
3847 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3848 " be ELEMENTAL, either", proc
->name
, &where
);
3852 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3854 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
3856 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3857 " SUBROUTINE", proc
->name
, &where
);
3861 /* If the overridden binding is a FUNCTION, the overriding must also be a
3862 FUNCTION and have the same characteristics. */
3863 if (old_target
->attr
.function
)
3865 if (!proc_target
->attr
.function
)
3867 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
3868 " FUNCTION", proc
->name
, &where
);
3872 /* FIXME: Do more comprehensive checking (including, for instance, the
3874 gcc_assert (proc_target
->result
&& old_target
->result
);
3875 if (!compare_type_rank (proc_target
->result
, old_target
->result
))
3877 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
3878 " matching result types and ranks", proc
->name
, &where
);
3882 /* Check string length. */
3883 if (proc_target
->result
->ts
.type
== BT_CHARACTER
3884 && proc_target
->result
->ts
.u
.cl
&& old_target
->result
->ts
.u
.cl
)
3886 int compval
= gfc_dep_compare_expr (proc_target
->result
->ts
.u
.cl
->length
,
3887 old_target
->result
->ts
.u
.cl
->length
);
3893 gfc_error ("Character length mismatch between '%s' at '%L' and "
3894 "overridden FUNCTION", proc
->name
, &where
);
3898 gfc_warning ("Possible character length mismatch between '%s' at"
3899 " '%L' and overridden FUNCTION", proc
->name
, &where
);
3906 gfc_internal_error ("gfc_check_typebound_override: Unexpected "
3907 "result %i of gfc_dep_compare_expr", compval
);
3913 /* If the overridden binding is PUBLIC, the overriding one must not be
3915 if (old
->n
.tb
->access
== ACCESS_PUBLIC
3916 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
3918 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
3919 " PRIVATE", proc
->name
, &where
);
3923 /* Compare the formal argument lists of both procedures. This is also abused
3924 to find the position of the passed-object dummy arguments of both
3925 bindings as at least the overridden one might not yet be resolved and we
3926 need those positions in the check below. */
3927 proc_pass_arg
= old_pass_arg
= 0;
3928 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
3930 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
3933 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
3934 proc_formal
&& old_formal
;
3935 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
3937 if (proc
->n
.tb
->pass_arg
3938 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
3939 proc_pass_arg
= argpos
;
3940 if (old
->n
.tb
->pass_arg
3941 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
3942 old_pass_arg
= argpos
;
3944 /* Check that the names correspond. */
3945 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
3947 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
3948 " to match the corresponding argument of the overridden"
3949 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
3950 old_formal
->sym
->name
);
3954 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
3955 if (check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
3956 check_type
, err
, sizeof(err
)) == FAILURE
)
3958 gfc_error ("Argument mismatch for the overriding procedure "
3959 "'%s' at %L: %s", proc
->name
, &where
, err
);
3965 if (proc_formal
|| old_formal
)
3967 gfc_error ("'%s' at %L must have the same number of formal arguments as"
3968 " the overridden procedure", proc
->name
, &where
);
3972 /* If the overridden binding is NOPASS, the overriding one must also be
3974 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
3976 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
3977 " NOPASS", proc
->name
, &where
);
3981 /* If the overridden binding is PASS(x), the overriding one must also be
3982 PASS and the passed-object dummy arguments must correspond. */
3983 if (!old
->n
.tb
->nopass
)
3985 if (proc
->n
.tb
->nopass
)
3987 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
3988 " PASS", proc
->name
, &where
);
3992 if (proc_pass_arg
!= old_pass_arg
)
3994 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
3995 " the same position as the passed-object dummy argument of"
3996 " the overridden procedure", proc
->name
, &where
);