1 /* Deal with interfaces.
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface
;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface
*intr
)
87 for (; intr
; intr
= next
)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary_intrinsic (gfc_intrinsic_op op
)
103 case INTRINSIC_UPLUS
:
106 case INTRINSIC_UMINUS
:
107 op
= INTRINSIC_MINUS
;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'op' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type
*type
,
124 gfc_intrinsic_op
*op
)
126 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES
)
132 *type
= INTERFACE_INTRINSIC_OP
;
133 *op
= INTRINSIC_ASSIGN
;
137 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
139 *type
= INTERFACE_INTRINSIC_OP
;
140 *op
= fold_unary_intrinsic (i
);
144 *op
= INTRINSIC_NONE
;
145 if (gfc_match (" operator ( ") == MATCH_YES
)
147 m
= gfc_match_defined_op_name (buffer
, 1);
153 m
= gfc_match_char (')');
159 strcpy (name
, buffer
);
160 *type
= INTERFACE_USER_OP
;
164 if (gfc_match_name (buffer
) == MATCH_YES
)
166 strcpy (name
, buffer
);
167 *type
= INTERFACE_GENERIC
;
171 *type
= INTERFACE_NAMELESS
;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five F95 forms of an interface statement. The
181 matcher for the abstract interface follows. */
184 gfc_match_interface (void)
186 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
192 m
= gfc_match_space ();
194 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
202 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
207 current_interface
.type
= type
;
211 case INTERFACE_GENERIC
:
212 if (gfc_get_symbol (name
, NULL
, &sym
))
215 if (!sym
->attr
.generic
216 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
221 gfc_error ("Dummy procedure '%s' at %C cannot have a "
222 "generic interface", sym
->name
);
226 current_interface
.sym
= gfc_new_block
= sym
;
229 case INTERFACE_USER_OP
:
230 current_interface
.uop
= gfc_get_uop (name
);
233 case INTERFACE_INTRINSIC_OP
:
234 current_interface
.op
= op
;
237 case INTERFACE_NAMELESS
:
238 case INTERFACE_ABSTRACT
:
247 /* Match a F2003 abstract interface. */
250 gfc_match_abstract_interface (void)
254 if (gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C")
258 m
= gfc_match_eos ();
262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
266 current_interface
.type
= INTERFACE_ABSTRACT
;
272 /* Match the different sort of generic-specs that can be present after
273 the END INTERFACE itself. */
276 gfc_match_end_interface (void)
278 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
283 m
= gfc_match_space ();
285 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
288 /* If we're not looking at the end of the statement now, or if this
289 is not a nameless interface but we did not see a space, punt. */
290 if (gfc_match_eos () != MATCH_YES
291 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
300 switch (current_interface
.type
)
302 case INTERFACE_NAMELESS
:
303 case INTERFACE_ABSTRACT
:
304 if (type
!= INTERFACE_NAMELESS
)
306 gfc_error ("Expected a nameless interface at %C");
312 case INTERFACE_INTRINSIC_OP
:
313 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
316 if (current_interface
.op
== INTRINSIC_ASSIGN
)
319 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
324 s1
= gfc_op2string (current_interface
.op
);
325 s2
= gfc_op2string (op
);
327 /* The following if-statements are used to enforce C1202
329 if ((strcmp(s1
, "==") == 0 && strcmp(s2
, ".eq.") == 0)
330 || (strcmp(s1
, ".eq.") == 0 && strcmp(s2
, "==") == 0))
332 if ((strcmp(s1
, "/=") == 0 && strcmp(s2
, ".ne.") == 0)
333 || (strcmp(s1
, ".ne.") == 0 && strcmp(s2
, "/=") == 0))
335 if ((strcmp(s1
, "<=") == 0 && strcmp(s2
, ".le.") == 0)
336 || (strcmp(s1
, ".le.") == 0 && strcmp(s2
, "<=") == 0))
338 if ((strcmp(s1
, "<") == 0 && strcmp(s2
, ".lt.") == 0)
339 || (strcmp(s1
, ".lt.") == 0 && strcmp(s2
, "<") == 0))
341 if ((strcmp(s1
, ">=") == 0 && strcmp(s2
, ".ge.") == 0)
342 || (strcmp(s1
, ".ge.") == 0 && strcmp(s2
, ">=") == 0))
344 if ((strcmp(s1
, ">") == 0 && strcmp(s2
, ".gt.") == 0)
345 || (strcmp(s1
, ".gt.") == 0 && strcmp(s2
, ">") == 0))
349 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
350 "but got %s", s1
, s2
);
357 case INTERFACE_USER_OP
:
358 /* Comparing the symbol node names is OK because only use-associated
359 symbols can be renamed. */
360 if (type
!= current_interface
.type
361 || strcmp (current_interface
.uop
->name
, name
) != 0)
363 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
364 current_interface
.uop
->name
);
370 case INTERFACE_GENERIC
:
371 if (type
!= current_interface
.type
372 || strcmp (current_interface
.sym
->name
, name
) != 0)
374 gfc_error ("Expecting 'END INTERFACE %s' at %C",
375 current_interface
.sym
->name
);
386 /* Compare two derived types using the criteria in 4.4.2 of the standard,
387 recursing through gfc_compare_types for the components. */
390 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
392 gfc_component
*dt1
, *dt2
;
394 if (derived1
== derived2
)
397 gcc_assert (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 (strcmp (derived1
->name
, derived2
->name
) == 0
403 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
404 && strcmp (derived1
->module
, derived2
->module
) == 0)
407 /* Compare type via the rules of the standard. Both types must have
408 the SEQUENCE or BIND(C) attribute to be equal. */
410 if (strcmp (derived1
->name
, derived2
->name
))
413 if (derived1
->component_access
== ACCESS_PRIVATE
414 || derived2
->component_access
== ACCESS_PRIVATE
)
417 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
418 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
421 dt1
= derived1
->components
;
422 dt2
= derived2
->components
;
424 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
425 simple test can speed things up. Otherwise, lots of things have to
429 if (strcmp (dt1
->name
, dt2
->name
) != 0)
432 if (dt1
->attr
.access
!= dt2
->attr
.access
)
435 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
438 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
441 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
444 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
447 /* Make sure that link lists do not put this function into an
448 endless recursive loop! */
449 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
450 && !(dt2
->ts
.type
== BT_DERIVED
&& derived2
== dt2
->ts
.u
.derived
)
451 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
454 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
455 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
458 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
459 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
465 if (dt1
== NULL
&& dt2
== NULL
)
467 if (dt1
== NULL
|| dt2
== NULL
)
475 /* Compare two typespecs, recursively if necessary. */
478 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
480 /* See if one of the typespecs is a BT_VOID, which is what is being used
481 to allow the funcs like c_f_pointer to accept any pointer type.
482 TODO: Possibly should narrow this to just the one typespec coming in
483 that is for the formal arg, but oh well. */
484 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
487 if (ts1
->type
== BT_CLASS
488 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
492 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
493 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
494 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
497 if (ts1
->type
!= ts2
->type
498 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
499 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
501 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
502 return (ts1
->kind
== ts2
->kind
);
504 /* Compare derived types. */
505 if (gfc_type_compatible (ts1
, ts2
))
508 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
512 /* Given two symbols that are formal arguments, compare their ranks
513 and types. Returns nonzero if they have the same rank and type,
517 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
519 gfc_array_spec
*as1
, *as2
;
522 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
523 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
525 r1
= as1
? as1
->rank
: 0;
526 r2
= as2
? as2
->rank
: 0;
529 && (!as1
|| as1
->type
!= AS_ASSUMED_RANK
)
530 && (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
531 return 0; /* Ranks differ. */
533 return gfc_compare_types (&s1
->ts
, &s2
->ts
)
534 || s1
->ts
.type
== BT_ASSUMED
|| s2
->ts
.type
== BT_ASSUMED
;
538 /* Given two symbols that are formal arguments, compare their types
539 and rank and their formal interfaces if they are both dummy
540 procedures. Returns nonzero if the same, zero if different. */
543 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
545 if (s1
== NULL
|| s2
== NULL
)
546 return s1
== s2
? 1 : 0;
551 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
552 return compare_type_rank (s1
, s2
);
554 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
557 /* At this point, both symbols are procedures. It can happen that
558 external procedures are compared, where one is identified by usage
559 to be a function or subroutine but the other is not. Check TKR
560 nonetheless for these cases. */
561 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
562 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
564 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
565 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
567 /* Now the type of procedure has been identified. */
568 if (s1
->attr
.function
!= s2
->attr
.function
569 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
572 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
575 /* Originally, gfortran recursed here to check the interfaces of passed
576 procedures. This is explicitly not required by the standard. */
581 /* Given a formal argument list and a keyword name, search the list
582 for that keyword. Returns the correct symbol node if found, NULL
586 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
588 for (; f
; f
= f
->next
)
589 if (strcmp (f
->sym
->name
, name
) == 0)
596 /******** Interface checking subroutines **********/
599 /* Given an operator interface and the operator, make sure that all
600 interfaces for that operator are legal. */
603 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
606 gfc_formal_arglist
*formal
;
609 int args
, r1
, r2
, k1
, k2
;
614 t1
= t2
= BT_UNKNOWN
;
615 i1
= i2
= INTENT_UNKNOWN
;
619 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
621 gfc_symbol
*fsym
= formal
->sym
;
624 gfc_error ("Alternate return cannot appear in operator "
625 "interface at %L", &sym
->declared_at
);
631 i1
= fsym
->attr
.intent
;
632 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
638 i2
= fsym
->attr
.intent
;
639 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
645 /* Only +, - and .not. can be unary operators.
646 .not. cannot be a binary operator. */
647 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
648 && op
!= INTRINSIC_MINUS
649 && op
!= INTRINSIC_NOT
)
650 || (args
== 2 && op
== INTRINSIC_NOT
))
652 if (op
== INTRINSIC_ASSIGN
)
653 gfc_error ("Assignment operator interface at %L must have "
654 "two arguments", &sym
->declared_at
);
656 gfc_error ("Operator interface at %L has the wrong number of arguments",
661 /* Check that intrinsics are mapped to functions, except
662 INTRINSIC_ASSIGN which should map to a subroutine. */
663 if (op
== INTRINSIC_ASSIGN
)
665 gfc_formal_arglist
*dummy_args
;
667 if (!sym
->attr
.subroutine
)
669 gfc_error ("Assignment operator interface at %L must be "
670 "a SUBROUTINE", &sym
->declared_at
);
674 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
675 - First argument an array with different rank than second,
676 - First argument is a scalar and second an array,
677 - Types and kinds do not conform, or
678 - First argument is of derived type. */
679 dummy_args
= gfc_sym_get_dummy_args (sym
);
680 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
681 && dummy_args
->sym
->ts
.type
!= BT_CLASS
682 && (r2
== 0 || r1
== r2
)
683 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
684 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
685 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
687 gfc_error ("Assignment operator interface at %L must not redefine "
688 "an INTRINSIC type assignment", &sym
->declared_at
);
694 if (!sym
->attr
.function
)
696 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
702 /* Check intents on operator interfaces. */
703 if (op
== INTRINSIC_ASSIGN
)
705 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
707 gfc_error ("First argument of defined assignment at %L must be "
708 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
714 gfc_error ("Second argument of defined assignment at %L must be "
715 "INTENT(IN)", &sym
->declared_at
);
723 gfc_error ("First argument of operator interface at %L must be "
724 "INTENT(IN)", &sym
->declared_at
);
728 if (args
== 2 && i2
!= INTENT_IN
)
730 gfc_error ("Second argument of operator interface at %L must be "
731 "INTENT(IN)", &sym
->declared_at
);
736 /* From now on, all we have to do is check that the operator definition
737 doesn't conflict with an intrinsic operator. The rules for this
738 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
739 as well as 12.3.2.1.1 of Fortran 2003:
741 "If the operator is an intrinsic-operator (R310), the number of
742 function arguments shall be consistent with the intrinsic uses of
743 that operator, and the types, kind type parameters, or ranks of the
744 dummy arguments shall differ from those required for the intrinsic
745 operation (7.1.2)." */
747 #define IS_NUMERIC_TYPE(t) \
748 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
750 /* Unary ops are easy, do them first. */
751 if (op
== INTRINSIC_NOT
)
753 if (t1
== BT_LOGICAL
)
759 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
761 if (IS_NUMERIC_TYPE (t1
))
767 /* Character intrinsic operators have same character kind, thus
768 operator definitions with operands of different character kinds
770 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
773 /* Intrinsic operators always perform on arguments of same rank,
774 so different ranks is also always safe. (rank == 0) is an exception
775 to that, because all intrinsic operators are elemental. */
776 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
782 case INTRINSIC_EQ_OS
:
784 case INTRINSIC_NE_OS
:
785 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
790 case INTRINSIC_MINUS
:
791 case INTRINSIC_TIMES
:
792 case INTRINSIC_DIVIDE
:
793 case INTRINSIC_POWER
:
794 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
799 case INTRINSIC_GT_OS
:
801 case INTRINSIC_GE_OS
:
803 case INTRINSIC_LT_OS
:
805 case INTRINSIC_LE_OS
:
806 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
808 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
809 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
813 case INTRINSIC_CONCAT
:
814 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
822 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
832 #undef IS_NUMERIC_TYPE
835 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
841 /* Given a pair of formal argument lists, we see if the two lists can
842 be distinguished by counting the number of nonoptional arguments of
843 a given type/rank in f1 and seeing if there are less then that
844 number of those arguments in f2 (including optional arguments).
845 Since this test is asymmetric, it has to be called twice to make it
846 symmetric. Returns nonzero if the argument lists are incompatible
847 by this test. This subroutine implements rule 1 of section F03:16.2.3.
848 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
851 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
852 const char *p1
, const char *p2
)
854 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
855 gfc_formal_arglist
*f
;
868 for (f
= f1
; f
; f
= f
->next
)
871 /* Build an array of integers that gives the same integer to
872 arguments of the same type/rank. */
873 arg
= XCNEWVEC (arginfo
, n1
);
876 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
884 for (i
= 0; i
< n1
; i
++)
886 if (arg
[i
].flag
!= -1)
889 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
890 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
891 continue; /* Skip OPTIONAL and PASS arguments. */
895 /* Find other non-optional, non-pass arguments of the same type/rank. */
896 for (j
= i
+ 1; j
< n1
; j
++)
897 if ((arg
[j
].sym
== NULL
898 || !(arg
[j
].sym
->attr
.optional
899 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
900 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
901 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
907 /* Now loop over each distinct type found in f1. */
911 for (i
= 0; i
< n1
; i
++)
913 if (arg
[i
].flag
!= k
)
917 for (j
= i
+ 1; j
< n1
; j
++)
918 if (arg
[j
].flag
== k
)
921 /* Count the number of non-pass arguments in f2 with that type,
922 including those that are optional. */
925 for (f
= f2
; f
; f
= f
->next
)
926 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
927 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
928 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
946 /* Perform the correspondence test in rule (3) of F08:C1215.
947 Returns zero if no argument is found that satisfies this rule,
948 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
951 This test is also not symmetric in f1 and f2 and must be called
952 twice. This test finds problems caused by sorting the actual
953 argument list with keywords. For example:
957 INTEGER :: A ; REAL :: B
961 INTEGER :: A ; REAL :: B
965 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
968 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
969 const char *p1
, const char *p2
)
971 gfc_formal_arglist
*f2_save
, *g
;
978 if (f1
->sym
->attr
.optional
)
981 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
983 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
986 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
987 || compare_type_rank (f2
->sym
, f1
->sym
))
988 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
989 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
990 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
993 /* Now search for a disambiguating keyword argument starting at
994 the current non-match. */
995 for (g
= f1
; g
; g
= g
->next
)
997 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1000 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1001 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1002 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1003 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1004 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1019 /* Check if the characteristics of two dummy arguments match,
1023 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1024 bool type_must_agree
, char *errmsg
, int err_len
)
1026 /* Check type and rank. */
1027 if (type_must_agree
&& !compare_type_rank (s2
, s1
))
1029 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1035 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1037 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1042 /* Check OPTIONAL attribute. */
1043 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1045 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1050 /* Check ALLOCATABLE attribute. */
1051 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1053 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1058 /* Check POINTER attribute. */
1059 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1061 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1066 /* Check TARGET attribute. */
1067 if (s1
->attr
.target
!= s2
->attr
.target
)
1069 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1074 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1075 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1077 /* Check interface of dummy procedures. */
1078 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1081 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1084 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1085 "'%s': %s", s1
->name
, err
);
1090 /* Check string length. */
1091 if (s1
->ts
.type
== BT_CHARACTER
1092 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1093 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1095 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1096 s2
->ts
.u
.cl
->length
);
1102 snprintf (errmsg
, err_len
, "Character length mismatch "
1103 "in argument '%s'", s1
->name
);
1107 /* FIXME: Implement a warning for this case.
1108 gfc_warning ("Possible character length mismatch in argument '%s'",
1116 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1117 "%i of gfc_dep_compare_expr", compval
);
1122 /* Check array shape. */
1123 if (s1
->as
&& s2
->as
)
1126 gfc_expr
*shape1
, *shape2
;
1128 if (s1
->as
->type
!= s2
->as
->type
)
1130 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1135 if (s1
->as
->type
== AS_EXPLICIT
)
1136 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1138 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1139 gfc_copy_expr (s1
->as
->lower
[i
]));
1140 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1141 gfc_copy_expr (s2
->as
->lower
[i
]));
1142 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1143 gfc_free_expr (shape1
);
1144 gfc_free_expr (shape2
);
1150 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1151 "argument '%s'", i
+ 1, s1
->name
);
1155 /* FIXME: Implement a warning for this case.
1156 gfc_warning ("Possible shape mismatch in argument '%s'",
1164 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1165 "result %i of gfc_dep_compare_expr",
1176 /* Check if the characteristics of two function results match,
1180 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1181 char *errmsg
, int err_len
)
1183 gfc_symbol
*r1
, *r2
;
1185 r1
= s1
->result
? s1
->result
: s1
;
1186 r2
= s2
->result
? s2
->result
: s2
;
1188 if (r1
->ts
.type
== BT_UNKNOWN
)
1191 /* Check type and rank. */
1192 if (!compare_type_rank (r1
, r2
))
1194 snprintf (errmsg
, err_len
, "Type/rank mismatch in function result");
1198 /* Check ALLOCATABLE attribute. */
1199 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1201 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1206 /* Check POINTER attribute. */
1207 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1209 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1214 /* Check CONTIGUOUS attribute. */
1215 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1217 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1222 /* Check PROCEDURE POINTER attribute. */
1223 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1225 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1230 /* Check string length. */
1231 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1233 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1235 snprintf (errmsg
, err_len
, "Character length mismatch "
1236 "in function result");
1240 if (r1
->ts
.u
.cl
->length
)
1242 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1243 r2
->ts
.u
.cl
->length
);
1249 snprintf (errmsg
, err_len
, "Character length mismatch "
1250 "in function result");
1254 /* FIXME: Implement a warning for this case.
1255 snprintf (errmsg, err_len, "Possible character length mismatch "
1256 "in function result");*/
1263 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1264 "result %i of gfc_dep_compare_expr", compval
);
1270 /* Check array shape. */
1271 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1274 gfc_expr
*shape1
, *shape2
;
1276 if (r1
->as
->type
!= r2
->as
->type
)
1278 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1282 if (r1
->as
->type
== AS_EXPLICIT
)
1283 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1285 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1286 gfc_copy_expr (r1
->as
->lower
[i
]));
1287 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1288 gfc_copy_expr (r2
->as
->lower
[i
]));
1289 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1290 gfc_free_expr (shape1
);
1291 gfc_free_expr (shape2
);
1297 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1298 "function result", i
+ 1);
1302 /* FIXME: Implement a warning for this case.
1303 gfc_warning ("Possible shape mismatch in return value");*/
1310 gfc_internal_error ("check_result_characteristics (2): "
1311 "Unexpected result %i of "
1312 "gfc_dep_compare_expr", compval
);
1322 /* 'Compare' two formal interfaces associated with a pair of symbols.
1323 We return nonzero if there exists an actual argument list that
1324 would be ambiguous between the two interfaces, zero otherwise.
1325 'strict_flag' specifies whether all the characteristics are
1326 required to match, which is not the case for ambiguity checks.
1327 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1330 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1331 int generic_flag
, int strict_flag
,
1332 char *errmsg
, int err_len
,
1333 const char *p1
, const char *p2
)
1335 gfc_formal_arglist
*f1
, *f2
;
1337 gcc_assert (name2
!= NULL
);
1339 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1340 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1341 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1344 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1348 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1351 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1355 /* Do strict checks on all characteristics
1356 (for dummy procedures and procedure pointer assignments). */
1357 if (!generic_flag
&& strict_flag
)
1359 if (s1
->attr
.function
&& s2
->attr
.function
)
1361 /* If both are functions, check result characteristics. */
1362 if (check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1367 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1369 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1372 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1374 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1379 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1380 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1383 f1
= gfc_sym_get_dummy_args (s1
);
1384 f2
= gfc_sym_get_dummy_args (s2
);
1386 if (f1
== NULL
&& f2
== NULL
)
1387 return 1; /* Special case: No arguments. */
1391 if (count_types_test (f1
, f2
, p1
, p2
)
1392 || count_types_test (f2
, f1
, p2
, p1
))
1394 if (generic_correspondence (f1
, f2
, p1
, p2
)
1395 || generic_correspondence (f2
, f1
, p2
, p1
))
1399 /* Perform the abbreviated correspondence test for operators (the
1400 arguments cannot be optional and are always ordered correctly).
1401 This is also done when comparing interfaces for dummy procedures and in
1402 procedure pointer assignments. */
1406 /* Check existence. */
1407 if (f1
== NULL
&& f2
== NULL
)
1409 if (f1
== NULL
|| f2
== NULL
)
1412 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1413 "arguments", name2
);
1417 if (UNLIMITED_POLY (f1
->sym
))
1422 /* Check all characteristics. */
1423 if (check_dummy_characteristics (f1
->sym
, f2
->sym
,
1424 true, errmsg
, err_len
) == FAILURE
)
1427 else if (!compare_type_rank (f2
->sym
, f1
->sym
))
1429 /* Only check type and rank. */
1431 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1444 /* Given a pointer to an interface pointer, remove duplicate
1445 interfaces and make sure that all symbols are either functions
1446 or subroutines, and all of the same kind. Returns nonzero if
1447 something goes wrong. */
1450 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1452 gfc_interface
*psave
, *q
, *qlast
;
1455 for (; p
; p
= p
->next
)
1457 /* Make sure all symbols in the interface have been defined as
1458 functions or subroutines. */
1459 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1460 || !p
->sym
->attr
.if_source
)
1461 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1463 if (p
->sym
->attr
.external
)
1464 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1465 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1467 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1468 "subroutine", p
->sym
->name
, interface_name
,
1469 &p
->sym
->declared_at
);
1473 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1474 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1475 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1476 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1478 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1479 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1480 " or all FUNCTIONs", interface_name
,
1481 &p
->sym
->declared_at
);
1483 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1484 "generic name is also the name of a derived type",
1485 interface_name
, &p
->sym
->declared_at
);
1489 /* F2003, C1207. F2008, C1207. */
1490 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1491 && gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1492 "'%s' in %s at %L", p
->sym
->name
, interface_name
,
1493 &p
->sym
->declared_at
) == FAILURE
)
1498 /* Remove duplicate interfaces in this interface list. */
1499 for (; p
; p
= p
->next
)
1503 for (q
= p
->next
; q
;)
1505 if (p
->sym
!= q
->sym
)
1512 /* Duplicate interface. */
1513 qlast
->next
= q
->next
;
1524 /* Check lists of interfaces to make sure that no two interfaces are
1525 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1528 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1529 int generic_flag
, const char *interface_name
,
1533 for (; p
; p
= p
->next
)
1534 for (q
= q0
; q
; q
= q
->next
)
1536 if (p
->sym
== q
->sym
)
1537 continue; /* Duplicates OK here. */
1539 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1542 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1543 && q
->sym
->attr
.flavor
!= FL_DERIVED
1544 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1545 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1548 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1549 p
->sym
->name
, q
->sym
->name
, interface_name
,
1551 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1552 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1553 p
->sym
->name
, q
->sym
->name
, interface_name
,
1556 gfc_warning ("Although not referenced, '%s' has ambiguous "
1557 "interfaces at %L", interface_name
, &p
->where
);
1565 /* Check the generic and operator interfaces of symbols to make sure
1566 that none of the interfaces conflict. The check has to be done
1567 after all of the symbols are actually loaded. */
1570 check_sym_interfaces (gfc_symbol
*sym
)
1572 char interface_name
[100];
1575 if (sym
->ns
!= gfc_current_ns
)
1578 if (sym
->generic
!= NULL
)
1580 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1581 if (check_interface0 (sym
->generic
, interface_name
))
1584 for (p
= sym
->generic
; p
; p
= p
->next
)
1586 if (p
->sym
->attr
.mod_proc
1587 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1588 || p
->sym
->attr
.procedure
))
1590 gfc_error ("'%s' at %L is not a module procedure",
1591 p
->sym
->name
, &p
->where
);
1596 /* Originally, this test was applied to host interfaces too;
1597 this is incorrect since host associated symbols, from any
1598 source, cannot be ambiguous with local symbols. */
1599 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1600 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1606 check_uop_interfaces (gfc_user_op
*uop
)
1608 char interface_name
[100];
1612 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1613 if (check_interface0 (uop
->op
, interface_name
))
1616 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1618 uop2
= gfc_find_uop (uop
->name
, ns
);
1622 check_interface1 (uop
->op
, uop2
->op
, 0,
1623 interface_name
, true);
1627 /* Given an intrinsic op, return an equivalent op if one exists,
1628 or INTRINSIC_NONE otherwise. */
1631 gfc_equivalent_op (gfc_intrinsic_op op
)
1636 return INTRINSIC_EQ_OS
;
1638 case INTRINSIC_EQ_OS
:
1639 return INTRINSIC_EQ
;
1642 return INTRINSIC_NE_OS
;
1644 case INTRINSIC_NE_OS
:
1645 return INTRINSIC_NE
;
1648 return INTRINSIC_GT_OS
;
1650 case INTRINSIC_GT_OS
:
1651 return INTRINSIC_GT
;
1654 return INTRINSIC_GE_OS
;
1656 case INTRINSIC_GE_OS
:
1657 return INTRINSIC_GE
;
1660 return INTRINSIC_LT_OS
;
1662 case INTRINSIC_LT_OS
:
1663 return INTRINSIC_LT
;
1666 return INTRINSIC_LE_OS
;
1668 case INTRINSIC_LE_OS
:
1669 return INTRINSIC_LE
;
1672 return INTRINSIC_NONE
;
1676 /* For the namespace, check generic, user operator and intrinsic
1677 operator interfaces for consistency and to remove duplicate
1678 interfaces. We traverse the whole namespace, counting on the fact
1679 that most symbols will not have generic or operator interfaces. */
1682 gfc_check_interfaces (gfc_namespace
*ns
)
1684 gfc_namespace
*old_ns
, *ns2
;
1685 char interface_name
[100];
1688 old_ns
= gfc_current_ns
;
1689 gfc_current_ns
= ns
;
1691 gfc_traverse_ns (ns
, check_sym_interfaces
);
1693 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1695 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1697 if (i
== INTRINSIC_USER
)
1700 if (i
== INTRINSIC_ASSIGN
)
1701 strcpy (interface_name
, "intrinsic assignment operator");
1703 sprintf (interface_name
, "intrinsic '%s' operator",
1704 gfc_op2string ((gfc_intrinsic_op
) i
));
1706 if (check_interface0 (ns
->op
[i
], interface_name
))
1710 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1713 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1715 gfc_intrinsic_op other_op
;
1717 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1718 interface_name
, true))
1721 /* i should be gfc_intrinsic_op, but has to be int with this cast
1722 here for stupid C++ compatibility rules. */
1723 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1724 if (other_op
!= INTRINSIC_NONE
1725 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1726 0, interface_name
, true))
1732 gfc_current_ns
= old_ns
;
1737 symbol_rank (gfc_symbol
*sym
)
1739 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
1740 return CLASS_DATA (sym
)->as
->rank
;
1742 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1746 /* Given a symbol of a formal argument list and an expression, if the
1747 formal argument is allocatable, check that the actual argument is
1748 allocatable. Returns nonzero if compatible, zero if not compatible. */
1751 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1753 symbol_attribute attr
;
1755 if (formal
->attr
.allocatable
1756 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1758 attr
= gfc_expr_attr (actual
);
1759 if (!attr
.allocatable
)
1767 /* Given a symbol of a formal argument list and an expression, if the
1768 formal argument is a pointer, see if the actual argument is a
1769 pointer. Returns nonzero if compatible, zero if not compatible. */
1772 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1774 symbol_attribute attr
;
1776 if (formal
->attr
.pointer
1777 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1778 && CLASS_DATA (formal
)->attr
.class_pointer
))
1780 attr
= gfc_expr_attr (actual
);
1782 /* Fortran 2008 allows non-pointer actual arguments. */
1783 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1794 /* Emit clear error messages for rank mismatch. */
1797 argument_rank_mismatch (const char *name
, locus
*where
,
1798 int rank1
, int rank2
)
1801 /* TS 29113, C407b. */
1804 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1805 " '%s' has assumed-rank", where
, name
);
1807 else if (rank1
== 0)
1809 gfc_error ("Rank mismatch in argument '%s' at %L "
1810 "(scalar and rank-%d)", name
, where
, rank2
);
1812 else if (rank2
== 0)
1814 gfc_error ("Rank mismatch in argument '%s' at %L "
1815 "(rank-%d and scalar)", name
, where
, rank1
);
1819 gfc_error ("Rank mismatch in argument '%s' at %L "
1820 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1825 /* Given a symbol of a formal argument list and an expression, see if
1826 the two are compatible as arguments. Returns nonzero if
1827 compatible, zero if not compatible. */
1830 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1831 int ranks_must_agree
, int is_elemental
, locus
*where
)
1834 bool rank_check
, is_pointer
;
1836 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1837 procs c_f_pointer or c_f_procpointer, and we need to accept most
1838 pointers the user could give us. This should allow that. */
1839 if (formal
->ts
.type
== BT_VOID
)
1842 if (formal
->ts
.type
== BT_DERIVED
1843 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1844 && actual
->ts
.type
== BT_DERIVED
1845 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1848 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1849 /* Make sure the vtab symbol is present when
1850 the module variables are generated. */
1851 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1853 if (actual
->ts
.type
== BT_PROCEDURE
)
1856 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1858 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1861 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1865 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1866 sizeof(err
), NULL
, NULL
))
1869 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1870 formal
->name
, &actual
->where
, err
);
1874 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1876 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1877 &act_sym
->declared_at
);
1878 if (act_sym
->ts
.type
== BT_UNKNOWN
1879 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1882 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1883 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1884 &act_sym
->declared_at
);
1890 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1891 && !gfc_is_simply_contiguous (actual
, true))
1894 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1895 "must be simply contiguous", formal
->name
, &actual
->where
);
1899 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1900 && actual
->ts
.type
!= BT_HOLLERITH
1901 && formal
->ts
.type
!= BT_ASSUMED
1902 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
1903 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
1904 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
1905 CLASS_DATA (actual
)->ts
.u
.derived
)))
1908 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1909 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1910 gfc_typename (&formal
->ts
));
1914 /* F2008, 12.5.2.5; IR F08/0073. */
1915 if (formal
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
1916 && ((CLASS_DATA (formal
)->attr
.class_pointer
1917 && !formal
->attr
.intent
== INTENT_IN
)
1918 || CLASS_DATA (formal
)->attr
.allocatable
))
1920 if (actual
->ts
.type
!= BT_CLASS
)
1923 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1924 formal
->name
, &actual
->where
);
1927 if (!gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
1928 CLASS_DATA (formal
)->ts
.u
.derived
))
1931 gfc_error ("Actual argument to '%s' at %L must have the same "
1932 "declared type", formal
->name
, &actual
->where
);
1937 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
1938 is necessary also for F03, so retain error for both.
1939 NOTE: Other type/kind errors pre-empt this error. Since they are F03
1940 compatible, no attempt has been made to channel to this one. */
1941 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
1942 && (CLASS_DATA (formal
)->attr
.allocatable
1943 ||CLASS_DATA (formal
)->attr
.class_pointer
))
1946 gfc_error ("Actual argument to '%s' at %L must be unlimited "
1947 "polymorphic since the formal argument is a "
1948 "pointer or allocatable unlimited polymorphic "
1949 "entity [F2008: 12.5.2.5]", formal
->name
,
1954 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
1957 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1958 formal
->name
, &actual
->where
);
1962 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
1964 gfc_ref
*last
= NULL
;
1966 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1967 if (ref
->type
== REF_COMPONENT
)
1970 /* F2008, 12.5.2.6. */
1971 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1973 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
1976 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1977 formal
->name
, &actual
->where
, formal
->as
->corank
,
1978 last
? last
->u
.c
.component
->as
->corank
1979 : actual
->symtree
->n
.sym
->as
->corank
);
1984 if (formal
->attr
.codimension
)
1986 /* F2008, 12.5.2.8. */
1987 if (formal
->attr
.dimension
1988 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1989 && gfc_expr_attr (actual
).dimension
1990 && !gfc_is_simply_contiguous (actual
, true))
1993 gfc_error ("Actual argument to '%s' at %L must be simply "
1994 "contiguous", formal
->name
, &actual
->where
);
1998 /* F2008, C1303 and C1304. */
1999 if (formal
->attr
.intent
!= INTENT_INOUT
2000 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2001 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2002 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2003 || formal
->attr
.lock_comp
))
2007 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
2008 "which is LOCK_TYPE or has a LOCK_TYPE component",
2009 formal
->name
, &actual
->where
);
2014 /* F2008, C1239/C1240. */
2015 if (actual
->expr_type
== EXPR_VARIABLE
2016 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2017 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2018 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2019 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
2020 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
2021 || formal
->attr
.contiguous
))
2024 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
2025 "array without CONTIGUOUS attribute - as actual argument at"
2026 " %L is not simply contiguous and both are ASYNCHRONOUS "
2027 "or VOLATILE", formal
->name
, &actual
->where
);
2031 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2032 && gfc_expr_attr (actual
).codimension
)
2034 if (formal
->attr
.intent
== INTENT_OUT
)
2037 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2038 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
2042 else if (gfc_option
.warn_surprising
&& where
2043 && formal
->attr
.intent
!= INTENT_IN
)
2044 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2045 "argument '%s', which is invalid if the allocation status"
2046 " is modified", &actual
->where
, formal
->name
);
2049 /* If the rank is the same or the formal argument has assumed-rank. */
2050 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2053 if (actual
->ts
.type
== BT_CLASS
&& CLASS_DATA (actual
)->as
2054 && CLASS_DATA (actual
)->as
->rank
== symbol_rank (formal
))
2057 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2058 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2059 || formal
->as
->type
== AS_DEFERRED
)
2060 && actual
->expr_type
!= EXPR_NULL
;
2062 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2063 if (rank_check
|| ranks_must_agree
2064 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2065 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2066 || (actual
->rank
== 0
2067 && ((formal
->ts
.type
== BT_CLASS
2068 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2069 || (formal
->ts
.type
!= BT_CLASS
2070 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2071 && actual
->expr_type
!= EXPR_NULL
)
2072 || (actual
->rank
== 0 && formal
->attr
.dimension
2073 && gfc_is_coindexed (actual
)))
2076 argument_rank_mismatch (formal
->name
, &actual
->where
,
2077 symbol_rank (formal
), actual
->rank
);
2080 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2083 /* At this point, we are considering a scalar passed to an array. This
2084 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2085 - if the actual argument is (a substring of) an element of a
2086 non-assumed-shape/non-pointer/non-polymorphic array; or
2087 - (F2003) if the actual argument is of type character of default/c_char
2090 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2091 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2093 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2095 if (ref
->type
== REF_COMPONENT
)
2096 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2097 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2098 && ref
->u
.ar
.dimen
> 0
2100 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2104 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2107 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2108 "at %L", formal
->name
, &actual
->where
);
2112 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2113 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2116 gfc_error ("Element of assumed-shaped or pointer "
2117 "array passed to array dummy argument '%s' at %L",
2118 formal
->name
, &actual
->where
);
2122 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2123 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2125 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2128 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2129 "CHARACTER actual argument with array dummy argument "
2130 "'%s' at %L", formal
->name
, &actual
->where
);
2134 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2136 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2137 "array dummy argument '%s' at %L",
2138 formal
->name
, &actual
->where
);
2141 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2147 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2150 argument_rank_mismatch (formal
->name
, &actual
->where
,
2151 symbol_rank (formal
), actual
->rank
);
2159 /* Returns the storage size of a symbol (formal argument) or
2160 zero if it cannot be determined. */
2162 static unsigned long
2163 get_sym_storage_size (gfc_symbol
*sym
)
2166 unsigned long strlen
, elements
;
2168 if (sym
->ts
.type
== BT_CHARACTER
)
2170 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2171 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2172 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2179 if (symbol_rank (sym
) == 0)
2183 if (sym
->as
->type
!= AS_EXPLICIT
)
2185 for (i
= 0; i
< sym
->as
->rank
; i
++)
2187 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2188 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2191 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2192 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2195 return strlen
*elements
;
2199 /* Returns the storage size of an expression (actual argument) or
2200 zero if it cannot be determined. For an array element, it returns
2201 the remaining size as the element sequence consists of all storage
2202 units of the actual argument up to the end of the array. */
2204 static unsigned long
2205 get_expr_storage_size (gfc_expr
*e
)
2208 long int strlen
, elements
;
2209 long int substrlen
= 0;
2210 bool is_str_storage
= false;
2216 if (e
->ts
.type
== BT_CHARACTER
)
2218 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2219 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2220 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2221 else if (e
->expr_type
== EXPR_CONSTANT
2222 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2223 strlen
= e
->value
.character
.length
;
2228 strlen
= 1; /* Length per element. */
2230 if (e
->rank
== 0 && !e
->ref
)
2238 for (i
= 0; i
< e
->rank
; i
++)
2239 elements
*= mpz_get_si (e
->shape
[i
]);
2240 return elements
*strlen
;
2243 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2245 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2246 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2250 /* The string length is the substring length.
2251 Set now to full string length. */
2252 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2253 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2256 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2258 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2262 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2263 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2265 long int start
, end
, stride
;
2268 if (ref
->u
.ar
.stride
[i
])
2270 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2271 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2276 if (ref
->u
.ar
.start
[i
])
2278 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2279 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2283 else if (ref
->u
.ar
.as
->lower
[i
]
2284 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2285 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2289 if (ref
->u
.ar
.end
[i
])
2291 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2292 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2296 else if (ref
->u
.ar
.as
->upper
[i
]
2297 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2298 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2302 elements
*= (end
- start
)/stride
+ 1L;
2304 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2305 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2307 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2308 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2309 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2310 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2311 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2316 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2317 && e
->expr_type
== EXPR_VARIABLE
)
2319 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2320 || e
->symtree
->n
.sym
->attr
.pointer
)
2326 /* Determine the number of remaining elements in the element
2327 sequence for array element designators. */
2328 is_str_storage
= true;
2329 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2331 if (ref
->u
.ar
.start
[i
] == NULL
2332 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2333 || ref
->u
.ar
.as
->upper
[i
] == NULL
2334 || ref
->u
.ar
.as
->lower
[i
] == NULL
2335 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2336 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2341 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2342 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2344 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2345 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2351 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2354 return elements
*strlen
;
2358 /* Given an expression, check whether it is an array section
2359 which has a vector subscript. If it has, one is returned,
2363 gfc_has_vector_subscript (gfc_expr
*e
)
2368 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2371 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2372 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2373 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2374 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2381 /* Given formal and actual argument lists, see if they are compatible.
2382 If they are compatible, the actual argument list is sorted to
2383 correspond with the formal list, and elements for missing optional
2384 arguments are inserted. If WHERE pointer is nonnull, then we issue
2385 errors when things don't match instead of just returning the status
2389 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2390 int ranks_must_agree
, int is_elemental
, locus
*where
)
2392 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2393 gfc_formal_arglist
*f
;
2395 unsigned long actual_size
, formal_size
;
2396 bool full_array
= false;
2400 if (actual
== NULL
&& formal
== NULL
)
2404 for (f
= formal
; f
; f
= f
->next
)
2407 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2409 for (i
= 0; i
< n
; i
++)
2416 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2418 /* Look for keywords but ignore g77 extensions like %VAL. */
2419 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2422 for (f
= formal
; f
; f
= f
->next
, i
++)
2426 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2433 gfc_error ("Keyword argument '%s' at %L is not in "
2434 "the procedure", a
->name
, &a
->expr
->where
);
2438 if (new_arg
[i
] != NULL
)
2441 gfc_error ("Keyword argument '%s' at %L is already associated "
2442 "with another actual argument", a
->name
,
2451 gfc_error ("More actual than formal arguments in procedure "
2452 "call at %L", where
);
2457 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2463 gfc_error ("Missing alternate return spec in subroutine call "
2468 if (a
->expr
== NULL
)
2471 gfc_error ("Unexpected alternate return spec in subroutine "
2472 "call at %L", where
);
2476 /* Make sure that intrinsic vtables exist for calls to unlimited
2477 polymorphic formal arguments. */
2478 if (UNLIMITED_POLY(f
->sym
)
2479 && a
->expr
->ts
.type
!= BT_DERIVED
2480 && a
->expr
->ts
.type
!= BT_CLASS
)
2481 gfc_find_intrinsic_vtab (&a
->expr
->ts
);
2483 if (a
->expr
->expr_type
== EXPR_NULL
2484 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2485 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2486 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2487 || (f
->sym
->ts
.type
== BT_CLASS
2488 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2489 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2490 || !f
->sym
->attr
.optional
2491 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2494 && (!f
->sym
->attr
.optional
2495 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2496 || (f
->sym
->ts
.type
== BT_CLASS
2497 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2498 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2499 where
, f
->sym
->name
);
2501 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2502 "dummy '%s'", where
, f
->sym
->name
);
2507 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2508 is_elemental
, where
))
2511 /* TS 29113, 6.3p2. */
2512 if (f
->sym
->ts
.type
== BT_ASSUMED
2513 && (a
->expr
->ts
.type
== BT_DERIVED
2514 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2516 gfc_namespace
*f2k_derived
;
2518 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2519 ? a
->expr
->ts
.u
.derived
->f2k_derived
2520 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2523 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2525 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2526 "derived type with type-bound or FINAL procedures",
2532 /* Special case for character arguments. For allocatable, pointer
2533 and assumed-shape dummies, the string length needs to match
2535 if (a
->expr
->ts
.type
== BT_CHARACTER
2536 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2537 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2538 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2539 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2540 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2541 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2542 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2543 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2545 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2546 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2547 "argument and pointer or allocatable dummy argument "
2549 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2550 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2551 f
->sym
->name
, &a
->expr
->where
);
2553 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2554 "argument and assumed-shape dummy argument '%s' "
2556 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2557 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2558 f
->sym
->name
, &a
->expr
->where
);
2562 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2563 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2564 && a
->expr
->ts
.type
== BT_CHARACTER
)
2567 gfc_error ("Actual argument at %L to allocatable or "
2568 "pointer dummy argument '%s' must have a deferred "
2569 "length type parameter if and only if the dummy has one",
2570 &a
->expr
->where
, f
->sym
->name
);
2574 if (f
->sym
->ts
.type
== BT_CLASS
)
2575 goto skip_size_check
;
2577 actual_size
= get_expr_storage_size (a
->expr
);
2578 formal_size
= get_sym_storage_size (f
->sym
);
2579 if (actual_size
!= 0 && actual_size
< formal_size
2580 && a
->expr
->ts
.type
!= BT_PROCEDURE
2581 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2583 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2584 gfc_warning ("Character length of actual argument shorter "
2585 "than of dummy argument '%s' (%lu/%lu) at %L",
2586 f
->sym
->name
, actual_size
, formal_size
,
2589 gfc_warning ("Actual argument contains too few "
2590 "elements for dummy argument '%s' (%lu/%lu) at %L",
2591 f
->sym
->name
, actual_size
, formal_size
,
2598 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2599 argument is provided for a procedure pointer formal argument. */
2600 if (f
->sym
->attr
.proc_pointer
2601 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2602 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2603 || (a
->expr
->expr_type
== EXPR_FUNCTION
2604 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2605 || gfc_is_proc_ptr_comp (a
->expr
)))
2608 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2609 f
->sym
->name
, &a
->expr
->where
);
2613 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2614 provided for a procedure formal argument. */
2615 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2616 && gfc_expr_attr (a
->expr
).flavor
!= FL_PROCEDURE
)
2619 gfc_error ("Expected a procedure for argument '%s' at %L",
2620 f
->sym
->name
, &a
->expr
->where
);
2624 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2625 && a
->expr
->expr_type
== EXPR_VARIABLE
2626 && a
->expr
->symtree
->n
.sym
->as
2627 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2628 && (a
->expr
->ref
== NULL
2629 || (a
->expr
->ref
->type
== REF_ARRAY
2630 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2633 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2634 " array at %L", f
->sym
->name
, where
);
2638 if (a
->expr
->expr_type
!= EXPR_NULL
2639 && compare_pointer (f
->sym
, a
->expr
) == 0)
2642 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2643 f
->sym
->name
, &a
->expr
->where
);
2647 if (a
->expr
->expr_type
!= EXPR_NULL
2648 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2649 && compare_pointer (f
->sym
, a
->expr
) == 2)
2652 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2653 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2658 /* Fortran 2008, C1242. */
2659 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2662 gfc_error ("Coindexed actual argument at %L to pointer "
2664 &a
->expr
->where
, f
->sym
->name
);
2668 /* Fortran 2008, 12.5.2.5 (no constraint). */
2669 if (a
->expr
->expr_type
== EXPR_VARIABLE
2670 && f
->sym
->attr
.intent
!= INTENT_IN
2671 && f
->sym
->attr
.allocatable
2672 && gfc_is_coindexed (a
->expr
))
2675 gfc_error ("Coindexed actual argument at %L to allocatable "
2676 "dummy '%s' requires INTENT(IN)",
2677 &a
->expr
->where
, f
->sym
->name
);
2681 /* Fortran 2008, C1237. */
2682 if (a
->expr
->expr_type
== EXPR_VARIABLE
2683 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2684 && gfc_is_coindexed (a
->expr
)
2685 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2686 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2689 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2690 "%L requires that dummy '%s' has neither "
2691 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2696 /* Fortran 2008, 12.5.2.4 (no constraint). */
2697 if (a
->expr
->expr_type
== EXPR_VARIABLE
2698 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2699 && gfc_is_coindexed (a
->expr
)
2700 && gfc_has_ultimate_allocatable (a
->expr
))
2703 gfc_error ("Coindexed actual argument at %L with allocatable "
2704 "ultimate component to dummy '%s' requires either VALUE "
2705 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2709 if (f
->sym
->ts
.type
== BT_CLASS
2710 && CLASS_DATA (f
->sym
)->attr
.allocatable
2711 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2715 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2716 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2721 if (a
->expr
->expr_type
!= EXPR_NULL
2722 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2725 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2726 f
->sym
->name
, &a
->expr
->where
);
2730 /* Check intent = OUT/INOUT for definable actual argument. */
2731 if ((f
->sym
->attr
.intent
== INTENT_OUT
2732 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2734 const char* context
= (where
2735 ? _("actual argument to INTENT = OUT/INOUT")
2738 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2739 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2740 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2741 && gfc_check_vardef_context (a
->expr
, true, false, false, context
)
2744 if (gfc_check_vardef_context (a
->expr
, false, false, false, context
)
2749 if ((f
->sym
->attr
.intent
== INTENT_OUT
2750 || f
->sym
->attr
.intent
== INTENT_INOUT
2751 || f
->sym
->attr
.volatile_
2752 || f
->sym
->attr
.asynchronous
)
2753 && gfc_has_vector_subscript (a
->expr
))
2756 gfc_error ("Array-section actual argument with vector "
2757 "subscripts at %L is incompatible with INTENT(OUT), "
2758 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2759 "of the dummy argument '%s'",
2760 &a
->expr
->where
, f
->sym
->name
);
2764 /* C1232 (R1221) For an actual argument which is an array section or
2765 an assumed-shape array, the dummy argument shall be an assumed-
2766 shape array, if the dummy argument has the VOLATILE attribute. */
2768 if (f
->sym
->attr
.volatile_
2769 && a
->expr
->symtree
->n
.sym
->as
2770 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2771 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2774 gfc_error ("Assumed-shape actual argument at %L is "
2775 "incompatible with the non-assumed-shape "
2776 "dummy argument '%s' due to VOLATILE attribute",
2777 &a
->expr
->where
,f
->sym
->name
);
2781 if (f
->sym
->attr
.volatile_
2782 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2783 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2786 gfc_error ("Array-section actual argument at %L is "
2787 "incompatible with the non-assumed-shape "
2788 "dummy argument '%s' due to VOLATILE attribute",
2789 &a
->expr
->where
,f
->sym
->name
);
2793 /* C1233 (R1221) For an actual argument which is a pointer array, the
2794 dummy argument shall be an assumed-shape or pointer array, if the
2795 dummy argument has the VOLATILE attribute. */
2797 if (f
->sym
->attr
.volatile_
2798 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2799 && a
->expr
->symtree
->n
.sym
->as
2801 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2802 || f
->sym
->attr
.pointer
)))
2805 gfc_error ("Pointer-array actual argument at %L requires "
2806 "an assumed-shape or pointer-array dummy "
2807 "argument '%s' due to VOLATILE attribute",
2808 &a
->expr
->where
,f
->sym
->name
);
2819 /* Make sure missing actual arguments are optional. */
2821 for (f
= formal
; f
; f
= f
->next
, i
++)
2823 if (new_arg
[i
] != NULL
)
2828 gfc_error ("Missing alternate return spec in subroutine call "
2832 if (!f
->sym
->attr
.optional
)
2835 gfc_error ("Missing actual argument for argument '%s' at %L",
2836 f
->sym
->name
, where
);
2841 /* The argument lists are compatible. We now relink a new actual
2842 argument list with null arguments in the right places. The head
2843 of the list remains the head. */
2844 for (i
= 0; i
< n
; i
++)
2845 if (new_arg
[i
] == NULL
)
2846 new_arg
[i
] = gfc_get_actual_arglist ();
2851 *new_arg
[0] = *actual
;
2855 new_arg
[0] = new_arg
[na
];
2859 for (i
= 0; i
< n
- 1; i
++)
2860 new_arg
[i
]->next
= new_arg
[i
+ 1];
2862 new_arg
[i
]->next
= NULL
;
2864 if (*ap
== NULL
&& n
> 0)
2867 /* Note the types of omitted optional arguments. */
2868 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2869 if (a
->expr
== NULL
&& a
->label
== NULL
)
2870 a
->missing_arg_type
= f
->sym
->ts
.type
;
2878 gfc_formal_arglist
*f
;
2879 gfc_actual_arglist
*a
;
2883 /* qsort comparison function for argument pairs, with the following
2885 - p->a->expr == NULL
2886 - p->a->expr->expr_type != EXPR_VARIABLE
2887 - growing p->a->expr->symbol. */
2890 pair_cmp (const void *p1
, const void *p2
)
2892 const gfc_actual_arglist
*a1
, *a2
;
2894 /* *p1 and *p2 are elements of the to-be-sorted array. */
2895 a1
= ((const argpair
*) p1
)->a
;
2896 a2
= ((const argpair
*) p2
)->a
;
2905 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2907 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2911 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2913 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2917 /* Given two expressions from some actual arguments, test whether they
2918 refer to the same expression. The analysis is conservative.
2919 Returning FAILURE will produce no warning. */
2922 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2924 const gfc_ref
*r1
, *r2
;
2927 || e1
->expr_type
!= EXPR_VARIABLE
2928 || e2
->expr_type
!= EXPR_VARIABLE
2929 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2932 /* TODO: improve comparison, see expr.c:show_ref(). */
2933 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2935 if (r1
->type
!= r2
->type
)
2940 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2942 /* TODO: At the moment, consider only full arrays;
2943 we could do better. */
2944 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2949 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2957 gfc_internal_error ("compare_actual_expr(): Bad component code");
2966 /* Given formal and actual argument lists that correspond to one
2967 another, check that identical actual arguments aren't not
2968 associated with some incompatible INTENTs. */
2971 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2973 sym_intent f1_intent
, f2_intent
;
2974 gfc_formal_arglist
*f1
;
2975 gfc_actual_arglist
*a1
;
2978 gfc_try t
= SUCCESS
;
2981 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2983 if (f1
== NULL
&& a1
== NULL
)
2985 if (f1
== NULL
|| a1
== NULL
)
2986 gfc_internal_error ("check_some_aliasing(): List mismatch");
2991 p
= XALLOCAVEC (argpair
, n
);
2993 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2999 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3001 for (i
= 0; i
< n
; i
++)
3004 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3005 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3007 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3008 for (j
= i
+ 1; j
< n
; j
++)
3010 /* Expected order after the sort. */
3011 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3012 gfc_internal_error ("check_some_aliasing(): corrupted data");
3014 /* Are the expression the same? */
3015 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
3017 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3018 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3019 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
3021 gfc_warning ("Same actual argument associated with INTENT(%s) "
3022 "argument '%s' and INTENT(%s) argument '%s' at %L",
3023 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3024 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3025 &p
[i
].a
->expr
->where
);
3035 /* Given formal and actual argument lists that correspond to one
3036 another, check that they are compatible in the sense that intents
3037 are not mismatched. */
3040 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3042 sym_intent f_intent
;
3044 for (;; f
= f
->next
, a
= a
->next
)
3046 if (f
== NULL
&& a
== NULL
)
3048 if (f
== NULL
|| a
== NULL
)
3049 gfc_internal_error ("check_intents(): List mismatch");
3051 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
3054 f_intent
= f
->sym
->attr
.intent
;
3056 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
3058 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3059 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3060 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3062 gfc_error ("Procedure argument at %L is local to a PURE "
3063 "procedure and has the POINTER attribute",
3069 /* Fortran 2008, C1283. */
3070 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
3072 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3074 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3075 "is passed to an INTENT(%s) argument",
3076 &a
->expr
->where
, gfc_intent_string (f_intent
));
3080 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3081 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3082 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3084 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3085 "is passed to a POINTER dummy argument",
3091 /* F2008, Section 12.5.2.4. */
3092 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3093 && gfc_is_coindexed (a
->expr
))
3095 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3096 "polymorphic dummy argument '%s'",
3097 &a
->expr
->where
, f
->sym
->name
);
3106 /* Check how a procedure is used against its interface. If all goes
3107 well, the actual argument list will also end up being properly
3111 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3113 gfc_formal_arglist
*dummy_args
;
3115 /* Warn about calls with an implicit interface. Special case
3116 for calling a ISO_C_BINDING becase c_loc and c_funloc
3117 are pseudo-unknown. Additionally, warn about procedures not
3118 explicitly declared at all if requested. */
3119 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
3121 if (gfc_option
.warn_implicit_interface
)
3122 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3124 else if (gfc_option
.warn_implicit_procedure
3125 && sym
->attr
.proc
== PROC_UNKNOWN
)
3126 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3130 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3132 gfc_actual_arglist
*a
;
3134 if (sym
->attr
.pointer
)
3136 gfc_error("The pointer object '%s' at %L must have an explicit "
3137 "function interface or be declared as array",
3142 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3144 gfc_error("The allocatable object '%s' at %L must have an explicit "
3145 "function interface or be declared as array",
3150 if (sym
->attr
.allocatable
)
3152 gfc_error("Allocatable function '%s' at %L must have an explicit "
3153 "function interface", sym
->name
, where
);
3157 for (a
= *ap
; a
; a
= a
->next
)
3159 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3160 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3162 gfc_error("Keyword argument requires explicit interface "
3163 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
3167 /* TS 29113, 6.2. */
3168 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3169 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3171 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3172 "interface", a
->expr
->symtree
->n
.sym
->name
,
3177 /* F2008, C1303 and C1304. */
3179 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3180 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3181 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3182 || gfc_expr_attr (a
->expr
).lock_comp
))
3184 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3185 "component at %L requires an explicit interface for "
3186 "procedure '%s'", &a
->expr
->where
, sym
->name
);
3190 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3191 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3193 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3197 /* TS 29113, C407b. */
3198 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3199 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3201 gfc_error ("Assumed-rank argument requires an explicit interface "
3202 "at %L", &a
->expr
->where
);
3210 dummy_args
= gfc_sym_get_dummy_args (sym
);
3212 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3215 if (check_intents (dummy_args
, *ap
) == FAILURE
)
3218 if (gfc_option
.warn_aliasing
)
3219 check_some_aliasing (dummy_args
, *ap
);
3225 /* Check how a procedure pointer component is used against its interface.
3226 If all goes well, the actual argument list will also end up being properly
3227 sorted. Completely analogous to gfc_procedure_use. */
3230 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3232 /* Warn about calls with an implicit interface. Special case
3233 for calling a ISO_C_BINDING becase c_loc and c_funloc
3234 are pseudo-unknown. */
3235 if (gfc_option
.warn_implicit_interface
3236 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3237 && !comp
->attr
.is_iso_c
)
3238 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3239 "interface at %L", comp
->name
, where
);
3241 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3243 gfc_actual_arglist
*a
;
3244 for (a
= *ap
; a
; a
= a
->next
)
3246 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3247 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3249 gfc_error("Keyword argument requires explicit interface "
3250 "for procedure pointer component '%s' at %L",
3251 comp
->name
, &a
->expr
->where
);
3259 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3260 comp
->attr
.elemental
, where
))
3263 check_intents (comp
->ts
.interface
->formal
, *ap
);
3264 if (gfc_option
.warn_aliasing
)
3265 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3269 /* Try if an actual argument list matches the formal list of a symbol,
3270 respecting the symbol's attributes like ELEMENTAL. This is used for
3271 GENERIC resolution. */
3274 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3276 gfc_formal_arglist
*dummy_args
;
3279 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3281 dummy_args
= gfc_sym_get_dummy_args (sym
);
3283 r
= !sym
->attr
.elemental
;
3284 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3286 check_intents (dummy_args
, *args
);
3287 if (gfc_option
.warn_aliasing
)
3288 check_some_aliasing (dummy_args
, *args
);
3296 /* Given an interface pointer and an actual argument list, search for
3297 a formal argument list that matches the actual. If found, returns
3298 a pointer to the symbol of the correct interface. Returns NULL if
3302 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3303 gfc_actual_arglist
**ap
)
3305 gfc_symbol
*elem_sym
= NULL
;
3306 gfc_symbol
*null_sym
= NULL
;
3307 locus null_expr_loc
;
3308 gfc_actual_arglist
*a
;
3309 bool has_null_arg
= false;
3311 for (a
= *ap
; a
; a
= a
->next
)
3312 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3313 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3315 has_null_arg
= true;
3316 null_expr_loc
= a
->expr
->where
;
3320 for (; intr
; intr
= intr
->next
)
3322 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3324 if (sub_flag
&& intr
->sym
->attr
.function
)
3326 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3329 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3331 if (has_null_arg
&& null_sym
)
3333 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3334 "between specific functions %s and %s",
3335 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3338 else if (has_null_arg
)
3340 null_sym
= intr
->sym
;
3344 /* Satisfy 12.4.4.1 such that an elemental match has lower
3345 weight than a non-elemental match. */
3346 if (intr
->sym
->attr
.elemental
)
3348 elem_sym
= intr
->sym
;
3358 return elem_sym
? elem_sym
: NULL
;
3362 /* Do a brute force recursive search for a symbol. */
3364 static gfc_symtree
*
3365 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3369 if (root
->n
.sym
== sym
)
3374 st
= find_symtree0 (root
->left
, sym
);
3375 if (root
->right
&& ! st
)
3376 st
= find_symtree0 (root
->right
, sym
);
3381 /* Find a symtree for a symbol. */
3384 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3389 /* First try to find it by name. */
3390 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3391 if (st
&& st
->n
.sym
== sym
)
3394 /* If it's been renamed, resort to a brute-force search. */
3395 /* TODO: avoid having to do this search. If the symbol doesn't exist
3396 in the symtree for the current namespace, it should probably be added. */
3397 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3399 st
= find_symtree0 (ns
->sym_root
, sym
);
3403 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3408 /* See if the arglist to an operator-call contains a derived-type argument
3409 with a matching type-bound operator. If so, return the matching specific
3410 procedure defined as operator-target as well as the base-object to use
3411 (which is the found derived-type argument with operator). The generic
3412 name, if any, is transmitted to the final expression via 'gname'. */
3414 static gfc_typebound_proc
*
3415 matching_typebound_op (gfc_expr
** tb_base
,
3416 gfc_actual_arglist
* args
,
3417 gfc_intrinsic_op op
, const char* uop
,
3418 const char ** gname
)
3420 gfc_actual_arglist
* base
;
3422 for (base
= args
; base
; base
= base
->next
)
3423 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3425 gfc_typebound_proc
* tb
;
3426 gfc_symbol
* derived
;
3429 while (base
->expr
->expr_type
== EXPR_OP
3430 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3431 base
->expr
= base
->expr
->value
.op
.op1
;
3433 if (base
->expr
->ts
.type
== BT_CLASS
)
3435 if (CLASS_DATA (base
->expr
) == NULL
3436 || !gfc_expr_attr (base
->expr
).class_ok
)
3438 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3441 derived
= base
->expr
->ts
.u
.derived
;
3443 if (op
== INTRINSIC_USER
)
3445 gfc_symtree
* tb_uop
;
3448 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3457 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3460 /* This means we hit a PRIVATE operator which is use-associated and
3461 should thus not be seen. */
3462 if (result
== FAILURE
)
3465 /* Look through the super-type hierarchy for a matching specific
3467 for (; tb
; tb
= tb
->overridden
)
3471 gcc_assert (tb
->is_generic
);
3472 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3475 gfc_actual_arglist
* argcopy
;
3478 gcc_assert (g
->specific
);
3479 if (g
->specific
->error
)
3482 target
= g
->specific
->u
.specific
->n
.sym
;
3484 /* Check if this arglist matches the formal. */
3485 argcopy
= gfc_copy_actual_arglist (args
);
3486 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3487 gfc_free_actual_arglist (argcopy
);
3489 /* Return if we found a match. */
3492 *tb_base
= base
->expr
;
3493 *gname
= g
->specific_st
->name
;
3504 /* For the 'actual arglist' of an operator call and a specific typebound
3505 procedure that has been found the target of a type-bound operator, build the
3506 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3507 type-bound procedures rather than resolving type-bound operators 'directly'
3508 so that we can reuse the existing logic. */
3511 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3512 gfc_expr
* base
, gfc_typebound_proc
* target
,
3515 e
->expr_type
= EXPR_COMPCALL
;
3516 e
->value
.compcall
.tbp
= target
;
3517 e
->value
.compcall
.name
= gname
? gname
: "$op";
3518 e
->value
.compcall
.actual
= actual
;
3519 e
->value
.compcall
.base_object
= base
;
3520 e
->value
.compcall
.ignore_pass
= 1;
3521 e
->value
.compcall
.assign
= 0;
3522 if (e
->ts
.type
== BT_UNKNOWN
3523 && target
->function
)
3525 if (target
->is_generic
)
3526 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3528 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3533 /* This subroutine is called when an expression is being resolved.
3534 The expression node in question is either a user defined operator
3535 or an intrinsic operator with arguments that aren't compatible
3536 with the operator. This subroutine builds an actual argument list
3537 corresponding to the operands, then searches for a compatible
3538 interface. If one is found, the expression node is replaced with
3539 the appropriate function call. We use the 'match' enum to specify
3540 whether a replacement has been made or not, or if an error occurred. */
3543 gfc_extend_expr (gfc_expr
*e
)
3545 gfc_actual_arglist
*actual
;
3554 actual
= gfc_get_actual_arglist ();
3555 actual
->expr
= e
->value
.op
.op1
;
3559 if (e
->value
.op
.op2
!= NULL
)
3561 actual
->next
= gfc_get_actual_arglist ();
3562 actual
->next
->expr
= e
->value
.op
.op2
;
3565 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3567 if (i
== INTRINSIC_USER
)
3569 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3571 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3575 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3582 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3584 /* Due to the distinction between '==' and '.eq.' and friends, one has
3585 to check if either is defined. */
3588 #define CHECK_OS_COMPARISON(comp) \
3589 case INTRINSIC_##comp: \
3590 case INTRINSIC_##comp##_OS: \
3591 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3593 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3595 CHECK_OS_COMPARISON(EQ
)
3596 CHECK_OS_COMPARISON(NE
)
3597 CHECK_OS_COMPARISON(GT
)
3598 CHECK_OS_COMPARISON(GE
)
3599 CHECK_OS_COMPARISON(LT
)
3600 CHECK_OS_COMPARISON(LE
)
3601 #undef CHECK_OS_COMPARISON
3604 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3612 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3613 found rather than just taking the first one and not checking further. */
3617 gfc_typebound_proc
* tbo
;
3620 /* See if we find a matching type-bound operator. */
3621 if (i
== INTRINSIC_USER
)
3622 tbo
= matching_typebound_op (&tb_base
, actual
,
3623 i
, e
->value
.op
.uop
->name
, &gname
);
3627 #define CHECK_OS_COMPARISON(comp) \
3628 case INTRINSIC_##comp: \
3629 case INTRINSIC_##comp##_OS: \
3630 tbo = matching_typebound_op (&tb_base, actual, \
3631 INTRINSIC_##comp, NULL, &gname); \
3633 tbo = matching_typebound_op (&tb_base, actual, \
3634 INTRINSIC_##comp##_OS, NULL, &gname); \
3636 CHECK_OS_COMPARISON(EQ
)
3637 CHECK_OS_COMPARISON(NE
)
3638 CHECK_OS_COMPARISON(GT
)
3639 CHECK_OS_COMPARISON(GE
)
3640 CHECK_OS_COMPARISON(LT
)
3641 CHECK_OS_COMPARISON(LE
)
3642 #undef CHECK_OS_COMPARISON
3645 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3649 /* If there is a matching typebound-operator, replace the expression with
3650 a call to it and succeed. */
3655 gcc_assert (tb_base
);
3656 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3658 result
= gfc_resolve_expr (e
);
3659 if (result
== FAILURE
)
3665 /* Don't use gfc_free_actual_arglist(). */
3666 free (actual
->next
);
3672 /* Change the expression node to a function call. */
3673 e
->expr_type
= EXPR_FUNCTION
;
3674 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3675 e
->value
.function
.actual
= actual
;
3676 e
->value
.function
.esym
= NULL
;
3677 e
->value
.function
.isym
= NULL
;
3678 e
->value
.function
.name
= NULL
;
3679 e
->user_operator
= 1;
3681 if (gfc_resolve_expr (e
) == FAILURE
)
3688 /* Tries to replace an assignment code node with a subroutine call to
3689 the subroutine associated with the assignment operator. Return
3690 SUCCESS if the node was replaced. On FAILURE, no error is
3694 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3696 gfc_actual_arglist
*actual
;
3697 gfc_expr
*lhs
, *rhs
;
3706 /* Don't allow an intrinsic assignment to be replaced. */
3707 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3708 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3709 && (lhs
->ts
.type
== rhs
->ts
.type
3710 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3713 actual
= gfc_get_actual_arglist ();
3716 actual
->next
= gfc_get_actual_arglist ();
3717 actual
->next
->expr
= rhs
;
3721 for (; ns
; ns
= ns
->parent
)
3723 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3728 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3732 gfc_typebound_proc
* tbo
;
3735 /* See if we find a matching type-bound assignment. */
3736 tbo
= matching_typebound_op (&tb_base
, actual
,
3737 INTRINSIC_ASSIGN
, NULL
, &gname
);
3739 /* If there is one, replace the expression with a call to it and
3743 gcc_assert (tb_base
);
3744 c
->expr1
= gfc_get_expr ();
3745 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3746 c
->expr1
->value
.compcall
.assign
= 1;
3747 c
->expr1
->where
= c
->loc
;
3749 c
->op
= EXEC_COMPCALL
;
3751 /* c is resolved from the caller, so no need to do it here. */
3756 free (actual
->next
);
3761 /* Replace the assignment with the call. */
3762 c
->op
= EXEC_ASSIGN_CALL
;
3763 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3766 c
->ext
.actual
= actual
;
3772 /* Make sure that the interface just parsed is not already present in
3773 the given interface list. Ambiguity isn't checked yet since module
3774 procedures can be present without interfaces. */
3777 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3781 for (ip
= base
; ip
; ip
= ip
->next
)
3783 if (ip
->sym
== new_sym
)
3785 gfc_error ("Entity '%s' at %L is already present in the interface",
3786 new_sym
->name
, &loc
);
3795 /* Add a symbol to the current interface. */
3798 gfc_add_interface (gfc_symbol
*new_sym
)
3800 gfc_interface
**head
, *intr
;
3804 switch (current_interface
.type
)
3806 case INTERFACE_NAMELESS
:
3807 case INTERFACE_ABSTRACT
:
3810 case INTERFACE_INTRINSIC_OP
:
3811 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3812 switch (current_interface
.op
)
3815 case INTRINSIC_EQ_OS
:
3816 if (gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3817 gfc_current_locus
) == FAILURE
3818 || gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
,
3819 gfc_current_locus
) == FAILURE
)
3824 case INTRINSIC_NE_OS
:
3825 if (gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3826 gfc_current_locus
) == FAILURE
3827 || gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
,
3828 gfc_current_locus
) == FAILURE
)
3833 case INTRINSIC_GT_OS
:
3834 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
,
3835 gfc_current_locus
) == FAILURE
3836 || gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
,
3837 gfc_current_locus
) == FAILURE
)
3842 case INTRINSIC_GE_OS
:
3843 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
,
3844 gfc_current_locus
) == FAILURE
3845 || gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
,
3846 gfc_current_locus
) == FAILURE
)
3851 case INTRINSIC_LT_OS
:
3852 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
,
3853 gfc_current_locus
) == FAILURE
3854 || gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
,
3855 gfc_current_locus
) == FAILURE
)
3860 case INTRINSIC_LE_OS
:
3861 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
,
3862 gfc_current_locus
) == FAILURE
3863 || gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
,
3864 gfc_current_locus
) == FAILURE
)
3869 if (gfc_check_new_interface (ns
->op
[current_interface
.op
], new_sym
,
3870 gfc_current_locus
) == FAILURE
)
3874 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3877 case INTERFACE_GENERIC
:
3878 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3880 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3884 if (gfc_check_new_interface (sym
->generic
, new_sym
, gfc_current_locus
)
3889 head
= ¤t_interface
.sym
->generic
;
3892 case INTERFACE_USER_OP
:
3893 if (gfc_check_new_interface (current_interface
.uop
->op
, new_sym
,
3894 gfc_current_locus
) == FAILURE
)
3897 head
= ¤t_interface
.uop
->op
;
3901 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3904 intr
= gfc_get_interface ();
3905 intr
->sym
= new_sym
;
3906 intr
->where
= gfc_current_locus
;
3916 gfc_current_interface_head (void)
3918 switch (current_interface
.type
)
3920 case INTERFACE_INTRINSIC_OP
:
3921 return current_interface
.ns
->op
[current_interface
.op
];
3924 case INTERFACE_GENERIC
:
3925 return current_interface
.sym
->generic
;
3928 case INTERFACE_USER_OP
:
3929 return current_interface
.uop
->op
;
3939 gfc_set_current_interface_head (gfc_interface
*i
)
3941 switch (current_interface
.type
)
3943 case INTERFACE_INTRINSIC_OP
:
3944 current_interface
.ns
->op
[current_interface
.op
] = i
;
3947 case INTERFACE_GENERIC
:
3948 current_interface
.sym
->generic
= i
;
3951 case INTERFACE_USER_OP
:
3952 current_interface
.uop
->op
= i
;
3961 /* Gets rid of a formal argument list. We do not free symbols.
3962 Symbols are freed when a namespace is freed. */
3965 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3967 gfc_formal_arglist
*q
;
3977 /* Check that it is ok for the type-bound procedure 'proc' to override the
3978 procedure 'old', cf. F08:4.5.7.3. */
3981 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
3984 gfc_symbol
*proc_target
, *old_target
;
3985 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
3986 gfc_formal_arglist
*proc_formal
, *old_formal
;
3990 /* This procedure should only be called for non-GENERIC proc. */
3991 gcc_assert (!proc
->n
.tb
->is_generic
);
3993 /* If the overwritten procedure is GENERIC, this is an error. */
3994 if (old
->n
.tb
->is_generic
)
3996 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3997 old
->name
, &proc
->n
.tb
->where
);
4001 where
= proc
->n
.tb
->where
;
4002 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4003 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4005 /* Check that overridden binding is not NON_OVERRIDABLE. */
4006 if (old
->n
.tb
->non_overridable
)
4008 gfc_error ("'%s' at %L overrides a procedure binding declared"
4009 " NON_OVERRIDABLE", proc
->name
, &where
);
4013 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4014 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4016 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
4017 " non-DEFERRED binding", proc
->name
, &where
);
4021 /* If the overridden binding is PURE, the overriding must be, too. */
4022 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4024 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
4025 proc
->name
, &where
);
4029 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4030 is not, the overriding must not be either. */
4031 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4033 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
4034 " ELEMENTAL", proc
->name
, &where
);
4037 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4039 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
4040 " be ELEMENTAL, either", proc
->name
, &where
);
4044 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4046 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4048 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4049 " SUBROUTINE", proc
->name
, &where
);
4053 /* If the overridden binding is a FUNCTION, the overriding must also be a
4054 FUNCTION and have the same characteristics. */
4055 if (old_target
->attr
.function
)
4057 if (!proc_target
->attr
.function
)
4059 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4060 " FUNCTION", proc
->name
, &where
);
4064 if (check_result_characteristics (proc_target
, old_target
,
4065 err
, sizeof(err
)) == FAILURE
)
4067 gfc_error ("Result mismatch for the overriding procedure "
4068 "'%s' at %L: %s", proc
->name
, &where
, err
);
4073 /* If the overridden binding is PUBLIC, the overriding one must not be
4075 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4076 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4078 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4079 " PRIVATE", proc
->name
, &where
);
4083 /* Compare the formal argument lists of both procedures. This is also abused
4084 to find the position of the passed-object dummy arguments of both
4085 bindings as at least the overridden one might not yet be resolved and we
4086 need those positions in the check below. */
4087 proc_pass_arg
= old_pass_arg
= 0;
4088 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4090 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4093 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4094 old_formal
= gfc_sym_get_dummy_args (old_target
);
4095 for ( ; proc_formal
&& old_formal
;
4096 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4098 if (proc
->n
.tb
->pass_arg
4099 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4100 proc_pass_arg
= argpos
;
4101 if (old
->n
.tb
->pass_arg
4102 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4103 old_pass_arg
= argpos
;
4105 /* Check that the names correspond. */
4106 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4108 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4109 " to match the corresponding argument of the overridden"
4110 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4111 old_formal
->sym
->name
);
4115 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4116 if (check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4117 check_type
, err
, sizeof(err
)) == FAILURE
)
4119 gfc_error ("Argument mismatch for the overriding procedure "
4120 "'%s' at %L: %s", proc
->name
, &where
, err
);
4126 if (proc_formal
|| old_formal
)
4128 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4129 " the overridden procedure", proc
->name
, &where
);
4133 /* If the overridden binding is NOPASS, the overriding one must also be
4135 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4137 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4138 " NOPASS", proc
->name
, &where
);
4142 /* If the overridden binding is PASS(x), the overriding one must also be
4143 PASS and the passed-object dummy arguments must correspond. */
4144 if (!old
->n
.tb
->nopass
)
4146 if (proc
->n
.tb
->nopass
)
4148 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4149 " PASS", proc
->name
, &where
);
4153 if (proc_pass_arg
!= old_pass_arg
)
4155 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4156 " the same position as the passed-object dummy argument of"
4157 " the overridden procedure", proc
->name
, &where
);