1 /* Deal with interfaces.
2 Copyright (C) 2000-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface
;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface
*intr
)
88 for (; intr
; intr
= next
)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op
)
104 case INTRINSIC_UPLUS
:
107 case INTRINSIC_UMINUS
:
108 op
= INTRINSIC_MINUS
;
118 /* Return the operator depending on the DTIO moded string. Note that
119 these are not operators in the normal sense and so have been placed
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
122 static gfc_intrinsic_op
125 if (strcmp (mode
, "formatted") == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strcmp (mode
, "unformatted") == 0)
128 return INTRINSIC_UNFORMATTED
;
129 return INTRINSIC_NONE
;
133 /* Match a generic specification. Depending on which type of
134 interface is found, the 'name' or 'op' pointers may be set.
135 This subroutine doesn't return MATCH_NO. */
138 gfc_match_generic_spec (interface_type
*type
,
140 gfc_intrinsic_op
*op
)
142 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
146 if (gfc_match (" assignment ( = )") == MATCH_YES
)
148 *type
= INTERFACE_INTRINSIC_OP
;
149 *op
= INTRINSIC_ASSIGN
;
153 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
155 *type
= INTERFACE_INTRINSIC_OP
;
156 *op
= fold_unary_intrinsic (i
);
160 *op
= INTRINSIC_NONE
;
161 if (gfc_match (" operator ( ") == MATCH_YES
)
163 m
= gfc_match_defined_op_name (buffer
, 1);
169 m
= gfc_match_char (')');
175 strcpy (name
, buffer
);
176 *type
= INTERFACE_USER_OP
;
180 if (gfc_match (" read ( %n )", buffer
) == MATCH_YES
)
182 *op
= dtio_op (buffer
);
183 if (*op
== INTRINSIC_FORMATTED
)
185 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RF
));
186 *type
= INTERFACE_DTIO
;
188 if (*op
== INTRINSIC_UNFORMATTED
)
190 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RUF
));
191 *type
= INTERFACE_DTIO
;
193 if (*op
!= INTRINSIC_NONE
)
197 if (gfc_match (" write ( %n )", buffer
) == MATCH_YES
)
199 *op
= dtio_op (buffer
);
200 if (*op
== INTRINSIC_FORMATTED
)
202 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WF
));
203 *type
= INTERFACE_DTIO
;
205 if (*op
== INTRINSIC_UNFORMATTED
)
207 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WUF
));
208 *type
= INTERFACE_DTIO
;
210 if (*op
!= INTRINSIC_NONE
)
214 if (gfc_match_name (buffer
) == MATCH_YES
)
216 strcpy (name
, buffer
);
217 *type
= INTERFACE_GENERIC
;
221 *type
= INTERFACE_NAMELESS
;
225 gfc_error ("Syntax error in generic specification at %C");
230 /* Match one of the five F95 forms of an interface statement. The
231 matcher for the abstract interface follows. */
234 gfc_match_interface (void)
236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
242 m
= gfc_match_space ();
244 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
247 /* If we're not looking at the end of the statement now, or if this
248 is not a nameless interface but we did not see a space, punt. */
249 if (gfc_match_eos () != MATCH_YES
250 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
257 current_interface
.type
= type
;
262 case INTERFACE_GENERIC
:
263 if (gfc_get_symbol (name
, NULL
, &sym
))
266 if (!sym
->attr
.generic
267 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
272 gfc_error ("Dummy procedure %qs at %C cannot have a "
273 "generic interface", sym
->name
);
277 current_interface
.sym
= gfc_new_block
= sym
;
280 case INTERFACE_USER_OP
:
281 current_interface
.uop
= gfc_get_uop (name
);
284 case INTERFACE_INTRINSIC_OP
:
285 current_interface
.op
= op
;
288 case INTERFACE_NAMELESS
:
289 case INTERFACE_ABSTRACT
:
298 /* Match a F2003 abstract interface. */
301 gfc_match_abstract_interface (void)
305 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
308 m
= gfc_match_eos ();
312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
316 current_interface
.type
= INTERFACE_ABSTRACT
;
322 /* Match the different sort of generic-specs that can be present after
323 the END INTERFACE itself. */
326 gfc_match_end_interface (void)
328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
333 m
= gfc_match_space ();
335 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
338 /* If we're not looking at the end of the statement now, or if this
339 is not a nameless interface but we did not see a space, punt. */
340 if (gfc_match_eos () != MATCH_YES
341 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
350 switch (current_interface
.type
)
352 case INTERFACE_NAMELESS
:
353 case INTERFACE_ABSTRACT
:
354 if (type
!= INTERFACE_NAMELESS
)
356 gfc_error ("Expected a nameless interface at %C");
362 case INTERFACE_INTRINSIC_OP
:
363 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
366 if (current_interface
.op
== INTRINSIC_ASSIGN
)
369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
374 s1
= gfc_op2string (current_interface
.op
);
375 s2
= gfc_op2string (op
);
377 /* The following if-statements are used to enforce C1202
379 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
380 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
382 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
383 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
385 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
386 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
388 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
389 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
391 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
392 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
394 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
395 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
399 if (strcmp(s2
, "none") == 0)
400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
404 "but got %qs", s1
, s2
);
411 case INTERFACE_USER_OP
:
412 /* Comparing the symbol node names is OK because only use-associated
413 symbols can be renamed. */
414 if (type
!= current_interface
.type
415 || strcmp (current_interface
.uop
->name
, name
) != 0)
417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
418 current_interface
.uop
->name
);
425 case INTERFACE_GENERIC
:
426 if (type
!= current_interface
.type
427 || strcmp (current_interface
.sym
->name
, name
) != 0)
429 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
430 current_interface
.sym
->name
);
441 /* Return whether the component was defined anonymously. */
444 is_anonymous_component (gfc_component
*cmp
)
446 /* Only UNION and MAP components are anonymous. In the case of a MAP,
447 the derived type symbol is FL_STRUCT and the component name looks like mM*.
448 This is the only case in which the second character of a component name is
450 return cmp
->ts
.type
== BT_UNION
451 || (cmp
->ts
.type
== BT_DERIVED
452 && cmp
->ts
.u
.derived
->attr
.flavor
== FL_STRUCT
453 && cmp
->name
[0] && cmp
->name
[1] && ISUPPER (cmp
->name
[1]));
457 /* Return whether the derived type was defined anonymously. */
460 is_anonymous_dt (gfc_symbol
*derived
)
462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
464 and the type name looks like XX*. This is the only case in which the
465 second character of a type name is uppercase. */
466 return derived
->attr
.flavor
== FL_UNION
467 || (derived
->attr
.flavor
== FL_STRUCT
468 && derived
->name
[0] && derived
->name
[1] && ISUPPER (derived
->name
[1]));
472 /* Compare components according to 4.4.2 of the Fortran standard. */
475 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
476 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
478 /* Compare names, but not for anonymous components such as UNION or MAP. */
479 if (!is_anonymous_component (cmp1
) && !is_anonymous_component (cmp2
)
480 && strcmp (cmp1
->name
, cmp2
->name
) != 0)
483 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
486 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
489 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
492 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
495 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
498 if (cmp1
->ts
.type
== BT_CHARACTER
&& cmp2
->ts
.type
== BT_CHARACTER
)
500 gfc_charlen
*l1
= cmp1
->ts
.u
.cl
;
501 gfc_charlen
*l2
= cmp2
->ts
.u
.cl
;
502 if (l1
&& l2
&& l1
->length
&& l2
->length
503 && l1
->length
->expr_type
== EXPR_CONSTANT
504 && l2
->length
->expr_type
== EXPR_CONSTANT
505 && gfc_dep_compare_expr (l1
->length
, l2
->length
) != 0)
509 /* Make sure that link lists do not put this function into an
510 endless recursive loop! */
511 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
512 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
513 && !gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
))
516 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
517 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
520 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
521 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
528 /* Compare two union types by comparing the components of their maps.
529 Because unions and maps are anonymous their types get special internal
530 names; therefore the usual derived type comparison will fail on them.
532 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
533 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
534 definitions' than 'equivalent structure'. */
537 compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
539 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
540 gfc_symbol
*map1_t
, *map2_t
;
542 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
545 if (un1
->attr
.zero_comp
!= un2
->attr
.zero_comp
)
548 if (un1
->attr
.zero_comp
)
551 map1
= un1
->components
;
552 map2
= un2
->components
;
554 /* In terms of 'equality' here we are worried about types which are
555 declared the same in two places, not types that represent equivalent
556 structures. (This is common because of FORTRAN's weird scoping rules.)
557 Though two unions with their maps in different orders could be equivalent,
558 we will say they are not equal for the purposes of this test; therefore
559 we compare the maps sequentially. */
562 map1_t
= map1
->ts
.u
.derived
;
563 map2_t
= map2
->ts
.u
.derived
;
565 cmp1
= map1_t
->components
;
566 cmp2
= map2_t
->components
;
568 /* Protect against null components. */
569 if (map1_t
->attr
.zero_comp
!= map2_t
->attr
.zero_comp
)
572 if (map1_t
->attr
.zero_comp
)
577 /* No two fields will ever point to the same map type unless they are
578 the same component, because one map field is created with its type
579 declaration. Therefore don't worry about recursion here. */
580 /* TODO: worry about recursion into parent types of the unions? */
581 if (!compare_components (cmp1
, cmp2
, map1_t
, map2_t
))
587 if (cmp1
== NULL
&& cmp2
== NULL
)
589 if (cmp1
== NULL
|| cmp2
== NULL
)
596 if (map1
== NULL
&& map2
== NULL
)
598 if (map1
== NULL
|| map2
== NULL
)
607 /* Compare two derived types using the criteria in 4.4.2 of the standard,
608 recursing through gfc_compare_types for the components. */
611 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
613 gfc_component
*cmp1
, *cmp2
;
615 if (derived1
== derived2
)
618 if (!derived1
|| !derived2
)
619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
621 /* Compare UNION types specially. */
622 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
623 return compare_union_types (derived1
, derived2
);
625 /* Special case for comparing derived types across namespaces. If the
626 true names and module names are the same and the module name is
627 nonnull, then they are equal. */
628 if (strcmp (derived1
->name
, derived2
->name
) == 0
629 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
630 && strcmp (derived1
->module
, derived2
->module
) == 0)
633 /* Compare type via the rules of the standard. Both types must have
634 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
635 because they can be anonymous; therefore two structures with different
636 names may be equal. */
638 /* Compare names, but not for anonymous types such as UNION or MAP. */
639 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
640 && strcmp (derived1
->name
, derived2
->name
) != 0)
643 if (derived1
->component_access
== ACCESS_PRIVATE
644 || derived2
->component_access
== ACCESS_PRIVATE
)
647 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
648 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
)
649 && !(derived1
->attr
.pdt_type
&& derived2
->attr
.pdt_type
))
652 /* Protect against null components. */
653 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
656 if (derived1
->attr
.zero_comp
)
659 cmp1
= derived1
->components
;
660 cmp2
= derived2
->components
;
662 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
663 simple test can speed things up. Otherwise, lots of things have to
667 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
673 if (cmp1
== NULL
&& cmp2
== NULL
)
675 if (cmp1
== NULL
|| cmp2
== NULL
)
683 /* Compare two typespecs, recursively if necessary. */
686 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
688 /* See if one of the typespecs is a BT_VOID, which is what is being used
689 to allow the funcs like c_f_pointer to accept any pointer type.
690 TODO: Possibly should narrow this to just the one typespec coming in
691 that is for the formal arg, but oh well. */
692 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
695 /* Special case for our C interop types. FIXME: There should be a
696 better way of doing this. When ISO C binding is cleared up,
697 this can probably be removed. See PR 57048. */
699 if (((ts1
->type
== BT_INTEGER
&& ts2
->type
== BT_DERIVED
)
700 || (ts1
->type
== BT_DERIVED
&& ts2
->type
== BT_INTEGER
))
701 && ts1
->u
.derived
&& ts2
->u
.derived
702 && ts1
->u
.derived
== ts2
->u
.derived
)
705 /* The _data component is not always present, therefore check for its
706 presence before assuming, that its derived->attr is available.
707 When the _data component is not present, then nevertheless the
708 unlimited_polymorphic flag may be set in the derived type's attr. */
709 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
710 && ((ts1
->u
.derived
->attr
.is_class
711 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
712 .unlimited_polymorphic
)
713 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
717 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
718 && ts2
->u
.derived
->components
719 && ((ts2
->u
.derived
->attr
.is_class
720 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
721 .unlimited_polymorphic
)
722 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
723 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
726 if (ts1
->type
!= ts2
->type
727 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
728 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
731 if (ts1
->type
== BT_UNION
)
732 return compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
734 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
735 return (ts1
->kind
== ts2
->kind
);
737 /* Compare derived types. */
738 return gfc_type_compatible (ts1
, ts2
);
743 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
745 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
748 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
753 compare_type_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
)
755 /* TYPE and CLASS of the same declared type are type compatible,
756 but have different characteristics. */
757 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
758 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
761 return compare_type (s1
, s2
);
766 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
768 gfc_array_spec
*as1
, *as2
;
771 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
774 as1
= (s1
->ts
.type
== BT_CLASS
775 && !s1
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
776 ? CLASS_DATA (s1
)->as
: s1
->as
;
777 as2
= (s2
->ts
.type
== BT_CLASS
778 && !s2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
779 ? CLASS_DATA (s2
)->as
: s2
->as
;
781 r1
= as1
? as1
->rank
: 0;
782 r2
= as2
? as2
->rank
: 0;
784 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
785 return false; /* Ranks differ. */
791 /* Given two symbols that are formal arguments, compare their ranks
792 and types. Returns true if they have the same rank and type,
796 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
798 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
802 /* Given two symbols that are formal arguments, compare their types
803 and rank and their formal interfaces if they are both dummy
804 procedures. Returns true if the same, false if different. */
807 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
809 if (s1
== NULL
|| s2
== NULL
)
815 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
816 return compare_type_rank (s1
, s2
);
818 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
821 /* At this point, both symbols are procedures. It can happen that
822 external procedures are compared, where one is identified by usage
823 to be a function or subroutine but the other is not. Check TKR
824 nonetheless for these cases. */
825 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
826 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
828 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
829 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
831 /* Now the type of procedure has been identified. */
832 if (s1
->attr
.function
!= s2
->attr
.function
833 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
836 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
839 /* Originally, gfortran recursed here to check the interfaces of passed
840 procedures. This is explicitly not required by the standard. */
845 /* Given a formal argument list and a keyword name, search the list
846 for that keyword. Returns the correct symbol node if found, NULL
850 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
852 for (; f
; f
= f
->next
)
853 if (strcmp (f
->sym
->name
, name
) == 0)
860 /******** Interface checking subroutines **********/
863 /* Given an operator interface and the operator, make sure that all
864 interfaces for that operator are legal. */
867 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
870 gfc_formal_arglist
*formal
;
873 int args
, r1
, r2
, k1
, k2
;
878 t1
= t2
= BT_UNKNOWN
;
879 i1
= i2
= INTENT_UNKNOWN
;
883 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
885 gfc_symbol
*fsym
= formal
->sym
;
888 gfc_error ("Alternate return cannot appear in operator "
889 "interface at %L", &sym
->declared_at
);
895 i1
= fsym
->attr
.intent
;
896 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
902 i2
= fsym
->attr
.intent
;
903 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
909 /* Only +, - and .not. can be unary operators.
910 .not. cannot be a binary operator. */
911 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
912 && op
!= INTRINSIC_MINUS
913 && op
!= INTRINSIC_NOT
)
914 || (args
== 2 && op
== INTRINSIC_NOT
))
916 if (op
== INTRINSIC_ASSIGN
)
917 gfc_error ("Assignment operator interface at %L must have "
918 "two arguments", &sym
->declared_at
);
920 gfc_error ("Operator interface at %L has the wrong number of arguments",
925 /* Check that intrinsics are mapped to functions, except
926 INTRINSIC_ASSIGN which should map to a subroutine. */
927 if (op
== INTRINSIC_ASSIGN
)
929 gfc_formal_arglist
*dummy_args
;
931 if (!sym
->attr
.subroutine
)
933 gfc_error ("Assignment operator interface at %L must be "
934 "a SUBROUTINE", &sym
->declared_at
);
938 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
939 - First argument an array with different rank than second,
940 - First argument is a scalar and second an array,
941 - Types and kinds do not conform, or
942 - First argument is of derived type. */
943 dummy_args
= gfc_sym_get_dummy_args (sym
);
944 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
945 && dummy_args
->sym
->ts
.type
!= BT_CLASS
946 && (r2
== 0 || r1
== r2
)
947 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
948 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
949 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
951 gfc_error ("Assignment operator interface at %L must not redefine "
952 "an INTRINSIC type assignment", &sym
->declared_at
);
958 if (!sym
->attr
.function
)
960 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
966 /* Check intents on operator interfaces. */
967 if (op
== INTRINSIC_ASSIGN
)
969 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
971 gfc_error ("First argument of defined assignment at %L must be "
972 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
978 gfc_error ("Second argument of defined assignment at %L must be "
979 "INTENT(IN)", &sym
->declared_at
);
987 gfc_error ("First argument of operator interface at %L must be "
988 "INTENT(IN)", &sym
->declared_at
);
992 if (args
== 2 && i2
!= INTENT_IN
)
994 gfc_error ("Second argument of operator interface at %L must be "
995 "INTENT(IN)", &sym
->declared_at
);
1000 /* From now on, all we have to do is check that the operator definition
1001 doesn't conflict with an intrinsic operator. The rules for this
1002 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
1003 as well as 12.3.2.1.1 of Fortran 2003:
1005 "If the operator is an intrinsic-operator (R310), the number of
1006 function arguments shall be consistent with the intrinsic uses of
1007 that operator, and the types, kind type parameters, or ranks of the
1008 dummy arguments shall differ from those required for the intrinsic
1009 operation (7.1.2)." */
1011 #define IS_NUMERIC_TYPE(t) \
1012 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
1014 /* Unary ops are easy, do them first. */
1015 if (op
== INTRINSIC_NOT
)
1017 if (t1
== BT_LOGICAL
)
1023 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1025 if (IS_NUMERIC_TYPE (t1
))
1031 /* Character intrinsic operators have same character kind, thus
1032 operator definitions with operands of different character kinds
1034 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1037 /* Intrinsic operators always perform on arguments of same rank,
1038 so different ranks is also always safe. (rank == 0) is an exception
1039 to that, because all intrinsic operators are elemental. */
1040 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1046 case INTRINSIC_EQ_OS
:
1048 case INTRINSIC_NE_OS
:
1049 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1053 case INTRINSIC_PLUS
:
1054 case INTRINSIC_MINUS
:
1055 case INTRINSIC_TIMES
:
1056 case INTRINSIC_DIVIDE
:
1057 case INTRINSIC_POWER
:
1058 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1063 case INTRINSIC_GT_OS
:
1065 case INTRINSIC_GE_OS
:
1067 case INTRINSIC_LT_OS
:
1069 case INTRINSIC_LE_OS
:
1070 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1072 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1073 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1077 case INTRINSIC_CONCAT
:
1078 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1085 case INTRINSIC_NEQV
:
1086 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1096 #undef IS_NUMERIC_TYPE
1099 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1105 /* Given a pair of formal argument lists, we see if the two lists can
1106 be distinguished by counting the number of nonoptional arguments of
1107 a given type/rank in f1 and seeing if there are less then that
1108 number of those arguments in f2 (including optional arguments).
1109 Since this test is asymmetric, it has to be called twice to make it
1110 symmetric. Returns nonzero if the argument lists are incompatible
1111 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1112 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1115 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1116 const char *p1
, const char *p2
)
1118 int ac1
, ac2
, i
, j
, k
, n1
;
1119 gfc_formal_arglist
*f
;
1132 for (f
= f1
; f
; f
= f
->next
)
1135 /* Build an array of integers that gives the same integer to
1136 arguments of the same type/rank. */
1137 arg
= XCNEWVEC (arginfo
, n1
);
1140 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1143 arg
[i
].sym
= f
->sym
;
1148 for (i
= 0; i
< n1
; i
++)
1150 if (arg
[i
].flag
!= -1)
1153 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1154 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1155 continue; /* Skip OPTIONAL and PASS arguments. */
1159 /* Find other non-optional, non-pass arguments of the same type/rank. */
1160 for (j
= i
+ 1; j
< n1
; j
++)
1161 if ((arg
[j
].sym
== NULL
1162 || !(arg
[j
].sym
->attr
.optional
1163 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1164 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1165 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1171 /* Now loop over each distinct type found in f1. */
1175 for (i
= 0; i
< n1
; i
++)
1177 if (arg
[i
].flag
!= k
)
1181 for (j
= i
+ 1; j
< n1
; j
++)
1182 if (arg
[j
].flag
== k
)
1185 /* Count the number of non-pass arguments in f2 with that type,
1186 including those that are optional. */
1189 for (f
= f2
; f
; f
= f
->next
)
1190 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1191 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1192 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1210 /* Returns true if two dummy arguments are distinguishable due to their POINTER
1211 and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
1212 The function is asymmetric wrt to the arguments s1 and s2 and should always
1213 be called twice (with flipped arguments in the second call). */
1216 compare_ptr_alloc(gfc_symbol
*s1
, gfc_symbol
*s2
)
1218 /* Is s1 allocatable? */
1219 const bool a1
= s1
->ts
.type
== BT_CLASS
?
1220 CLASS_DATA(s1
)->attr
.allocatable
: s1
->attr
.allocatable
;
1221 /* Is s2 a pointer? */
1222 const bool p2
= s2
->ts
.type
== BT_CLASS
?
1223 CLASS_DATA(s2
)->attr
.class_pointer
: s2
->attr
.pointer
;
1224 return a1
&& p2
&& (s2
->attr
.intent
!= INTENT_IN
);
1228 /* Perform the correspondence test in rule (3) of F08:C1215.
1229 Returns zero if no argument is found that satisfies this rule,
1230 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1233 This test is also not symmetric in f1 and f2 and must be called
1234 twice. This test finds problems caused by sorting the actual
1235 argument list with keywords. For example:
1239 INTEGER :: A ; REAL :: B
1243 INTEGER :: A ; REAL :: B
1247 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1250 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1251 const char *p1
, const char *p2
)
1253 gfc_formal_arglist
*f2_save
, *g
;
1260 if (f1
->sym
->attr
.optional
)
1263 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1265 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1268 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1269 || compare_type_rank (f2
->sym
, f1
->sym
))
1270 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1271 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1272 || compare_ptr_alloc(f2
->sym
, f1
->sym
))))
1275 /* Now search for a disambiguating keyword argument starting at
1276 the current non-match. */
1277 for (g
= f1
; g
; g
= g
->next
)
1279 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1282 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1283 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1284 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1285 && (compare_ptr_alloc(sym
, g
->sym
)
1286 || compare_ptr_alloc(g
->sym
, sym
))))
1302 symbol_rank (gfc_symbol
*sym
)
1304 gfc_array_spec
*as
= NULL
;
1306 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1307 as
= CLASS_DATA (sym
)->as
;
1311 return as
? as
->rank
: 0;
1315 /* Check if the characteristics of two dummy arguments match,
1319 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1320 bool type_must_agree
, char *errmsg
,
1323 if (s1
== NULL
|| s2
== NULL
)
1324 return s1
== s2
? true : false;
1326 /* Check type and rank. */
1327 if (type_must_agree
)
1329 if (!compare_type_characteristics (s1
, s2
)
1330 || !compare_type_characteristics (s2
, s1
))
1332 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1333 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1336 if (!compare_rank (s1
, s2
))
1338 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1339 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1345 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1347 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1352 /* Check OPTIONAL attribute. */
1353 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1355 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1360 /* Check ALLOCATABLE attribute. */
1361 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1363 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1368 /* Check POINTER attribute. */
1369 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1371 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1376 /* Check TARGET attribute. */
1377 if (s1
->attr
.target
!= s2
->attr
.target
)
1379 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1384 /* Check ASYNCHRONOUS attribute. */
1385 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1387 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1392 /* Check CONTIGUOUS attribute. */
1393 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1395 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1400 /* Check VALUE attribute. */
1401 if (s1
->attr
.value
!= s2
->attr
.value
)
1403 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1408 /* Check VOLATILE attribute. */
1409 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1411 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1416 /* Check interface of dummy procedures. */
1417 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1420 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1423 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1424 "'%s': %s", s1
->name
, err
);
1429 /* Check string length. */
1430 if (s1
->ts
.type
== BT_CHARACTER
1431 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1432 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1434 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1435 s2
->ts
.u
.cl
->length
);
1441 snprintf (errmsg
, err_len
, "Character length mismatch "
1442 "in argument '%s'", s1
->name
);
1446 /* FIXME: Implement a warning for this case.
1447 gfc_warning (0, "Possible character length mismatch in argument %qs",
1455 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1456 "%i of gfc_dep_compare_expr", compval
);
1461 /* Check array shape. */
1462 if (s1
->as
&& s2
->as
)
1465 gfc_expr
*shape1
, *shape2
;
1467 if (s1
->as
->type
!= s2
->as
->type
)
1469 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1474 if (s1
->as
->corank
!= s2
->as
->corank
)
1476 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1477 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1481 if (s1
->as
->type
== AS_EXPLICIT
)
1482 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1484 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1485 gfc_copy_expr (s1
->as
->lower
[i
]));
1486 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1487 gfc_copy_expr (s2
->as
->lower
[i
]));
1488 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1489 gfc_free_expr (shape1
);
1490 gfc_free_expr (shape2
);
1496 if (i
< s1
->as
->rank
)
1497 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1498 " argument '%s'", i
+ 1, s1
->name
);
1500 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1501 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1505 /* FIXME: Implement a warning for this case.
1506 gfc_warning (0, "Possible shape mismatch in argument %qs",
1514 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1515 "result %i of gfc_dep_compare_expr",
1526 /* Check if the characteristics of two function results match,
1530 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1531 char *errmsg
, int err_len
)
1533 gfc_symbol
*r1
, *r2
;
1535 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1536 r1
= s1
->ts
.interface
->result
;
1538 r1
= s1
->result
? s1
->result
: s1
;
1540 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1541 r2
= s2
->ts
.interface
->result
;
1543 r2
= s2
->result
? s2
->result
: s2
;
1545 if (r1
->ts
.type
== BT_UNKNOWN
)
1548 /* Check type and rank. */
1549 if (!compare_type_characteristics (r1
, r2
))
1551 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1552 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1555 if (!compare_rank (r1
, r2
))
1557 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1558 symbol_rank (r1
), symbol_rank (r2
));
1562 /* Check ALLOCATABLE attribute. */
1563 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1565 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1570 /* Check POINTER attribute. */
1571 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1573 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1578 /* Check CONTIGUOUS attribute. */
1579 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1581 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1586 /* Check PROCEDURE POINTER attribute. */
1587 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1589 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1594 /* Check string length. */
1595 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1597 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1599 snprintf (errmsg
, err_len
, "Character length mismatch "
1600 "in function result");
1604 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1606 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1607 r2
->ts
.u
.cl
->length
);
1613 snprintf (errmsg
, err_len
, "Character length mismatch "
1614 "in function result");
1618 /* FIXME: Implement a warning for this case.
1619 snprintf (errmsg, err_len, "Possible character length mismatch "
1620 "in function result");*/
1627 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1628 "result %i of gfc_dep_compare_expr", compval
);
1634 /* Check array shape. */
1635 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1638 gfc_expr
*shape1
, *shape2
;
1640 if (r1
->as
->type
!= r2
->as
->type
)
1642 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1646 if (r1
->as
->type
== AS_EXPLICIT
)
1647 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1649 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1650 gfc_copy_expr (r1
->as
->lower
[i
]));
1651 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1652 gfc_copy_expr (r2
->as
->lower
[i
]));
1653 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1654 gfc_free_expr (shape1
);
1655 gfc_free_expr (shape2
);
1661 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1662 "function result", i
+ 1);
1666 /* FIXME: Implement a warning for this case.
1667 gfc_warning (0, "Possible shape mismatch in return value");*/
1674 gfc_internal_error ("check_result_characteristics (2): "
1675 "Unexpected result %i of "
1676 "gfc_dep_compare_expr", compval
);
1686 /* 'Compare' two formal interfaces associated with a pair of symbols.
1687 We return true if there exists an actual argument list that
1688 would be ambiguous between the two interfaces, zero otherwise.
1689 'strict_flag' specifies whether all the characteristics are
1690 required to match, which is not the case for ambiguity checks.
1691 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1694 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1695 int generic_flag
, int strict_flag
,
1696 char *errmsg
, int err_len
,
1697 const char *p1
, const char *p2
)
1699 gfc_formal_arglist
*f1
, *f2
;
1701 gcc_assert (name2
!= NULL
);
1703 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1704 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1705 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1708 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1712 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1715 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1719 /* Do strict checks on all characteristics
1720 (for dummy procedures and procedure pointer assignments). */
1721 if (!generic_flag
&& strict_flag
)
1723 if (s1
->attr
.function
&& s2
->attr
.function
)
1725 /* If both are functions, check result characteristics. */
1726 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1727 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1731 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1733 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1736 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1738 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1743 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1744 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1747 f1
= gfc_sym_get_dummy_args (s1
);
1748 f2
= gfc_sym_get_dummy_args (s2
);
1750 /* Special case: No arguments. */
1751 if (f1
== NULL
&& f2
== NULL
)
1756 if (count_types_test (f1
, f2
, p1
, p2
)
1757 || count_types_test (f2
, f1
, p2
, p1
))
1760 /* Special case: alternate returns. If both f1->sym and f2->sym are
1761 NULL, then the leading formal arguments are alternate returns.
1762 The previous conditional should catch argument lists with
1763 different number of argument. */
1764 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1767 if (generic_correspondence (f1
, f2
, p1
, p2
)
1768 || generic_correspondence (f2
, f1
, p2
, p1
))
1772 /* Perform the abbreviated correspondence test for operators (the
1773 arguments cannot be optional and are always ordered correctly).
1774 This is also done when comparing interfaces for dummy procedures and in
1775 procedure pointer assignments. */
1777 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1779 /* Check existence. */
1780 if (f1
== NULL
|| f2
== NULL
)
1783 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1784 "arguments", name2
);
1790 /* Check all characteristics. */
1791 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1797 /* Operators: Only check type and rank of arguments. */
1798 if (!compare_type (f2
->sym
, f1
->sym
))
1801 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1802 "(%s/%s)", f1
->sym
->name
,
1803 gfc_typename (&f1
->sym
->ts
),
1804 gfc_typename (&f2
->sym
->ts
));
1807 if (!compare_rank (f2
->sym
, f1
->sym
))
1810 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1811 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1812 symbol_rank (f2
->sym
));
1815 if ((gfc_option
.allow_std
& GFC_STD_F2008
)
1816 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1817 || compare_ptr_alloc(f2
->sym
, f1
->sym
)))
1820 snprintf (errmsg
, err_len
, "Mismatching POINTER/ALLOCATABLE "
1821 "attribute in argument '%s' ", f1
->sym
->name
);
1831 /* Given a pointer to an interface pointer, remove duplicate
1832 interfaces and make sure that all symbols are either functions
1833 or subroutines, and all of the same kind. Returns true if
1834 something goes wrong. */
1837 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1839 gfc_interface
*psave
, *q
, *qlast
;
1842 for (; p
; p
= p
->next
)
1844 /* Make sure all symbols in the interface have been defined as
1845 functions or subroutines. */
1846 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1847 || !p
->sym
->attr
.if_source
)
1848 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1851 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1853 if (p
->sym
->attr
.external
)
1855 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1856 "; did you mean %qs?",
1857 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1860 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1861 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1864 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1865 "subroutine; did you mean %qs?", p
->sym
->name
,
1866 interface_name
, &p
->sym
->declared_at
, guessed
);
1868 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1869 "subroutine", p
->sym
->name
, interface_name
,
1870 &p
->sym
->declared_at
);
1874 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1875 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1876 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1877 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1879 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1880 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1881 " or all FUNCTIONs", interface_name
,
1882 &p
->sym
->declared_at
);
1883 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1884 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1885 "generic name is also the name of a derived type",
1886 interface_name
, &p
->sym
->declared_at
);
1890 /* F2003, C1207. F2008, C1207. */
1891 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1892 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1893 "%qs in %s at %L", p
->sym
->name
,
1894 interface_name
, &p
->sym
->declared_at
))
1899 /* Remove duplicate interfaces in this interface list. */
1900 for (; p
; p
= p
->next
)
1904 for (q
= p
->next
; q
;)
1906 if (p
->sym
!= q
->sym
)
1913 /* Duplicate interface. */
1914 qlast
->next
= q
->next
;
1925 /* Check lists of interfaces to make sure that no two interfaces are
1926 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1929 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1930 int generic_flag
, const char *interface_name
,
1934 for (; p
; p
= p
->next
)
1935 for (q
= q0
; q
; q
= q
->next
)
1937 if (p
->sym
== q
->sym
)
1938 continue; /* Duplicates OK here. */
1940 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1943 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1944 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1945 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1946 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1949 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1950 "and %qs at %L", interface_name
,
1951 q
->sym
->name
, &q
->sym
->declared_at
,
1952 p
->sym
->name
, &p
->sym
->declared_at
);
1953 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1954 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1955 "and %qs at %L", interface_name
,
1956 q
->sym
->name
, &q
->sym
->declared_at
,
1957 p
->sym
->name
, &p
->sym
->declared_at
);
1959 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1960 "interfaces at %L", interface_name
, &p
->where
);
1968 /* Check the generic and operator interfaces of symbols to make sure
1969 that none of the interfaces conflict. The check has to be done
1970 after all of the symbols are actually loaded. */
1973 check_sym_interfaces (gfc_symbol
*sym
)
1975 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("generic interface ''")];
1978 if (sym
->ns
!= gfc_current_ns
)
1981 if (sym
->generic
!= NULL
)
1983 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1984 if (check_interface0 (sym
->generic
, interface_name
))
1987 for (p
= sym
->generic
; p
; p
= p
->next
)
1989 if (p
->sym
->attr
.mod_proc
1990 && !p
->sym
->attr
.module_procedure
1991 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1992 || p
->sym
->attr
.procedure
))
1994 gfc_error ("%qs at %L is not a module procedure",
1995 p
->sym
->name
, &p
->where
);
2000 /* Originally, this test was applied to host interfaces too;
2001 this is incorrect since host associated symbols, from any
2002 source, cannot be ambiguous with local symbols. */
2003 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
2004 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
2010 check_uop_interfaces (gfc_user_op
*uop
)
2012 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
2016 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
2017 if (check_interface0 (uop
->op
, interface_name
))
2020 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2022 uop2
= gfc_find_uop (uop
->name
, ns
);
2026 check_interface1 (uop
->op
, uop2
->op
, 0,
2027 interface_name
, true);
2031 /* Given an intrinsic op, return an equivalent op if one exists,
2032 or INTRINSIC_NONE otherwise. */
2035 gfc_equivalent_op (gfc_intrinsic_op op
)
2040 return INTRINSIC_EQ_OS
;
2042 case INTRINSIC_EQ_OS
:
2043 return INTRINSIC_EQ
;
2046 return INTRINSIC_NE_OS
;
2048 case INTRINSIC_NE_OS
:
2049 return INTRINSIC_NE
;
2052 return INTRINSIC_GT_OS
;
2054 case INTRINSIC_GT_OS
:
2055 return INTRINSIC_GT
;
2058 return INTRINSIC_GE_OS
;
2060 case INTRINSIC_GE_OS
:
2061 return INTRINSIC_GE
;
2064 return INTRINSIC_LT_OS
;
2066 case INTRINSIC_LT_OS
:
2067 return INTRINSIC_LT
;
2070 return INTRINSIC_LE_OS
;
2072 case INTRINSIC_LE_OS
:
2073 return INTRINSIC_LE
;
2076 return INTRINSIC_NONE
;
2080 /* For the namespace, check generic, user operator and intrinsic
2081 operator interfaces for consistency and to remove duplicate
2082 interfaces. We traverse the whole namespace, counting on the fact
2083 that most symbols will not have generic or operator interfaces. */
2086 gfc_check_interfaces (gfc_namespace
*ns
)
2088 gfc_namespace
*old_ns
, *ns2
;
2089 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2092 old_ns
= gfc_current_ns
;
2093 gfc_current_ns
= ns
;
2095 gfc_traverse_ns (ns
, check_sym_interfaces
);
2097 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2099 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2101 if (i
== INTRINSIC_USER
)
2104 if (i
== INTRINSIC_ASSIGN
)
2105 strcpy (interface_name
, "intrinsic assignment operator");
2107 sprintf (interface_name
, "intrinsic '%s' operator",
2108 gfc_op2string ((gfc_intrinsic_op
) i
));
2110 if (check_interface0 (ns
->op
[i
], interface_name
))
2114 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2117 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2119 gfc_intrinsic_op other_op
;
2121 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2122 interface_name
, true))
2125 /* i should be gfc_intrinsic_op, but has to be int with this cast
2126 here for stupid C++ compatibility rules. */
2127 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2128 if (other_op
!= INTRINSIC_NONE
2129 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2130 0, interface_name
, true))
2136 gfc_current_ns
= old_ns
;
2140 /* Given a symbol of a formal argument list and an expression, if the
2141 formal argument is allocatable, check that the actual argument is
2142 allocatable. Returns true if compatible, zero if not compatible. */
2145 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2147 if (formal
->attr
.allocatable
2148 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2150 symbol_attribute attr
= gfc_expr_attr (actual
);
2151 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2153 else if (!attr
.allocatable
)
2161 /* Given a symbol of a formal argument list and an expression, if the
2162 formal argument is a pointer, see if the actual argument is a
2163 pointer. Returns nonzero if compatible, zero if not compatible. */
2166 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2168 symbol_attribute attr
;
2170 if (formal
->attr
.pointer
2171 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2172 && CLASS_DATA (formal
)->attr
.class_pointer
))
2174 attr
= gfc_expr_attr (actual
);
2176 /* Fortran 2008 allows non-pointer actual arguments. */
2177 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2188 /* Emit clear error messages for rank mismatch. */
2191 argument_rank_mismatch (const char *name
, locus
*where
,
2192 int rank1
, int rank2
)
2195 /* TS 29113, C407b. */
2197 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2198 " %qs has assumed-rank", where
, name
);
2199 else if (rank1
== 0)
2200 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2201 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2202 else if (rank2
== 0)
2203 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2204 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2206 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2207 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2211 /* Given a symbol of a formal argument list and an expression, see if
2212 the two are compatible as arguments. Returns true if
2213 compatible, false if not compatible. */
2216 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2217 int ranks_must_agree
, int is_elemental
, locus
*where
)
2220 bool rank_check
, is_pointer
;
2224 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2225 procs c_f_pointer or c_f_procpointer, and we need to accept most
2226 pointers the user could give us. This should allow that. */
2227 if (formal
->ts
.type
== BT_VOID
)
2230 if (formal
->ts
.type
== BT_DERIVED
2231 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2232 && actual
->ts
.type
== BT_DERIVED
2233 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2236 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2237 /* Make sure the vtab symbol is present when
2238 the module variables are generated. */
2239 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2241 if (actual
->ts
.type
== BT_PROCEDURE
)
2243 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2245 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2248 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2252 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2253 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
);
2262 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2264 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2265 &act_sym
->declared_at
);
2266 if (act_sym
->ts
.type
== BT_UNKNOWN
2267 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2270 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2271 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2272 &act_sym
->declared_at
);
2277 ppc
= gfc_get_proc_ptr_comp (actual
);
2278 if (ppc
&& ppc
->ts
.interface
)
2280 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2281 err
, sizeof(err
), NULL
, NULL
))
2284 gfc_error_opt (OPT_Wargument_mismatch
,
2285 "Interface mismatch in dummy procedure %qs at %L:"
2286 " %s", formal
->name
, &actual
->where
, err
);
2292 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2293 && !gfc_is_simply_contiguous (actual
, true, false))
2296 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2297 "must be simply contiguous", formal
->name
, &actual
->where
);
2301 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2302 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2305 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2306 && actual
->ts
.type
!= BT_HOLLERITH
2307 && formal
->ts
.type
!= BT_ASSUMED
2308 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2309 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2310 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2311 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2312 CLASS_DATA (actual
)->ts
.u
.derived
)))
2315 gfc_error_opt (OPT_Wargument_mismatch
,
2316 "Type mismatch in argument %qs at %L; passed %s to %s",
2317 formal
->name
, where
, gfc_typename (&actual
->ts
),
2318 gfc_typename (&formal
->ts
));
2322 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2325 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2326 "argument %qs is of assumed type", &actual
->where
,
2331 /* F2008, 12.5.2.5; IR F08/0073. */
2332 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2333 && actual
->expr_type
!= EXPR_NULL
2334 && ((CLASS_DATA (formal
)->attr
.class_pointer
2335 && formal
->attr
.intent
!= INTENT_IN
)
2336 || CLASS_DATA (formal
)->attr
.allocatable
))
2338 if (actual
->ts
.type
!= BT_CLASS
)
2341 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2342 formal
->name
, &actual
->where
);
2346 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2347 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2348 CLASS_DATA (formal
)->ts
.u
.derived
))
2351 gfc_error ("Actual argument to %qs at %L must have the same "
2352 "declared type", formal
->name
, &actual
->where
);
2357 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2358 is necessary also for F03, so retain error for both.
2359 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2360 compatible, no attempt has been made to channel to this one. */
2361 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2362 && (CLASS_DATA (formal
)->attr
.allocatable
2363 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2366 gfc_error ("Actual argument to %qs at %L must be unlimited "
2367 "polymorphic since the formal argument is a "
2368 "pointer or allocatable unlimited polymorphic "
2369 "entity [F2008: 12.5.2.5]", formal
->name
,
2374 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2377 gfc_error ("Actual argument to %qs at %L must be a coarray",
2378 formal
->name
, &actual
->where
);
2382 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2384 gfc_ref
*last
= NULL
;
2386 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2387 if (ref
->type
== REF_COMPONENT
)
2390 /* F2008, 12.5.2.6. */
2391 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2393 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2396 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2397 formal
->name
, &actual
->where
, formal
->as
->corank
,
2398 last
? last
->u
.c
.component
->as
->corank
2399 : actual
->symtree
->n
.sym
->as
->corank
);
2404 if (formal
->attr
.codimension
)
2406 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2407 /* F2018, 12.5.2.8. */
2408 if (formal
->attr
.dimension
2409 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2410 && actual_attr
.dimension
2411 && !gfc_is_simply_contiguous (actual
, true, true))
2414 gfc_error ("Actual argument to %qs at %L must be simply "
2415 "contiguous or an element of such an array",
2416 formal
->name
, &actual
->where
);
2420 /* F2008, C1303 and C1304. */
2421 if (formal
->attr
.intent
!= INTENT_INOUT
2422 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2423 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2424 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2425 || formal
->attr
.lock_comp
))
2429 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2430 "which is LOCK_TYPE or has a LOCK_TYPE component",
2431 formal
->name
, &actual
->where
);
2435 /* TS18508, C702/C703. */
2436 if (formal
->attr
.intent
!= INTENT_INOUT
2437 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2438 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2439 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2440 || formal
->attr
.event_comp
))
2444 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2445 "which is EVENT_TYPE or has a EVENT_TYPE component",
2446 formal
->name
, &actual
->where
);
2451 /* F2008, C1239/C1240. */
2452 if (actual
->expr_type
== EXPR_VARIABLE
2453 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2454 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2455 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2456 && actual
->rank
&& formal
->as
2457 && !gfc_is_simply_contiguous (actual
, true, false)
2458 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2459 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2460 || formal
->attr
.contiguous
))
2463 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2464 "assumed-rank array without CONTIGUOUS attribute - as actual"
2465 " argument at %L is not simply contiguous and both are "
2466 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2470 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2471 && actual_attr
.codimension
)
2473 if (formal
->attr
.intent
== INTENT_OUT
)
2476 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2477 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2481 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2482 gfc_warning (OPT_Wsurprising
,
2483 "Passing coarray at %L to allocatable, noncoarray dummy "
2484 "argument %qs, which is invalid if the allocation status"
2485 " is modified", &actual
->where
, formal
->name
);
2488 /* If the rank is the same or the formal argument has assumed-rank. */
2489 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2492 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2493 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2494 || formal
->as
->type
== AS_DEFERRED
)
2495 && actual
->expr_type
!= EXPR_NULL
;
2497 /* Skip rank checks for NO_ARG_CHECK. */
2498 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2501 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2502 if (rank_check
|| ranks_must_agree
2503 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2504 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2505 || (actual
->rank
== 0
2506 && ((formal
->ts
.type
== BT_CLASS
2507 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2508 || (formal
->ts
.type
!= BT_CLASS
2509 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2510 && actual
->expr_type
!= EXPR_NULL
)
2511 || (actual
->rank
== 0 && formal
->attr
.dimension
2512 && gfc_is_coindexed (actual
)))
2515 argument_rank_mismatch (formal
->name
, &actual
->where
,
2516 symbol_rank (formal
), actual
->rank
);
2519 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2522 /* At this point, we are considering a scalar passed to an array. This
2523 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2524 - if the actual argument is (a substring of) an element of a
2525 non-assumed-shape/non-pointer/non-polymorphic array; or
2526 - (F2003) if the actual argument is of type character of default/c_char
2529 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2530 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2532 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2534 if (ref
->type
== REF_COMPONENT
)
2535 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2536 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2537 && ref
->u
.ar
.dimen
> 0
2539 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2543 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2546 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2547 "at %L", formal
->name
, &actual
->where
);
2551 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2552 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2555 gfc_error ("Element of assumed-shaped or pointer "
2556 "array passed to array dummy argument %qs at %L",
2557 formal
->name
, &actual
->where
);
2561 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2562 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2564 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2567 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2568 "CHARACTER actual argument with array dummy argument "
2569 "%qs at %L", formal
->name
, &actual
->where
);
2573 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2575 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2576 "array dummy argument %qs at %L",
2577 formal
->name
, &actual
->where
);
2581 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2584 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2587 argument_rank_mismatch (formal
->name
, &actual
->where
,
2588 symbol_rank (formal
), actual
->rank
);
2596 /* Returns the storage size of a symbol (formal argument) or
2597 zero if it cannot be determined. */
2599 static unsigned long
2600 get_sym_storage_size (gfc_symbol
*sym
)
2603 unsigned long strlen
, elements
;
2605 if (sym
->ts
.type
== BT_CHARACTER
)
2607 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2608 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2609 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2616 if (symbol_rank (sym
) == 0)
2620 if (sym
->as
->type
!= AS_EXPLICIT
)
2622 for (i
= 0; i
< sym
->as
->rank
; i
++)
2624 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2625 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2628 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2629 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2632 return strlen
*elements
;
2636 /* Returns the storage size of an expression (actual argument) or
2637 zero if it cannot be determined. For an array element, it returns
2638 the remaining size as the element sequence consists of all storage
2639 units of the actual argument up to the end of the array. */
2641 static unsigned long
2642 get_expr_storage_size (gfc_expr
*e
)
2645 long int strlen
, elements
;
2646 long int substrlen
= 0;
2647 bool is_str_storage
= false;
2653 if (e
->ts
.type
== BT_CHARACTER
)
2655 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2656 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2657 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2658 else if (e
->expr_type
== EXPR_CONSTANT
2659 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2660 strlen
= e
->value
.character
.length
;
2665 strlen
= 1; /* Length per element. */
2667 if (e
->rank
== 0 && !e
->ref
)
2675 for (i
= 0; i
< e
->rank
; i
++)
2676 elements
*= mpz_get_si (e
->shape
[i
]);
2677 return elements
*strlen
;
2680 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2682 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2683 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2687 /* The string length is the substring length.
2688 Set now to full string length. */
2689 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2690 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2693 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2695 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2699 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2700 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2702 long int start
, end
, stride
;
2705 if (ref
->u
.ar
.stride
[i
])
2707 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2708 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2713 if (ref
->u
.ar
.start
[i
])
2715 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2716 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2720 else if (ref
->u
.ar
.as
->lower
[i
]
2721 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2722 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2726 if (ref
->u
.ar
.end
[i
])
2728 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2729 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2733 else if (ref
->u
.ar
.as
->upper
[i
]
2734 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2735 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2739 elements
*= (end
- start
)/stride
+ 1L;
2741 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2742 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2744 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2745 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2746 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2747 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2748 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2749 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2750 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2755 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2756 && e
->expr_type
== EXPR_VARIABLE
)
2758 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2759 || e
->symtree
->n
.sym
->attr
.pointer
)
2765 /* Determine the number of remaining elements in the element
2766 sequence for array element designators. */
2767 is_str_storage
= true;
2768 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2770 if (ref
->u
.ar
.start
[i
] == NULL
2771 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2772 || ref
->u
.ar
.as
->upper
[i
] == NULL
2773 || ref
->u
.ar
.as
->lower
[i
] == NULL
2774 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2775 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2780 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2781 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2783 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2784 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2787 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2788 && ref
->u
.c
.component
->attr
.proc_pointer
2789 && ref
->u
.c
.component
->attr
.dimension
)
2791 /* Array-valued procedure-pointer components. */
2792 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2793 for (i
= 0; i
< as
->rank
; i
++)
2795 if (!as
->upper
[i
] || !as
->lower
[i
]
2796 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2797 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2801 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2802 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2808 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2811 return elements
*strlen
;
2815 /* Given an expression, check whether it is an array section
2816 which has a vector subscript. */
2819 gfc_has_vector_subscript (gfc_expr
*e
)
2824 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2827 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2828 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2829 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2830 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2838 is_procptr_result (gfc_expr
*expr
)
2840 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2842 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2844 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2845 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2849 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2850 number of total candidates in CANDIDATES_LEN. */
2853 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
2855 size_t &candidates_len
)
2857 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
2858 vec_push (candidates
, candidates_len
, p
->sym
->name
);
2862 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2865 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
2867 char **candidates
= NULL
;
2868 size_t candidates_len
= 0;
2869 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
2870 return gfc_closest_fuzzy_match (arg
, candidates
);
2874 /* Given formal and actual argument lists, see if they are compatible.
2875 If they are compatible, the actual argument list is sorted to
2876 correspond with the formal list, and elements for missing optional
2877 arguments are inserted. If WHERE pointer is nonnull, then we issue
2878 errors when things don't match instead of just returning the status
2882 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2883 int ranks_must_agree
, int is_elemental
,
2884 bool in_statement_function
, locus
*where
)
2886 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2887 gfc_formal_arglist
*f
;
2889 unsigned long actual_size
, formal_size
;
2890 bool full_array
= false;
2891 gfc_array_ref
*actual_arr_ref
;
2895 if (actual
== NULL
&& formal
== NULL
)
2899 for (f
= formal
; f
; f
= f
->next
)
2902 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2904 for (i
= 0; i
< n
; i
++)
2911 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2913 if (a
->name
!= NULL
&& in_statement_function
)
2915 gfc_error ("Keyword argument %qs at %L is invalid in "
2916 "a statement function", a
->name
, &a
->expr
->where
);
2920 /* Look for keywords but ignore g77 extensions like %VAL. */
2921 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2924 for (f
= formal
; f
; f
= f
->next
, i
++)
2928 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2936 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
2938 gfc_error ("Keyword argument %qs at %L is not in "
2939 "the procedure; did you mean %qs?",
2940 a
->name
, &a
->expr
->where
, guessed
);
2942 gfc_error ("Keyword argument %qs at %L is not in "
2943 "the procedure", a
->name
, &a
->expr
->where
);
2948 if (new_arg
[i
] != NULL
)
2951 gfc_error ("Keyword argument %qs at %L is already associated "
2952 "with another actual argument", a
->name
,
2961 gfc_error ("More actual than formal arguments in procedure "
2962 "call at %L", where
);
2967 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2972 /* These errors have to be issued, otherwise an ICE can occur.
2975 gfc_error_now ("Missing alternate return specifier in subroutine "
2976 "call at %L", where
);
2980 if (a
->expr
== NULL
)
2983 gfc_error_now ("Unexpected alternate return specifier in "
2984 "subroutine call at %L", where
);
2988 /* Make sure that intrinsic vtables exist for calls to unlimited
2989 polymorphic formal arguments. */
2990 if (UNLIMITED_POLY (f
->sym
)
2991 && a
->expr
->ts
.type
!= BT_DERIVED
2992 && a
->expr
->ts
.type
!= BT_CLASS
2993 && a
->expr
->ts
.type
!= BT_ASSUMED
)
2994 gfc_find_vtab (&a
->expr
->ts
);
2996 if (a
->expr
->expr_type
== EXPR_NULL
2997 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2998 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2999 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
3000 || (f
->sym
->ts
.type
== BT_CLASS
3001 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3002 && (CLASS_DATA (f
->sym
)->attr
.allocatable
3003 || !f
->sym
->attr
.optional
3004 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
3007 && (!f
->sym
->attr
.optional
3008 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
3009 || (f
->sym
->ts
.type
== BT_CLASS
3010 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
3011 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
3012 where
, f
->sym
->name
);
3014 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3015 "dummy %qs", where
, f
->sym
->name
);
3020 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
3021 is_elemental
, where
))
3024 /* TS 29113, 6.3p2. */
3025 if (f
->sym
->ts
.type
== BT_ASSUMED
3026 && (a
->expr
->ts
.type
== BT_DERIVED
3027 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
3029 gfc_namespace
*f2k_derived
;
3031 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
3032 ? a
->expr
->ts
.u
.derived
->f2k_derived
3033 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
3036 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
3038 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3039 "derived type with type-bound or FINAL procedures",
3045 /* Special case for character arguments. For allocatable, pointer
3046 and assumed-shape dummies, the string length needs to match
3048 if (a
->expr
->ts
.type
== BT_CHARACTER
3049 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3050 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3051 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3052 && f
->sym
->ts
.u
.cl
->length
3053 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3054 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3055 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3056 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3057 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3059 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3060 gfc_warning (OPT_Wargument_mismatch
,
3061 "Character length mismatch (%ld/%ld) between actual "
3062 "argument and pointer or allocatable dummy argument "
3064 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3065 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3066 f
->sym
->name
, &a
->expr
->where
);
3068 gfc_warning (OPT_Wargument_mismatch
,
3069 "Character length mismatch (%ld/%ld) between actual "
3070 "argument and assumed-shape dummy argument %qs "
3072 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3073 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3074 f
->sym
->name
, &a
->expr
->where
);
3078 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3079 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3080 && a
->expr
->ts
.type
== BT_CHARACTER
)
3083 gfc_error ("Actual argument at %L to allocatable or "
3084 "pointer dummy argument %qs must have a deferred "
3085 "length type parameter if and only if the dummy has one",
3086 &a
->expr
->where
, f
->sym
->name
);
3090 if (f
->sym
->ts
.type
== BT_CLASS
)
3091 goto skip_size_check
;
3093 actual_size
= get_expr_storage_size (a
->expr
);
3094 formal_size
= get_sym_storage_size (f
->sym
);
3095 if (actual_size
!= 0 && actual_size
< formal_size
3096 && a
->expr
->ts
.type
!= BT_PROCEDURE
3097 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3099 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3100 gfc_warning (OPT_Wargument_mismatch
,
3101 "Character length of actual argument shorter "
3102 "than of dummy argument %qs (%lu/%lu) at %L",
3103 f
->sym
->name
, actual_size
, formal_size
,
3107 /* Emit a warning for -std=legacy and an error otherwise. */
3108 if (gfc_option
.warn_std
== 0)
3109 gfc_warning (OPT_Wargument_mismatch
,
3110 "Actual argument contains too few "
3111 "elements for dummy argument %qs (%lu/%lu) "
3112 "at %L", f
->sym
->name
, actual_size
,
3113 formal_size
, &a
->expr
->where
);
3115 gfc_error_now ("Actual argument contains too few "
3116 "elements for dummy argument %qs (%lu/%lu) "
3117 "at %L", f
->sym
->name
, actual_size
,
3118 formal_size
, &a
->expr
->where
);
3125 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3126 argument is provided for a procedure pointer formal argument. */
3127 if (f
->sym
->attr
.proc_pointer
3128 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3129 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3130 || gfc_is_proc_ptr_comp (a
->expr
)))
3131 || (a
->expr
->expr_type
== EXPR_FUNCTION
3132 && is_procptr_result (a
->expr
))))
3135 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3136 f
->sym
->name
, &a
->expr
->where
);
3140 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3141 provided for a procedure formal argument. */
3142 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3143 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3144 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3145 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3146 || gfc_is_proc_ptr_comp (a
->expr
)))
3147 || (a
->expr
->expr_type
== EXPR_FUNCTION
3148 && is_procptr_result (a
->expr
))))
3151 gfc_error ("Expected a procedure for argument %qs at %L",
3152 f
->sym
->name
, &a
->expr
->where
);
3156 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3157 && a
->expr
->expr_type
== EXPR_VARIABLE
3158 && a
->expr
->symtree
->n
.sym
->as
3159 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3160 && (a
->expr
->ref
== NULL
3161 || (a
->expr
->ref
->type
== REF_ARRAY
3162 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3165 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3166 " array at %L", f
->sym
->name
, where
);
3170 if (a
->expr
->expr_type
!= EXPR_NULL
3171 && compare_pointer (f
->sym
, a
->expr
) == 0)
3174 gfc_error ("Actual argument for %qs must be a pointer at %L",
3175 f
->sym
->name
, &a
->expr
->where
);
3179 if (a
->expr
->expr_type
!= EXPR_NULL
3180 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3181 && compare_pointer (f
->sym
, a
->expr
) == 2)
3184 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3185 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3190 /* Fortran 2008, C1242. */
3191 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3194 gfc_error ("Coindexed actual argument at %L to pointer "
3196 &a
->expr
->where
, f
->sym
->name
);
3200 /* Fortran 2008, 12.5.2.5 (no constraint). */
3201 if (a
->expr
->expr_type
== EXPR_VARIABLE
3202 && f
->sym
->attr
.intent
!= INTENT_IN
3203 && f
->sym
->attr
.allocatable
3204 && gfc_is_coindexed (a
->expr
))
3207 gfc_error ("Coindexed actual argument at %L to allocatable "
3208 "dummy %qs requires INTENT(IN)",
3209 &a
->expr
->where
, f
->sym
->name
);
3213 /* Fortran 2008, C1237. */
3214 if (a
->expr
->expr_type
== EXPR_VARIABLE
3215 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3216 && gfc_is_coindexed (a
->expr
)
3217 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3218 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3221 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3222 "%L requires that dummy %qs has neither "
3223 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3228 /* Fortran 2008, 12.5.2.4 (no constraint). */
3229 if (a
->expr
->expr_type
== EXPR_VARIABLE
3230 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3231 && gfc_is_coindexed (a
->expr
)
3232 && gfc_has_ultimate_allocatable (a
->expr
))
3235 gfc_error ("Coindexed actual argument at %L with allocatable "
3236 "ultimate component to dummy %qs requires either VALUE "
3237 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3241 if (f
->sym
->ts
.type
== BT_CLASS
3242 && CLASS_DATA (f
->sym
)->attr
.allocatable
3243 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3247 gfc_error ("Actual CLASS array argument for %qs must be a full "
3248 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3253 if (a
->expr
->expr_type
!= EXPR_NULL
3254 && !compare_allocatable (f
->sym
, a
->expr
))
3257 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3258 f
->sym
->name
, &a
->expr
->where
);
3262 /* Check intent = OUT/INOUT for definable actual argument. */
3263 if (!in_statement_function
3264 && (f
->sym
->attr
.intent
== INTENT_OUT
3265 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3267 const char* context
= (where
3268 ? _("actual argument to INTENT = OUT/INOUT")
3271 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3272 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3273 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3274 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3276 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3280 if ((f
->sym
->attr
.intent
== INTENT_OUT
3281 || f
->sym
->attr
.intent
== INTENT_INOUT
3282 || f
->sym
->attr
.volatile_
3283 || f
->sym
->attr
.asynchronous
)
3284 && gfc_has_vector_subscript (a
->expr
))
3287 gfc_error ("Array-section actual argument with vector "
3288 "subscripts at %L is incompatible with INTENT(OUT), "
3289 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3290 "of the dummy argument %qs",
3291 &a
->expr
->where
, f
->sym
->name
);
3295 /* C1232 (R1221) For an actual argument which is an array section or
3296 an assumed-shape array, the dummy argument shall be an assumed-
3297 shape array, if the dummy argument has the VOLATILE attribute. */
3299 if (f
->sym
->attr
.volatile_
3300 && a
->expr
->expr_type
== EXPR_VARIABLE
3301 && a
->expr
->symtree
->n
.sym
->as
3302 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3303 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3306 gfc_error ("Assumed-shape actual argument at %L is "
3307 "incompatible with the non-assumed-shape "
3308 "dummy argument %qs due to VOLATILE attribute",
3309 &a
->expr
->where
,f
->sym
->name
);
3313 /* Find the last array_ref. */
3314 actual_arr_ref
= NULL
;
3316 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3318 if (f
->sym
->attr
.volatile_
3319 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3320 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3323 gfc_error ("Array-section actual argument at %L is "
3324 "incompatible with the non-assumed-shape "
3325 "dummy argument %qs due to VOLATILE attribute",
3326 &a
->expr
->where
, f
->sym
->name
);
3330 /* C1233 (R1221) For an actual argument which is a pointer array, the
3331 dummy argument shall be an assumed-shape or pointer array, if the
3332 dummy argument has the VOLATILE attribute. */
3334 if (f
->sym
->attr
.volatile_
3335 && a
->expr
->expr_type
== EXPR_VARIABLE
3336 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3337 && a
->expr
->symtree
->n
.sym
->as
3339 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3340 || f
->sym
->attr
.pointer
)))
3343 gfc_error ("Pointer-array actual argument at %L requires "
3344 "an assumed-shape or pointer-array dummy "
3345 "argument %qs due to VOLATILE attribute",
3346 &a
->expr
->where
,f
->sym
->name
);
3357 /* Make sure missing actual arguments are optional. */
3359 for (f
= formal
; f
; f
= f
->next
, i
++)
3361 if (new_arg
[i
] != NULL
)
3366 gfc_error ("Missing alternate return spec in subroutine call "
3370 if (!f
->sym
->attr
.optional
3371 || (in_statement_function
&& f
->sym
->attr
.optional
))
3374 gfc_error ("Missing actual argument for argument %qs at %L",
3375 f
->sym
->name
, where
);
3380 /* The argument lists are compatible. We now relink a new actual
3381 argument list with null arguments in the right places. The head
3382 of the list remains the head. */
3383 for (i
= 0; i
< n
; i
++)
3384 if (new_arg
[i
] == NULL
)
3385 new_arg
[i
] = gfc_get_actual_arglist ();
3389 std::swap (*new_arg
[0], *actual
);
3390 std::swap (new_arg
[0], new_arg
[na
]);
3393 for (i
= 0; i
< n
- 1; i
++)
3394 new_arg
[i
]->next
= new_arg
[i
+ 1];
3396 new_arg
[i
]->next
= NULL
;
3398 if (*ap
== NULL
&& n
> 0)
3401 /* Note the types of omitted optional arguments. */
3402 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3403 if (a
->expr
== NULL
&& a
->label
== NULL
)
3404 a
->missing_arg_type
= f
->sym
->ts
.type
;
3412 gfc_formal_arglist
*f
;
3413 gfc_actual_arglist
*a
;
3417 /* qsort comparison function for argument pairs, with the following
3419 - p->a->expr == NULL
3420 - p->a->expr->expr_type != EXPR_VARIABLE
3421 - by gfc_symbol pointer value (larger first). */
3424 pair_cmp (const void *p1
, const void *p2
)
3426 const gfc_actual_arglist
*a1
, *a2
;
3428 /* *p1 and *p2 are elements of the to-be-sorted array. */
3429 a1
= ((const argpair
*) p1
)->a
;
3430 a2
= ((const argpair
*) p2
)->a
;
3439 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3441 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3445 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3447 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3449 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3453 /* Given two expressions from some actual arguments, test whether they
3454 refer to the same expression. The analysis is conservative.
3455 Returning false will produce no warning. */
3458 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3460 const gfc_ref
*r1
, *r2
;
3463 || e1
->expr_type
!= EXPR_VARIABLE
3464 || e2
->expr_type
!= EXPR_VARIABLE
3465 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3468 /* TODO: improve comparison, see expr.c:show_ref(). */
3469 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3471 if (r1
->type
!= r2
->type
)
3476 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3478 /* TODO: At the moment, consider only full arrays;
3479 we could do better. */
3480 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3485 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3493 gfc_internal_error ("compare_actual_expr(): Bad component code");
3502 /* Given formal and actual argument lists that correspond to one
3503 another, check that identical actual arguments aren't not
3504 associated with some incompatible INTENTs. */
3507 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3509 sym_intent f1_intent
, f2_intent
;
3510 gfc_formal_arglist
*f1
;
3511 gfc_actual_arglist
*a1
;
3517 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3519 if (f1
== NULL
&& a1
== NULL
)
3521 if (f1
== NULL
|| a1
== NULL
)
3522 gfc_internal_error ("check_some_aliasing(): List mismatch");
3527 p
= XALLOCAVEC (argpair
, n
);
3529 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3535 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3537 for (i
= 0; i
< n
; i
++)
3540 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3541 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3543 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3544 for (j
= i
+ 1; j
< n
; j
++)
3546 /* Expected order after the sort. */
3547 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3548 gfc_internal_error ("check_some_aliasing(): corrupted data");
3550 /* Are the expression the same? */
3551 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3553 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3554 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3555 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3556 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3558 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3559 "argument %qs and INTENT(%s) argument %qs at %L",
3560 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3561 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3562 &p
[i
].a
->expr
->where
);
3572 /* Given formal and actual argument lists that correspond to one
3573 another, check that they are compatible in the sense that intents
3574 are not mismatched. */
3577 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3579 sym_intent f_intent
;
3581 for (;; f
= f
->next
, a
= a
->next
)
3585 if (f
== NULL
&& a
== NULL
)
3587 if (f
== NULL
|| a
== NULL
)
3588 gfc_internal_error ("check_intents(): List mismatch");
3590 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3591 && a
->expr
->value
.function
.isym
3592 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3593 expr
= a
->expr
->value
.function
.actual
->expr
;
3597 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3600 f_intent
= f
->sym
->attr
.intent
;
3602 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3604 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3605 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3606 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3608 gfc_error ("Procedure argument at %L is local to a PURE "
3609 "procedure and has the POINTER attribute",
3615 /* Fortran 2008, C1283. */
3616 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3618 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3620 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3621 "is passed to an INTENT(%s) argument",
3622 &expr
->where
, gfc_intent_string (f_intent
));
3626 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3627 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3628 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3630 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3631 "is passed to a POINTER dummy argument",
3637 /* F2008, Section 12.5.2.4. */
3638 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3639 && gfc_is_coindexed (expr
))
3641 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3642 "polymorphic dummy argument %qs",
3643 &expr
->where
, f
->sym
->name
);
3652 /* Check how a procedure is used against its interface. If all goes
3653 well, the actual argument list will also end up being properly
3657 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3659 gfc_actual_arglist
*a
;
3660 gfc_formal_arglist
*dummy_args
;
3662 /* Warn about calls with an implicit interface. Special case
3663 for calling a ISO_C_BINDING because c_loc and c_funloc
3664 are pseudo-unknown. Additionally, warn about procedures not
3665 explicitly declared at all if requested. */
3666 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3668 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3671 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3673 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3674 "; did you mean %qs?",
3675 sym
->name
, where
, guessed
);
3677 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3681 if (warn_implicit_interface
)
3682 gfc_warning (OPT_Wimplicit_interface
,
3683 "Procedure %qs called with an implicit interface at %L",
3685 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3686 gfc_warning (OPT_Wimplicit_procedure
,
3687 "Procedure %qs called at %L is not explicitly declared",
3689 gfc_find_proc_namespace (sym
->ns
)->implicit_interface_calls
= 1;
3692 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3694 if (sym
->attr
.pointer
)
3696 gfc_error ("The pointer object %qs at %L must have an explicit "
3697 "function interface or be declared as array",
3702 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3704 gfc_error ("The allocatable object %qs at %L must have an explicit "
3705 "function interface or be declared as array",
3710 if (sym
->attr
.allocatable
)
3712 gfc_error ("Allocatable function %qs at %L must have an explicit "
3713 "function interface", sym
->name
, where
);
3717 for (a
= *ap
; a
; a
= a
->next
)
3719 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3720 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3722 gfc_error ("Keyword argument requires explicit interface "
3723 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3727 /* TS 29113, 6.2. */
3728 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3729 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3731 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3732 "interface", a
->expr
->symtree
->n
.sym
->name
,
3737 /* F2008, C1303 and C1304. */
3739 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3740 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3741 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3742 || gfc_expr_attr (a
->expr
).lock_comp
))
3744 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3745 "component at %L requires an explicit interface for "
3746 "procedure %qs", &a
->expr
->where
, sym
->name
);
3751 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3752 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3753 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3754 == ISOFORTRAN_EVENT_TYPE
)
3755 || gfc_expr_attr (a
->expr
).event_comp
))
3757 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3758 "component at %L requires an explicit interface for "
3759 "procedure %qs", &a
->expr
->where
, sym
->name
);
3763 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3764 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3766 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3770 /* TS 29113, C407b. */
3771 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3772 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3774 gfc_error ("Assumed-rank argument requires an explicit interface "
3775 "at %L", &a
->expr
->where
);
3783 dummy_args
= gfc_sym_get_dummy_args (sym
);
3785 /* For a statement function, check that types and type parameters of actual
3786 arguments and dummy arguments match. */
3787 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3788 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3791 if (!check_intents (dummy_args
, *ap
))
3795 check_some_aliasing (dummy_args
, *ap
);
3801 /* Check how a procedure pointer component is used against its interface.
3802 If all goes well, the actual argument list will also end up being properly
3803 sorted. Completely analogous to gfc_procedure_use. */
3806 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3808 /* Warn about calls with an implicit interface. Special case
3809 for calling a ISO_C_BINDING because c_loc and c_funloc
3810 are pseudo-unknown. */
3811 if (warn_implicit_interface
3812 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3813 && !comp
->attr
.is_iso_c
)
3814 gfc_warning (OPT_Wimplicit_interface
,
3815 "Procedure pointer component %qs called with an implicit "
3816 "interface at %L", comp
->name
, where
);
3818 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3820 gfc_actual_arglist
*a
;
3821 for (a
= *ap
; a
; a
= a
->next
)
3823 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3824 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3826 gfc_error ("Keyword argument requires explicit interface "
3827 "for procedure pointer component %qs at %L",
3828 comp
->name
, &a
->expr
->where
);
3836 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3837 comp
->attr
.elemental
, false, where
))
3840 check_intents (comp
->ts
.interface
->formal
, *ap
);
3842 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3846 /* Try if an actual argument list matches the formal list of a symbol,
3847 respecting the symbol's attributes like ELEMENTAL. This is used for
3848 GENERIC resolution. */
3851 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3853 gfc_formal_arglist
*dummy_args
;
3856 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3859 dummy_args
= gfc_sym_get_dummy_args (sym
);
3861 r
= !sym
->attr
.elemental
;
3862 if (compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
3864 check_intents (dummy_args
, *args
);
3866 check_some_aliasing (dummy_args
, *args
);
3874 /* Given an interface pointer and an actual argument list, search for
3875 a formal argument list that matches the actual. If found, returns
3876 a pointer to the symbol of the correct interface. Returns NULL if
3880 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3881 gfc_actual_arglist
**ap
)
3883 gfc_symbol
*elem_sym
= NULL
;
3884 gfc_symbol
*null_sym
= NULL
;
3885 locus null_expr_loc
;
3886 gfc_actual_arglist
*a
;
3887 bool has_null_arg
= false;
3889 for (a
= *ap
; a
; a
= a
->next
)
3890 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3891 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3893 has_null_arg
= true;
3894 null_expr_loc
= a
->expr
->where
;
3898 for (; intr
; intr
= intr
->next
)
3900 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3902 if (sub_flag
&& intr
->sym
->attr
.function
)
3904 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3907 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3909 if (has_null_arg
&& null_sym
)
3911 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3912 "between specific functions %s and %s",
3913 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3916 else if (has_null_arg
)
3918 null_sym
= intr
->sym
;
3922 /* Satisfy 12.4.4.1 such that an elemental match has lower
3923 weight than a non-elemental match. */
3924 if (intr
->sym
->attr
.elemental
)
3926 elem_sym
= intr
->sym
;
3936 return elem_sym
? elem_sym
: NULL
;
3940 /* Do a brute force recursive search for a symbol. */
3942 static gfc_symtree
*
3943 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3947 if (root
->n
.sym
== sym
)
3952 st
= find_symtree0 (root
->left
, sym
);
3953 if (root
->right
&& ! st
)
3954 st
= find_symtree0 (root
->right
, sym
);
3959 /* Find a symtree for a symbol. */
3962 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3967 /* First try to find it by name. */
3968 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3969 if (st
&& st
->n
.sym
== sym
)
3972 /* If it's been renamed, resort to a brute-force search. */
3973 /* TODO: avoid having to do this search. If the symbol doesn't exist
3974 in the symtree for the current namespace, it should probably be added. */
3975 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3977 st
= find_symtree0 (ns
->sym_root
, sym
);
3981 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3986 /* See if the arglist to an operator-call contains a derived-type argument
3987 with a matching type-bound operator. If so, return the matching specific
3988 procedure defined as operator-target as well as the base-object to use
3989 (which is the found derived-type argument with operator). The generic
3990 name, if any, is transmitted to the final expression via 'gname'. */
3992 static gfc_typebound_proc
*
3993 matching_typebound_op (gfc_expr
** tb_base
,
3994 gfc_actual_arglist
* args
,
3995 gfc_intrinsic_op op
, const char* uop
,
3996 const char ** gname
)
3998 gfc_actual_arglist
* base
;
4000 for (base
= args
; base
; base
= base
->next
)
4001 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
4003 gfc_typebound_proc
* tb
;
4004 gfc_symbol
* derived
;
4007 while (base
->expr
->expr_type
== EXPR_OP
4008 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4009 base
->expr
= base
->expr
->value
.op
.op1
;
4011 if (base
->expr
->ts
.type
== BT_CLASS
)
4013 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
4014 || !gfc_expr_attr (base
->expr
).class_ok
)
4016 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
4019 derived
= base
->expr
->ts
.u
.derived
;
4021 if (op
== INTRINSIC_USER
)
4023 gfc_symtree
* tb_uop
;
4026 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
4035 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
4038 /* This means we hit a PRIVATE operator which is use-associated and
4039 should thus not be seen. */
4043 /* Look through the super-type hierarchy for a matching specific
4045 for (; tb
; tb
= tb
->overridden
)
4049 gcc_assert (tb
->is_generic
);
4050 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4053 gfc_actual_arglist
* argcopy
;
4056 gcc_assert (g
->specific
);
4057 if (g
->specific
->error
)
4060 target
= g
->specific
->u
.specific
->n
.sym
;
4062 /* Check if this arglist matches the formal. */
4063 argcopy
= gfc_copy_actual_arglist (args
);
4064 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4065 gfc_free_actual_arglist (argcopy
);
4067 /* Return if we found a match. */
4070 *tb_base
= base
->expr
;
4071 *gname
= g
->specific_st
->name
;
4082 /* For the 'actual arglist' of an operator call and a specific typebound
4083 procedure that has been found the target of a type-bound operator, build the
4084 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4085 type-bound procedures rather than resolving type-bound operators 'directly'
4086 so that we can reuse the existing logic. */
4089 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4090 gfc_expr
* base
, gfc_typebound_proc
* target
,
4093 e
->expr_type
= EXPR_COMPCALL
;
4094 e
->value
.compcall
.tbp
= target
;
4095 e
->value
.compcall
.name
= gname
? gname
: "$op";
4096 e
->value
.compcall
.actual
= actual
;
4097 e
->value
.compcall
.base_object
= base
;
4098 e
->value
.compcall
.ignore_pass
= 1;
4099 e
->value
.compcall
.assign
= 0;
4100 if (e
->ts
.type
== BT_UNKNOWN
4101 && target
->function
)
4103 if (target
->is_generic
)
4104 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4106 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4111 /* This subroutine is called when an expression is being resolved.
4112 The expression node in question is either a user defined operator
4113 or an intrinsic operator with arguments that aren't compatible
4114 with the operator. This subroutine builds an actual argument list
4115 corresponding to the operands, then searches for a compatible
4116 interface. If one is found, the expression node is replaced with
4117 the appropriate function call. We use the 'match' enum to specify
4118 whether a replacement has been made or not, or if an error occurred. */
4121 gfc_extend_expr (gfc_expr
*e
)
4123 gfc_actual_arglist
*actual
;
4129 gfc_typebound_proc
* tbo
;
4134 actual
= gfc_get_actual_arglist ();
4135 actual
->expr
= e
->value
.op
.op1
;
4139 if (e
->value
.op
.op2
!= NULL
)
4141 actual
->next
= gfc_get_actual_arglist ();
4142 actual
->next
->expr
= e
->value
.op
.op2
;
4145 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4147 /* See if we find a matching type-bound operator. */
4148 if (i
== INTRINSIC_USER
)
4149 tbo
= matching_typebound_op (&tb_base
, actual
,
4150 i
, e
->value
.op
.uop
->name
, &gname
);
4154 #define CHECK_OS_COMPARISON(comp) \
4155 case INTRINSIC_##comp: \
4156 case INTRINSIC_##comp##_OS: \
4157 tbo = matching_typebound_op (&tb_base, actual, \
4158 INTRINSIC_##comp, NULL, &gname); \
4160 tbo = matching_typebound_op (&tb_base, actual, \
4161 INTRINSIC_##comp##_OS, NULL, &gname); \
4163 CHECK_OS_COMPARISON(EQ
)
4164 CHECK_OS_COMPARISON(NE
)
4165 CHECK_OS_COMPARISON(GT
)
4166 CHECK_OS_COMPARISON(GE
)
4167 CHECK_OS_COMPARISON(LT
)
4168 CHECK_OS_COMPARISON(LE
)
4169 #undef CHECK_OS_COMPARISON
4172 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4176 /* If there is a matching typebound-operator, replace the expression with
4177 a call to it and succeed. */
4180 gcc_assert (tb_base
);
4181 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4183 if (!gfc_resolve_expr (e
))
4189 if (i
== INTRINSIC_USER
)
4191 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4193 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4197 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4204 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4206 /* Due to the distinction between '==' and '.eq.' and friends, one has
4207 to check if either is defined. */
4210 #define CHECK_OS_COMPARISON(comp) \
4211 case INTRINSIC_##comp: \
4212 case INTRINSIC_##comp##_OS: \
4213 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4215 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4217 CHECK_OS_COMPARISON(EQ
)
4218 CHECK_OS_COMPARISON(NE
)
4219 CHECK_OS_COMPARISON(GT
)
4220 CHECK_OS_COMPARISON(GE
)
4221 CHECK_OS_COMPARISON(LT
)
4222 CHECK_OS_COMPARISON(LE
)
4223 #undef CHECK_OS_COMPARISON
4226 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4234 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4235 found rather than just taking the first one and not checking further. */
4239 /* Don't use gfc_free_actual_arglist(). */
4240 free (actual
->next
);
4245 /* Change the expression node to a function call. */
4246 e
->expr_type
= EXPR_FUNCTION
;
4247 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4248 e
->value
.function
.actual
= actual
;
4249 e
->value
.function
.esym
= NULL
;
4250 e
->value
.function
.isym
= NULL
;
4251 e
->value
.function
.name
= NULL
;
4252 e
->user_operator
= 1;
4254 if (!gfc_resolve_expr (e
))
4261 /* Tries to replace an assignment code node with a subroutine call to the
4262 subroutine associated with the assignment operator. Return true if the node
4263 was replaced. On false, no error is generated. */
4266 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4268 gfc_actual_arglist
*actual
;
4269 gfc_expr
*lhs
, *rhs
, *tb_base
;
4270 gfc_symbol
*sym
= NULL
;
4271 const char *gname
= NULL
;
4272 gfc_typebound_proc
* tbo
;
4277 /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
4278 if (c
->op
== EXEC_ASSIGN
4279 && c
->expr1
->expr_type
== EXPR_VARIABLE
4280 && c
->expr2
->expr_type
== EXPR_CONSTANT
&& c
->expr2
->ts
.type
== BT_BOZ
)
4283 /* Don't allow an intrinsic assignment to be replaced. */
4284 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4285 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4286 && (lhs
->ts
.type
== rhs
->ts
.type
4287 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4290 actual
= gfc_get_actual_arglist ();
4293 actual
->next
= gfc_get_actual_arglist ();
4294 actual
->next
->expr
= rhs
;
4296 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4298 /* See if we find a matching type-bound assignment. */
4299 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4304 /* Success: Replace the expression with a type-bound call. */
4305 gcc_assert (tb_base
);
4306 c
->expr1
= gfc_get_expr ();
4307 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4308 c
->expr1
->value
.compcall
.assign
= 1;
4309 c
->expr1
->where
= c
->loc
;
4311 c
->op
= EXEC_COMPCALL
;
4315 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4316 for (; ns
; ns
= ns
->parent
)
4318 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4325 /* Success: Replace the assignment with the call. */
4326 c
->op
= EXEC_ASSIGN_CALL
;
4327 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4330 c
->ext
.actual
= actual
;
4334 /* Failure: No assignment procedure found. */
4335 free (actual
->next
);
4341 /* Make sure that the interface just parsed is not already present in
4342 the given interface list. Ambiguity isn't checked yet since module
4343 procedures can be present without interfaces. */
4346 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4350 for (ip
= base
; ip
; ip
= ip
->next
)
4352 if (ip
->sym
== new_sym
)
4354 gfc_error ("Entity %qs at %L is already present in the interface",
4355 new_sym
->name
, &loc
);
4364 /* Add a symbol to the current interface. */
4367 gfc_add_interface (gfc_symbol
*new_sym
)
4369 gfc_interface
**head
, *intr
;
4373 switch (current_interface
.type
)
4375 case INTERFACE_NAMELESS
:
4376 case INTERFACE_ABSTRACT
:
4379 case INTERFACE_INTRINSIC_OP
:
4380 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4381 switch (current_interface
.op
)
4384 case INTRINSIC_EQ_OS
:
4385 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4387 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4388 new_sym
, gfc_current_locus
))
4393 case INTRINSIC_NE_OS
:
4394 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4396 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4397 new_sym
, gfc_current_locus
))
4402 case INTRINSIC_GT_OS
:
4403 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4404 new_sym
, gfc_current_locus
)
4405 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4406 new_sym
, gfc_current_locus
))
4411 case INTRINSIC_GE_OS
:
4412 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4413 new_sym
, gfc_current_locus
)
4414 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4415 new_sym
, gfc_current_locus
))
4420 case INTRINSIC_LT_OS
:
4421 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4422 new_sym
, gfc_current_locus
)
4423 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4424 new_sym
, gfc_current_locus
))
4429 case INTRINSIC_LE_OS
:
4430 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4431 new_sym
, gfc_current_locus
)
4432 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4433 new_sym
, gfc_current_locus
))
4438 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4439 new_sym
, gfc_current_locus
))
4443 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4446 case INTERFACE_GENERIC
:
4447 case INTERFACE_DTIO
:
4448 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4450 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4454 if (!gfc_check_new_interface (sym
->generic
,
4455 new_sym
, gfc_current_locus
))
4459 head
= ¤t_interface
.sym
->generic
;
4462 case INTERFACE_USER_OP
:
4463 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4464 new_sym
, gfc_current_locus
))
4467 head
= ¤t_interface
.uop
->op
;
4471 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4474 intr
= gfc_get_interface ();
4475 intr
->sym
= new_sym
;
4476 intr
->where
= gfc_current_locus
;
4486 gfc_current_interface_head (void)
4488 switch (current_interface
.type
)
4490 case INTERFACE_INTRINSIC_OP
:
4491 return current_interface
.ns
->op
[current_interface
.op
];
4493 case INTERFACE_GENERIC
:
4494 case INTERFACE_DTIO
:
4495 return current_interface
.sym
->generic
;
4497 case INTERFACE_USER_OP
:
4498 return current_interface
.uop
->op
;
4507 gfc_set_current_interface_head (gfc_interface
*i
)
4509 switch (current_interface
.type
)
4511 case INTERFACE_INTRINSIC_OP
:
4512 current_interface
.ns
->op
[current_interface
.op
] = i
;
4515 case INTERFACE_GENERIC
:
4516 case INTERFACE_DTIO
:
4517 current_interface
.sym
->generic
= i
;
4520 case INTERFACE_USER_OP
:
4521 current_interface
.uop
->op
= i
;
4530 /* Gets rid of a formal argument list. We do not free symbols.
4531 Symbols are freed when a namespace is freed. */
4534 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4536 gfc_formal_arglist
*q
;
4546 /* Check that it is ok for the type-bound procedure 'proc' to override the
4547 procedure 'old', cf. F08:4.5.7.3. */
4550 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4553 gfc_symbol
*proc_target
, *old_target
;
4554 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4555 gfc_formal_arglist
*proc_formal
, *old_formal
;
4559 /* This procedure should only be called for non-GENERIC proc. */
4560 gcc_assert (!proc
->n
.tb
->is_generic
);
4562 /* If the overwritten procedure is GENERIC, this is an error. */
4563 if (old
->n
.tb
->is_generic
)
4565 gfc_error ("Cannot overwrite GENERIC %qs at %L",
4566 old
->name
, &proc
->n
.tb
->where
);
4570 where
= proc
->n
.tb
->where
;
4571 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4572 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4574 /* Check that overridden binding is not NON_OVERRIDABLE. */
4575 if (old
->n
.tb
->non_overridable
)
4577 gfc_error ("%qs at %L overrides a procedure binding declared"
4578 " NON_OVERRIDABLE", proc
->name
, &where
);
4582 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4583 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4585 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4586 " non-DEFERRED binding", proc
->name
, &where
);
4590 /* If the overridden binding is PURE, the overriding must be, too. */
4591 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4593 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4594 proc
->name
, &where
);
4598 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4599 is not, the overriding must not be either. */
4600 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4602 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4603 " ELEMENTAL", proc
->name
, &where
);
4606 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4608 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4609 " be ELEMENTAL, either", proc
->name
, &where
);
4613 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4615 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4617 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4618 " SUBROUTINE", proc
->name
, &where
);
4622 /* If the overridden binding is a FUNCTION, the overriding must also be a
4623 FUNCTION and have the same characteristics. */
4624 if (old_target
->attr
.function
)
4626 if (!proc_target
->attr
.function
)
4628 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4629 " FUNCTION", proc
->name
, &where
);
4633 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4636 gfc_error ("Result mismatch for the overriding procedure "
4637 "%qs at %L: %s", proc
->name
, &where
, err
);
4642 /* If the overridden binding is PUBLIC, the overriding one must not be
4644 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4645 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4647 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4648 " PRIVATE", proc
->name
, &where
);
4652 /* Compare the formal argument lists of both procedures. This is also abused
4653 to find the position of the passed-object dummy arguments of both
4654 bindings as at least the overridden one might not yet be resolved and we
4655 need those positions in the check below. */
4656 proc_pass_arg
= old_pass_arg
= 0;
4657 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4659 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4662 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4663 old_formal
= gfc_sym_get_dummy_args (old_target
);
4664 for ( ; proc_formal
&& old_formal
;
4665 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4667 if (proc
->n
.tb
->pass_arg
4668 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4669 proc_pass_arg
= argpos
;
4670 if (old
->n
.tb
->pass_arg
4671 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4672 old_pass_arg
= argpos
;
4674 /* Check that the names correspond. */
4675 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4677 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4678 " to match the corresponding argument of the overridden"
4679 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4680 old_formal
->sym
->name
);
4684 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4685 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4686 check_type
, err
, sizeof(err
)))
4688 gfc_error_opt (OPT_Wargument_mismatch
,
4689 "Argument mismatch for the overriding procedure "
4690 "%qs at %L: %s", proc
->name
, &where
, err
);
4696 if (proc_formal
|| old_formal
)
4698 gfc_error ("%qs at %L must have the same number of formal arguments as"
4699 " the overridden procedure", proc
->name
, &where
);
4703 /* If the overridden binding is NOPASS, the overriding one must also be
4705 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4707 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4708 " NOPASS", proc
->name
, &where
);
4712 /* If the overridden binding is PASS(x), the overriding one must also be
4713 PASS and the passed-object dummy arguments must correspond. */
4714 if (!old
->n
.tb
->nopass
)
4716 if (proc
->n
.tb
->nopass
)
4718 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4719 " PASS", proc
->name
, &where
);
4723 if (proc_pass_arg
!= old_pass_arg
)
4725 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4726 " the same position as the passed-object dummy argument of"
4727 " the overridden procedure", proc
->name
, &where
);
4736 /* The following three functions check that the formal arguments
4737 of user defined derived type IO procedures are compliant with
4738 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4741 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4742 int kind
, int rank
, sym_intent intent
)
4744 if (fsym
->ts
.type
!= type
)
4746 gfc_error ("DTIO dummy argument at %L must be of type %s",
4747 &fsym
->declared_at
, gfc_basic_typename (type
));
4751 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4752 && fsym
->ts
.kind
!= kind
)
4753 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4754 &fsym
->declared_at
, kind
);
4758 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4759 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4760 gfc_error ("DTIO dummy argument at %L must be a scalar",
4761 &fsym
->declared_at
);
4763 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4764 gfc_error ("DTIO dummy argument at %L must be an "
4765 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4767 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4768 gfc_error ("DTIO character argument at %L must have assumed length",
4769 &fsym
->declared_at
);
4771 if (fsym
->attr
.intent
!= intent
)
4772 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4773 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4779 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4780 bool typebound
, bool formatted
, int code
)
4782 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4783 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4784 gfc_interface
*intr
;
4785 gfc_formal_arglist
*formal
;
4788 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4789 || ((dtio_codes
)code
== DTIO_RUF
);
4797 /* Typebound DTIO binding. */
4798 tb_io_proc
= tb_io_st
->n
.tb
;
4799 if (tb_io_proc
== NULL
)
4802 gcc_assert (tb_io_proc
->is_generic
);
4804 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4805 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4808 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4812 generic_proc
= tb_io_st
->n
.sym
;
4813 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4816 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4818 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4819 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4820 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4822 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4823 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4825 dtio_sub
= intr
->sym
;
4828 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4830 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4831 "procedure", &intr
->sym
->declared_at
);
4836 if (dtio_sub
== NULL
)
4840 gcc_assert (dtio_sub
);
4841 if (!dtio_sub
->attr
.subroutine
)
4842 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4843 dtio_sub
->name
, &dtio_sub
->declared_at
);
4846 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4849 if (arg_num
< (formatted
? 6 : 4))
4851 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4852 dtio_sub
->name
, &dtio_sub
->declared_at
);
4856 if (arg_num
> (formatted
? 6 : 4))
4858 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4859 dtio_sub
->name
, &dtio_sub
->declared_at
);
4864 /* Now go through the formal arglist. */
4866 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4868 if (!formatted
&& arg_num
== 3)
4874 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4875 "procedure", &dtio_sub
->declared_at
);
4882 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4883 BT_DERIVED
: BT_CLASS
;
4885 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4886 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4892 kind
= gfc_default_integer_kind
;
4894 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4897 case(3): /* IOTYPE */
4898 type
= BT_CHARACTER
;
4899 kind
= gfc_default_character_kind
;
4901 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4904 case(4): /* VLIST */
4906 kind
= gfc_default_integer_kind
;
4908 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4911 case(5): /* IOSTAT */
4913 kind
= gfc_default_integer_kind
;
4914 intent
= INTENT_OUT
;
4915 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4918 case(6): /* IOMSG */
4919 type
= BT_CHARACTER
;
4920 kind
= gfc_default_character_kind
;
4921 intent
= INTENT_INOUT
;
4922 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4929 derived
->attr
.has_dtio_procs
= 1;
4934 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4936 gfc_symtree
*tb_io_st
;
4941 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4944 /* Check typebound DTIO bindings. */
4945 for (code
= 0; code
< 4; code
++)
4947 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4948 || ((dtio_codes
)code
== DTIO_WF
);
4950 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4951 gfc_code2string (dtio_procs
, code
),
4952 true, &derived
->declared_at
);
4953 if (tb_io_st
!= NULL
)
4954 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4957 /* Check generic DTIO interfaces. */
4958 for (code
= 0; code
< 4; code
++)
4960 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4961 || ((dtio_codes
)code
== DTIO_WF
);
4963 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4964 gfc_code2string (dtio_procs
, code
));
4965 if (tb_io_st
!= NULL
)
4966 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4972 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4974 gfc_symtree
*tb_io_st
= NULL
;
4977 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4980 /* Try to find a typebound DTIO binding. */
4981 if (formatted
== true)
4984 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4985 gfc_code2string (dtio_procs
,
4988 &derived
->declared_at
);
4990 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4991 gfc_code2string (dtio_procs
,
4994 &derived
->declared_at
);
4999 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5000 gfc_code2string (dtio_procs
,
5003 &derived
->declared_at
);
5005 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5006 gfc_code2string (dtio_procs
,
5009 &derived
->declared_at
);
5016 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
5018 gfc_symtree
*tb_io_st
= NULL
;
5019 gfc_symbol
*dtio_sub
= NULL
;
5020 gfc_symbol
*extended
;
5021 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
5023 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
5025 if (tb_io_st
!= NULL
)
5027 const char *genname
;
5030 tb_io_proc
= tb_io_st
->n
.tb
;
5031 gcc_assert (tb_io_proc
!= NULL
);
5032 gcc_assert (tb_io_proc
->is_generic
);
5033 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
5035 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5036 gcc_assert (!specific_proc
->is_generic
);
5038 /* Go back and make sure that we have the right specific procedure.
5039 Here we most likely have a procedure from the parent type, which
5040 can be overridden in extensions. */
5041 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
5042 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
5043 true, &tb_io_proc
->where
);
5045 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
5047 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5052 /* If there is not a typebound binding, look for a generic
5054 for (extended
= derived
; extended
;
5055 extended
= gfc_get_derived_super_type (extended
))
5057 if (extended
== NULL
|| extended
->ns
== NULL
5058 || extended
->attr
.flavor
== FL_UNKNOWN
)
5061 if (formatted
== true)
5064 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5065 gfc_code2string (dtio_procs
,
5068 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5069 gfc_code2string (dtio_procs
,
5075 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5076 gfc_code2string (dtio_procs
,
5079 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5080 gfc_code2string (dtio_procs
,
5084 if (tb_io_st
!= NULL
5086 && tb_io_st
->n
.sym
->generic
)
5088 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5089 intr
&& intr
->sym
; intr
= intr
->next
)
5091 if (intr
->sym
->formal
)
5093 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5094 if ((fsym
->ts
.type
== BT_CLASS
5095 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5096 || (fsym
->ts
.type
== BT_DERIVED
5097 && fsym
->ts
.u
.derived
== extended
))
5099 dtio_sub
= intr
->sym
;
5108 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5109 gfc_find_derived_vtab (derived
);