1 /* Deal with interfaces.
2 Copyright (C) 2000-2018 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"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface
;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface
*intr
)
88 for (; intr
; intr
= next
)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op
)
104 case INTRINSIC_UPLUS
:
107 case INTRINSIC_UMINUS
:
108 op
= INTRINSIC_MINUS
;
118 /* Return the operator depending on the DTIO moded string. Note that
119 these are not operators in the normal sense and so have been placed
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
122 static gfc_intrinsic_op
125 if (strcmp (mode
, "formatted") == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strcmp (mode
, "unformatted") == 0)
128 return INTRINSIC_UNFORMATTED
;
129 return INTRINSIC_NONE
;
133 /* Match a generic specification. Depending on which type of
134 interface is found, the 'name' or 'op' pointers may be set.
135 This subroutine doesn't return MATCH_NO. */
138 gfc_match_generic_spec (interface_type
*type
,
140 gfc_intrinsic_op
*op
)
142 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
146 if (gfc_match (" assignment ( = )") == MATCH_YES
)
148 *type
= INTERFACE_INTRINSIC_OP
;
149 *op
= INTRINSIC_ASSIGN
;
153 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
155 *type
= INTERFACE_INTRINSIC_OP
;
156 *op
= fold_unary_intrinsic (i
);
160 *op
= INTRINSIC_NONE
;
161 if (gfc_match (" operator ( ") == MATCH_YES
)
163 m
= gfc_match_defined_op_name (buffer
, 1);
169 m
= gfc_match_char (')');
175 strcpy (name
, buffer
);
176 *type
= INTERFACE_USER_OP
;
180 if (gfc_match (" read ( %n )", buffer
) == MATCH_YES
)
182 *op
= dtio_op (buffer
);
183 if (*op
== INTRINSIC_FORMATTED
)
185 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RF
));
186 *type
= INTERFACE_DTIO
;
188 if (*op
== INTRINSIC_UNFORMATTED
)
190 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RUF
));
191 *type
= INTERFACE_DTIO
;
193 if (*op
!= INTRINSIC_NONE
)
197 if (gfc_match (" write ( %n )", buffer
) == MATCH_YES
)
199 *op
= dtio_op (buffer
);
200 if (*op
== INTRINSIC_FORMATTED
)
202 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WF
));
203 *type
= INTERFACE_DTIO
;
205 if (*op
== INTRINSIC_UNFORMATTED
)
207 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WUF
));
208 *type
= INTERFACE_DTIO
;
210 if (*op
!= INTRINSIC_NONE
)
214 if (gfc_match_name (buffer
) == MATCH_YES
)
216 strcpy (name
, buffer
);
217 *type
= INTERFACE_GENERIC
;
221 *type
= INTERFACE_NAMELESS
;
225 gfc_error ("Syntax error in generic specification at %C");
230 /* Match one of the five F95 forms of an interface statement. The
231 matcher for the abstract interface follows. */
234 gfc_match_interface (void)
236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
242 m
= gfc_match_space ();
244 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
247 /* If we're not looking at the end of the statement now, or if this
248 is not a nameless interface but we did not see a space, punt. */
249 if (gfc_match_eos () != MATCH_YES
250 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
257 current_interface
.type
= type
;
262 case INTERFACE_GENERIC
:
263 if (gfc_get_symbol (name
, NULL
, &sym
))
266 if (!sym
->attr
.generic
267 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
272 gfc_error ("Dummy procedure %qs at %C cannot have a "
273 "generic interface", sym
->name
);
277 current_interface
.sym
= gfc_new_block
= sym
;
280 case INTERFACE_USER_OP
:
281 current_interface
.uop
= gfc_get_uop (name
);
284 case INTERFACE_INTRINSIC_OP
:
285 current_interface
.op
= op
;
288 case INTERFACE_NAMELESS
:
289 case INTERFACE_ABSTRACT
:
298 /* Match a F2003 abstract interface. */
301 gfc_match_abstract_interface (void)
305 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
308 m
= gfc_match_eos ();
312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
316 current_interface
.type
= INTERFACE_ABSTRACT
;
322 /* Match the different sort of generic-specs that can be present after
323 the END INTERFACE itself. */
326 gfc_match_end_interface (void)
328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
333 m
= gfc_match_space ();
335 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
338 /* If we're not looking at the end of the statement now, or if this
339 is not a nameless interface but we did not see a space, punt. */
340 if (gfc_match_eos () != MATCH_YES
341 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
350 switch (current_interface
.type
)
352 case INTERFACE_NAMELESS
:
353 case INTERFACE_ABSTRACT
:
354 if (type
!= INTERFACE_NAMELESS
)
356 gfc_error ("Expected a nameless interface at %C");
362 case INTERFACE_INTRINSIC_OP
:
363 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
366 if (current_interface
.op
== INTRINSIC_ASSIGN
)
369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
374 s1
= gfc_op2string (current_interface
.op
);
375 s2
= gfc_op2string (op
);
377 /* The following if-statements are used to enforce C1202
379 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
380 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
382 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
383 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
385 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
386 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
388 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
389 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
391 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
392 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
394 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
395 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
399 if (strcmp(s2
, "none") == 0)
400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
404 "but got %qs", s1
, s2
);
411 case INTERFACE_USER_OP
:
412 /* Comparing the symbol node names is OK because only use-associated
413 symbols can be renamed. */
414 if (type
!= current_interface
.type
415 || strcmp (current_interface
.uop
->name
, name
) != 0)
417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
418 current_interface
.uop
->name
);
425 case INTERFACE_GENERIC
:
426 if (type
!= current_interface
.type
427 || strcmp (current_interface
.sym
->name
, name
) != 0)
429 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
430 current_interface
.sym
->name
);
441 /* Return whether the component was defined anonymously. */
444 is_anonymous_component (gfc_component
*cmp
)
446 /* Only UNION and MAP components are anonymous. In the case of a MAP,
447 the derived type symbol is FL_STRUCT and the component name looks like mM*.
448 This is the only case in which the second character of a component name is
450 return cmp
->ts
.type
== BT_UNION
451 || (cmp
->ts
.type
== BT_DERIVED
452 && cmp
->ts
.u
.derived
->attr
.flavor
== FL_STRUCT
453 && cmp
->name
[0] && cmp
->name
[1] && ISUPPER (cmp
->name
[1]));
457 /* Return whether the derived type was defined anonymously. */
460 is_anonymous_dt (gfc_symbol
*derived
)
462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
464 and the type name looks like XX*. This is the only case in which the
465 second character of a type name is uppercase. */
466 return derived
->attr
.flavor
== FL_UNION
467 || (derived
->attr
.flavor
== FL_STRUCT
468 && derived
->name
[0] && derived
->name
[1] && ISUPPER (derived
->name
[1]));
472 /* Compare components according to 4.4.2 of the Fortran standard. */
475 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
476 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
478 /* Compare names, but not for anonymous components such as UNION or MAP. */
479 if (!is_anonymous_component (cmp1
) && !is_anonymous_component (cmp2
)
480 && strcmp (cmp1
->name
, cmp2
->name
) != 0)
483 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
486 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
489 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
492 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
495 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
498 if (cmp1
->ts
.type
== BT_CHARACTER
&& cmp2
->ts
.type
== BT_CHARACTER
)
500 gfc_charlen
*l1
= cmp1
->ts
.u
.cl
;
501 gfc_charlen
*l2
= cmp2
->ts
.u
.cl
;
502 if (l1
&& l2
&& l1
->length
&& l2
->length
503 && l1
->length
->expr_type
== EXPR_CONSTANT
504 && l2
->length
->expr_type
== EXPR_CONSTANT
505 && gfc_dep_compare_expr (l1
->length
, l2
->length
) != 0)
509 /* Make sure that link lists do not put this function into an
510 endless recursive loop! */
511 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
512 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
513 && !gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
))
516 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
517 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
520 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
521 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
528 /* Compare two union types by comparing the components of their maps.
529 Because unions and maps are anonymous their types get special internal
530 names; therefore the usual derived type comparison will fail on them.
532 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
533 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
534 definitions' than 'equivalent structure'. */
537 compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
539 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
540 gfc_symbol
*map1_t
, *map2_t
;
542 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
545 if (un1
->attr
.zero_comp
!= un2
->attr
.zero_comp
)
548 if (un1
->attr
.zero_comp
)
551 map1
= un1
->components
;
552 map2
= un2
->components
;
554 /* In terms of 'equality' here we are worried about types which are
555 declared the same in two places, not types that represent equivalent
556 structures. (This is common because of FORTRAN's weird scoping rules.)
557 Though two unions with their maps in different orders could be equivalent,
558 we will say they are not equal for the purposes of this test; therefore
559 we compare the maps sequentially. */
562 map1_t
= map1
->ts
.u
.derived
;
563 map2_t
= map2
->ts
.u
.derived
;
565 cmp1
= map1_t
->components
;
566 cmp2
= map2_t
->components
;
568 /* Protect against null components. */
569 if (map1_t
->attr
.zero_comp
!= map2_t
->attr
.zero_comp
)
572 if (map1_t
->attr
.zero_comp
)
577 /* No two fields will ever point to the same map type unless they are
578 the same component, because one map field is created with its type
579 declaration. Therefore don't worry about recursion here. */
580 /* TODO: worry about recursion into parent types of the unions? */
581 if (!compare_components (cmp1
, cmp2
, map1_t
, map2_t
))
587 if (cmp1
== NULL
&& cmp2
== NULL
)
589 if (cmp1
== NULL
|| cmp2
== NULL
)
596 if (map1
== NULL
&& map2
== NULL
)
598 if (map1
== NULL
|| map2
== NULL
)
607 /* Compare two derived types using the criteria in 4.4.2 of the standard,
608 recursing through gfc_compare_types for the components. */
611 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
613 gfc_component
*cmp1
, *cmp2
;
615 if (derived1
== derived2
)
618 if (!derived1
|| !derived2
)
619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
621 /* Compare UNION types specially. */
622 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
623 return compare_union_types (derived1
, derived2
);
625 /* Special case for comparing derived types across namespaces. If the
626 true names and module names are the same and the module name is
627 nonnull, then they are equal. */
628 if (strcmp (derived1
->name
, derived2
->name
) == 0
629 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
630 && strcmp (derived1
->module
, derived2
->module
) == 0)
633 /* Compare type via the rules of the standard. Both types must have
634 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
635 because they can be anonymous; therefore two structures with different
636 names may be equal. */
638 /* Compare names, but not for anonymous types such as UNION or MAP. */
639 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
640 && strcmp (derived1
->name
, derived2
->name
) != 0)
643 if (derived1
->component_access
== ACCESS_PRIVATE
644 || derived2
->component_access
== ACCESS_PRIVATE
)
647 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
648 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
)
649 && !(derived1
->attr
.pdt_type
&& derived2
->attr
.pdt_type
))
652 /* Protect against null components. */
653 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
656 if (derived1
->attr
.zero_comp
)
659 cmp1
= derived1
->components
;
660 cmp2
= derived2
->components
;
662 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
663 simple test can speed things up. Otherwise, lots of things have to
667 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
673 if (cmp1
== NULL
&& cmp2
== NULL
)
675 if (cmp1
== NULL
|| cmp2
== NULL
)
683 /* Compare two typespecs, recursively if necessary. */
686 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
688 /* See if one of the typespecs is a BT_VOID, which is what is being used
689 to allow the funcs like c_f_pointer to accept any pointer type.
690 TODO: Possibly should narrow this to just the one typespec coming in
691 that is for the formal arg, but oh well. */
692 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
695 /* The _data component is not always present, therefore check for its
696 presence before assuming, that its derived->attr is available.
697 When the _data component is not present, then nevertheless the
698 unlimited_polymorphic flag may be set in the derived type's attr. */
699 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
700 && ((ts1
->u
.derived
->attr
.is_class
701 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
702 .unlimited_polymorphic
)
703 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
707 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
708 && ts2
->u
.derived
->components
709 && ((ts2
->u
.derived
->attr
.is_class
710 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
711 .unlimited_polymorphic
)
712 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
713 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
716 if (ts1
->type
!= ts2
->type
717 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
718 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
721 if (ts1
->type
== BT_UNION
)
722 return compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
724 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
725 return (ts1
->kind
== ts2
->kind
);
727 /* Compare derived types. */
728 return gfc_type_compatible (ts1
, ts2
);
733 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
735 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
738 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
743 compare_type_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
)
745 /* TYPE and CLASS of the same declared type are type compatible,
746 but have different characteristics. */
747 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
748 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
751 return compare_type (s1
, s2
);
756 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
758 gfc_array_spec
*as1
, *as2
;
761 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
764 as1
= (s1
->ts
.type
== BT_CLASS
765 && !s1
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
766 ? CLASS_DATA (s1
)->as
: s1
->as
;
767 as2
= (s2
->ts
.type
== BT_CLASS
768 && !s2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
769 ? CLASS_DATA (s2
)->as
: s2
->as
;
771 r1
= as1
? as1
->rank
: 0;
772 r2
= as2
? as2
->rank
: 0;
774 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
775 return false; /* Ranks differ. */
781 /* Given two symbols that are formal arguments, compare their ranks
782 and types. Returns true if they have the same rank and type,
786 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
788 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
792 /* Given two symbols that are formal arguments, compare their types
793 and rank and their formal interfaces if they are both dummy
794 procedures. Returns true if the same, false if different. */
797 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
799 if (s1
== NULL
|| s2
== NULL
)
805 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
806 return compare_type_rank (s1
, s2
);
808 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
811 /* At this point, both symbols are procedures. It can happen that
812 external procedures are compared, where one is identified by usage
813 to be a function or subroutine but the other is not. Check TKR
814 nonetheless for these cases. */
815 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
816 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
818 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
819 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
821 /* Now the type of procedure has been identified. */
822 if (s1
->attr
.function
!= s2
->attr
.function
823 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
826 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
829 /* Originally, gfortran recursed here to check the interfaces of passed
830 procedures. This is explicitly not required by the standard. */
835 /* Given a formal argument list and a keyword name, search the list
836 for that keyword. Returns the correct symbol node if found, NULL
840 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
842 for (; f
; f
= f
->next
)
843 if (strcmp (f
->sym
->name
, name
) == 0)
850 /******** Interface checking subroutines **********/
853 /* Given an operator interface and the operator, make sure that all
854 interfaces for that operator are legal. */
857 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
860 gfc_formal_arglist
*formal
;
863 int args
, r1
, r2
, k1
, k2
;
868 t1
= t2
= BT_UNKNOWN
;
869 i1
= i2
= INTENT_UNKNOWN
;
873 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
875 gfc_symbol
*fsym
= formal
->sym
;
878 gfc_error ("Alternate return cannot appear in operator "
879 "interface at %L", &sym
->declared_at
);
885 i1
= fsym
->attr
.intent
;
886 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
892 i2
= fsym
->attr
.intent
;
893 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
899 /* Only +, - and .not. can be unary operators.
900 .not. cannot be a binary operator. */
901 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
902 && op
!= INTRINSIC_MINUS
903 && op
!= INTRINSIC_NOT
)
904 || (args
== 2 && op
== INTRINSIC_NOT
))
906 if (op
== INTRINSIC_ASSIGN
)
907 gfc_error ("Assignment operator interface at %L must have "
908 "two arguments", &sym
->declared_at
);
910 gfc_error ("Operator interface at %L has the wrong number of arguments",
915 /* Check that intrinsics are mapped to functions, except
916 INTRINSIC_ASSIGN which should map to a subroutine. */
917 if (op
== INTRINSIC_ASSIGN
)
919 gfc_formal_arglist
*dummy_args
;
921 if (!sym
->attr
.subroutine
)
923 gfc_error ("Assignment operator interface at %L must be "
924 "a SUBROUTINE", &sym
->declared_at
);
928 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
929 - First argument an array with different rank than second,
930 - First argument is a scalar and second an array,
931 - Types and kinds do not conform, or
932 - First argument is of derived type. */
933 dummy_args
= gfc_sym_get_dummy_args (sym
);
934 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
935 && dummy_args
->sym
->ts
.type
!= BT_CLASS
936 && (r2
== 0 || r1
== r2
)
937 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
938 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
939 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
941 gfc_error ("Assignment operator interface at %L must not redefine "
942 "an INTRINSIC type assignment", &sym
->declared_at
);
948 if (!sym
->attr
.function
)
950 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
956 /* Check intents on operator interfaces. */
957 if (op
== INTRINSIC_ASSIGN
)
959 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
961 gfc_error ("First argument of defined assignment at %L must be "
962 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
968 gfc_error ("Second argument of defined assignment at %L must be "
969 "INTENT(IN)", &sym
->declared_at
);
977 gfc_error ("First argument of operator interface at %L must be "
978 "INTENT(IN)", &sym
->declared_at
);
982 if (args
== 2 && i2
!= INTENT_IN
)
984 gfc_error ("Second argument of operator interface at %L must be "
985 "INTENT(IN)", &sym
->declared_at
);
990 /* From now on, all we have to do is check that the operator definition
991 doesn't conflict with an intrinsic operator. The rules for this
992 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
993 as well as 12.3.2.1.1 of Fortran 2003:
995 "If the operator is an intrinsic-operator (R310), the number of
996 function arguments shall be consistent with the intrinsic uses of
997 that operator, and the types, kind type parameters, or ranks of the
998 dummy arguments shall differ from those required for the intrinsic
999 operation (7.1.2)." */
1001 #define IS_NUMERIC_TYPE(t) \
1002 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
1004 /* Unary ops are easy, do them first. */
1005 if (op
== INTRINSIC_NOT
)
1007 if (t1
== BT_LOGICAL
)
1013 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1015 if (IS_NUMERIC_TYPE (t1
))
1021 /* Character intrinsic operators have same character kind, thus
1022 operator definitions with operands of different character kinds
1024 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1027 /* Intrinsic operators always perform on arguments of same rank,
1028 so different ranks is also always safe. (rank == 0) is an exception
1029 to that, because all intrinsic operators are elemental. */
1030 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1036 case INTRINSIC_EQ_OS
:
1038 case INTRINSIC_NE_OS
:
1039 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1043 case INTRINSIC_PLUS
:
1044 case INTRINSIC_MINUS
:
1045 case INTRINSIC_TIMES
:
1046 case INTRINSIC_DIVIDE
:
1047 case INTRINSIC_POWER
:
1048 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1053 case INTRINSIC_GT_OS
:
1055 case INTRINSIC_GE_OS
:
1057 case INTRINSIC_LT_OS
:
1059 case INTRINSIC_LE_OS
:
1060 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1062 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1063 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1067 case INTRINSIC_CONCAT
:
1068 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1075 case INTRINSIC_NEQV
:
1076 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1086 #undef IS_NUMERIC_TYPE
1089 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1095 /* Given a pair of formal argument lists, we see if the two lists can
1096 be distinguished by counting the number of nonoptional arguments of
1097 a given type/rank in f1 and seeing if there are less then that
1098 number of those arguments in f2 (including optional arguments).
1099 Since this test is asymmetric, it has to be called twice to make it
1100 symmetric. Returns nonzero if the argument lists are incompatible
1101 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1102 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1105 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1106 const char *p1
, const char *p2
)
1108 int ac1
, ac2
, i
, j
, k
, n1
;
1109 gfc_formal_arglist
*f
;
1122 for (f
= f1
; f
; f
= f
->next
)
1125 /* Build an array of integers that gives the same integer to
1126 arguments of the same type/rank. */
1127 arg
= XCNEWVEC (arginfo
, n1
);
1130 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1133 arg
[i
].sym
= f
->sym
;
1138 for (i
= 0; i
< n1
; i
++)
1140 if (arg
[i
].flag
!= -1)
1143 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1144 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1145 continue; /* Skip OPTIONAL and PASS arguments. */
1149 /* Find other non-optional, non-pass arguments of the same type/rank. */
1150 for (j
= i
+ 1; j
< n1
; j
++)
1151 if ((arg
[j
].sym
== NULL
1152 || !(arg
[j
].sym
->attr
.optional
1153 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1154 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1155 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1161 /* Now loop over each distinct type found in f1. */
1165 for (i
= 0; i
< n1
; i
++)
1167 if (arg
[i
].flag
!= k
)
1171 for (j
= i
+ 1; j
< n1
; j
++)
1172 if (arg
[j
].flag
== k
)
1175 /* Count the number of non-pass arguments in f2 with that type,
1176 including those that are optional. */
1179 for (f
= f2
; f
; f
= f
->next
)
1180 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1181 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1182 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1200 /* Returns true if two dummy arguments are distinguishable due to their POINTER
1201 and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
1202 The function is asymmetric wrt to the arguments s1 and s2 and should always
1203 be called twice (with flipped arguments in the second call). */
1206 compare_ptr_alloc(gfc_symbol
*s1
, gfc_symbol
*s2
)
1208 /* Is s1 allocatable? */
1209 const bool a1
= s1
->ts
.type
== BT_CLASS
?
1210 CLASS_DATA(s1
)->attr
.allocatable
: s1
->attr
.allocatable
;
1211 /* Is s2 a pointer? */
1212 const bool p2
= s2
->ts
.type
== BT_CLASS
?
1213 CLASS_DATA(s2
)->attr
.class_pointer
: s2
->attr
.pointer
;
1214 return a1
&& p2
&& (s2
->attr
.intent
!= INTENT_IN
);
1218 /* Perform the correspondence test in rule (3) of F08:C1215.
1219 Returns zero if no argument is found that satisfies this rule,
1220 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1223 This test is also not symmetric in f1 and f2 and must be called
1224 twice. This test finds problems caused by sorting the actual
1225 argument list with keywords. For example:
1229 INTEGER :: A ; REAL :: B
1233 INTEGER :: A ; REAL :: B
1237 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1240 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1241 const char *p1
, const char *p2
)
1243 gfc_formal_arglist
*f2_save
, *g
;
1250 if (f1
->sym
->attr
.optional
)
1253 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1255 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1258 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1259 || compare_type_rank (f2
->sym
, f1
->sym
))
1260 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1261 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1262 || compare_ptr_alloc(f2
->sym
, f1
->sym
))))
1265 /* Now search for a disambiguating keyword argument starting at
1266 the current non-match. */
1267 for (g
= f1
; g
; g
= g
->next
)
1269 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1272 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1273 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1274 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1275 && (compare_ptr_alloc(sym
, g
->sym
)
1276 || compare_ptr_alloc(g
->sym
, sym
))))
1292 symbol_rank (gfc_symbol
*sym
)
1294 gfc_array_spec
*as
= NULL
;
1296 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1297 as
= CLASS_DATA (sym
)->as
;
1301 return as
? as
->rank
: 0;
1305 /* Check if the characteristics of two dummy arguments match,
1309 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1310 bool type_must_agree
, char *errmsg
,
1313 if (s1
== NULL
|| s2
== NULL
)
1314 return s1
== s2
? true : false;
1316 /* Check type and rank. */
1317 if (type_must_agree
)
1319 if (!compare_type_characteristics (s1
, s2
)
1320 || !compare_type_characteristics (s2
, s1
))
1322 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1323 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1326 if (!compare_rank (s1
, s2
))
1328 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1329 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1335 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1337 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1342 /* Check OPTIONAL attribute. */
1343 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1345 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1350 /* Check ALLOCATABLE attribute. */
1351 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1353 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1358 /* Check POINTER attribute. */
1359 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1361 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1366 /* Check TARGET attribute. */
1367 if (s1
->attr
.target
!= s2
->attr
.target
)
1369 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1374 /* Check ASYNCHRONOUS attribute. */
1375 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1377 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1382 /* Check CONTIGUOUS attribute. */
1383 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1385 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1390 /* Check VALUE attribute. */
1391 if (s1
->attr
.value
!= s2
->attr
.value
)
1393 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1398 /* Check VOLATILE attribute. */
1399 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1401 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1406 /* Check interface of dummy procedures. */
1407 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1410 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1413 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1414 "'%s': %s", s1
->name
, err
);
1419 /* Check string length. */
1420 if (s1
->ts
.type
== BT_CHARACTER
1421 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1422 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1424 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1425 s2
->ts
.u
.cl
->length
);
1431 snprintf (errmsg
, err_len
, "Character length mismatch "
1432 "in argument '%s'", s1
->name
);
1436 /* FIXME: Implement a warning for this case.
1437 gfc_warning (0, "Possible character length mismatch in argument %qs",
1445 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1446 "%i of gfc_dep_compare_expr", compval
);
1451 /* Check array shape. */
1452 if (s1
->as
&& s2
->as
)
1455 gfc_expr
*shape1
, *shape2
;
1457 if (s1
->as
->type
!= s2
->as
->type
)
1459 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1464 if (s1
->as
->corank
!= s2
->as
->corank
)
1466 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1467 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1471 if (s1
->as
->type
== AS_EXPLICIT
)
1472 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1474 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1475 gfc_copy_expr (s1
->as
->lower
[i
]));
1476 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1477 gfc_copy_expr (s2
->as
->lower
[i
]));
1478 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1479 gfc_free_expr (shape1
);
1480 gfc_free_expr (shape2
);
1486 if (i
< s1
->as
->rank
)
1487 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1488 " argument '%s'", i
+ 1, s1
->name
);
1490 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1491 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1495 /* FIXME: Implement a warning for this case.
1496 gfc_warning (0, "Possible shape mismatch in argument %qs",
1504 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1505 "result %i of gfc_dep_compare_expr",
1516 /* Check if the characteristics of two function results match,
1520 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1521 char *errmsg
, int err_len
)
1523 gfc_symbol
*r1
, *r2
;
1525 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1526 r1
= s1
->ts
.interface
->result
;
1528 r1
= s1
->result
? s1
->result
: s1
;
1530 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1531 r2
= s2
->ts
.interface
->result
;
1533 r2
= s2
->result
? s2
->result
: s2
;
1535 if (r1
->ts
.type
== BT_UNKNOWN
)
1538 /* Check type and rank. */
1539 if (!compare_type_characteristics (r1
, r2
))
1541 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1542 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1545 if (!compare_rank (r1
, r2
))
1547 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1548 symbol_rank (r1
), symbol_rank (r2
));
1552 /* Check ALLOCATABLE attribute. */
1553 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1555 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1560 /* Check POINTER attribute. */
1561 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1563 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1568 /* Check CONTIGUOUS attribute. */
1569 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1571 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1576 /* Check PROCEDURE POINTER attribute. */
1577 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1579 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1584 /* Check string length. */
1585 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1587 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1589 snprintf (errmsg
, err_len
, "Character length mismatch "
1590 "in function result");
1594 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1596 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1597 r2
->ts
.u
.cl
->length
);
1603 snprintf (errmsg
, err_len
, "Character length mismatch "
1604 "in function result");
1608 /* FIXME: Implement a warning for this case.
1609 snprintf (errmsg, err_len, "Possible character length mismatch "
1610 "in function result");*/
1617 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1618 "result %i of gfc_dep_compare_expr", compval
);
1624 /* Check array shape. */
1625 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1628 gfc_expr
*shape1
, *shape2
;
1630 if (r1
->as
->type
!= r2
->as
->type
)
1632 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1636 if (r1
->as
->type
== AS_EXPLICIT
)
1637 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1639 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1640 gfc_copy_expr (r1
->as
->lower
[i
]));
1641 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1642 gfc_copy_expr (r2
->as
->lower
[i
]));
1643 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1644 gfc_free_expr (shape1
);
1645 gfc_free_expr (shape2
);
1651 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1652 "function result", i
+ 1);
1656 /* FIXME: Implement a warning for this case.
1657 gfc_warning (0, "Possible shape mismatch in return value");*/
1664 gfc_internal_error ("check_result_characteristics (2): "
1665 "Unexpected result %i of "
1666 "gfc_dep_compare_expr", compval
);
1676 /* 'Compare' two formal interfaces associated with a pair of symbols.
1677 We return true if there exists an actual argument list that
1678 would be ambiguous between the two interfaces, zero otherwise.
1679 'strict_flag' specifies whether all the characteristics are
1680 required to match, which is not the case for ambiguity checks.
1681 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1684 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1685 int generic_flag
, int strict_flag
,
1686 char *errmsg
, int err_len
,
1687 const char *p1
, const char *p2
)
1689 gfc_formal_arglist
*f1
, *f2
;
1691 gcc_assert (name2
!= NULL
);
1693 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1694 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1695 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1698 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1702 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1705 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1709 /* Do strict checks on all characteristics
1710 (for dummy procedures and procedure pointer assignments). */
1711 if (!generic_flag
&& strict_flag
)
1713 if (s1
->attr
.function
&& s2
->attr
.function
)
1715 /* If both are functions, check result characteristics. */
1716 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1717 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1721 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1723 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1726 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1728 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1733 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1734 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1737 f1
= gfc_sym_get_dummy_args (s1
);
1738 f2
= gfc_sym_get_dummy_args (s2
);
1740 /* Special case: No arguments. */
1741 if (f1
== NULL
&& f2
== NULL
)
1746 if (count_types_test (f1
, f2
, p1
, p2
)
1747 || count_types_test (f2
, f1
, p2
, p1
))
1750 /* Special case: alternate returns. If both f1->sym and f2->sym are
1751 NULL, then the leading formal arguments are alternate returns.
1752 The previous conditional should catch argument lists with
1753 different number of argument. */
1754 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1757 if (generic_correspondence (f1
, f2
, p1
, p2
)
1758 || generic_correspondence (f2
, f1
, p2
, p1
))
1762 /* Perform the abbreviated correspondence test for operators (the
1763 arguments cannot be optional and are always ordered correctly).
1764 This is also done when comparing interfaces for dummy procedures and in
1765 procedure pointer assignments. */
1767 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1769 /* Check existence. */
1770 if (f1
== NULL
|| f2
== NULL
)
1773 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1774 "arguments", name2
);
1780 /* Check all characteristics. */
1781 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1787 /* Operators: Only check type and rank of arguments. */
1788 if (!compare_type (f2
->sym
, f1
->sym
))
1791 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1792 "(%s/%s)", f1
->sym
->name
,
1793 gfc_typename (&f1
->sym
->ts
),
1794 gfc_typename (&f2
->sym
->ts
));
1797 if (!compare_rank (f2
->sym
, f1
->sym
))
1800 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1801 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1802 symbol_rank (f2
->sym
));
1805 if ((gfc_option
.allow_std
& GFC_STD_F2008
)
1806 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1807 || compare_ptr_alloc(f2
->sym
, f1
->sym
)))
1810 snprintf (errmsg
, err_len
, "Mismatching POINTER/ALLOCATABLE "
1811 "attribute in argument '%s' ", f1
->sym
->name
);
1821 /* Given a pointer to an interface pointer, remove duplicate
1822 interfaces and make sure that all symbols are either functions
1823 or subroutines, and all of the same kind. Returns true if
1824 something goes wrong. */
1827 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1829 gfc_interface
*psave
, *q
, *qlast
;
1832 for (; p
; p
= p
->next
)
1834 /* Make sure all symbols in the interface have been defined as
1835 functions or subroutines. */
1836 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1837 || !p
->sym
->attr
.if_source
)
1838 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1841 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1843 if (p
->sym
->attr
.external
)
1845 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1846 "; did you mean %qs?",
1847 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1850 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1851 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1854 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1855 "subroutine; did you mean %qs?", p
->sym
->name
,
1856 interface_name
, &p
->sym
->declared_at
, guessed
);
1858 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1859 "subroutine", p
->sym
->name
, interface_name
,
1860 &p
->sym
->declared_at
);
1864 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1865 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1866 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1867 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1869 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1870 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1871 " or all FUNCTIONs", interface_name
,
1872 &p
->sym
->declared_at
);
1873 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1874 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1875 "generic name is also the name of a derived type",
1876 interface_name
, &p
->sym
->declared_at
);
1880 /* F2003, C1207. F2008, C1207. */
1881 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1882 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1883 "%qs in %s at %L", p
->sym
->name
,
1884 interface_name
, &p
->sym
->declared_at
))
1889 /* Remove duplicate interfaces in this interface list. */
1890 for (; p
; p
= p
->next
)
1894 for (q
= p
->next
; q
;)
1896 if (p
->sym
!= q
->sym
)
1903 /* Duplicate interface. */
1904 qlast
->next
= q
->next
;
1915 /* Check lists of interfaces to make sure that no two interfaces are
1916 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1919 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1920 int generic_flag
, const char *interface_name
,
1924 for (; p
; p
= p
->next
)
1925 for (q
= q0
; q
; q
= q
->next
)
1927 if (p
->sym
== q
->sym
)
1928 continue; /* Duplicates OK here. */
1930 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1933 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1934 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1935 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1936 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1939 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1940 "and %qs at %L", interface_name
,
1941 q
->sym
->name
, &q
->sym
->declared_at
,
1942 p
->sym
->name
, &p
->sym
->declared_at
);
1943 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1944 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1945 "and %qs at %L", interface_name
,
1946 q
->sym
->name
, &q
->sym
->declared_at
,
1947 p
->sym
->name
, &p
->sym
->declared_at
);
1949 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1950 "interfaces at %L", interface_name
, &p
->where
);
1958 /* Check the generic and operator interfaces of symbols to make sure
1959 that none of the interfaces conflict. The check has to be done
1960 after all of the symbols are actually loaded. */
1963 check_sym_interfaces (gfc_symbol
*sym
)
1965 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("generic interface ''")];
1968 if (sym
->ns
!= gfc_current_ns
)
1971 if (sym
->generic
!= NULL
)
1973 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1974 if (check_interface0 (sym
->generic
, interface_name
))
1977 for (p
= sym
->generic
; p
; p
= p
->next
)
1979 if (p
->sym
->attr
.mod_proc
1980 && !p
->sym
->attr
.module_procedure
1981 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1982 || p
->sym
->attr
.procedure
))
1984 gfc_error ("%qs at %L is not a module procedure",
1985 p
->sym
->name
, &p
->where
);
1990 /* Originally, this test was applied to host interfaces too;
1991 this is incorrect since host associated symbols, from any
1992 source, cannot be ambiguous with local symbols. */
1993 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1994 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
2000 check_uop_interfaces (gfc_user_op
*uop
)
2002 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
2006 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
2007 if (check_interface0 (uop
->op
, interface_name
))
2010 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2012 uop2
= gfc_find_uop (uop
->name
, ns
);
2016 check_interface1 (uop
->op
, uop2
->op
, 0,
2017 interface_name
, true);
2021 /* Given an intrinsic op, return an equivalent op if one exists,
2022 or INTRINSIC_NONE otherwise. */
2025 gfc_equivalent_op (gfc_intrinsic_op op
)
2030 return INTRINSIC_EQ_OS
;
2032 case INTRINSIC_EQ_OS
:
2033 return INTRINSIC_EQ
;
2036 return INTRINSIC_NE_OS
;
2038 case INTRINSIC_NE_OS
:
2039 return INTRINSIC_NE
;
2042 return INTRINSIC_GT_OS
;
2044 case INTRINSIC_GT_OS
:
2045 return INTRINSIC_GT
;
2048 return INTRINSIC_GE_OS
;
2050 case INTRINSIC_GE_OS
:
2051 return INTRINSIC_GE
;
2054 return INTRINSIC_LT_OS
;
2056 case INTRINSIC_LT_OS
:
2057 return INTRINSIC_LT
;
2060 return INTRINSIC_LE_OS
;
2062 case INTRINSIC_LE_OS
:
2063 return INTRINSIC_LE
;
2066 return INTRINSIC_NONE
;
2070 /* For the namespace, check generic, user operator and intrinsic
2071 operator interfaces for consistency and to remove duplicate
2072 interfaces. We traverse the whole namespace, counting on the fact
2073 that most symbols will not have generic or operator interfaces. */
2076 gfc_check_interfaces (gfc_namespace
*ns
)
2078 gfc_namespace
*old_ns
, *ns2
;
2079 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2082 old_ns
= gfc_current_ns
;
2083 gfc_current_ns
= ns
;
2085 gfc_traverse_ns (ns
, check_sym_interfaces
);
2087 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2089 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2091 if (i
== INTRINSIC_USER
)
2094 if (i
== INTRINSIC_ASSIGN
)
2095 strcpy (interface_name
, "intrinsic assignment operator");
2097 sprintf (interface_name
, "intrinsic '%s' operator",
2098 gfc_op2string ((gfc_intrinsic_op
) i
));
2100 if (check_interface0 (ns
->op
[i
], interface_name
))
2104 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2107 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2109 gfc_intrinsic_op other_op
;
2111 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2112 interface_name
, true))
2115 /* i should be gfc_intrinsic_op, but has to be int with this cast
2116 here for stupid C++ compatibility rules. */
2117 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2118 if (other_op
!= INTRINSIC_NONE
2119 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2120 0, interface_name
, true))
2126 gfc_current_ns
= old_ns
;
2130 /* Given a symbol of a formal argument list and an expression, if the
2131 formal argument is allocatable, check that the actual argument is
2132 allocatable. Returns true if compatible, zero if not compatible. */
2135 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2137 if (formal
->attr
.allocatable
2138 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2140 symbol_attribute attr
= gfc_expr_attr (actual
);
2141 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2143 else if (!attr
.allocatable
)
2151 /* Given a symbol of a formal argument list and an expression, if the
2152 formal argument is a pointer, see if the actual argument is a
2153 pointer. Returns nonzero if compatible, zero if not compatible. */
2156 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2158 symbol_attribute attr
;
2160 if (formal
->attr
.pointer
2161 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2162 && CLASS_DATA (formal
)->attr
.class_pointer
))
2164 attr
= gfc_expr_attr (actual
);
2166 /* Fortran 2008 allows non-pointer actual arguments. */
2167 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2178 /* Emit clear error messages for rank mismatch. */
2181 argument_rank_mismatch (const char *name
, locus
*where
,
2182 int rank1
, int rank2
)
2185 /* TS 29113, C407b. */
2187 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2188 " %qs has assumed-rank", where
, name
);
2189 else if (rank1
== 0)
2190 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2191 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2192 else if (rank2
== 0)
2193 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2194 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2196 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2197 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2201 /* Given a symbol of a formal argument list and an expression, see if
2202 the two are compatible as arguments. Returns true if
2203 compatible, false if not compatible. */
2206 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2207 int ranks_must_agree
, int is_elemental
, locus
*where
)
2210 bool rank_check
, is_pointer
;
2214 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2215 procs c_f_pointer or c_f_procpointer, and we need to accept most
2216 pointers the user could give us. This should allow that. */
2217 if (formal
->ts
.type
== BT_VOID
)
2220 if (formal
->ts
.type
== BT_DERIVED
2221 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2222 && actual
->ts
.type
== BT_DERIVED
2223 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2226 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2227 /* Make sure the vtab symbol is present when
2228 the module variables are generated. */
2229 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2231 if (actual
->ts
.type
== BT_PROCEDURE
)
2233 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2235 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2238 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2242 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2243 sizeof(err
), NULL
, NULL
))
2246 gfc_error_opt (OPT_Wargument_mismatch
,
2247 "Interface mismatch in dummy procedure %qs at %L:"
2248 " %s", formal
->name
, &actual
->where
, err
);
2252 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2254 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2255 &act_sym
->declared_at
);
2256 if (act_sym
->ts
.type
== BT_UNKNOWN
2257 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2260 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2261 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2262 &act_sym
->declared_at
);
2267 ppc
= gfc_get_proc_ptr_comp (actual
);
2268 if (ppc
&& ppc
->ts
.interface
)
2270 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2271 err
, sizeof(err
), NULL
, NULL
))
2274 gfc_error_opt (OPT_Wargument_mismatch
,
2275 "Interface mismatch in dummy procedure %qs at %L:"
2276 " %s", formal
->name
, &actual
->where
, err
);
2282 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2283 && !gfc_is_simply_contiguous (actual
, true, false))
2286 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2287 "must be simply contiguous", formal
->name
, &actual
->where
);
2291 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2292 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2295 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2296 && actual
->ts
.type
!= BT_HOLLERITH
2297 && formal
->ts
.type
!= BT_ASSUMED
2298 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2299 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2300 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2301 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2302 CLASS_DATA (actual
)->ts
.u
.derived
)))
2305 gfc_error_opt (OPT_Wargument_mismatch
,
2306 "Type mismatch in argument %qs at %L; passed %s to %s",
2307 formal
->name
, where
, gfc_typename (&actual
->ts
),
2308 gfc_typename (&formal
->ts
));
2312 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2315 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2316 "argument %qs is of assumed type", &actual
->where
,
2321 /* F2008, 12.5.2.5; IR F08/0073. */
2322 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2323 && actual
->expr_type
!= EXPR_NULL
2324 && ((CLASS_DATA (formal
)->attr
.class_pointer
2325 && formal
->attr
.intent
!= INTENT_IN
)
2326 || CLASS_DATA (formal
)->attr
.allocatable
))
2328 if (actual
->ts
.type
!= BT_CLASS
)
2331 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2332 formal
->name
, &actual
->where
);
2336 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2337 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2338 CLASS_DATA (formal
)->ts
.u
.derived
))
2341 gfc_error ("Actual argument to %qs at %L must have the same "
2342 "declared type", formal
->name
, &actual
->where
);
2347 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2348 is necessary also for F03, so retain error for both.
2349 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2350 compatible, no attempt has been made to channel to this one. */
2351 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2352 && (CLASS_DATA (formal
)->attr
.allocatable
2353 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2356 gfc_error ("Actual argument to %qs at %L must be unlimited "
2357 "polymorphic since the formal argument is a "
2358 "pointer or allocatable unlimited polymorphic "
2359 "entity [F2008: 12.5.2.5]", formal
->name
,
2364 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2367 gfc_error ("Actual argument to %qs at %L must be a coarray",
2368 formal
->name
, &actual
->where
);
2372 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2374 gfc_ref
*last
= NULL
;
2376 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2377 if (ref
->type
== REF_COMPONENT
)
2380 /* F2008, 12.5.2.6. */
2381 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2383 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2386 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2387 formal
->name
, &actual
->where
, formal
->as
->corank
,
2388 last
? last
->u
.c
.component
->as
->corank
2389 : actual
->symtree
->n
.sym
->as
->corank
);
2394 if (formal
->attr
.codimension
)
2396 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2397 /* F2018, 12.5.2.8. */
2398 if (formal
->attr
.dimension
2399 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2400 && actual_attr
.dimension
2401 && !gfc_is_simply_contiguous (actual
, true, true))
2404 gfc_error ("Actual argument to %qs at %L must be simply "
2405 "contiguous or an element of such an array",
2406 formal
->name
, &actual
->where
);
2410 /* F2008, C1303 and C1304. */
2411 if (formal
->attr
.intent
!= INTENT_INOUT
2412 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2413 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2414 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2415 || formal
->attr
.lock_comp
))
2419 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2420 "which is LOCK_TYPE or has a LOCK_TYPE component",
2421 formal
->name
, &actual
->where
);
2425 /* TS18508, C702/C703. */
2426 if (formal
->attr
.intent
!= INTENT_INOUT
2427 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2428 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2429 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2430 || formal
->attr
.event_comp
))
2434 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2435 "which is EVENT_TYPE or has a EVENT_TYPE component",
2436 formal
->name
, &actual
->where
);
2441 /* F2008, C1239/C1240. */
2442 if (actual
->expr_type
== EXPR_VARIABLE
2443 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2444 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2445 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2446 && actual
->rank
&& formal
->as
2447 && !gfc_is_simply_contiguous (actual
, true, false)
2448 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2449 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2450 || formal
->attr
.contiguous
))
2453 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2454 "assumed-rank array without CONTIGUOUS attribute - as actual"
2455 " argument at %L is not simply contiguous and both are "
2456 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2460 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2461 && actual_attr
.codimension
)
2463 if (formal
->attr
.intent
== INTENT_OUT
)
2466 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2467 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2471 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2472 gfc_warning (OPT_Wsurprising
,
2473 "Passing coarray at %L to allocatable, noncoarray dummy "
2474 "argument %qs, which is invalid if the allocation status"
2475 " is modified", &actual
->where
, formal
->name
);
2478 /* If the rank is the same or the formal argument has assumed-rank. */
2479 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2482 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2483 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2484 || formal
->as
->type
== AS_DEFERRED
)
2485 && actual
->expr_type
!= EXPR_NULL
;
2487 /* Skip rank checks for NO_ARG_CHECK. */
2488 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2491 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2492 if (rank_check
|| ranks_must_agree
2493 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2494 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2495 || (actual
->rank
== 0
2496 && ((formal
->ts
.type
== BT_CLASS
2497 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2498 || (formal
->ts
.type
!= BT_CLASS
2499 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2500 && actual
->expr_type
!= EXPR_NULL
)
2501 || (actual
->rank
== 0 && formal
->attr
.dimension
2502 && gfc_is_coindexed (actual
)))
2505 argument_rank_mismatch (formal
->name
, &actual
->where
,
2506 symbol_rank (formal
), actual
->rank
);
2509 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2512 /* At this point, we are considering a scalar passed to an array. This
2513 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2514 - if the actual argument is (a substring of) an element of a
2515 non-assumed-shape/non-pointer/non-polymorphic array; or
2516 - (F2003) if the actual argument is of type character of default/c_char
2519 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2520 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2522 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2524 if (ref
->type
== REF_COMPONENT
)
2525 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2526 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2527 && ref
->u
.ar
.dimen
> 0
2529 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2533 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2536 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2537 "at %L", formal
->name
, &actual
->where
);
2541 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2542 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2545 gfc_error ("Element of assumed-shaped or pointer "
2546 "array passed to array dummy argument %qs at %L",
2547 formal
->name
, &actual
->where
);
2551 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2552 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2554 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2557 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2558 "CHARACTER actual argument with array dummy argument "
2559 "%qs at %L", formal
->name
, &actual
->where
);
2563 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2565 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2566 "array dummy argument %qs at %L",
2567 formal
->name
, &actual
->where
);
2571 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2574 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2577 argument_rank_mismatch (formal
->name
, &actual
->where
,
2578 symbol_rank (formal
), actual
->rank
);
2586 /* Returns the storage size of a symbol (formal argument) or
2587 zero if it cannot be determined. */
2589 static unsigned long
2590 get_sym_storage_size (gfc_symbol
*sym
)
2593 unsigned long strlen
, elements
;
2595 if (sym
->ts
.type
== BT_CHARACTER
)
2597 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2598 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2599 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2606 if (symbol_rank (sym
) == 0)
2610 if (sym
->as
->type
!= AS_EXPLICIT
)
2612 for (i
= 0; i
< sym
->as
->rank
; i
++)
2614 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2615 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2618 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2619 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2622 return strlen
*elements
;
2626 /* Returns the storage size of an expression (actual argument) or
2627 zero if it cannot be determined. For an array element, it returns
2628 the remaining size as the element sequence consists of all storage
2629 units of the actual argument up to the end of the array. */
2631 static unsigned long
2632 get_expr_storage_size (gfc_expr
*e
)
2635 long int strlen
, elements
;
2636 long int substrlen
= 0;
2637 bool is_str_storage
= false;
2643 if (e
->ts
.type
== BT_CHARACTER
)
2645 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2646 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2647 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2648 else if (e
->expr_type
== EXPR_CONSTANT
2649 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2650 strlen
= e
->value
.character
.length
;
2655 strlen
= 1; /* Length per element. */
2657 if (e
->rank
== 0 && !e
->ref
)
2665 for (i
= 0; i
< e
->rank
; i
++)
2666 elements
*= mpz_get_si (e
->shape
[i
]);
2667 return elements
*strlen
;
2670 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2672 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2673 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2677 /* The string length is the substring length.
2678 Set now to full string length. */
2679 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2680 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2683 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2685 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2689 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2690 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2692 long int start
, end
, stride
;
2695 if (ref
->u
.ar
.stride
[i
])
2697 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2698 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2703 if (ref
->u
.ar
.start
[i
])
2705 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2706 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2710 else if (ref
->u
.ar
.as
->lower
[i
]
2711 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2712 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2716 if (ref
->u
.ar
.end
[i
])
2718 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2719 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2723 else if (ref
->u
.ar
.as
->upper
[i
]
2724 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2725 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2729 elements
*= (end
- start
)/stride
+ 1L;
2731 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2732 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2734 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2735 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2736 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2737 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2738 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2739 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2740 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2745 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2746 && e
->expr_type
== EXPR_VARIABLE
)
2748 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2749 || e
->symtree
->n
.sym
->attr
.pointer
)
2755 /* Determine the number of remaining elements in the element
2756 sequence for array element designators. */
2757 is_str_storage
= true;
2758 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2760 if (ref
->u
.ar
.start
[i
] == NULL
2761 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2762 || ref
->u
.ar
.as
->upper
[i
] == NULL
2763 || ref
->u
.ar
.as
->lower
[i
] == NULL
2764 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2765 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2770 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2771 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2773 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2774 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2777 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2778 && ref
->u
.c
.component
->attr
.proc_pointer
2779 && ref
->u
.c
.component
->attr
.dimension
)
2781 /* Array-valued procedure-pointer components. */
2782 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2783 for (i
= 0; i
< as
->rank
; i
++)
2785 if (!as
->upper
[i
] || !as
->lower
[i
]
2786 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2787 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2791 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2792 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2798 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2801 return elements
*strlen
;
2805 /* Given an expression, check whether it is an array section
2806 which has a vector subscript. */
2809 gfc_has_vector_subscript (gfc_expr
*e
)
2814 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2817 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2818 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2819 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2820 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2828 is_procptr_result (gfc_expr
*expr
)
2830 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2832 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2834 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2835 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2839 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2840 number of total candidates in CANDIDATES_LEN. */
2843 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
2845 size_t &candidates_len
)
2847 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
2848 vec_push (candidates
, candidates_len
, p
->sym
->name
);
2852 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2855 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
2857 char **candidates
= NULL
;
2858 size_t candidates_len
= 0;
2859 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
2860 return gfc_closest_fuzzy_match (arg
, candidates
);
2864 /* Given formal and actual argument lists, see if they are compatible.
2865 If they are compatible, the actual argument list is sorted to
2866 correspond with the formal list, and elements for missing optional
2867 arguments are inserted. If WHERE pointer is nonnull, then we issue
2868 errors when things don't match instead of just returning the status
2872 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2873 int ranks_must_agree
, int is_elemental
,
2874 bool in_statement_function
, locus
*where
)
2876 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2877 gfc_formal_arglist
*f
;
2879 unsigned long actual_size
, formal_size
;
2880 bool full_array
= false;
2881 gfc_array_ref
*actual_arr_ref
;
2885 if (actual
== NULL
&& formal
== NULL
)
2889 for (f
= formal
; f
; f
= f
->next
)
2892 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2894 for (i
= 0; i
< n
; i
++)
2901 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2903 if (a
->name
!= NULL
&& in_statement_function
)
2905 gfc_error ("Keyword argument %qs at %L is invalid in "
2906 "a statement function", a
->name
, &a
->expr
->where
);
2910 /* Look for keywords but ignore g77 extensions like %VAL. */
2911 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2914 for (f
= formal
; f
; f
= f
->next
, i
++)
2918 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2926 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
2928 gfc_error ("Keyword argument %qs at %L is not in "
2929 "the procedure; did you mean %qs?",
2930 a
->name
, &a
->expr
->where
, guessed
);
2932 gfc_error ("Keyword argument %qs at %L is not in "
2933 "the procedure", a
->name
, &a
->expr
->where
);
2938 if (new_arg
[i
] != NULL
)
2941 gfc_error ("Keyword argument %qs at %L is already associated "
2942 "with another actual argument", a
->name
,
2951 gfc_error ("More actual than formal arguments in procedure "
2952 "call at %L", where
);
2957 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2963 gfc_error ("Missing alternate return spec in subroutine call "
2968 if (a
->expr
== NULL
)
2971 gfc_error ("Unexpected alternate return spec in subroutine "
2972 "call at %L", where
);
2976 /* Make sure that intrinsic vtables exist for calls to unlimited
2977 polymorphic formal arguments. */
2978 if (UNLIMITED_POLY (f
->sym
)
2979 && a
->expr
->ts
.type
!= BT_DERIVED
2980 && a
->expr
->ts
.type
!= BT_CLASS
)
2981 gfc_find_vtab (&a
->expr
->ts
);
2983 if (a
->expr
->expr_type
== EXPR_NULL
2984 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2985 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2986 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2987 || (f
->sym
->ts
.type
== BT_CLASS
2988 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2989 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2990 || !f
->sym
->attr
.optional
2991 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2994 && (!f
->sym
->attr
.optional
2995 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2996 || (f
->sym
->ts
.type
== BT_CLASS
2997 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2998 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2999 where
, f
->sym
->name
);
3001 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3002 "dummy %qs", where
, f
->sym
->name
);
3007 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
3008 is_elemental
, where
))
3011 /* TS 29113, 6.3p2. */
3012 if (f
->sym
->ts
.type
== BT_ASSUMED
3013 && (a
->expr
->ts
.type
== BT_DERIVED
3014 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
3016 gfc_namespace
*f2k_derived
;
3018 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
3019 ? a
->expr
->ts
.u
.derived
->f2k_derived
3020 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
3023 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
3025 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3026 "derived type with type-bound or FINAL procedures",
3032 /* Special case for character arguments. For allocatable, pointer
3033 and assumed-shape dummies, the string length needs to match
3035 if (a
->expr
->ts
.type
== BT_CHARACTER
3036 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3037 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3038 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3039 && f
->sym
->ts
.u
.cl
->length
3040 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3041 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3042 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3043 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3044 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3046 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3047 gfc_warning (OPT_Wargument_mismatch
,
3048 "Character length mismatch (%ld/%ld) between actual "
3049 "argument and pointer or allocatable dummy argument "
3051 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3052 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3053 f
->sym
->name
, &a
->expr
->where
);
3055 gfc_warning (OPT_Wargument_mismatch
,
3056 "Character length mismatch (%ld/%ld) between actual "
3057 "argument and assumed-shape dummy argument %qs "
3059 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3060 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3061 f
->sym
->name
, &a
->expr
->where
);
3065 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3066 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3067 && a
->expr
->ts
.type
== BT_CHARACTER
)
3070 gfc_error ("Actual argument at %L to allocatable or "
3071 "pointer dummy argument %qs must have a deferred "
3072 "length type parameter if and only if the dummy has one",
3073 &a
->expr
->where
, f
->sym
->name
);
3077 if (f
->sym
->ts
.type
== BT_CLASS
)
3078 goto skip_size_check
;
3080 actual_size
= get_expr_storage_size (a
->expr
);
3081 formal_size
= get_sym_storage_size (f
->sym
);
3082 if (actual_size
!= 0 && actual_size
< formal_size
3083 && a
->expr
->ts
.type
!= BT_PROCEDURE
3084 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3086 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3087 gfc_warning (OPT_Wargument_mismatch
,
3088 "Character length of actual argument shorter "
3089 "than of dummy argument %qs (%lu/%lu) at %L",
3090 f
->sym
->name
, actual_size
, formal_size
,
3094 /* Emit a warning for -std=legacy and an error otherwise. */
3095 if (gfc_option
.warn_std
== 0)
3096 gfc_warning (OPT_Wargument_mismatch
,
3097 "Actual argument contains too few "
3098 "elements for dummy argument %qs (%lu/%lu) "
3099 "at %L", f
->sym
->name
, actual_size
,
3100 formal_size
, &a
->expr
->where
);
3102 gfc_error_now ("Actual argument contains too few "
3103 "elements for dummy argument %qs (%lu/%lu) "
3104 "at %L", f
->sym
->name
, actual_size
,
3105 formal_size
, &a
->expr
->where
);
3112 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3113 argument is provided for a procedure pointer formal argument. */
3114 if (f
->sym
->attr
.proc_pointer
3115 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3116 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3117 || gfc_is_proc_ptr_comp (a
->expr
)))
3118 || (a
->expr
->expr_type
== EXPR_FUNCTION
3119 && is_procptr_result (a
->expr
))))
3122 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3123 f
->sym
->name
, &a
->expr
->where
);
3127 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3128 provided for a procedure formal argument. */
3129 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3130 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3131 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3132 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3133 || gfc_is_proc_ptr_comp (a
->expr
)))
3134 || (a
->expr
->expr_type
== EXPR_FUNCTION
3135 && is_procptr_result (a
->expr
))))
3138 gfc_error ("Expected a procedure for argument %qs at %L",
3139 f
->sym
->name
, &a
->expr
->where
);
3143 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3144 && a
->expr
->expr_type
== EXPR_VARIABLE
3145 && a
->expr
->symtree
->n
.sym
->as
3146 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3147 && (a
->expr
->ref
== NULL
3148 || (a
->expr
->ref
->type
== REF_ARRAY
3149 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3152 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3153 " array at %L", f
->sym
->name
, where
);
3157 if (a
->expr
->expr_type
!= EXPR_NULL
3158 && compare_pointer (f
->sym
, a
->expr
) == 0)
3161 gfc_error ("Actual argument for %qs must be a pointer at %L",
3162 f
->sym
->name
, &a
->expr
->where
);
3166 if (a
->expr
->expr_type
!= EXPR_NULL
3167 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3168 && compare_pointer (f
->sym
, a
->expr
) == 2)
3171 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3172 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3177 /* Fortran 2008, C1242. */
3178 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3181 gfc_error ("Coindexed actual argument at %L to pointer "
3183 &a
->expr
->where
, f
->sym
->name
);
3187 /* Fortran 2008, 12.5.2.5 (no constraint). */
3188 if (a
->expr
->expr_type
== EXPR_VARIABLE
3189 && f
->sym
->attr
.intent
!= INTENT_IN
3190 && f
->sym
->attr
.allocatable
3191 && gfc_is_coindexed (a
->expr
))
3194 gfc_error ("Coindexed actual argument at %L to allocatable "
3195 "dummy %qs requires INTENT(IN)",
3196 &a
->expr
->where
, f
->sym
->name
);
3200 /* Fortran 2008, C1237. */
3201 if (a
->expr
->expr_type
== EXPR_VARIABLE
3202 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3203 && gfc_is_coindexed (a
->expr
)
3204 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3205 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3208 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3209 "%L requires that dummy %qs has neither "
3210 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3215 /* Fortran 2008, 12.5.2.4 (no constraint). */
3216 if (a
->expr
->expr_type
== EXPR_VARIABLE
3217 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3218 && gfc_is_coindexed (a
->expr
)
3219 && gfc_has_ultimate_allocatable (a
->expr
))
3222 gfc_error ("Coindexed actual argument at %L with allocatable "
3223 "ultimate component to dummy %qs requires either VALUE "
3224 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3228 if (f
->sym
->ts
.type
== BT_CLASS
3229 && CLASS_DATA (f
->sym
)->attr
.allocatable
3230 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3234 gfc_error ("Actual CLASS array argument for %qs must be a full "
3235 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3240 if (a
->expr
->expr_type
!= EXPR_NULL
3241 && !compare_allocatable (f
->sym
, a
->expr
))
3244 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3245 f
->sym
->name
, &a
->expr
->where
);
3249 /* Check intent = OUT/INOUT for definable actual argument. */
3250 if (!in_statement_function
3251 && (f
->sym
->attr
.intent
== INTENT_OUT
3252 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3254 const char* context
= (where
3255 ? _("actual argument to INTENT = OUT/INOUT")
3258 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3259 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3260 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3261 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3263 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3267 if ((f
->sym
->attr
.intent
== INTENT_OUT
3268 || f
->sym
->attr
.intent
== INTENT_INOUT
3269 || f
->sym
->attr
.volatile_
3270 || f
->sym
->attr
.asynchronous
)
3271 && gfc_has_vector_subscript (a
->expr
))
3274 gfc_error ("Array-section actual argument with vector "
3275 "subscripts at %L is incompatible with INTENT(OUT), "
3276 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3277 "of the dummy argument %qs",
3278 &a
->expr
->where
, f
->sym
->name
);
3282 /* C1232 (R1221) For an actual argument which is an array section or
3283 an assumed-shape array, the dummy argument shall be an assumed-
3284 shape array, if the dummy argument has the VOLATILE attribute. */
3286 if (f
->sym
->attr
.volatile_
3287 && a
->expr
->expr_type
== EXPR_VARIABLE
3288 && a
->expr
->symtree
->n
.sym
->as
3289 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3290 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3293 gfc_error ("Assumed-shape actual argument at %L is "
3294 "incompatible with the non-assumed-shape "
3295 "dummy argument %qs due to VOLATILE attribute",
3296 &a
->expr
->where
,f
->sym
->name
);
3300 /* Find the last array_ref. */
3301 actual_arr_ref
= NULL
;
3303 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3305 if (f
->sym
->attr
.volatile_
3306 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3307 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3310 gfc_error ("Array-section actual argument at %L is "
3311 "incompatible with the non-assumed-shape "
3312 "dummy argument %qs due to VOLATILE attribute",
3313 &a
->expr
->where
, f
->sym
->name
);
3317 /* C1233 (R1221) For an actual argument which is a pointer array, the
3318 dummy argument shall be an assumed-shape or pointer array, if the
3319 dummy argument has the VOLATILE attribute. */
3321 if (f
->sym
->attr
.volatile_
3322 && a
->expr
->expr_type
== EXPR_VARIABLE
3323 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3324 && a
->expr
->symtree
->n
.sym
->as
3326 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3327 || f
->sym
->attr
.pointer
)))
3330 gfc_error ("Pointer-array actual argument at %L requires "
3331 "an assumed-shape or pointer-array dummy "
3332 "argument %qs due to VOLATILE attribute",
3333 &a
->expr
->where
,f
->sym
->name
);
3344 /* Make sure missing actual arguments are optional. */
3346 for (f
= formal
; f
; f
= f
->next
, i
++)
3348 if (new_arg
[i
] != NULL
)
3353 gfc_error ("Missing alternate return spec in subroutine call "
3357 if (!f
->sym
->attr
.optional
3358 || (in_statement_function
&& f
->sym
->attr
.optional
))
3361 gfc_error ("Missing actual argument for argument %qs at %L",
3362 f
->sym
->name
, where
);
3367 /* The argument lists are compatible. We now relink a new actual
3368 argument list with null arguments in the right places. The head
3369 of the list remains the head. */
3370 for (i
= 0; i
< n
; i
++)
3371 if (new_arg
[i
] == NULL
)
3372 new_arg
[i
] = gfc_get_actual_arglist ();
3376 std::swap (*new_arg
[0], *actual
);
3377 std::swap (new_arg
[0], new_arg
[na
]);
3380 for (i
= 0; i
< n
- 1; i
++)
3381 new_arg
[i
]->next
= new_arg
[i
+ 1];
3383 new_arg
[i
]->next
= NULL
;
3385 if (*ap
== NULL
&& n
> 0)
3388 /* Note the types of omitted optional arguments. */
3389 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3390 if (a
->expr
== NULL
&& a
->label
== NULL
)
3391 a
->missing_arg_type
= f
->sym
->ts
.type
;
3399 gfc_formal_arglist
*f
;
3400 gfc_actual_arglist
*a
;
3404 /* qsort comparison function for argument pairs, with the following
3406 - p->a->expr == NULL
3407 - p->a->expr->expr_type != EXPR_VARIABLE
3408 - by gfc_symbol pointer value (larger first). */
3411 pair_cmp (const void *p1
, const void *p2
)
3413 const gfc_actual_arglist
*a1
, *a2
;
3415 /* *p1 and *p2 are elements of the to-be-sorted array. */
3416 a1
= ((const argpair
*) p1
)->a
;
3417 a2
= ((const argpair
*) p2
)->a
;
3426 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3428 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3432 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3434 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3436 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3440 /* Given two expressions from some actual arguments, test whether they
3441 refer to the same expression. The analysis is conservative.
3442 Returning false will produce no warning. */
3445 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3447 const gfc_ref
*r1
, *r2
;
3450 || e1
->expr_type
!= EXPR_VARIABLE
3451 || e2
->expr_type
!= EXPR_VARIABLE
3452 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3455 /* TODO: improve comparison, see expr.c:show_ref(). */
3456 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3458 if (r1
->type
!= r2
->type
)
3463 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3465 /* TODO: At the moment, consider only full arrays;
3466 we could do better. */
3467 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3472 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3480 gfc_internal_error ("compare_actual_expr(): Bad component code");
3489 /* Given formal and actual argument lists that correspond to one
3490 another, check that identical actual arguments aren't not
3491 associated with some incompatible INTENTs. */
3494 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3496 sym_intent f1_intent
, f2_intent
;
3497 gfc_formal_arglist
*f1
;
3498 gfc_actual_arglist
*a1
;
3504 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3506 if (f1
== NULL
&& a1
== NULL
)
3508 if (f1
== NULL
|| a1
== NULL
)
3509 gfc_internal_error ("check_some_aliasing(): List mismatch");
3514 p
= XALLOCAVEC (argpair
, n
);
3516 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3522 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3524 for (i
= 0; i
< n
; i
++)
3527 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3528 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3530 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3531 for (j
= i
+ 1; j
< n
; j
++)
3533 /* Expected order after the sort. */
3534 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3535 gfc_internal_error ("check_some_aliasing(): corrupted data");
3537 /* Are the expression the same? */
3538 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3540 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3541 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3542 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3543 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3545 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3546 "argument %qs and INTENT(%s) argument %qs at %L",
3547 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3548 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3549 &p
[i
].a
->expr
->where
);
3559 /* Given formal and actual argument lists that correspond to one
3560 another, check that they are compatible in the sense that intents
3561 are not mismatched. */
3564 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3566 sym_intent f_intent
;
3568 for (;; f
= f
->next
, a
= a
->next
)
3572 if (f
== NULL
&& a
== NULL
)
3574 if (f
== NULL
|| a
== NULL
)
3575 gfc_internal_error ("check_intents(): List mismatch");
3577 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3578 && a
->expr
->value
.function
.isym
3579 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3580 expr
= a
->expr
->value
.function
.actual
->expr
;
3584 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3587 f_intent
= f
->sym
->attr
.intent
;
3589 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3591 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3592 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3593 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3595 gfc_error ("Procedure argument at %L is local to a PURE "
3596 "procedure and has the POINTER attribute",
3602 /* Fortran 2008, C1283. */
3603 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3605 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3607 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3608 "is passed to an INTENT(%s) argument",
3609 &expr
->where
, gfc_intent_string (f_intent
));
3613 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3614 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3615 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3617 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3618 "is passed to a POINTER dummy argument",
3624 /* F2008, Section 12.5.2.4. */
3625 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3626 && gfc_is_coindexed (expr
))
3628 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3629 "polymorphic dummy argument %qs",
3630 &expr
->where
, f
->sym
->name
);
3639 /* Check how a procedure is used against its interface. If all goes
3640 well, the actual argument list will also end up being properly
3644 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3646 gfc_actual_arglist
*a
;
3647 gfc_formal_arglist
*dummy_args
;
3649 /* Warn about calls with an implicit interface. Special case
3650 for calling a ISO_C_BINDING because c_loc and c_funloc
3651 are pseudo-unknown. Additionally, warn about procedures not
3652 explicitly declared at all if requested. */
3653 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3655 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3658 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3660 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3661 "; did you mean %qs?",
3662 sym
->name
, where
, guessed
);
3664 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3668 if (warn_implicit_interface
)
3669 gfc_warning (OPT_Wimplicit_interface
,
3670 "Procedure %qs called with an implicit interface at %L",
3672 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3673 gfc_warning (OPT_Wimplicit_procedure
,
3674 "Procedure %qs called at %L is not explicitly declared",
3678 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3680 if (sym
->attr
.pointer
)
3682 gfc_error ("The pointer object %qs at %L must have an explicit "
3683 "function interface or be declared as array",
3688 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3690 gfc_error ("The allocatable object %qs at %L must have an explicit "
3691 "function interface or be declared as array",
3696 if (sym
->attr
.allocatable
)
3698 gfc_error ("Allocatable function %qs at %L must have an explicit "
3699 "function interface", sym
->name
, where
);
3703 for (a
= *ap
; a
; a
= a
->next
)
3705 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3706 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3708 gfc_error ("Keyword argument requires explicit interface "
3709 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3713 /* TS 29113, 6.2. */
3714 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3715 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3717 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3718 "interface", a
->expr
->symtree
->n
.sym
->name
,
3723 /* F2008, C1303 and C1304. */
3725 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3726 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3727 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3728 || gfc_expr_attr (a
->expr
).lock_comp
))
3730 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3731 "component at %L requires an explicit interface for "
3732 "procedure %qs", &a
->expr
->where
, sym
->name
);
3737 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3738 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3739 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3740 == ISOFORTRAN_EVENT_TYPE
)
3741 || gfc_expr_attr (a
->expr
).event_comp
))
3743 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3744 "component at %L requires an explicit interface for "
3745 "procedure %qs", &a
->expr
->where
, sym
->name
);
3749 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3750 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3752 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3756 /* TS 29113, C407b. */
3757 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3758 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3760 gfc_error ("Assumed-rank argument requires an explicit interface "
3761 "at %L", &a
->expr
->where
);
3769 dummy_args
= gfc_sym_get_dummy_args (sym
);
3771 /* For a statement function, check that types and type parameters of actual
3772 arguments and dummy arguments match. */
3773 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3774 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3777 if (!check_intents (dummy_args
, *ap
))
3781 check_some_aliasing (dummy_args
, *ap
);
3787 /* Check how a procedure pointer component is used against its interface.
3788 If all goes well, the actual argument list will also end up being properly
3789 sorted. Completely analogous to gfc_procedure_use. */
3792 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3794 /* Warn about calls with an implicit interface. Special case
3795 for calling a ISO_C_BINDING because c_loc and c_funloc
3796 are pseudo-unknown. */
3797 if (warn_implicit_interface
3798 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3799 && !comp
->attr
.is_iso_c
)
3800 gfc_warning (OPT_Wimplicit_interface
,
3801 "Procedure pointer component %qs called with an implicit "
3802 "interface at %L", comp
->name
, where
);
3804 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3806 gfc_actual_arglist
*a
;
3807 for (a
= *ap
; a
; a
= a
->next
)
3809 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3810 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3812 gfc_error ("Keyword argument requires explicit interface "
3813 "for procedure pointer component %qs at %L",
3814 comp
->name
, &a
->expr
->where
);
3822 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3823 comp
->attr
.elemental
, false, where
))
3826 check_intents (comp
->ts
.interface
->formal
, *ap
);
3828 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3832 /* Try if an actual argument list matches the formal list of a symbol,
3833 respecting the symbol's attributes like ELEMENTAL. This is used for
3834 GENERIC resolution. */
3837 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3839 gfc_formal_arglist
*dummy_args
;
3842 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3845 dummy_args
= gfc_sym_get_dummy_args (sym
);
3847 r
= !sym
->attr
.elemental
;
3848 if (compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
3850 check_intents (dummy_args
, *args
);
3852 check_some_aliasing (dummy_args
, *args
);
3860 /* Given an interface pointer and an actual argument list, search for
3861 a formal argument list that matches the actual. If found, returns
3862 a pointer to the symbol of the correct interface. Returns NULL if
3866 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3867 gfc_actual_arglist
**ap
)
3869 gfc_symbol
*elem_sym
= NULL
;
3870 gfc_symbol
*null_sym
= NULL
;
3871 locus null_expr_loc
;
3872 gfc_actual_arglist
*a
;
3873 bool has_null_arg
= false;
3875 for (a
= *ap
; a
; a
= a
->next
)
3876 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3877 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3879 has_null_arg
= true;
3880 null_expr_loc
= a
->expr
->where
;
3884 for (; intr
; intr
= intr
->next
)
3886 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3888 if (sub_flag
&& intr
->sym
->attr
.function
)
3890 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3893 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3895 if (has_null_arg
&& null_sym
)
3897 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3898 "between specific functions %s and %s",
3899 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3902 else if (has_null_arg
)
3904 null_sym
= intr
->sym
;
3908 /* Satisfy 12.4.4.1 such that an elemental match has lower
3909 weight than a non-elemental match. */
3910 if (intr
->sym
->attr
.elemental
)
3912 elem_sym
= intr
->sym
;
3922 return elem_sym
? elem_sym
: NULL
;
3926 /* Do a brute force recursive search for a symbol. */
3928 static gfc_symtree
*
3929 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3933 if (root
->n
.sym
== sym
)
3938 st
= find_symtree0 (root
->left
, sym
);
3939 if (root
->right
&& ! st
)
3940 st
= find_symtree0 (root
->right
, sym
);
3945 /* Find a symtree for a symbol. */
3948 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3953 /* First try to find it by name. */
3954 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3955 if (st
&& st
->n
.sym
== sym
)
3958 /* If it's been renamed, resort to a brute-force search. */
3959 /* TODO: avoid having to do this search. If the symbol doesn't exist
3960 in the symtree for the current namespace, it should probably be added. */
3961 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3963 st
= find_symtree0 (ns
->sym_root
, sym
);
3967 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3972 /* See if the arglist to an operator-call contains a derived-type argument
3973 with a matching type-bound operator. If so, return the matching specific
3974 procedure defined as operator-target as well as the base-object to use
3975 (which is the found derived-type argument with operator). The generic
3976 name, if any, is transmitted to the final expression via 'gname'. */
3978 static gfc_typebound_proc
*
3979 matching_typebound_op (gfc_expr
** tb_base
,
3980 gfc_actual_arglist
* args
,
3981 gfc_intrinsic_op op
, const char* uop
,
3982 const char ** gname
)
3984 gfc_actual_arglist
* base
;
3986 for (base
= args
; base
; base
= base
->next
)
3987 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3989 gfc_typebound_proc
* tb
;
3990 gfc_symbol
* derived
;
3993 while (base
->expr
->expr_type
== EXPR_OP
3994 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3995 base
->expr
= base
->expr
->value
.op
.op1
;
3997 if (base
->expr
->ts
.type
== BT_CLASS
)
3999 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
4000 || !gfc_expr_attr (base
->expr
).class_ok
)
4002 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
4005 derived
= base
->expr
->ts
.u
.derived
;
4007 if (op
== INTRINSIC_USER
)
4009 gfc_symtree
* tb_uop
;
4012 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
4021 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
4024 /* This means we hit a PRIVATE operator which is use-associated and
4025 should thus not be seen. */
4029 /* Look through the super-type hierarchy for a matching specific
4031 for (; tb
; tb
= tb
->overridden
)
4035 gcc_assert (tb
->is_generic
);
4036 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4039 gfc_actual_arglist
* argcopy
;
4042 gcc_assert (g
->specific
);
4043 if (g
->specific
->error
)
4046 target
= g
->specific
->u
.specific
->n
.sym
;
4048 /* Check if this arglist matches the formal. */
4049 argcopy
= gfc_copy_actual_arglist (args
);
4050 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4051 gfc_free_actual_arglist (argcopy
);
4053 /* Return if we found a match. */
4056 *tb_base
= base
->expr
;
4057 *gname
= g
->specific_st
->name
;
4068 /* For the 'actual arglist' of an operator call and a specific typebound
4069 procedure that has been found the target of a type-bound operator, build the
4070 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4071 type-bound procedures rather than resolving type-bound operators 'directly'
4072 so that we can reuse the existing logic. */
4075 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4076 gfc_expr
* base
, gfc_typebound_proc
* target
,
4079 e
->expr_type
= EXPR_COMPCALL
;
4080 e
->value
.compcall
.tbp
= target
;
4081 e
->value
.compcall
.name
= gname
? gname
: "$op";
4082 e
->value
.compcall
.actual
= actual
;
4083 e
->value
.compcall
.base_object
= base
;
4084 e
->value
.compcall
.ignore_pass
= 1;
4085 e
->value
.compcall
.assign
= 0;
4086 if (e
->ts
.type
== BT_UNKNOWN
4087 && target
->function
)
4089 if (target
->is_generic
)
4090 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4092 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4097 /* This subroutine is called when an expression is being resolved.
4098 The expression node in question is either a user defined operator
4099 or an intrinsic operator with arguments that aren't compatible
4100 with the operator. This subroutine builds an actual argument list
4101 corresponding to the operands, then searches for a compatible
4102 interface. If one is found, the expression node is replaced with
4103 the appropriate function call. We use the 'match' enum to specify
4104 whether a replacement has been made or not, or if an error occurred. */
4107 gfc_extend_expr (gfc_expr
*e
)
4109 gfc_actual_arglist
*actual
;
4115 gfc_typebound_proc
* tbo
;
4120 actual
= gfc_get_actual_arglist ();
4121 actual
->expr
= e
->value
.op
.op1
;
4125 if (e
->value
.op
.op2
!= NULL
)
4127 actual
->next
= gfc_get_actual_arglist ();
4128 actual
->next
->expr
= e
->value
.op
.op2
;
4131 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4133 /* See if we find a matching type-bound operator. */
4134 if (i
== INTRINSIC_USER
)
4135 tbo
= matching_typebound_op (&tb_base
, actual
,
4136 i
, e
->value
.op
.uop
->name
, &gname
);
4140 #define CHECK_OS_COMPARISON(comp) \
4141 case INTRINSIC_##comp: \
4142 case INTRINSIC_##comp##_OS: \
4143 tbo = matching_typebound_op (&tb_base, actual, \
4144 INTRINSIC_##comp, NULL, &gname); \
4146 tbo = matching_typebound_op (&tb_base, actual, \
4147 INTRINSIC_##comp##_OS, NULL, &gname); \
4149 CHECK_OS_COMPARISON(EQ
)
4150 CHECK_OS_COMPARISON(NE
)
4151 CHECK_OS_COMPARISON(GT
)
4152 CHECK_OS_COMPARISON(GE
)
4153 CHECK_OS_COMPARISON(LT
)
4154 CHECK_OS_COMPARISON(LE
)
4155 #undef CHECK_OS_COMPARISON
4158 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4162 /* If there is a matching typebound-operator, replace the expression with
4163 a call to it and succeed. */
4166 gcc_assert (tb_base
);
4167 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4169 if (!gfc_resolve_expr (e
))
4175 if (i
== INTRINSIC_USER
)
4177 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4179 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4183 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4190 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4192 /* Due to the distinction between '==' and '.eq.' and friends, one has
4193 to check if either is defined. */
4196 #define CHECK_OS_COMPARISON(comp) \
4197 case INTRINSIC_##comp: \
4198 case INTRINSIC_##comp##_OS: \
4199 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4201 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4203 CHECK_OS_COMPARISON(EQ
)
4204 CHECK_OS_COMPARISON(NE
)
4205 CHECK_OS_COMPARISON(GT
)
4206 CHECK_OS_COMPARISON(GE
)
4207 CHECK_OS_COMPARISON(LT
)
4208 CHECK_OS_COMPARISON(LE
)
4209 #undef CHECK_OS_COMPARISON
4212 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4220 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4221 found rather than just taking the first one and not checking further. */
4225 /* Don't use gfc_free_actual_arglist(). */
4226 free (actual
->next
);
4231 /* Change the expression node to a function call. */
4232 e
->expr_type
= EXPR_FUNCTION
;
4233 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4234 e
->value
.function
.actual
= actual
;
4235 e
->value
.function
.esym
= NULL
;
4236 e
->value
.function
.isym
= NULL
;
4237 e
->value
.function
.name
= NULL
;
4238 e
->user_operator
= 1;
4240 if (!gfc_resolve_expr (e
))
4247 /* Tries to replace an assignment code node with a subroutine call to the
4248 subroutine associated with the assignment operator. Return true if the node
4249 was replaced. On false, no error is generated. */
4252 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4254 gfc_actual_arglist
*actual
;
4255 gfc_expr
*lhs
, *rhs
, *tb_base
;
4256 gfc_symbol
*sym
= NULL
;
4257 const char *gname
= NULL
;
4258 gfc_typebound_proc
* tbo
;
4263 /* Don't allow an intrinsic assignment to be replaced. */
4264 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4265 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4266 && (lhs
->ts
.type
== rhs
->ts
.type
4267 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4270 actual
= gfc_get_actual_arglist ();
4273 actual
->next
= gfc_get_actual_arglist ();
4274 actual
->next
->expr
= rhs
;
4276 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4278 /* See if we find a matching type-bound assignment. */
4279 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4284 /* Success: Replace the expression with a type-bound call. */
4285 gcc_assert (tb_base
);
4286 c
->expr1
= gfc_get_expr ();
4287 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4288 c
->expr1
->value
.compcall
.assign
= 1;
4289 c
->expr1
->where
= c
->loc
;
4291 c
->op
= EXEC_COMPCALL
;
4295 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4296 for (; ns
; ns
= ns
->parent
)
4298 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4305 /* Success: Replace the assignment with the call. */
4306 c
->op
= EXEC_ASSIGN_CALL
;
4307 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4310 c
->ext
.actual
= actual
;
4314 /* Failure: No assignment procedure found. */
4315 free (actual
->next
);
4321 /* Make sure that the interface just parsed is not already present in
4322 the given interface list. Ambiguity isn't checked yet since module
4323 procedures can be present without interfaces. */
4326 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4330 for (ip
= base
; ip
; ip
= ip
->next
)
4332 if (ip
->sym
== new_sym
)
4334 gfc_error ("Entity %qs at %L is already present in the interface",
4335 new_sym
->name
, &loc
);
4344 /* Add a symbol to the current interface. */
4347 gfc_add_interface (gfc_symbol
*new_sym
)
4349 gfc_interface
**head
, *intr
;
4353 switch (current_interface
.type
)
4355 case INTERFACE_NAMELESS
:
4356 case INTERFACE_ABSTRACT
:
4359 case INTERFACE_INTRINSIC_OP
:
4360 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4361 switch (current_interface
.op
)
4364 case INTRINSIC_EQ_OS
:
4365 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4367 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4368 new_sym
, gfc_current_locus
))
4373 case INTRINSIC_NE_OS
:
4374 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4376 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4377 new_sym
, gfc_current_locus
))
4382 case INTRINSIC_GT_OS
:
4383 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4384 new_sym
, gfc_current_locus
)
4385 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4386 new_sym
, gfc_current_locus
))
4391 case INTRINSIC_GE_OS
:
4392 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4393 new_sym
, gfc_current_locus
)
4394 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4395 new_sym
, gfc_current_locus
))
4400 case INTRINSIC_LT_OS
:
4401 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4402 new_sym
, gfc_current_locus
)
4403 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4404 new_sym
, gfc_current_locus
))
4409 case INTRINSIC_LE_OS
:
4410 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4411 new_sym
, gfc_current_locus
)
4412 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4413 new_sym
, gfc_current_locus
))
4418 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4419 new_sym
, gfc_current_locus
))
4423 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4426 case INTERFACE_GENERIC
:
4427 case INTERFACE_DTIO
:
4428 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4430 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4434 if (!gfc_check_new_interface (sym
->generic
,
4435 new_sym
, gfc_current_locus
))
4439 head
= ¤t_interface
.sym
->generic
;
4442 case INTERFACE_USER_OP
:
4443 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4444 new_sym
, gfc_current_locus
))
4447 head
= ¤t_interface
.uop
->op
;
4451 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4454 intr
= gfc_get_interface ();
4455 intr
->sym
= new_sym
;
4456 intr
->where
= gfc_current_locus
;
4466 gfc_current_interface_head (void)
4468 switch (current_interface
.type
)
4470 case INTERFACE_INTRINSIC_OP
:
4471 return current_interface
.ns
->op
[current_interface
.op
];
4473 case INTERFACE_GENERIC
:
4474 case INTERFACE_DTIO
:
4475 return current_interface
.sym
->generic
;
4477 case INTERFACE_USER_OP
:
4478 return current_interface
.uop
->op
;
4487 gfc_set_current_interface_head (gfc_interface
*i
)
4489 switch (current_interface
.type
)
4491 case INTERFACE_INTRINSIC_OP
:
4492 current_interface
.ns
->op
[current_interface
.op
] = i
;
4495 case INTERFACE_GENERIC
:
4496 case INTERFACE_DTIO
:
4497 current_interface
.sym
->generic
= i
;
4500 case INTERFACE_USER_OP
:
4501 current_interface
.uop
->op
= i
;
4510 /* Gets rid of a formal argument list. We do not free symbols.
4511 Symbols are freed when a namespace is freed. */
4514 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4516 gfc_formal_arglist
*q
;
4526 /* Check that it is ok for the type-bound procedure 'proc' to override the
4527 procedure 'old', cf. F08:4.5.7.3. */
4530 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4533 gfc_symbol
*proc_target
, *old_target
;
4534 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4535 gfc_formal_arglist
*proc_formal
, *old_formal
;
4539 /* This procedure should only be called for non-GENERIC proc. */
4540 gcc_assert (!proc
->n
.tb
->is_generic
);
4542 /* If the overwritten procedure is GENERIC, this is an error. */
4543 if (old
->n
.tb
->is_generic
)
4545 gfc_error ("Can't overwrite GENERIC %qs at %L",
4546 old
->name
, &proc
->n
.tb
->where
);
4550 where
= proc
->n
.tb
->where
;
4551 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4552 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4554 /* Check that overridden binding is not NON_OVERRIDABLE. */
4555 if (old
->n
.tb
->non_overridable
)
4557 gfc_error ("%qs at %L overrides a procedure binding declared"
4558 " NON_OVERRIDABLE", proc
->name
, &where
);
4562 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4563 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4565 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4566 " non-DEFERRED binding", proc
->name
, &where
);
4570 /* If the overridden binding is PURE, the overriding must be, too. */
4571 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4573 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4574 proc
->name
, &where
);
4578 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4579 is not, the overriding must not be either. */
4580 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4582 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4583 " ELEMENTAL", proc
->name
, &where
);
4586 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4588 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4589 " be ELEMENTAL, either", proc
->name
, &where
);
4593 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4595 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4597 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4598 " SUBROUTINE", proc
->name
, &where
);
4602 /* If the overridden binding is a FUNCTION, the overriding must also be a
4603 FUNCTION and have the same characteristics. */
4604 if (old_target
->attr
.function
)
4606 if (!proc_target
->attr
.function
)
4608 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4609 " FUNCTION", proc
->name
, &where
);
4613 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4616 gfc_error ("Result mismatch for the overriding procedure "
4617 "%qs at %L: %s", proc
->name
, &where
, err
);
4622 /* If the overridden binding is PUBLIC, the overriding one must not be
4624 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4625 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4627 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4628 " PRIVATE", proc
->name
, &where
);
4632 /* Compare the formal argument lists of both procedures. This is also abused
4633 to find the position of the passed-object dummy arguments of both
4634 bindings as at least the overridden one might not yet be resolved and we
4635 need those positions in the check below. */
4636 proc_pass_arg
= old_pass_arg
= 0;
4637 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4639 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4642 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4643 old_formal
= gfc_sym_get_dummy_args (old_target
);
4644 for ( ; proc_formal
&& old_formal
;
4645 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4647 if (proc
->n
.tb
->pass_arg
4648 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4649 proc_pass_arg
= argpos
;
4650 if (old
->n
.tb
->pass_arg
4651 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4652 old_pass_arg
= argpos
;
4654 /* Check that the names correspond. */
4655 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4657 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4658 " to match the corresponding argument of the overridden"
4659 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4660 old_formal
->sym
->name
);
4664 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4665 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4666 check_type
, err
, sizeof(err
)))
4668 gfc_error_opt (OPT_Wargument_mismatch
,
4669 "Argument mismatch for the overriding procedure "
4670 "%qs at %L: %s", proc
->name
, &where
, err
);
4676 if (proc_formal
|| old_formal
)
4678 gfc_error ("%qs at %L must have the same number of formal arguments as"
4679 " the overridden procedure", proc
->name
, &where
);
4683 /* If the overridden binding is NOPASS, the overriding one must also be
4685 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4687 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4688 " NOPASS", proc
->name
, &where
);
4692 /* If the overridden binding is PASS(x), the overriding one must also be
4693 PASS and the passed-object dummy arguments must correspond. */
4694 if (!old
->n
.tb
->nopass
)
4696 if (proc
->n
.tb
->nopass
)
4698 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4699 " PASS", proc
->name
, &where
);
4703 if (proc_pass_arg
!= old_pass_arg
)
4705 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4706 " the same position as the passed-object dummy argument of"
4707 " the overridden procedure", proc
->name
, &where
);
4716 /* The following three functions check that the formal arguments
4717 of user defined derived type IO procedures are compliant with
4718 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4721 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4722 int kind
, int rank
, sym_intent intent
)
4724 if (fsym
->ts
.type
!= type
)
4726 gfc_error ("DTIO dummy argument at %L must be of type %s",
4727 &fsym
->declared_at
, gfc_basic_typename (type
));
4731 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4732 && fsym
->ts
.kind
!= kind
)
4733 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4734 &fsym
->declared_at
, kind
);
4738 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4739 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4740 gfc_error ("DTIO dummy argument at %L must be a scalar",
4741 &fsym
->declared_at
);
4743 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4744 gfc_error ("DTIO dummy argument at %L must be an "
4745 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4747 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4748 gfc_error ("DTIO character argument at %L must have assumed length",
4749 &fsym
->declared_at
);
4751 if (fsym
->attr
.intent
!= intent
)
4752 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4753 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4759 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4760 bool typebound
, bool formatted
, int code
)
4762 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4763 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4764 gfc_interface
*intr
;
4765 gfc_formal_arglist
*formal
;
4768 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4769 || ((dtio_codes
)code
== DTIO_RUF
);
4777 /* Typebound DTIO binding. */
4778 tb_io_proc
= tb_io_st
->n
.tb
;
4779 if (tb_io_proc
== NULL
)
4782 gcc_assert (tb_io_proc
->is_generic
);
4784 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4785 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4788 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4792 generic_proc
= tb_io_st
->n
.sym
;
4793 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4796 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4798 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4799 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4800 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4802 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4803 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4805 dtio_sub
= intr
->sym
;
4808 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4810 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4811 "procedure", &intr
->sym
->declared_at
);
4816 if (dtio_sub
== NULL
)
4820 gcc_assert (dtio_sub
);
4821 if (!dtio_sub
->attr
.subroutine
)
4822 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4823 dtio_sub
->name
, &dtio_sub
->declared_at
);
4826 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4829 if (arg_num
< (formatted
? 6 : 4))
4831 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4832 dtio_sub
->name
, &dtio_sub
->declared_at
);
4836 if (arg_num
> (formatted
? 6 : 4))
4838 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4839 dtio_sub
->name
, &dtio_sub
->declared_at
);
4844 /* Now go through the formal arglist. */
4846 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4848 if (!formatted
&& arg_num
== 3)
4854 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4855 "procedure", &dtio_sub
->declared_at
);
4862 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4863 BT_DERIVED
: BT_CLASS
;
4865 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4866 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4872 kind
= gfc_default_integer_kind
;
4874 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4877 case(3): /* IOTYPE */
4878 type
= BT_CHARACTER
;
4879 kind
= gfc_default_character_kind
;
4881 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4884 case(4): /* VLIST */
4886 kind
= gfc_default_integer_kind
;
4888 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4891 case(5): /* IOSTAT */
4893 kind
= gfc_default_integer_kind
;
4894 intent
= INTENT_OUT
;
4895 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4898 case(6): /* IOMSG */
4899 type
= BT_CHARACTER
;
4900 kind
= gfc_default_character_kind
;
4901 intent
= INTENT_INOUT
;
4902 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4909 derived
->attr
.has_dtio_procs
= 1;
4914 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4916 gfc_symtree
*tb_io_st
;
4921 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4924 /* Check typebound DTIO bindings. */
4925 for (code
= 0; code
< 4; code
++)
4927 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4928 || ((dtio_codes
)code
== DTIO_WF
);
4930 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4931 gfc_code2string (dtio_procs
, code
),
4932 true, &derived
->declared_at
);
4933 if (tb_io_st
!= NULL
)
4934 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4937 /* Check generic DTIO interfaces. */
4938 for (code
= 0; code
< 4; code
++)
4940 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4941 || ((dtio_codes
)code
== DTIO_WF
);
4943 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4944 gfc_code2string (dtio_procs
, code
));
4945 if (tb_io_st
!= NULL
)
4946 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4952 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4954 gfc_symtree
*tb_io_st
= NULL
;
4957 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4960 /* Try to find a typebound DTIO binding. */
4961 if (formatted
== true)
4964 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4965 gfc_code2string (dtio_procs
,
4968 &derived
->declared_at
);
4970 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4971 gfc_code2string (dtio_procs
,
4974 &derived
->declared_at
);
4979 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4980 gfc_code2string (dtio_procs
,
4983 &derived
->declared_at
);
4985 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4986 gfc_code2string (dtio_procs
,
4989 &derived
->declared_at
);
4996 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4998 gfc_symtree
*tb_io_st
= NULL
;
4999 gfc_symbol
*dtio_sub
= NULL
;
5000 gfc_symbol
*extended
;
5001 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
5003 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
5005 if (tb_io_st
!= NULL
)
5007 const char *genname
;
5010 tb_io_proc
= tb_io_st
->n
.tb
;
5011 gcc_assert (tb_io_proc
!= NULL
);
5012 gcc_assert (tb_io_proc
->is_generic
);
5013 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
5015 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5016 gcc_assert (!specific_proc
->is_generic
);
5018 /* Go back and make sure that we have the right specific procedure.
5019 Here we most likely have a procedure from the parent type, which
5020 can be overridden in extensions. */
5021 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
5022 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
5023 true, &tb_io_proc
->where
);
5025 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
5027 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5032 /* If there is not a typebound binding, look for a generic
5034 for (extended
= derived
; extended
;
5035 extended
= gfc_get_derived_super_type (extended
))
5037 if (extended
== NULL
|| extended
->ns
== NULL
5038 || extended
->attr
.flavor
== FL_UNKNOWN
)
5041 if (formatted
== true)
5044 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5045 gfc_code2string (dtio_procs
,
5048 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5049 gfc_code2string (dtio_procs
,
5055 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5056 gfc_code2string (dtio_procs
,
5059 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5060 gfc_code2string (dtio_procs
,
5064 if (tb_io_st
!= NULL
5066 && tb_io_st
->n
.sym
->generic
)
5068 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5069 intr
&& intr
->sym
; intr
= intr
->next
)
5071 if (intr
->sym
->formal
)
5073 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5074 if ((fsym
->ts
.type
== BT_CLASS
5075 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5076 || (fsym
->ts
.type
== BT_DERIVED
5077 && fsym
->ts
.u
.derived
== extended
))
5079 dtio_sub
= intr
->sym
;
5088 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5089 gfc_find_derived_vtab (derived
);