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 (strncmp (mode
, "formatted", 9) == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strncmp (mode
, "unformatted", 9) == 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 /* Special case for our C interop types. There should be a better
696 way of doing this... */
698 if (((ts1
->type
== BT_INTEGER
&& ts2
->type
== BT_DERIVED
)
699 || (ts1
->type
== BT_DERIVED
&& ts2
->type
== BT_INTEGER
))
700 && ts1
->u
.derived
&& ts2
->u
.derived
701 && ts1
->u
.derived
== ts2
->u
.derived
)
704 /* The _data component is not always present, therefore check for its
705 presence before assuming, that its derived->attr is available.
706 When the _data component is not present, then nevertheless the
707 unlimited_polymorphic flag may be set in the derived type's attr. */
708 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
709 && ((ts1
->u
.derived
->attr
.is_class
710 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
711 .unlimited_polymorphic
)
712 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
716 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
717 && ts2
->u
.derived
->components
718 && ((ts2
->u
.derived
->attr
.is_class
719 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
720 .unlimited_polymorphic
)
721 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
722 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
725 if (ts1
->type
!= ts2
->type
726 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
727 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
730 if (ts1
->type
== BT_UNION
)
731 return compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
733 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
734 return (ts1
->kind
== ts2
->kind
);
736 /* Compare derived types. */
737 return gfc_type_compatible (ts1
, ts2
);
742 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
744 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
747 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
752 compare_type_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
)
754 /* TYPE and CLASS of the same declared type are type compatible,
755 but have different characteristics. */
756 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
757 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
760 return compare_type (s1
, s2
);
765 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
767 gfc_array_spec
*as1
, *as2
;
770 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
773 as1
= (s1
->ts
.type
== BT_CLASS
774 && !s1
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
775 ? CLASS_DATA (s1
)->as
: s1
->as
;
776 as2
= (s2
->ts
.type
== BT_CLASS
777 && !s2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
778 ? CLASS_DATA (s2
)->as
: s2
->as
;
780 r1
= as1
? as1
->rank
: 0;
781 r2
= as2
? as2
->rank
: 0;
783 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
784 return false; /* Ranks differ. */
790 /* Given two symbols that are formal arguments, compare their ranks
791 and types. Returns true if they have the same rank and type,
795 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
797 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
801 /* Given two symbols that are formal arguments, compare their types
802 and rank and their formal interfaces if they are both dummy
803 procedures. Returns true if the same, false if different. */
806 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
808 if (s1
== NULL
|| s2
== NULL
)
814 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
815 return compare_type_rank (s1
, s2
);
817 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
820 /* At this point, both symbols are procedures. It can happen that
821 external procedures are compared, where one is identified by usage
822 to be a function or subroutine but the other is not. Check TKR
823 nonetheless for these cases. */
824 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
825 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
827 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
828 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
830 /* Now the type of procedure has been identified. */
831 if (s1
->attr
.function
!= s2
->attr
.function
832 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
835 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
838 /* Originally, gfortran recursed here to check the interfaces of passed
839 procedures. This is explicitly not required by the standard. */
844 /* Given a formal argument list and a keyword name, search the list
845 for that keyword. Returns the correct symbol node if found, NULL
849 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
851 for (; f
; f
= f
->next
)
852 if (strcmp (f
->sym
->name
, name
) == 0)
859 /******** Interface checking subroutines **********/
862 /* Given an operator interface and the operator, make sure that all
863 interfaces for that operator are legal. */
866 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
869 gfc_formal_arglist
*formal
;
872 int args
, r1
, r2
, k1
, k2
;
877 t1
= t2
= BT_UNKNOWN
;
878 i1
= i2
= INTENT_UNKNOWN
;
882 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
884 gfc_symbol
*fsym
= formal
->sym
;
887 gfc_error ("Alternate return cannot appear in operator "
888 "interface at %L", &sym
->declared_at
);
894 i1
= fsym
->attr
.intent
;
895 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
901 i2
= fsym
->attr
.intent
;
902 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
908 /* Only +, - and .not. can be unary operators.
909 .not. cannot be a binary operator. */
910 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
911 && op
!= INTRINSIC_MINUS
912 && op
!= INTRINSIC_NOT
)
913 || (args
== 2 && op
== INTRINSIC_NOT
))
915 if (op
== INTRINSIC_ASSIGN
)
916 gfc_error ("Assignment operator interface at %L must have "
917 "two arguments", &sym
->declared_at
);
919 gfc_error ("Operator interface at %L has the wrong number of arguments",
924 /* Check that intrinsics are mapped to functions, except
925 INTRINSIC_ASSIGN which should map to a subroutine. */
926 if (op
== INTRINSIC_ASSIGN
)
928 gfc_formal_arglist
*dummy_args
;
930 if (!sym
->attr
.subroutine
)
932 gfc_error ("Assignment operator interface at %L must be "
933 "a SUBROUTINE", &sym
->declared_at
);
937 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
938 - First argument an array with different rank than second,
939 - First argument is a scalar and second an array,
940 - Types and kinds do not conform, or
941 - First argument is of derived type. */
942 dummy_args
= gfc_sym_get_dummy_args (sym
);
943 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
944 && dummy_args
->sym
->ts
.type
!= BT_CLASS
945 && (r2
== 0 || r1
== r2
)
946 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
947 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
948 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
950 gfc_error ("Assignment operator interface at %L must not redefine "
951 "an INTRINSIC type assignment", &sym
->declared_at
);
957 if (!sym
->attr
.function
)
959 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
965 /* Check intents on operator interfaces. */
966 if (op
== INTRINSIC_ASSIGN
)
968 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
970 gfc_error ("First argument of defined assignment at %L must be "
971 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
977 gfc_error ("Second argument of defined assignment at %L must be "
978 "INTENT(IN)", &sym
->declared_at
);
986 gfc_error ("First argument of operator interface at %L must be "
987 "INTENT(IN)", &sym
->declared_at
);
991 if (args
== 2 && i2
!= INTENT_IN
)
993 gfc_error ("Second argument of operator interface at %L must be "
994 "INTENT(IN)", &sym
->declared_at
);
999 /* From now on, all we have to do is check that the operator definition
1000 doesn't conflict with an intrinsic operator. The rules for this
1001 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
1002 as well as 12.3.2.1.1 of Fortran 2003:
1004 "If the operator is an intrinsic-operator (R310), the number of
1005 function arguments shall be consistent with the intrinsic uses of
1006 that operator, and the types, kind type parameters, or ranks of the
1007 dummy arguments shall differ from those required for the intrinsic
1008 operation (7.1.2)." */
1010 #define IS_NUMERIC_TYPE(t) \
1011 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
1013 /* Unary ops are easy, do them first. */
1014 if (op
== INTRINSIC_NOT
)
1016 if (t1
== BT_LOGICAL
)
1022 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1024 if (IS_NUMERIC_TYPE (t1
))
1030 /* Character intrinsic operators have same character kind, thus
1031 operator definitions with operands of different character kinds
1033 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1036 /* Intrinsic operators always perform on arguments of same rank,
1037 so different ranks is also always safe. (rank == 0) is an exception
1038 to that, because all intrinsic operators are elemental. */
1039 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1045 case INTRINSIC_EQ_OS
:
1047 case INTRINSIC_NE_OS
:
1048 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1052 case INTRINSIC_PLUS
:
1053 case INTRINSIC_MINUS
:
1054 case INTRINSIC_TIMES
:
1055 case INTRINSIC_DIVIDE
:
1056 case INTRINSIC_POWER
:
1057 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1062 case INTRINSIC_GT_OS
:
1064 case INTRINSIC_GE_OS
:
1066 case INTRINSIC_LT_OS
:
1068 case INTRINSIC_LE_OS
:
1069 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1071 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1072 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1076 case INTRINSIC_CONCAT
:
1077 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1084 case INTRINSIC_NEQV
:
1085 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1095 #undef IS_NUMERIC_TYPE
1098 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1104 /* Given a pair of formal argument lists, we see if the two lists can
1105 be distinguished by counting the number of nonoptional arguments of
1106 a given type/rank in f1 and seeing if there are less then that
1107 number of those arguments in f2 (including optional arguments).
1108 Since this test is asymmetric, it has to be called twice to make it
1109 symmetric. Returns nonzero if the argument lists are incompatible
1110 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1111 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1114 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1115 const char *p1
, const char *p2
)
1117 int ac1
, ac2
, i
, j
, k
, n1
;
1118 gfc_formal_arglist
*f
;
1131 for (f
= f1
; f
; f
= f
->next
)
1134 /* Build an array of integers that gives the same integer to
1135 arguments of the same type/rank. */
1136 arg
= XCNEWVEC (arginfo
, n1
);
1139 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1142 arg
[i
].sym
= f
->sym
;
1147 for (i
= 0; i
< n1
; i
++)
1149 if (arg
[i
].flag
!= -1)
1152 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1153 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1154 continue; /* Skip OPTIONAL and PASS arguments. */
1158 /* Find other non-optional, non-pass arguments of the same type/rank. */
1159 for (j
= i
+ 1; j
< n1
; j
++)
1160 if ((arg
[j
].sym
== NULL
1161 || !(arg
[j
].sym
->attr
.optional
1162 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1163 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1164 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1170 /* Now loop over each distinct type found in f1. */
1174 for (i
= 0; i
< n1
; i
++)
1176 if (arg
[i
].flag
!= k
)
1180 for (j
= i
+ 1; j
< n1
; j
++)
1181 if (arg
[j
].flag
== k
)
1184 /* Count the number of non-pass arguments in f2 with that type,
1185 including those that are optional. */
1188 for (f
= f2
; f
; f
= f
->next
)
1189 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1190 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1191 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1209 /* Perform the correspondence test in rule (3) of F08:C1215.
1210 Returns zero if no argument is found that satisfies this rule,
1211 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1214 This test is also not symmetric in f1 and f2 and must be called
1215 twice. This test finds problems caused by sorting the actual
1216 argument list with keywords. For example:
1220 INTEGER :: A ; REAL :: B
1224 INTEGER :: A ; REAL :: B
1228 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1231 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1232 const char *p1
, const char *p2
)
1234 gfc_formal_arglist
*f2_save
, *g
;
1241 if (f1
->sym
->attr
.optional
)
1244 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1246 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1249 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1250 || compare_type_rank (f2
->sym
, f1
->sym
))
1251 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1252 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1253 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1256 /* Now search for a disambiguating keyword argument starting at
1257 the current non-match. */
1258 for (g
= f1
; g
; g
= g
->next
)
1260 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1263 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1264 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1265 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1266 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1267 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1283 symbol_rank (gfc_symbol
*sym
)
1285 gfc_array_spec
*as
= NULL
;
1287 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1288 as
= CLASS_DATA (sym
)->as
;
1292 return as
? as
->rank
: 0;
1296 /* Check if the characteristics of two dummy arguments match,
1300 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1301 bool type_must_agree
, char *errmsg
,
1304 if (s1
== NULL
|| s2
== NULL
)
1305 return s1
== s2
? true : false;
1307 /* Check type and rank. */
1308 if (type_must_agree
)
1310 if (!compare_type_characteristics (s1
, s2
)
1311 || !compare_type_characteristics (s2
, s1
))
1313 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1314 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1317 if (!compare_rank (s1
, s2
))
1319 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1320 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1326 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1328 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1333 /* Check OPTIONAL attribute. */
1334 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1336 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1341 /* Check ALLOCATABLE attribute. */
1342 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1344 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1349 /* Check POINTER attribute. */
1350 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1352 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1357 /* Check TARGET attribute. */
1358 if (s1
->attr
.target
!= s2
->attr
.target
)
1360 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1365 /* Check ASYNCHRONOUS attribute. */
1366 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1368 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1373 /* Check CONTIGUOUS attribute. */
1374 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1376 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1381 /* Check VALUE attribute. */
1382 if (s1
->attr
.value
!= s2
->attr
.value
)
1384 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1389 /* Check VOLATILE attribute. */
1390 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1392 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1397 /* Check interface of dummy procedures. */
1398 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1401 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1404 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1405 "'%s': %s", s1
->name
, err
);
1410 /* Check string length. */
1411 if (s1
->ts
.type
== BT_CHARACTER
1412 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1413 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1415 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1416 s2
->ts
.u
.cl
->length
);
1422 snprintf (errmsg
, err_len
, "Character length mismatch "
1423 "in argument '%s'", s1
->name
);
1427 /* FIXME: Implement a warning for this case.
1428 gfc_warning (0, "Possible character length mismatch in argument %qs",
1436 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1437 "%i of gfc_dep_compare_expr", compval
);
1442 /* Check array shape. */
1443 if (s1
->as
&& s2
->as
)
1446 gfc_expr
*shape1
, *shape2
;
1448 if (s1
->as
->type
!= s2
->as
->type
)
1450 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1455 if (s1
->as
->corank
!= s2
->as
->corank
)
1457 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1458 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1462 if (s1
->as
->type
== AS_EXPLICIT
)
1463 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1465 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1466 gfc_copy_expr (s1
->as
->lower
[i
]));
1467 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1468 gfc_copy_expr (s2
->as
->lower
[i
]));
1469 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1470 gfc_free_expr (shape1
);
1471 gfc_free_expr (shape2
);
1477 if (i
< s1
->as
->rank
)
1478 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1479 " argument '%s'", i
+ 1, s1
->name
);
1481 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1482 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1486 /* FIXME: Implement a warning for this case.
1487 gfc_warning (0, "Possible shape mismatch in argument %qs",
1495 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1496 "result %i of gfc_dep_compare_expr",
1507 /* Check if the characteristics of two function results match,
1511 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1512 char *errmsg
, int err_len
)
1514 gfc_symbol
*r1
, *r2
;
1516 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1517 r1
= s1
->ts
.interface
->result
;
1519 r1
= s1
->result
? s1
->result
: s1
;
1521 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1522 r2
= s2
->ts
.interface
->result
;
1524 r2
= s2
->result
? s2
->result
: s2
;
1526 if (r1
->ts
.type
== BT_UNKNOWN
)
1529 /* Check type and rank. */
1530 if (!compare_type_characteristics (r1
, r2
))
1532 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1533 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1536 if (!compare_rank (r1
, r2
))
1538 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1539 symbol_rank (r1
), symbol_rank (r2
));
1543 /* Check ALLOCATABLE attribute. */
1544 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1546 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1551 /* Check POINTER attribute. */
1552 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1554 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1559 /* Check CONTIGUOUS attribute. */
1560 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1562 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1567 /* Check PROCEDURE POINTER attribute. */
1568 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1570 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1575 /* Check string length. */
1576 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1578 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1580 snprintf (errmsg
, err_len
, "Character length mismatch "
1581 "in function result");
1585 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1587 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1588 r2
->ts
.u
.cl
->length
);
1594 snprintf (errmsg
, err_len
, "Character length mismatch "
1595 "in function result");
1599 /* FIXME: Implement a warning for this case.
1600 snprintf (errmsg, err_len, "Possible character length mismatch "
1601 "in function result");*/
1608 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1609 "result %i of gfc_dep_compare_expr", compval
);
1615 /* Check array shape. */
1616 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1619 gfc_expr
*shape1
, *shape2
;
1621 if (r1
->as
->type
!= r2
->as
->type
)
1623 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1627 if (r1
->as
->type
== AS_EXPLICIT
)
1628 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1630 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1631 gfc_copy_expr (r1
->as
->lower
[i
]));
1632 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1633 gfc_copy_expr (r2
->as
->lower
[i
]));
1634 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1635 gfc_free_expr (shape1
);
1636 gfc_free_expr (shape2
);
1642 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1643 "function result", i
+ 1);
1647 /* FIXME: Implement a warning for this case.
1648 gfc_warning (0, "Possible shape mismatch in return value");*/
1655 gfc_internal_error ("check_result_characteristics (2): "
1656 "Unexpected result %i of "
1657 "gfc_dep_compare_expr", compval
);
1667 /* 'Compare' two formal interfaces associated with a pair of symbols.
1668 We return true if there exists an actual argument list that
1669 would be ambiguous between the two interfaces, zero otherwise.
1670 'strict_flag' specifies whether all the characteristics are
1671 required to match, which is not the case for ambiguity checks.
1672 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1675 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1676 int generic_flag
, int strict_flag
,
1677 char *errmsg
, int err_len
,
1678 const char *p1
, const char *p2
)
1680 gfc_formal_arglist
*f1
, *f2
;
1682 gcc_assert (name2
!= NULL
);
1684 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1685 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1686 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1689 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1693 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1696 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1700 /* Do strict checks on all characteristics
1701 (for dummy procedures and procedure pointer assignments). */
1702 if (!generic_flag
&& strict_flag
)
1704 if (s1
->attr
.function
&& s2
->attr
.function
)
1706 /* If both are functions, check result characteristics. */
1707 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1708 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1712 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1714 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1717 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1719 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1724 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1725 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1728 f1
= gfc_sym_get_dummy_args (s1
);
1729 f2
= gfc_sym_get_dummy_args (s2
);
1731 /* Special case: No arguments. */
1732 if (f1
== NULL
&& f2
== NULL
)
1737 if (count_types_test (f1
, f2
, p1
, p2
)
1738 || count_types_test (f2
, f1
, p2
, p1
))
1741 /* Special case: alternate returns. If both f1->sym and f2->sym are
1742 NULL, then the leading formal arguments are alternate returns.
1743 The previous conditional should catch argument lists with
1744 different number of argument. */
1745 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1748 if (generic_correspondence (f1
, f2
, p1
, p2
)
1749 || generic_correspondence (f2
, f1
, p2
, p1
))
1753 /* Perform the abbreviated correspondence test for operators (the
1754 arguments cannot be optional and are always ordered correctly).
1755 This is also done when comparing interfaces for dummy procedures and in
1756 procedure pointer assignments. */
1758 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1760 /* Check existence. */
1761 if (f1
== NULL
|| f2
== NULL
)
1764 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1765 "arguments", name2
);
1771 /* Check all characteristics. */
1772 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1778 /* Only check type and rank. */
1779 if (!compare_type (f2
->sym
, f1
->sym
))
1782 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1783 "(%s/%s)", f1
->sym
->name
,
1784 gfc_typename (&f1
->sym
->ts
),
1785 gfc_typename (&f2
->sym
->ts
));
1788 if (!compare_rank (f2
->sym
, f1
->sym
))
1791 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1792 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1793 symbol_rank (f2
->sym
));
1803 /* Given a pointer to an interface pointer, remove duplicate
1804 interfaces and make sure that all symbols are either functions
1805 or subroutines, and all of the same kind. Returns true if
1806 something goes wrong. */
1809 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1811 gfc_interface
*psave
, *q
, *qlast
;
1814 for (; p
; p
= p
->next
)
1816 /* Make sure all symbols in the interface have been defined as
1817 functions or subroutines. */
1818 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1819 || !p
->sym
->attr
.if_source
)
1820 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1823 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1825 if (p
->sym
->attr
.external
)
1827 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1828 "; did you mean %qs?",
1829 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1832 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1833 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1836 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1837 "subroutine; did you mean %qs?", p
->sym
->name
,
1838 interface_name
, &p
->sym
->declared_at
, guessed
);
1840 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1841 "subroutine", p
->sym
->name
, interface_name
,
1842 &p
->sym
->declared_at
);
1846 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1847 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1848 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1849 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1851 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1852 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1853 " or all FUNCTIONs", interface_name
,
1854 &p
->sym
->declared_at
);
1855 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1856 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1857 "generic name is also the name of a derived type",
1858 interface_name
, &p
->sym
->declared_at
);
1862 /* F2003, C1207. F2008, C1207. */
1863 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1864 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1865 "%qs in %s at %L", p
->sym
->name
,
1866 interface_name
, &p
->sym
->declared_at
))
1871 /* Remove duplicate interfaces in this interface list. */
1872 for (; p
; p
= p
->next
)
1876 for (q
= p
->next
; q
;)
1878 if (p
->sym
!= q
->sym
)
1885 /* Duplicate interface. */
1886 qlast
->next
= q
->next
;
1897 /* Check lists of interfaces to make sure that no two interfaces are
1898 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1901 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1902 int generic_flag
, const char *interface_name
,
1906 for (; p
; p
= p
->next
)
1907 for (q
= q0
; q
; q
= q
->next
)
1909 if (p
->sym
== q
->sym
)
1910 continue; /* Duplicates OK here. */
1912 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1915 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1916 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1917 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1918 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1921 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1922 "and %qs at %L", interface_name
,
1923 q
->sym
->name
, &q
->sym
->declared_at
,
1924 p
->sym
->name
, &p
->sym
->declared_at
);
1925 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1926 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1927 "and %qs at %L", interface_name
,
1928 q
->sym
->name
, &q
->sym
->declared_at
,
1929 p
->sym
->name
, &p
->sym
->declared_at
);
1931 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1932 "interfaces at %L", interface_name
, &p
->where
);
1940 /* Check the generic and operator interfaces of symbols to make sure
1941 that none of the interfaces conflict. The check has to be done
1942 after all of the symbols are actually loaded. */
1945 check_sym_interfaces (gfc_symbol
*sym
)
1947 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("generic interface ''")];
1950 if (sym
->ns
!= gfc_current_ns
)
1953 if (sym
->generic
!= NULL
)
1955 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1956 if (check_interface0 (sym
->generic
, interface_name
))
1959 for (p
= sym
->generic
; p
; p
= p
->next
)
1961 if (p
->sym
->attr
.mod_proc
1962 && !p
->sym
->attr
.module_procedure
1963 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1964 || p
->sym
->attr
.procedure
))
1966 gfc_error ("%qs at %L is not a module procedure",
1967 p
->sym
->name
, &p
->where
);
1972 /* Originally, this test was applied to host interfaces too;
1973 this is incorrect since host associated symbols, from any
1974 source, cannot be ambiguous with local symbols. */
1975 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1976 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1982 check_uop_interfaces (gfc_user_op
*uop
)
1984 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
1988 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1989 if (check_interface0 (uop
->op
, interface_name
))
1992 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1994 uop2
= gfc_find_uop (uop
->name
, ns
);
1998 check_interface1 (uop
->op
, uop2
->op
, 0,
1999 interface_name
, true);
2003 /* Given an intrinsic op, return an equivalent op if one exists,
2004 or INTRINSIC_NONE otherwise. */
2007 gfc_equivalent_op (gfc_intrinsic_op op
)
2012 return INTRINSIC_EQ_OS
;
2014 case INTRINSIC_EQ_OS
:
2015 return INTRINSIC_EQ
;
2018 return INTRINSIC_NE_OS
;
2020 case INTRINSIC_NE_OS
:
2021 return INTRINSIC_NE
;
2024 return INTRINSIC_GT_OS
;
2026 case INTRINSIC_GT_OS
:
2027 return INTRINSIC_GT
;
2030 return INTRINSIC_GE_OS
;
2032 case INTRINSIC_GE_OS
:
2033 return INTRINSIC_GE
;
2036 return INTRINSIC_LT_OS
;
2038 case INTRINSIC_LT_OS
:
2039 return INTRINSIC_LT
;
2042 return INTRINSIC_LE_OS
;
2044 case INTRINSIC_LE_OS
:
2045 return INTRINSIC_LE
;
2048 return INTRINSIC_NONE
;
2052 /* For the namespace, check generic, user operator and intrinsic
2053 operator interfaces for consistency and to remove duplicate
2054 interfaces. We traverse the whole namespace, counting on the fact
2055 that most symbols will not have generic or operator interfaces. */
2058 gfc_check_interfaces (gfc_namespace
*ns
)
2060 gfc_namespace
*old_ns
, *ns2
;
2061 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2064 old_ns
= gfc_current_ns
;
2065 gfc_current_ns
= ns
;
2067 gfc_traverse_ns (ns
, check_sym_interfaces
);
2069 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2071 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2073 if (i
== INTRINSIC_USER
)
2076 if (i
== INTRINSIC_ASSIGN
)
2077 strcpy (interface_name
, "intrinsic assignment operator");
2079 sprintf (interface_name
, "intrinsic '%s' operator",
2080 gfc_op2string ((gfc_intrinsic_op
) i
));
2082 if (check_interface0 (ns
->op
[i
], interface_name
))
2086 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2089 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2091 gfc_intrinsic_op other_op
;
2093 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2094 interface_name
, true))
2097 /* i should be gfc_intrinsic_op, but has to be int with this cast
2098 here for stupid C++ compatibility rules. */
2099 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2100 if (other_op
!= INTRINSIC_NONE
2101 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2102 0, interface_name
, true))
2108 gfc_current_ns
= old_ns
;
2112 /* Given a symbol of a formal argument list and an expression, if the
2113 formal argument is allocatable, check that the actual argument is
2114 allocatable. Returns true if compatible, zero if not compatible. */
2117 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2119 if (formal
->attr
.allocatable
2120 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2122 symbol_attribute attr
= gfc_expr_attr (actual
);
2123 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2125 else if (!attr
.allocatable
)
2133 /* Given a symbol of a formal argument list and an expression, if the
2134 formal argument is a pointer, see if the actual argument is a
2135 pointer. Returns nonzero if compatible, zero if not compatible. */
2138 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2140 symbol_attribute attr
;
2142 if (formal
->attr
.pointer
2143 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2144 && CLASS_DATA (formal
)->attr
.class_pointer
))
2146 attr
= gfc_expr_attr (actual
);
2148 /* Fortran 2008 allows non-pointer actual arguments. */
2149 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2160 /* Emit clear error messages for rank mismatch. */
2163 argument_rank_mismatch (const char *name
, locus
*where
,
2164 int rank1
, int rank2
)
2167 /* TS 29113, C407b. */
2169 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2170 " %qs has assumed-rank", where
, name
);
2171 else if (rank1
== 0)
2172 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2173 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2174 else if (rank2
== 0)
2175 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2176 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2178 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2179 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2183 /* Given a symbol of a formal argument list and an expression, see if
2184 the two are compatible as arguments. Returns true if
2185 compatible, false if not compatible. */
2188 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2189 int ranks_must_agree
, int is_elemental
, locus
*where
)
2192 bool rank_check
, is_pointer
;
2196 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2197 procs c_f_pointer or c_f_procpointer, and we need to accept most
2198 pointers the user could give us. This should allow that. */
2199 if (formal
->ts
.type
== BT_VOID
)
2202 if (formal
->ts
.type
== BT_DERIVED
2203 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2204 && actual
->ts
.type
== BT_DERIVED
2205 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2208 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2209 /* Make sure the vtab symbol is present when
2210 the module variables are generated. */
2211 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2213 if (actual
->ts
.type
== BT_PROCEDURE
)
2215 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2217 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2220 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2224 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2225 sizeof(err
), NULL
, NULL
))
2228 gfc_error_opt (OPT_Wargument_mismatch
,
2229 "Interface mismatch in dummy procedure %qs at %L:"
2230 " %s", formal
->name
, &actual
->where
, err
);
2234 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2236 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2237 &act_sym
->declared_at
);
2238 if (act_sym
->ts
.type
== BT_UNKNOWN
2239 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2242 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2243 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2244 &act_sym
->declared_at
);
2249 ppc
= gfc_get_proc_ptr_comp (actual
);
2250 if (ppc
&& ppc
->ts
.interface
)
2252 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2253 err
, sizeof(err
), NULL
, NULL
))
2256 gfc_error_opt (OPT_Wargument_mismatch
,
2257 "Interface mismatch in dummy procedure %qs at %L:"
2258 " %s", formal
->name
, &actual
->where
, err
);
2264 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2265 && !gfc_is_simply_contiguous (actual
, true, false))
2268 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2269 "must be simply contiguous", formal
->name
, &actual
->where
);
2273 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2274 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2277 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2278 && actual
->ts
.type
!= BT_HOLLERITH
2279 && formal
->ts
.type
!= BT_ASSUMED
2280 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2281 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2282 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2283 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2284 CLASS_DATA (actual
)->ts
.u
.derived
)))
2287 gfc_error_opt (OPT_Wargument_mismatch
,
2288 "Type mismatch in argument %qs at %L; passed %s to %s",
2289 formal
->name
, where
, gfc_typename (&actual
->ts
),
2290 gfc_typename (&formal
->ts
));
2294 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2297 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2298 "argument %qs is of assumed type", &actual
->where
,
2303 /* F2008, 12.5.2.5; IR F08/0073. */
2304 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2305 && actual
->expr_type
!= EXPR_NULL
2306 && ((CLASS_DATA (formal
)->attr
.class_pointer
2307 && formal
->attr
.intent
!= INTENT_IN
)
2308 || CLASS_DATA (formal
)->attr
.allocatable
))
2310 if (actual
->ts
.type
!= BT_CLASS
)
2313 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2314 formal
->name
, &actual
->where
);
2318 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2319 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2320 CLASS_DATA (formal
)->ts
.u
.derived
))
2323 gfc_error ("Actual argument to %qs at %L must have the same "
2324 "declared type", formal
->name
, &actual
->where
);
2329 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2330 is necessary also for F03, so retain error for both.
2331 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2332 compatible, no attempt has been made to channel to this one. */
2333 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2334 && (CLASS_DATA (formal
)->attr
.allocatable
2335 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2338 gfc_error ("Actual argument to %qs at %L must be unlimited "
2339 "polymorphic since the formal argument is a "
2340 "pointer or allocatable unlimited polymorphic "
2341 "entity [F2008: 12.5.2.5]", formal
->name
,
2346 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2349 gfc_error ("Actual argument to %qs at %L must be a coarray",
2350 formal
->name
, &actual
->where
);
2354 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2356 gfc_ref
*last
= NULL
;
2358 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2359 if (ref
->type
== REF_COMPONENT
)
2362 /* F2008, 12.5.2.6. */
2363 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2365 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2368 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2369 formal
->name
, &actual
->where
, formal
->as
->corank
,
2370 last
? last
->u
.c
.component
->as
->corank
2371 : actual
->symtree
->n
.sym
->as
->corank
);
2376 if (formal
->attr
.codimension
)
2378 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2379 /* F2018, 12.5.2.8. */
2380 if (formal
->attr
.dimension
2381 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2382 && actual_attr
.dimension
2383 && !gfc_is_simply_contiguous (actual
, true, true))
2386 gfc_error ("Actual argument to %qs at %L must be simply "
2387 "contiguous or an element of such an array",
2388 formal
->name
, &actual
->where
);
2392 /* F2008, C1303 and C1304. */
2393 if (formal
->attr
.intent
!= INTENT_INOUT
2394 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2395 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2396 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2397 || formal
->attr
.lock_comp
))
2401 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2402 "which is LOCK_TYPE or has a LOCK_TYPE component",
2403 formal
->name
, &actual
->where
);
2407 /* TS18508, C702/C703. */
2408 if (formal
->attr
.intent
!= INTENT_INOUT
2409 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2410 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2411 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2412 || formal
->attr
.event_comp
))
2416 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2417 "which is EVENT_TYPE or has a EVENT_TYPE component",
2418 formal
->name
, &actual
->where
);
2423 /* F2008, C1239/C1240. */
2424 if (actual
->expr_type
== EXPR_VARIABLE
2425 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2426 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2427 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2428 && actual
->rank
&& formal
->as
2429 && !gfc_is_simply_contiguous (actual
, true, false)
2430 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2431 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2432 || formal
->attr
.contiguous
))
2435 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2436 "assumed-rank array without CONTIGUOUS attribute - as actual"
2437 " argument at %L is not simply contiguous and both are "
2438 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2442 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2443 && actual_attr
.codimension
)
2445 if (formal
->attr
.intent
== INTENT_OUT
)
2448 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2449 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2453 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2454 gfc_warning (OPT_Wsurprising
,
2455 "Passing coarray at %L to allocatable, noncoarray dummy "
2456 "argument %qs, which is invalid if the allocation status"
2457 " is modified", &actual
->where
, formal
->name
);
2460 /* If the rank is the same or the formal argument has assumed-rank. */
2461 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2464 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2465 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2466 || formal
->as
->type
== AS_DEFERRED
)
2467 && actual
->expr_type
!= EXPR_NULL
;
2469 /* Skip rank checks for NO_ARG_CHECK. */
2470 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2473 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2474 if (rank_check
|| ranks_must_agree
2475 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2476 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2477 || (actual
->rank
== 0
2478 && ((formal
->ts
.type
== BT_CLASS
2479 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2480 || (formal
->ts
.type
!= BT_CLASS
2481 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2482 && actual
->expr_type
!= EXPR_NULL
)
2483 || (actual
->rank
== 0 && formal
->attr
.dimension
2484 && gfc_is_coindexed (actual
)))
2487 argument_rank_mismatch (formal
->name
, &actual
->where
,
2488 symbol_rank (formal
), actual
->rank
);
2491 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2494 /* At this point, we are considering a scalar passed to an array. This
2495 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2496 - if the actual argument is (a substring of) an element of a
2497 non-assumed-shape/non-pointer/non-polymorphic array; or
2498 - (F2003) if the actual argument is of type character of default/c_char
2501 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2502 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2504 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2506 if (ref
->type
== REF_COMPONENT
)
2507 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2508 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2509 && ref
->u
.ar
.dimen
> 0
2511 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2515 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2518 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2519 "at %L", formal
->name
, &actual
->where
);
2523 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2524 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2527 gfc_error ("Element of assumed-shaped or pointer "
2528 "array passed to array dummy argument %qs at %L",
2529 formal
->name
, &actual
->where
);
2533 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2534 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2536 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2539 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2540 "CHARACTER actual argument with array dummy argument "
2541 "%qs at %L", formal
->name
, &actual
->where
);
2545 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2547 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2548 "array dummy argument %qs at %L",
2549 formal
->name
, &actual
->where
);
2553 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2556 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2559 argument_rank_mismatch (formal
->name
, &actual
->where
,
2560 symbol_rank (formal
), actual
->rank
);
2568 /* Returns the storage size of a symbol (formal argument) or
2569 zero if it cannot be determined. */
2571 static unsigned long
2572 get_sym_storage_size (gfc_symbol
*sym
)
2575 unsigned long strlen
, elements
;
2577 if (sym
->ts
.type
== BT_CHARACTER
)
2579 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2580 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2581 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2588 if (symbol_rank (sym
) == 0)
2592 if (sym
->as
->type
!= AS_EXPLICIT
)
2594 for (i
= 0; i
< sym
->as
->rank
; i
++)
2596 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2597 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2600 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2601 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2604 return strlen
*elements
;
2608 /* Returns the storage size of an expression (actual argument) or
2609 zero if it cannot be determined. For an array element, it returns
2610 the remaining size as the element sequence consists of all storage
2611 units of the actual argument up to the end of the array. */
2613 static unsigned long
2614 get_expr_storage_size (gfc_expr
*e
)
2617 long int strlen
, elements
;
2618 long int substrlen
= 0;
2619 bool is_str_storage
= false;
2625 if (e
->ts
.type
== BT_CHARACTER
)
2627 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2628 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2629 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2630 else if (e
->expr_type
== EXPR_CONSTANT
2631 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2632 strlen
= e
->value
.character
.length
;
2637 strlen
= 1; /* Length per element. */
2639 if (e
->rank
== 0 && !e
->ref
)
2647 for (i
= 0; i
< e
->rank
; i
++)
2648 elements
*= mpz_get_si (e
->shape
[i
]);
2649 return elements
*strlen
;
2652 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2654 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2655 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2659 /* The string length is the substring length.
2660 Set now to full string length. */
2661 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2662 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2665 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2667 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2671 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2672 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2674 long int start
, end
, stride
;
2677 if (ref
->u
.ar
.stride
[i
])
2679 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2680 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2685 if (ref
->u
.ar
.start
[i
])
2687 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2688 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2692 else if (ref
->u
.ar
.as
->lower
[i
]
2693 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2694 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2698 if (ref
->u
.ar
.end
[i
])
2700 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2701 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2705 else if (ref
->u
.ar
.as
->upper
[i
]
2706 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2707 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2711 elements
*= (end
- start
)/stride
+ 1L;
2713 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2714 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2716 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2717 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2718 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2719 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2720 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2721 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2722 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2727 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2728 && e
->expr_type
== EXPR_VARIABLE
)
2730 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2731 || e
->symtree
->n
.sym
->attr
.pointer
)
2737 /* Determine the number of remaining elements in the element
2738 sequence for array element designators. */
2739 is_str_storage
= true;
2740 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2742 if (ref
->u
.ar
.start
[i
] == NULL
2743 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2744 || ref
->u
.ar
.as
->upper
[i
] == NULL
2745 || ref
->u
.ar
.as
->lower
[i
] == NULL
2746 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2747 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2752 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2753 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2755 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2756 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2759 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2760 && ref
->u
.c
.component
->attr
.proc_pointer
2761 && ref
->u
.c
.component
->attr
.dimension
)
2763 /* Array-valued procedure-pointer components. */
2764 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2765 for (i
= 0; i
< as
->rank
; i
++)
2767 if (!as
->upper
[i
] || !as
->lower
[i
]
2768 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2769 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2773 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2774 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2780 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2783 return elements
*strlen
;
2787 /* Given an expression, check whether it is an array section
2788 which has a vector subscript. */
2791 gfc_has_vector_subscript (gfc_expr
*e
)
2796 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2799 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2800 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2801 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2802 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2810 is_procptr_result (gfc_expr
*expr
)
2812 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2814 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2816 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2817 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2821 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2822 number of total candidates in CANDIDATES_LEN. */
2825 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
2827 size_t &candidates_len
)
2829 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
2830 vec_push (candidates
, candidates_len
, p
->sym
->name
);
2834 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2837 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
2839 char **candidates
= NULL
;
2840 size_t candidates_len
= 0;
2841 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
2842 return gfc_closest_fuzzy_match (arg
, candidates
);
2846 /* Given formal and actual argument lists, see if they are compatible.
2847 If they are compatible, the actual argument list is sorted to
2848 correspond with the formal list, and elements for missing optional
2849 arguments are inserted. If WHERE pointer is nonnull, then we issue
2850 errors when things don't match instead of just returning the status
2854 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2855 int ranks_must_agree
, int is_elemental
,
2856 bool in_statement_function
, locus
*where
)
2858 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2859 gfc_formal_arglist
*f
;
2861 unsigned long actual_size
, formal_size
;
2862 bool full_array
= false;
2863 gfc_array_ref
*actual_arr_ref
;
2867 if (actual
== NULL
&& formal
== NULL
)
2871 for (f
= formal
; f
; f
= f
->next
)
2874 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2876 for (i
= 0; i
< n
; i
++)
2883 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2885 if (a
->name
!= NULL
&& in_statement_function
)
2887 gfc_error ("Keyword argument %qs at %L is invalid in "
2888 "a statement function", a
->name
, &a
->expr
->where
);
2892 /* Look for keywords but ignore g77 extensions like %VAL. */
2893 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2896 for (f
= formal
; f
; f
= f
->next
, i
++)
2900 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2908 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
2910 gfc_error ("Keyword argument %qs at %L is not in "
2911 "the procedure; did you mean %qs?",
2912 a
->name
, &a
->expr
->where
, guessed
);
2914 gfc_error ("Keyword argument %qs at %L is not in "
2915 "the procedure", a
->name
, &a
->expr
->where
);
2920 if (new_arg
[i
] != NULL
)
2923 gfc_error ("Keyword argument %qs at %L is already associated "
2924 "with another actual argument", a
->name
,
2933 gfc_error ("More actual than formal arguments in procedure "
2934 "call at %L", where
);
2939 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2944 /* These errors have to be issued, otherwise an ICE can occur.
2947 gfc_error_now ("Missing alternate return specifier in subroutine "
2948 "call at %L", where
);
2952 if (a
->expr
== NULL
)
2955 gfc_error_now ("Unexpected alternate return specifier in "
2956 "subroutine call at %L", where
);
2960 /* Make sure that intrinsic vtables exist for calls to unlimited
2961 polymorphic formal arguments. */
2962 if (UNLIMITED_POLY (f
->sym
)
2963 && a
->expr
->ts
.type
!= BT_DERIVED
2964 && a
->expr
->ts
.type
!= BT_CLASS
)
2965 gfc_find_vtab (&a
->expr
->ts
);
2967 if (a
->expr
->expr_type
== EXPR_NULL
2968 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2969 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2970 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2971 || (f
->sym
->ts
.type
== BT_CLASS
2972 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2973 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2974 || !f
->sym
->attr
.optional
2975 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2978 && (!f
->sym
->attr
.optional
2979 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2980 || (f
->sym
->ts
.type
== BT_CLASS
2981 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2982 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2983 where
, f
->sym
->name
);
2985 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2986 "dummy %qs", where
, f
->sym
->name
);
2991 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2992 is_elemental
, where
))
2995 /* TS 29113, 6.3p2. */
2996 if (f
->sym
->ts
.type
== BT_ASSUMED
2997 && (a
->expr
->ts
.type
== BT_DERIVED
2998 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
3000 gfc_namespace
*f2k_derived
;
3002 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
3003 ? a
->expr
->ts
.u
.derived
->f2k_derived
3004 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
3007 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
3009 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3010 "derived type with type-bound or FINAL procedures",
3016 /* Special case for character arguments. For allocatable, pointer
3017 and assumed-shape dummies, the string length needs to match
3019 if (a
->expr
->ts
.type
== BT_CHARACTER
3020 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3021 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3022 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3023 && f
->sym
->ts
.u
.cl
->length
3024 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3025 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3026 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3027 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3028 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3030 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3031 gfc_warning (OPT_Wargument_mismatch
,
3032 "Character length mismatch (%ld/%ld) between actual "
3033 "argument and pointer or allocatable dummy argument "
3035 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3036 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3037 f
->sym
->name
, &a
->expr
->where
);
3039 gfc_warning (OPT_Wargument_mismatch
,
3040 "Character length mismatch (%ld/%ld) between actual "
3041 "argument and assumed-shape dummy argument %qs "
3043 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3044 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3045 f
->sym
->name
, &a
->expr
->where
);
3049 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3050 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3051 && a
->expr
->ts
.type
== BT_CHARACTER
)
3054 gfc_error ("Actual argument at %L to allocatable or "
3055 "pointer dummy argument %qs must have a deferred "
3056 "length type parameter if and only if the dummy has one",
3057 &a
->expr
->where
, f
->sym
->name
);
3061 if (f
->sym
->ts
.type
== BT_CLASS
)
3062 goto skip_size_check
;
3064 actual_size
= get_expr_storage_size (a
->expr
);
3065 formal_size
= get_sym_storage_size (f
->sym
);
3066 if (actual_size
!= 0 && actual_size
< formal_size
3067 && a
->expr
->ts
.type
!= BT_PROCEDURE
3068 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3070 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3071 gfc_warning (OPT_Wargument_mismatch
,
3072 "Character length of actual argument shorter "
3073 "than of dummy argument %qs (%lu/%lu) at %L",
3074 f
->sym
->name
, actual_size
, formal_size
,
3078 /* Emit a warning for -std=legacy and an error otherwise. */
3079 if (gfc_option
.warn_std
== 0)
3080 gfc_warning (OPT_Wargument_mismatch
,
3081 "Actual argument contains too few "
3082 "elements for dummy argument %qs (%lu/%lu) "
3083 "at %L", f
->sym
->name
, actual_size
,
3084 formal_size
, &a
->expr
->where
);
3086 gfc_error_now ("Actual argument contains too few "
3087 "elements for dummy argument %qs (%lu/%lu) "
3088 "at %L", f
->sym
->name
, actual_size
,
3089 formal_size
, &a
->expr
->where
);
3096 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3097 argument is provided for a procedure pointer formal argument. */
3098 if (f
->sym
->attr
.proc_pointer
3099 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3100 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3101 || gfc_is_proc_ptr_comp (a
->expr
)))
3102 || (a
->expr
->expr_type
== EXPR_FUNCTION
3103 && is_procptr_result (a
->expr
))))
3106 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3107 f
->sym
->name
, &a
->expr
->where
);
3111 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3112 provided for a procedure formal argument. */
3113 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3114 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3115 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
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 for argument %qs at %L",
3123 f
->sym
->name
, &a
->expr
->where
);
3127 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3128 && a
->expr
->expr_type
== EXPR_VARIABLE
3129 && a
->expr
->symtree
->n
.sym
->as
3130 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3131 && (a
->expr
->ref
== NULL
3132 || (a
->expr
->ref
->type
== REF_ARRAY
3133 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3136 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3137 " array at %L", f
->sym
->name
, where
);
3141 if (a
->expr
->expr_type
!= EXPR_NULL
3142 && compare_pointer (f
->sym
, a
->expr
) == 0)
3145 gfc_error ("Actual argument for %qs must be a pointer at %L",
3146 f
->sym
->name
, &a
->expr
->where
);
3150 if (a
->expr
->expr_type
!= EXPR_NULL
3151 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3152 && compare_pointer (f
->sym
, a
->expr
) == 2)
3155 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3156 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3161 /* Fortran 2008, C1242. */
3162 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3165 gfc_error ("Coindexed actual argument at %L to pointer "
3167 &a
->expr
->where
, f
->sym
->name
);
3171 /* Fortran 2008, 12.5.2.5 (no constraint). */
3172 if (a
->expr
->expr_type
== EXPR_VARIABLE
3173 && f
->sym
->attr
.intent
!= INTENT_IN
3174 && f
->sym
->attr
.allocatable
3175 && gfc_is_coindexed (a
->expr
))
3178 gfc_error ("Coindexed actual argument at %L to allocatable "
3179 "dummy %qs requires INTENT(IN)",
3180 &a
->expr
->where
, f
->sym
->name
);
3184 /* Fortran 2008, C1237. */
3185 if (a
->expr
->expr_type
== EXPR_VARIABLE
3186 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3187 && gfc_is_coindexed (a
->expr
)
3188 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3189 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3192 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3193 "%L requires that dummy %qs has neither "
3194 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3199 /* Fortran 2008, 12.5.2.4 (no constraint). */
3200 if (a
->expr
->expr_type
== EXPR_VARIABLE
3201 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3202 && gfc_is_coindexed (a
->expr
)
3203 && gfc_has_ultimate_allocatable (a
->expr
))
3206 gfc_error ("Coindexed actual argument at %L with allocatable "
3207 "ultimate component to dummy %qs requires either VALUE "
3208 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3212 if (f
->sym
->ts
.type
== BT_CLASS
3213 && CLASS_DATA (f
->sym
)->attr
.allocatable
3214 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3218 gfc_error ("Actual CLASS array argument for %qs must be a full "
3219 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3224 if (a
->expr
->expr_type
!= EXPR_NULL
3225 && !compare_allocatable (f
->sym
, a
->expr
))
3228 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3229 f
->sym
->name
, &a
->expr
->where
);
3233 /* Check intent = OUT/INOUT for definable actual argument. */
3234 if (!in_statement_function
3235 && (f
->sym
->attr
.intent
== INTENT_OUT
3236 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3238 const char* context
= (where
3239 ? _("actual argument to INTENT = OUT/INOUT")
3242 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3243 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3244 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3245 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3247 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3251 if ((f
->sym
->attr
.intent
== INTENT_OUT
3252 || f
->sym
->attr
.intent
== INTENT_INOUT
3253 || f
->sym
->attr
.volatile_
3254 || f
->sym
->attr
.asynchronous
)
3255 && gfc_has_vector_subscript (a
->expr
))
3258 gfc_error ("Array-section actual argument with vector "
3259 "subscripts at %L is incompatible with INTENT(OUT), "
3260 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3261 "of the dummy argument %qs",
3262 &a
->expr
->where
, f
->sym
->name
);
3266 /* C1232 (R1221) For an actual argument which is an array section or
3267 an assumed-shape array, the dummy argument shall be an assumed-
3268 shape array, if the dummy argument has the VOLATILE attribute. */
3270 if (f
->sym
->attr
.volatile_
3271 && a
->expr
->expr_type
== EXPR_VARIABLE
3272 && a
->expr
->symtree
->n
.sym
->as
3273 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3274 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3277 gfc_error ("Assumed-shape actual argument at %L is "
3278 "incompatible with the non-assumed-shape "
3279 "dummy argument %qs due to VOLATILE attribute",
3280 &a
->expr
->where
,f
->sym
->name
);
3284 /* Find the last array_ref. */
3285 actual_arr_ref
= NULL
;
3287 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3289 if (f
->sym
->attr
.volatile_
3290 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3291 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3294 gfc_error ("Array-section actual argument at %L is "
3295 "incompatible with the non-assumed-shape "
3296 "dummy argument %qs due to VOLATILE attribute",
3297 &a
->expr
->where
, f
->sym
->name
);
3301 /* C1233 (R1221) For an actual argument which is a pointer array, the
3302 dummy argument shall be an assumed-shape or pointer array, if the
3303 dummy argument has the VOLATILE attribute. */
3305 if (f
->sym
->attr
.volatile_
3306 && a
->expr
->expr_type
== EXPR_VARIABLE
3307 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3308 && a
->expr
->symtree
->n
.sym
->as
3310 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3311 || f
->sym
->attr
.pointer
)))
3314 gfc_error ("Pointer-array actual argument at %L requires "
3315 "an assumed-shape or pointer-array dummy "
3316 "argument %qs due to VOLATILE attribute",
3317 &a
->expr
->where
,f
->sym
->name
);
3328 /* Make sure missing actual arguments are optional. */
3330 for (f
= formal
; f
; f
= f
->next
, i
++)
3332 if (new_arg
[i
] != NULL
)
3337 gfc_error ("Missing alternate return spec in subroutine call "
3341 if (!f
->sym
->attr
.optional
3342 || (in_statement_function
&& f
->sym
->attr
.optional
))
3345 gfc_error ("Missing actual argument for argument %qs at %L",
3346 f
->sym
->name
, where
);
3351 /* The argument lists are compatible. We now relink a new actual
3352 argument list with null arguments in the right places. The head
3353 of the list remains the head. */
3354 for (i
= 0; i
< n
; i
++)
3355 if (new_arg
[i
] == NULL
)
3356 new_arg
[i
] = gfc_get_actual_arglist ();
3360 std::swap (*new_arg
[0], *actual
);
3361 std::swap (new_arg
[0], new_arg
[na
]);
3364 for (i
= 0; i
< n
- 1; i
++)
3365 new_arg
[i
]->next
= new_arg
[i
+ 1];
3367 new_arg
[i
]->next
= NULL
;
3369 if (*ap
== NULL
&& n
> 0)
3372 /* Note the types of omitted optional arguments. */
3373 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3374 if (a
->expr
== NULL
&& a
->label
== NULL
)
3375 a
->missing_arg_type
= f
->sym
->ts
.type
;
3383 gfc_formal_arglist
*f
;
3384 gfc_actual_arglist
*a
;
3388 /* qsort comparison function for argument pairs, with the following
3390 - p->a->expr == NULL
3391 - p->a->expr->expr_type != EXPR_VARIABLE
3392 - by gfc_symbol pointer value (larger first). */
3395 pair_cmp (const void *p1
, const void *p2
)
3397 const gfc_actual_arglist
*a1
, *a2
;
3399 /* *p1 and *p2 are elements of the to-be-sorted array. */
3400 a1
= ((const argpair
*) p1
)->a
;
3401 a2
= ((const argpair
*) p2
)->a
;
3410 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3412 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3416 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3418 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3420 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3424 /* Given two expressions from some actual arguments, test whether they
3425 refer to the same expression. The analysis is conservative.
3426 Returning false will produce no warning. */
3429 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3431 const gfc_ref
*r1
, *r2
;
3434 || e1
->expr_type
!= EXPR_VARIABLE
3435 || e2
->expr_type
!= EXPR_VARIABLE
3436 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3439 /* TODO: improve comparison, see expr.c:show_ref(). */
3440 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3442 if (r1
->type
!= r2
->type
)
3447 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3449 /* TODO: At the moment, consider only full arrays;
3450 we could do better. */
3451 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3456 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3464 gfc_internal_error ("compare_actual_expr(): Bad component code");
3473 /* Given formal and actual argument lists that correspond to one
3474 another, check that identical actual arguments aren't not
3475 associated with some incompatible INTENTs. */
3478 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3480 sym_intent f1_intent
, f2_intent
;
3481 gfc_formal_arglist
*f1
;
3482 gfc_actual_arglist
*a1
;
3488 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3490 if (f1
== NULL
&& a1
== NULL
)
3492 if (f1
== NULL
|| a1
== NULL
)
3493 gfc_internal_error ("check_some_aliasing(): List mismatch");
3498 p
= XALLOCAVEC (argpair
, n
);
3500 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3506 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3508 for (i
= 0; i
< n
; i
++)
3511 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3512 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3514 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3515 for (j
= i
+ 1; j
< n
; j
++)
3517 /* Expected order after the sort. */
3518 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3519 gfc_internal_error ("check_some_aliasing(): corrupted data");
3521 /* Are the expression the same? */
3522 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3524 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3525 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3526 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3527 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3529 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3530 "argument %qs and INTENT(%s) argument %qs at %L",
3531 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3532 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3533 &p
[i
].a
->expr
->where
);
3543 /* Given formal and actual argument lists that correspond to one
3544 another, check that they are compatible in the sense that intents
3545 are not mismatched. */
3548 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3550 sym_intent f_intent
;
3552 for (;; f
= f
->next
, a
= a
->next
)
3556 if (f
== NULL
&& a
== NULL
)
3558 if (f
== NULL
|| a
== NULL
)
3559 gfc_internal_error ("check_intents(): List mismatch");
3561 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3562 && a
->expr
->value
.function
.isym
3563 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3564 expr
= a
->expr
->value
.function
.actual
->expr
;
3568 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3571 f_intent
= f
->sym
->attr
.intent
;
3573 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3575 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3576 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3577 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3579 gfc_error ("Procedure argument at %L is local to a PURE "
3580 "procedure and has the POINTER attribute",
3586 /* Fortran 2008, C1283. */
3587 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3589 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3591 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3592 "is passed to an INTENT(%s) argument",
3593 &expr
->where
, gfc_intent_string (f_intent
));
3597 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3598 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3599 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3601 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3602 "is passed to a POINTER dummy argument",
3608 /* F2008, Section 12.5.2.4. */
3609 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3610 && gfc_is_coindexed (expr
))
3612 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3613 "polymorphic dummy argument %qs",
3614 &expr
->where
, f
->sym
->name
);
3623 /* Check how a procedure is used against its interface. If all goes
3624 well, the actual argument list will also end up being properly
3628 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3630 gfc_actual_arglist
*a
;
3631 gfc_formal_arglist
*dummy_args
;
3633 /* Warn about calls with an implicit interface. Special case
3634 for calling a ISO_C_BINDING because c_loc and c_funloc
3635 are pseudo-unknown. Additionally, warn about procedures not
3636 explicitly declared at all if requested. */
3637 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3639 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3642 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3644 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3645 "; did you mean %qs?",
3646 sym
->name
, where
, guessed
);
3648 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3652 if (warn_implicit_interface
)
3653 gfc_warning (OPT_Wimplicit_interface
,
3654 "Procedure %qs called with an implicit interface at %L",
3656 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3657 gfc_warning (OPT_Wimplicit_procedure
,
3658 "Procedure %qs called at %L is not explicitly declared",
3660 gfc_find_proc_namespace (sym
->ns
)->implicit_interface_calls
= 1;
3663 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3665 if (sym
->attr
.pointer
)
3667 gfc_error ("The pointer object %qs at %L must have an explicit "
3668 "function interface or be declared as array",
3673 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3675 gfc_error ("The allocatable object %qs at %L must have an explicit "
3676 "function interface or be declared as array",
3681 if (sym
->attr
.allocatable
)
3683 gfc_error ("Allocatable function %qs at %L must have an explicit "
3684 "function interface", sym
->name
, where
);
3688 for (a
= *ap
; a
; a
= a
->next
)
3690 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3691 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3693 gfc_error ("Keyword argument requires explicit interface "
3694 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3698 /* TS 29113, 6.2. */
3699 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3700 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3702 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3703 "interface", a
->expr
->symtree
->n
.sym
->name
,
3708 /* F2008, C1303 and C1304. */
3710 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3711 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3712 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3713 || gfc_expr_attr (a
->expr
).lock_comp
))
3715 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3716 "component at %L requires an explicit interface for "
3717 "procedure %qs", &a
->expr
->where
, sym
->name
);
3722 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3723 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3724 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3725 == ISOFORTRAN_EVENT_TYPE
)
3726 || gfc_expr_attr (a
->expr
).event_comp
))
3728 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3729 "component at %L requires an explicit interface for "
3730 "procedure %qs", &a
->expr
->where
, sym
->name
);
3734 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3735 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3737 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3741 /* TS 29113, C407b. */
3742 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3743 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3745 gfc_error ("Assumed-rank argument requires an explicit interface "
3746 "at %L", &a
->expr
->where
);
3754 dummy_args
= gfc_sym_get_dummy_args (sym
);
3756 /* For a statement function, check that types and type parameters of actual
3757 arguments and dummy arguments match. */
3758 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3759 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3762 if (!check_intents (dummy_args
, *ap
))
3766 check_some_aliasing (dummy_args
, *ap
);
3772 /* Check how a procedure pointer component is used against its interface.
3773 If all goes well, the actual argument list will also end up being properly
3774 sorted. Completely analogous to gfc_procedure_use. */
3777 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3779 /* Warn about calls with an implicit interface. Special case
3780 for calling a ISO_C_BINDING because c_loc and c_funloc
3781 are pseudo-unknown. */
3782 if (warn_implicit_interface
3783 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3784 && !comp
->attr
.is_iso_c
)
3785 gfc_warning (OPT_Wimplicit_interface
,
3786 "Procedure pointer component %qs called with an implicit "
3787 "interface at %L", comp
->name
, where
);
3789 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3791 gfc_actual_arglist
*a
;
3792 for (a
= *ap
; a
; a
= a
->next
)
3794 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3795 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3797 gfc_error ("Keyword argument requires explicit interface "
3798 "for procedure pointer component %qs at %L",
3799 comp
->name
, &a
->expr
->where
);
3807 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3808 comp
->attr
.elemental
, false, where
))
3811 check_intents (comp
->ts
.interface
->formal
, *ap
);
3813 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3817 /* Try if an actual argument list matches the formal list of a symbol,
3818 respecting the symbol's attributes like ELEMENTAL. This is used for
3819 GENERIC resolution. */
3822 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3824 gfc_formal_arglist
*dummy_args
;
3827 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3830 dummy_args
= gfc_sym_get_dummy_args (sym
);
3832 r
= !sym
->attr
.elemental
;
3833 if (compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
3835 check_intents (dummy_args
, *args
);
3837 check_some_aliasing (dummy_args
, *args
);
3845 /* Given an interface pointer and an actual argument list, search for
3846 a formal argument list that matches the actual. If found, returns
3847 a pointer to the symbol of the correct interface. Returns NULL if
3851 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3852 gfc_actual_arglist
**ap
)
3854 gfc_symbol
*elem_sym
= NULL
;
3855 gfc_symbol
*null_sym
= NULL
;
3856 locus null_expr_loc
;
3857 gfc_actual_arglist
*a
;
3858 bool has_null_arg
= false;
3860 for (a
= *ap
; a
; a
= a
->next
)
3861 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3862 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3864 has_null_arg
= true;
3865 null_expr_loc
= a
->expr
->where
;
3869 for (; intr
; intr
= intr
->next
)
3871 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3873 if (sub_flag
&& intr
->sym
->attr
.function
)
3875 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3878 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3880 if (has_null_arg
&& null_sym
)
3882 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3883 "between specific functions %s and %s",
3884 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3887 else if (has_null_arg
)
3889 null_sym
= intr
->sym
;
3893 /* Satisfy 12.4.4.1 such that an elemental match has lower
3894 weight than a non-elemental match. */
3895 if (intr
->sym
->attr
.elemental
)
3897 elem_sym
= intr
->sym
;
3907 return elem_sym
? elem_sym
: NULL
;
3911 /* Do a brute force recursive search for a symbol. */
3913 static gfc_symtree
*
3914 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3918 if (root
->n
.sym
== sym
)
3923 st
= find_symtree0 (root
->left
, sym
);
3924 if (root
->right
&& ! st
)
3925 st
= find_symtree0 (root
->right
, sym
);
3930 /* Find a symtree for a symbol. */
3933 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3938 /* First try to find it by name. */
3939 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3940 if (st
&& st
->n
.sym
== sym
)
3943 /* If it's been renamed, resort to a brute-force search. */
3944 /* TODO: avoid having to do this search. If the symbol doesn't exist
3945 in the symtree for the current namespace, it should probably be added. */
3946 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3948 st
= find_symtree0 (ns
->sym_root
, sym
);
3952 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3957 /* See if the arglist to an operator-call contains a derived-type argument
3958 with a matching type-bound operator. If so, return the matching specific
3959 procedure defined as operator-target as well as the base-object to use
3960 (which is the found derived-type argument with operator). The generic
3961 name, if any, is transmitted to the final expression via 'gname'. */
3963 static gfc_typebound_proc
*
3964 matching_typebound_op (gfc_expr
** tb_base
,
3965 gfc_actual_arglist
* args
,
3966 gfc_intrinsic_op op
, const char* uop
,
3967 const char ** gname
)
3969 gfc_actual_arglist
* base
;
3971 for (base
= args
; base
; base
= base
->next
)
3972 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3974 gfc_typebound_proc
* tb
;
3975 gfc_symbol
* derived
;
3978 while (base
->expr
->expr_type
== EXPR_OP
3979 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3980 base
->expr
= base
->expr
->value
.op
.op1
;
3982 if (base
->expr
->ts
.type
== BT_CLASS
)
3984 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
3985 || !gfc_expr_attr (base
->expr
).class_ok
)
3987 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3990 derived
= base
->expr
->ts
.u
.derived
;
3992 if (op
== INTRINSIC_USER
)
3994 gfc_symtree
* tb_uop
;
3997 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
4006 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
4009 /* This means we hit a PRIVATE operator which is use-associated and
4010 should thus not be seen. */
4014 /* Look through the super-type hierarchy for a matching specific
4016 for (; tb
; tb
= tb
->overridden
)
4020 gcc_assert (tb
->is_generic
);
4021 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4024 gfc_actual_arglist
* argcopy
;
4027 gcc_assert (g
->specific
);
4028 if (g
->specific
->error
)
4031 target
= g
->specific
->u
.specific
->n
.sym
;
4033 /* Check if this arglist matches the formal. */
4034 argcopy
= gfc_copy_actual_arglist (args
);
4035 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4036 gfc_free_actual_arglist (argcopy
);
4038 /* Return if we found a match. */
4041 *tb_base
= base
->expr
;
4042 *gname
= g
->specific_st
->name
;
4053 /* For the 'actual arglist' of an operator call and a specific typebound
4054 procedure that has been found the target of a type-bound operator, build the
4055 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4056 type-bound procedures rather than resolving type-bound operators 'directly'
4057 so that we can reuse the existing logic. */
4060 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4061 gfc_expr
* base
, gfc_typebound_proc
* target
,
4064 e
->expr_type
= EXPR_COMPCALL
;
4065 e
->value
.compcall
.tbp
= target
;
4066 e
->value
.compcall
.name
= gname
? gname
: "$op";
4067 e
->value
.compcall
.actual
= actual
;
4068 e
->value
.compcall
.base_object
= base
;
4069 e
->value
.compcall
.ignore_pass
= 1;
4070 e
->value
.compcall
.assign
= 0;
4071 if (e
->ts
.type
== BT_UNKNOWN
4072 && target
->function
)
4074 if (target
->is_generic
)
4075 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4077 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4082 /* This subroutine is called when an expression is being resolved.
4083 The expression node in question is either a user defined operator
4084 or an intrinsic operator with arguments that aren't compatible
4085 with the operator. This subroutine builds an actual argument list
4086 corresponding to the operands, then searches for a compatible
4087 interface. If one is found, the expression node is replaced with
4088 the appropriate function call. We use the 'match' enum to specify
4089 whether a replacement has been made or not, or if an error occurred. */
4092 gfc_extend_expr (gfc_expr
*e
)
4094 gfc_actual_arglist
*actual
;
4100 gfc_typebound_proc
* tbo
;
4105 actual
= gfc_get_actual_arglist ();
4106 actual
->expr
= e
->value
.op
.op1
;
4110 if (e
->value
.op
.op2
!= NULL
)
4112 actual
->next
= gfc_get_actual_arglist ();
4113 actual
->next
->expr
= e
->value
.op
.op2
;
4116 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4118 /* See if we find a matching type-bound operator. */
4119 if (i
== INTRINSIC_USER
)
4120 tbo
= matching_typebound_op (&tb_base
, actual
,
4121 i
, e
->value
.op
.uop
->name
, &gname
);
4125 #define CHECK_OS_COMPARISON(comp) \
4126 case INTRINSIC_##comp: \
4127 case INTRINSIC_##comp##_OS: \
4128 tbo = matching_typebound_op (&tb_base, actual, \
4129 INTRINSIC_##comp, NULL, &gname); \
4131 tbo = matching_typebound_op (&tb_base, actual, \
4132 INTRINSIC_##comp##_OS, NULL, &gname); \
4134 CHECK_OS_COMPARISON(EQ
)
4135 CHECK_OS_COMPARISON(NE
)
4136 CHECK_OS_COMPARISON(GT
)
4137 CHECK_OS_COMPARISON(GE
)
4138 CHECK_OS_COMPARISON(LT
)
4139 CHECK_OS_COMPARISON(LE
)
4140 #undef CHECK_OS_COMPARISON
4143 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4147 /* If there is a matching typebound-operator, replace the expression with
4148 a call to it and succeed. */
4151 gcc_assert (tb_base
);
4152 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4154 if (!gfc_resolve_expr (e
))
4160 if (i
== INTRINSIC_USER
)
4162 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4164 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4168 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4175 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4177 /* Due to the distinction between '==' and '.eq.' and friends, one has
4178 to check if either is defined. */
4181 #define CHECK_OS_COMPARISON(comp) \
4182 case INTRINSIC_##comp: \
4183 case INTRINSIC_##comp##_OS: \
4184 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4186 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4188 CHECK_OS_COMPARISON(EQ
)
4189 CHECK_OS_COMPARISON(NE
)
4190 CHECK_OS_COMPARISON(GT
)
4191 CHECK_OS_COMPARISON(GE
)
4192 CHECK_OS_COMPARISON(LT
)
4193 CHECK_OS_COMPARISON(LE
)
4194 #undef CHECK_OS_COMPARISON
4197 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4205 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4206 found rather than just taking the first one and not checking further. */
4210 /* Don't use gfc_free_actual_arglist(). */
4211 free (actual
->next
);
4216 /* Change the expression node to a function call. */
4217 e
->expr_type
= EXPR_FUNCTION
;
4218 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4219 e
->value
.function
.actual
= actual
;
4220 e
->value
.function
.esym
= NULL
;
4221 e
->value
.function
.isym
= NULL
;
4222 e
->value
.function
.name
= NULL
;
4223 e
->user_operator
= 1;
4225 if (!gfc_resolve_expr (e
))
4232 /* Tries to replace an assignment code node with a subroutine call to the
4233 subroutine associated with the assignment operator. Return true if the node
4234 was replaced. On false, no error is generated. */
4237 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4239 gfc_actual_arglist
*actual
;
4240 gfc_expr
*lhs
, *rhs
, *tb_base
;
4241 gfc_symbol
*sym
= NULL
;
4242 const char *gname
= NULL
;
4243 gfc_typebound_proc
* tbo
;
4248 /* Don't allow an intrinsic assignment to be replaced. */
4249 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4250 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4251 && (lhs
->ts
.type
== rhs
->ts
.type
4252 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4255 actual
= gfc_get_actual_arglist ();
4258 actual
->next
= gfc_get_actual_arglist ();
4259 actual
->next
->expr
= rhs
;
4261 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4263 /* See if we find a matching type-bound assignment. */
4264 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4269 /* Success: Replace the expression with a type-bound call. */
4270 gcc_assert (tb_base
);
4271 c
->expr1
= gfc_get_expr ();
4272 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4273 c
->expr1
->value
.compcall
.assign
= 1;
4274 c
->expr1
->where
= c
->loc
;
4276 c
->op
= EXEC_COMPCALL
;
4280 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4281 for (; ns
; ns
= ns
->parent
)
4283 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4290 /* Success: Replace the assignment with the call. */
4291 c
->op
= EXEC_ASSIGN_CALL
;
4292 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4295 c
->ext
.actual
= actual
;
4299 /* Failure: No assignment procedure found. */
4300 free (actual
->next
);
4306 /* Make sure that the interface just parsed is not already present in
4307 the given interface list. Ambiguity isn't checked yet since module
4308 procedures can be present without interfaces. */
4311 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4315 for (ip
= base
; ip
; ip
= ip
->next
)
4317 if (ip
->sym
== new_sym
)
4319 gfc_error ("Entity %qs at %L is already present in the interface",
4320 new_sym
->name
, &loc
);
4329 /* Add a symbol to the current interface. */
4332 gfc_add_interface (gfc_symbol
*new_sym
)
4334 gfc_interface
**head
, *intr
;
4338 switch (current_interface
.type
)
4340 case INTERFACE_NAMELESS
:
4341 case INTERFACE_ABSTRACT
:
4344 case INTERFACE_INTRINSIC_OP
:
4345 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4346 switch (current_interface
.op
)
4349 case INTRINSIC_EQ_OS
:
4350 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4352 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4353 new_sym
, gfc_current_locus
))
4358 case INTRINSIC_NE_OS
:
4359 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4361 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4362 new_sym
, gfc_current_locus
))
4367 case INTRINSIC_GT_OS
:
4368 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4369 new_sym
, gfc_current_locus
)
4370 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4371 new_sym
, gfc_current_locus
))
4376 case INTRINSIC_GE_OS
:
4377 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4378 new_sym
, gfc_current_locus
)
4379 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4380 new_sym
, gfc_current_locus
))
4385 case INTRINSIC_LT_OS
:
4386 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4387 new_sym
, gfc_current_locus
)
4388 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4389 new_sym
, gfc_current_locus
))
4394 case INTRINSIC_LE_OS
:
4395 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4396 new_sym
, gfc_current_locus
)
4397 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4398 new_sym
, gfc_current_locus
))
4403 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4404 new_sym
, gfc_current_locus
))
4408 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4411 case INTERFACE_GENERIC
:
4412 case INTERFACE_DTIO
:
4413 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4415 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4419 if (!gfc_check_new_interface (sym
->generic
,
4420 new_sym
, gfc_current_locus
))
4424 head
= ¤t_interface
.sym
->generic
;
4427 case INTERFACE_USER_OP
:
4428 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4429 new_sym
, gfc_current_locus
))
4432 head
= ¤t_interface
.uop
->op
;
4436 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4439 intr
= gfc_get_interface ();
4440 intr
->sym
= new_sym
;
4441 intr
->where
= gfc_current_locus
;
4451 gfc_current_interface_head (void)
4453 switch (current_interface
.type
)
4455 case INTERFACE_INTRINSIC_OP
:
4456 return current_interface
.ns
->op
[current_interface
.op
];
4458 case INTERFACE_GENERIC
:
4459 case INTERFACE_DTIO
:
4460 return current_interface
.sym
->generic
;
4462 case INTERFACE_USER_OP
:
4463 return current_interface
.uop
->op
;
4472 gfc_set_current_interface_head (gfc_interface
*i
)
4474 switch (current_interface
.type
)
4476 case INTERFACE_INTRINSIC_OP
:
4477 current_interface
.ns
->op
[current_interface
.op
] = i
;
4480 case INTERFACE_GENERIC
:
4481 case INTERFACE_DTIO
:
4482 current_interface
.sym
->generic
= i
;
4485 case INTERFACE_USER_OP
:
4486 current_interface
.uop
->op
= i
;
4495 /* Gets rid of a formal argument list. We do not free symbols.
4496 Symbols are freed when a namespace is freed. */
4499 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4501 gfc_formal_arglist
*q
;
4511 /* Check that it is ok for the type-bound procedure 'proc' to override the
4512 procedure 'old', cf. F08:4.5.7.3. */
4515 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4518 gfc_symbol
*proc_target
, *old_target
;
4519 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4520 gfc_formal_arglist
*proc_formal
, *old_formal
;
4524 /* This procedure should only be called for non-GENERIC proc. */
4525 gcc_assert (!proc
->n
.tb
->is_generic
);
4527 /* If the overwritten procedure is GENERIC, this is an error. */
4528 if (old
->n
.tb
->is_generic
)
4530 gfc_error ("Can't overwrite GENERIC %qs at %L",
4531 old
->name
, &proc
->n
.tb
->where
);
4535 where
= proc
->n
.tb
->where
;
4536 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4537 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4539 /* Check that overridden binding is not NON_OVERRIDABLE. */
4540 if (old
->n
.tb
->non_overridable
)
4542 gfc_error ("%qs at %L overrides a procedure binding declared"
4543 " NON_OVERRIDABLE", proc
->name
, &where
);
4547 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4548 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4550 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4551 " non-DEFERRED binding", proc
->name
, &where
);
4555 /* If the overridden binding is PURE, the overriding must be, too. */
4556 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4558 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4559 proc
->name
, &where
);
4563 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4564 is not, the overriding must not be either. */
4565 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4567 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4568 " ELEMENTAL", proc
->name
, &where
);
4571 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4573 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4574 " be ELEMENTAL, either", proc
->name
, &where
);
4578 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4580 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4582 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4583 " SUBROUTINE", proc
->name
, &where
);
4587 /* If the overridden binding is a FUNCTION, the overriding must also be a
4588 FUNCTION and have the same characteristics. */
4589 if (old_target
->attr
.function
)
4591 if (!proc_target
->attr
.function
)
4593 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4594 " FUNCTION", proc
->name
, &where
);
4598 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4601 gfc_error ("Result mismatch for the overriding procedure "
4602 "%qs at %L: %s", proc
->name
, &where
, err
);
4607 /* If the overridden binding is PUBLIC, the overriding one must not be
4609 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4610 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4612 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4613 " PRIVATE", proc
->name
, &where
);
4617 /* Compare the formal argument lists of both procedures. This is also abused
4618 to find the position of the passed-object dummy arguments of both
4619 bindings as at least the overridden one might not yet be resolved and we
4620 need those positions in the check below. */
4621 proc_pass_arg
= old_pass_arg
= 0;
4622 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4624 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4627 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4628 old_formal
= gfc_sym_get_dummy_args (old_target
);
4629 for ( ; proc_formal
&& old_formal
;
4630 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4632 if (proc
->n
.tb
->pass_arg
4633 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4634 proc_pass_arg
= argpos
;
4635 if (old
->n
.tb
->pass_arg
4636 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4637 old_pass_arg
= argpos
;
4639 /* Check that the names correspond. */
4640 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4642 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4643 " to match the corresponding argument of the overridden"
4644 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4645 old_formal
->sym
->name
);
4649 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4650 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4651 check_type
, err
, sizeof(err
)))
4653 gfc_error_opt (OPT_Wargument_mismatch
,
4654 "Argument mismatch for the overriding procedure "
4655 "%qs at %L: %s", proc
->name
, &where
, err
);
4661 if (proc_formal
|| old_formal
)
4663 gfc_error ("%qs at %L must have the same number of formal arguments as"
4664 " the overridden procedure", proc
->name
, &where
);
4668 /* If the overridden binding is NOPASS, the overriding one must also be
4670 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4672 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4673 " NOPASS", proc
->name
, &where
);
4677 /* If the overridden binding is PASS(x), the overriding one must also be
4678 PASS and the passed-object dummy arguments must correspond. */
4679 if (!old
->n
.tb
->nopass
)
4681 if (proc
->n
.tb
->nopass
)
4683 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4684 " PASS", proc
->name
, &where
);
4688 if (proc_pass_arg
!= old_pass_arg
)
4690 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4691 " the same position as the passed-object dummy argument of"
4692 " the overridden procedure", proc
->name
, &where
);
4701 /* The following three functions check that the formal arguments
4702 of user defined derived type IO procedures are compliant with
4703 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4706 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4707 int kind
, int rank
, sym_intent intent
)
4709 if (fsym
->ts
.type
!= type
)
4711 gfc_error ("DTIO dummy argument at %L must be of type %s",
4712 &fsym
->declared_at
, gfc_basic_typename (type
));
4716 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4717 && fsym
->ts
.kind
!= kind
)
4718 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4719 &fsym
->declared_at
, kind
);
4723 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4724 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4725 gfc_error ("DTIO dummy argument at %L must be a scalar",
4726 &fsym
->declared_at
);
4728 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4729 gfc_error ("DTIO dummy argument at %L must be an "
4730 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4732 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4733 gfc_error ("DTIO character argument at %L must have assumed length",
4734 &fsym
->declared_at
);
4736 if (fsym
->attr
.intent
!= intent
)
4737 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4738 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4744 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4745 bool typebound
, bool formatted
, int code
)
4747 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4748 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4749 gfc_interface
*intr
;
4750 gfc_formal_arglist
*formal
;
4753 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4754 || ((dtio_codes
)code
== DTIO_RUF
);
4762 /* Typebound DTIO binding. */
4763 tb_io_proc
= tb_io_st
->n
.tb
;
4764 if (tb_io_proc
== NULL
)
4767 gcc_assert (tb_io_proc
->is_generic
);
4768 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4770 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4771 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4774 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4778 generic_proc
= tb_io_st
->n
.sym
;
4779 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4782 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4784 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4785 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4786 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4788 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4789 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4791 dtio_sub
= intr
->sym
;
4794 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4796 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4797 "procedure", &intr
->sym
->declared_at
);
4802 if (dtio_sub
== NULL
)
4806 gcc_assert (dtio_sub
);
4807 if (!dtio_sub
->attr
.subroutine
)
4808 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4809 dtio_sub
->name
, &dtio_sub
->declared_at
);
4812 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4815 if (arg_num
< (formatted
? 6 : 4))
4817 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4818 dtio_sub
->name
, &dtio_sub
->declared_at
);
4822 if (arg_num
> (formatted
? 6 : 4))
4824 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4825 dtio_sub
->name
, &dtio_sub
->declared_at
);
4830 /* Now go through the formal arglist. */
4832 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4834 if (!formatted
&& arg_num
== 3)
4840 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4841 "procedure", &dtio_sub
->declared_at
);
4848 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4849 BT_DERIVED
: BT_CLASS
;
4851 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4852 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4858 kind
= gfc_default_integer_kind
;
4860 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4863 case(3): /* IOTYPE */
4864 type
= BT_CHARACTER
;
4865 kind
= gfc_default_character_kind
;
4867 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4870 case(4): /* VLIST */
4872 kind
= gfc_default_integer_kind
;
4874 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4877 case(5): /* IOSTAT */
4879 kind
= gfc_default_integer_kind
;
4880 intent
= INTENT_OUT
;
4881 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4884 case(6): /* IOMSG */
4885 type
= BT_CHARACTER
;
4886 kind
= gfc_default_character_kind
;
4887 intent
= INTENT_INOUT
;
4888 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4895 derived
->attr
.has_dtio_procs
= 1;
4900 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4902 gfc_symtree
*tb_io_st
;
4907 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4910 /* Check typebound DTIO bindings. */
4911 for (code
= 0; code
< 4; code
++)
4913 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4914 || ((dtio_codes
)code
== DTIO_WF
);
4916 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4917 gfc_code2string (dtio_procs
, code
),
4918 true, &derived
->declared_at
);
4919 if (tb_io_st
!= NULL
)
4920 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4923 /* Check generic DTIO interfaces. */
4924 for (code
= 0; code
< 4; code
++)
4926 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4927 || ((dtio_codes
)code
== DTIO_WF
);
4929 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4930 gfc_code2string (dtio_procs
, code
));
4931 if (tb_io_st
!= NULL
)
4932 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4938 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4940 gfc_symtree
*tb_io_st
= NULL
;
4943 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4946 /* Try to find a typebound DTIO binding. */
4947 if (formatted
== true)
4950 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4951 gfc_code2string (dtio_procs
,
4954 &derived
->declared_at
);
4956 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4957 gfc_code2string (dtio_procs
,
4960 &derived
->declared_at
);
4965 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4966 gfc_code2string (dtio_procs
,
4969 &derived
->declared_at
);
4971 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4972 gfc_code2string (dtio_procs
,
4975 &derived
->declared_at
);
4982 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4984 gfc_symtree
*tb_io_st
= NULL
;
4985 gfc_symbol
*dtio_sub
= NULL
;
4986 gfc_symbol
*extended
;
4987 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4989 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
4991 if (tb_io_st
!= NULL
)
4993 const char *genname
;
4996 tb_io_proc
= tb_io_st
->n
.tb
;
4997 gcc_assert (tb_io_proc
!= NULL
);
4998 gcc_assert (tb_io_proc
->is_generic
);
4999 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
5001 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5002 gcc_assert (!specific_proc
->is_generic
);
5004 /* Go back and make sure that we have the right specific procedure.
5005 Here we most likely have a procedure from the parent type, which
5006 can be overridden in extensions. */
5007 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
5008 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
5009 true, &tb_io_proc
->where
);
5011 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
5013 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5018 /* If there is not a typebound binding, look for a generic
5020 for (extended
= derived
; extended
;
5021 extended
= gfc_get_derived_super_type (extended
))
5023 if (extended
== NULL
|| extended
->ns
== NULL
5024 || extended
->attr
.flavor
== FL_UNKNOWN
)
5027 if (formatted
== true)
5030 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5031 gfc_code2string (dtio_procs
,
5034 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5035 gfc_code2string (dtio_procs
,
5041 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5042 gfc_code2string (dtio_procs
,
5045 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5046 gfc_code2string (dtio_procs
,
5050 if (tb_io_st
!= NULL
5052 && tb_io_st
->n
.sym
->generic
)
5054 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5055 intr
&& intr
->sym
; intr
= intr
->next
)
5057 if (intr
->sym
->formal
)
5059 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5060 if ((fsym
->ts
.type
== BT_CLASS
5061 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5062 || (fsym
->ts
.type
== BT_DERIVED
5063 && fsym
->ts
.u
.derived
== extended
))
5065 dtio_sub
= intr
->sym
;
5074 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5075 gfc_find_derived_vtab (derived
);