1 /* Deal with interfaces.
2 Copyright (C) 2000-2021 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
|| 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_dummy_typename (&s1
->ts
),
1334 gfc_dummy_typename (&s2
->ts
));
1337 if (!compare_rank (s1
, s2
))
1339 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1340 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1346 if (s1
->attr
.intent
!= s2
->attr
.intent
&& !s1
->attr
.artificial
1347 && !s2
->attr
.artificial
)
1349 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1354 /* Check OPTIONAL attribute. */
1355 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1357 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1362 /* Check ALLOCATABLE attribute. */
1363 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1365 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1370 /* Check POINTER attribute. */
1371 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1373 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1378 /* Check TARGET attribute. */
1379 if (s1
->attr
.target
!= s2
->attr
.target
)
1381 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1386 /* Check ASYNCHRONOUS attribute. */
1387 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1389 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1394 /* Check CONTIGUOUS attribute. */
1395 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1397 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1402 /* Check VALUE attribute. */
1403 if (s1
->attr
.value
!= s2
->attr
.value
)
1405 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1410 /* Check VOLATILE attribute. */
1411 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1413 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1418 /* Check interface of dummy procedures. */
1419 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1422 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1425 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1426 "'%s': %s", s1
->name
, err
);
1431 /* Check string length. */
1432 if (s1
->ts
.type
== BT_CHARACTER
1433 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1434 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1436 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1437 s2
->ts
.u
.cl
->length
);
1443 snprintf (errmsg
, err_len
, "Character length mismatch "
1444 "in argument '%s'", s1
->name
);
1448 /* FIXME: Implement a warning for this case.
1449 gfc_warning (0, "Possible character length mismatch in argument %qs",
1457 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1458 "%i of gfc_dep_compare_expr", compval
);
1463 /* Check array shape. */
1464 if (s1
->as
&& s2
->as
)
1467 gfc_expr
*shape1
, *shape2
;
1469 /* Sometimes the ambiguity between deferred shape and assumed shape
1470 does not get resolved in module procedures, where the only explicit
1471 declaration of the dummy is in the interface. */
1472 if (s1
->ns
->proc_name
&& s1
->ns
->proc_name
->attr
.module_procedure
1473 && s1
->as
->type
== AS_ASSUMED_SHAPE
1474 && s2
->as
->type
== AS_DEFERRED
)
1476 s2
->as
->type
= AS_ASSUMED_SHAPE
;
1477 for (i
= 0; i
< s2
->as
->rank
; i
++)
1478 if (s1
->as
->lower
[i
] != NULL
)
1479 s2
->as
->lower
[i
] = gfc_copy_expr (s1
->as
->lower
[i
]);
1482 if (s1
->as
->type
!= s2
->as
->type
)
1484 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1489 if (s1
->as
->corank
!= s2
->as
->corank
)
1491 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1492 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1496 if (s1
->as
->type
== AS_EXPLICIT
)
1497 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1499 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1500 gfc_copy_expr (s1
->as
->lower
[i
]));
1501 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1502 gfc_copy_expr (s2
->as
->lower
[i
]));
1503 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1504 gfc_free_expr (shape1
);
1505 gfc_free_expr (shape2
);
1511 if (i
< s1
->as
->rank
)
1512 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1513 " argument '%s'", i
+ 1, s1
->name
);
1515 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1516 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1520 /* FIXME: Implement a warning for this case.
1521 gfc_warning (0, "Possible shape mismatch in argument %qs",
1529 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1530 "result %i of gfc_dep_compare_expr",
1541 /* Check if the characteristics of two function results match,
1545 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1546 char *errmsg
, int err_len
)
1548 gfc_symbol
*r1
, *r2
;
1550 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1551 r1
= s1
->ts
.interface
->result
;
1553 r1
= s1
->result
? s1
->result
: s1
;
1555 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1556 r2
= s2
->ts
.interface
->result
;
1558 r2
= s2
->result
? s2
->result
: s2
;
1560 if (r1
->ts
.type
== BT_UNKNOWN
)
1563 /* Check type and rank. */
1564 if (!compare_type_characteristics (r1
, r2
))
1566 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1567 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1570 if (!compare_rank (r1
, r2
))
1572 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1573 symbol_rank (r1
), symbol_rank (r2
));
1577 /* Check ALLOCATABLE attribute. */
1578 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1580 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1585 /* Check POINTER attribute. */
1586 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1588 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1593 /* Check CONTIGUOUS attribute. */
1594 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1596 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1601 /* Check PROCEDURE POINTER attribute. */
1602 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1604 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1609 /* Check string length. */
1610 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1612 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1614 snprintf (errmsg
, err_len
, "Character length mismatch "
1615 "in function result");
1619 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1621 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1622 r2
->ts
.u
.cl
->length
);
1628 snprintf (errmsg
, err_len
, "Character length mismatch "
1629 "in function result");
1633 /* FIXME: Implement a warning for this case.
1634 snprintf (errmsg, err_len, "Possible character length mismatch "
1635 "in function result");*/
1642 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1643 "result %i of gfc_dep_compare_expr", compval
);
1649 /* Check array shape. */
1650 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1653 gfc_expr
*shape1
, *shape2
;
1655 if (r1
->as
->type
!= r2
->as
->type
)
1657 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1661 if (r1
->as
->type
== AS_EXPLICIT
)
1662 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1664 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1665 gfc_copy_expr (r1
->as
->lower
[i
]));
1666 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1667 gfc_copy_expr (r2
->as
->lower
[i
]));
1668 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1669 gfc_free_expr (shape1
);
1670 gfc_free_expr (shape2
);
1676 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1677 "function result", i
+ 1);
1681 /* FIXME: Implement a warning for this case.
1682 gfc_warning (0, "Possible shape mismatch in return value");*/
1689 gfc_internal_error ("check_result_characteristics (2): "
1690 "Unexpected result %i of "
1691 "gfc_dep_compare_expr", compval
);
1701 /* 'Compare' two formal interfaces associated with a pair of symbols.
1702 We return true if there exists an actual argument list that
1703 would be ambiguous between the two interfaces, zero otherwise.
1704 'strict_flag' specifies whether all the characteristics are
1705 required to match, which is not the case for ambiguity checks.
1706 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1709 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1710 int generic_flag
, int strict_flag
,
1711 char *errmsg
, int err_len
,
1712 const char *p1
, const char *p2
,
1713 bool *bad_result_characteristics
)
1715 gfc_formal_arglist
*f1
, *f2
;
1717 gcc_assert (name2
!= NULL
);
1719 if (bad_result_characteristics
)
1720 *bad_result_characteristics
= false;
1722 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1723 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1724 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1727 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1731 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1734 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1738 /* Do strict checks on all characteristics
1739 (for dummy procedures and procedure pointer assignments). */
1740 if (!generic_flag
&& strict_flag
)
1742 if (s1
->attr
.function
&& s2
->attr
.function
)
1744 /* If both are functions, check result characteristics. */
1745 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1746 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1748 if (bad_result_characteristics
)
1749 *bad_result_characteristics
= true;
1754 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1756 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1759 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1761 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1766 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1767 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1770 f1
= gfc_sym_get_dummy_args (s1
);
1771 f2
= gfc_sym_get_dummy_args (s2
);
1773 /* Special case: No arguments. */
1774 if (f1
== NULL
&& f2
== NULL
)
1779 if (count_types_test (f1
, f2
, p1
, p2
)
1780 || count_types_test (f2
, f1
, p2
, p1
))
1783 /* Special case: alternate returns. If both f1->sym and f2->sym are
1784 NULL, then the leading formal arguments are alternate returns.
1785 The previous conditional should catch argument lists with
1786 different number of argument. */
1787 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1790 if (generic_correspondence (f1
, f2
, p1
, p2
)
1791 || generic_correspondence (f2
, f1
, p2
, p1
))
1795 /* Perform the abbreviated correspondence test for operators (the
1796 arguments cannot be optional and are always ordered correctly).
1797 This is also done when comparing interfaces for dummy procedures and in
1798 procedure pointer assignments. */
1800 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1802 /* Check existence. */
1803 if (f1
== NULL
|| f2
== NULL
)
1806 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1807 "arguments", name2
);
1813 /* Check all characteristics. */
1814 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1820 /* Operators: Only check type and rank of arguments. */
1821 if (!compare_type (f2
->sym
, f1
->sym
))
1824 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1825 "(%s/%s)", f1
->sym
->name
,
1826 gfc_typename (&f1
->sym
->ts
),
1827 gfc_typename (&f2
->sym
->ts
));
1830 if (!compare_rank (f2
->sym
, f1
->sym
))
1833 snprintf (errmsg
, err_len
, "Rank mismatch in argument "
1834 "'%s' (%i/%i)", f1
->sym
->name
,
1835 symbol_rank (f1
->sym
), symbol_rank (f2
->sym
));
1838 if ((gfc_option
.allow_std
& GFC_STD_F2008
)
1839 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1840 || compare_ptr_alloc(f2
->sym
, f1
->sym
)))
1843 snprintf (errmsg
, err_len
, "Mismatching POINTER/ALLOCATABLE "
1844 "attribute in argument '%s' ", f1
->sym
->name
);
1854 /* Given a pointer to an interface pointer, remove duplicate
1855 interfaces and make sure that all symbols are either functions
1856 or subroutines, and all of the same kind. Returns true if
1857 something goes wrong. */
1860 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1862 gfc_interface
*psave
, *q
, *qlast
;
1865 for (; p
; p
= p
->next
)
1867 /* Make sure all symbols in the interface have been defined as
1868 functions or subroutines. */
1869 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1870 || !p
->sym
->attr
.if_source
)
1871 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1874 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1876 if (p
->sym
->attr
.external
)
1878 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1879 "; did you mean %qs?",
1880 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1883 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1884 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1887 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1888 "subroutine; did you mean %qs?", p
->sym
->name
,
1889 interface_name
, &p
->sym
->declared_at
, guessed
);
1891 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1892 "subroutine", p
->sym
->name
, interface_name
,
1893 &p
->sym
->declared_at
);
1897 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1898 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1899 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1900 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1902 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1903 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1904 " or all FUNCTIONs", interface_name
,
1905 &p
->sym
->declared_at
);
1906 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1907 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1908 "generic name is also the name of a derived type",
1909 interface_name
, &p
->sym
->declared_at
);
1913 /* F2003, C1207. F2008, C1207. */
1914 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1915 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1916 "%qs in %s at %L", p
->sym
->name
,
1917 interface_name
, &p
->sym
->declared_at
))
1922 /* Remove duplicate interfaces in this interface list. */
1923 for (; p
; p
= p
->next
)
1927 for (q
= p
->next
; q
;)
1929 if (p
->sym
!= q
->sym
)
1936 /* Duplicate interface. */
1937 qlast
->next
= q
->next
;
1948 /* Check lists of interfaces to make sure that no two interfaces are
1949 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1952 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1953 int generic_flag
, const char *interface_name
,
1957 for (; p
; p
= p
->next
)
1958 for (q
= q0
; q
; q
= q
->next
)
1960 if (p
->sym
== q
->sym
)
1961 continue; /* Duplicates OK here. */
1963 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1966 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1967 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1968 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1969 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1972 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1973 "and %qs at %L", interface_name
,
1974 q
->sym
->name
, &q
->sym
->declared_at
,
1975 p
->sym
->name
, &p
->sym
->declared_at
);
1976 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1977 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1978 "and %qs at %L", interface_name
,
1979 q
->sym
->name
, &q
->sym
->declared_at
,
1980 p
->sym
->name
, &p
->sym
->declared_at
);
1982 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1983 "interfaces at %L", interface_name
, &p
->where
);
1991 /* Check the generic and operator interfaces of symbols to make sure
1992 that none of the interfaces conflict. The check has to be done
1993 after all of the symbols are actually loaded. */
1996 check_sym_interfaces (gfc_symbol
*sym
)
1998 /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */
1999 char interface_name
[2*GFC_MAX_SYMBOL_LEN
+2 + sizeof("generic interface ''")];
2002 if (sym
->ns
!= gfc_current_ns
)
2005 if (sym
->generic
!= NULL
)
2007 size_t len
= strlen (sym
->name
) + sizeof("generic interface ''");
2008 gcc_assert (len
< sizeof (interface_name
));
2009 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
2010 if (check_interface0 (sym
->generic
, interface_name
))
2013 for (p
= sym
->generic
; p
; p
= p
->next
)
2015 if (p
->sym
->attr
.mod_proc
2016 && !p
->sym
->attr
.module_procedure
2017 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
2018 || p
->sym
->attr
.procedure
))
2020 gfc_error ("%qs at %L is not a module procedure",
2021 p
->sym
->name
, &p
->where
);
2026 /* Originally, this test was applied to host interfaces too;
2027 this is incorrect since host associated symbols, from any
2028 source, cannot be ambiguous with local symbols. */
2029 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
2030 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
2036 check_uop_interfaces (gfc_user_op
*uop
)
2038 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
2042 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
2043 if (check_interface0 (uop
->op
, interface_name
))
2046 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2048 uop2
= gfc_find_uop (uop
->name
, ns
);
2052 check_interface1 (uop
->op
, uop2
->op
, 0,
2053 interface_name
, true);
2057 /* Given an intrinsic op, return an equivalent op if one exists,
2058 or INTRINSIC_NONE otherwise. */
2061 gfc_equivalent_op (gfc_intrinsic_op op
)
2066 return INTRINSIC_EQ_OS
;
2068 case INTRINSIC_EQ_OS
:
2069 return INTRINSIC_EQ
;
2072 return INTRINSIC_NE_OS
;
2074 case INTRINSIC_NE_OS
:
2075 return INTRINSIC_NE
;
2078 return INTRINSIC_GT_OS
;
2080 case INTRINSIC_GT_OS
:
2081 return INTRINSIC_GT
;
2084 return INTRINSIC_GE_OS
;
2086 case INTRINSIC_GE_OS
:
2087 return INTRINSIC_GE
;
2090 return INTRINSIC_LT_OS
;
2092 case INTRINSIC_LT_OS
:
2093 return INTRINSIC_LT
;
2096 return INTRINSIC_LE_OS
;
2098 case INTRINSIC_LE_OS
:
2099 return INTRINSIC_LE
;
2102 return INTRINSIC_NONE
;
2106 /* For the namespace, check generic, user operator and intrinsic
2107 operator interfaces for consistency and to remove duplicate
2108 interfaces. We traverse the whole namespace, counting on the fact
2109 that most symbols will not have generic or operator interfaces. */
2112 gfc_check_interfaces (gfc_namespace
*ns
)
2114 gfc_namespace
*old_ns
, *ns2
;
2115 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2118 old_ns
= gfc_current_ns
;
2119 gfc_current_ns
= ns
;
2121 gfc_traverse_ns (ns
, check_sym_interfaces
);
2123 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2125 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2127 if (i
== INTRINSIC_USER
)
2130 if (i
== INTRINSIC_ASSIGN
)
2131 strcpy (interface_name
, "intrinsic assignment operator");
2133 sprintf (interface_name
, "intrinsic '%s' operator",
2134 gfc_op2string ((gfc_intrinsic_op
) i
));
2136 if (check_interface0 (ns
->op
[i
], interface_name
))
2140 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2143 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2145 gfc_intrinsic_op other_op
;
2147 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2148 interface_name
, true))
2151 /* i should be gfc_intrinsic_op, but has to be int with this cast
2152 here for stupid C++ compatibility rules. */
2153 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2154 if (other_op
!= INTRINSIC_NONE
2155 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2156 0, interface_name
, true))
2162 gfc_current_ns
= old_ns
;
2166 /* Given a symbol of a formal argument list and an expression, if the
2167 formal argument is allocatable, check that the actual argument is
2168 allocatable. Returns true if compatible, zero if not compatible. */
2171 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2173 if (formal
->attr
.allocatable
2174 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2176 symbol_attribute attr
= gfc_expr_attr (actual
);
2177 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2179 else if (!attr
.allocatable
)
2187 /* Given a symbol of a formal argument list and an expression, if the
2188 formal argument is a pointer, see if the actual argument is a
2189 pointer. Returns nonzero if compatible, zero if not compatible. */
2192 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2194 symbol_attribute attr
;
2196 if (formal
->attr
.pointer
2197 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2198 && CLASS_DATA (formal
)->attr
.class_pointer
))
2200 attr
= gfc_expr_attr (actual
);
2202 /* Fortran 2008 allows non-pointer actual arguments. */
2203 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2214 /* Emit clear error messages for rank mismatch. */
2217 argument_rank_mismatch (const char *name
, locus
*where
,
2218 int rank1
, int rank2
, locus
*where_formal
)
2221 /* TS 29113, C407b. */
2222 if (where_formal
== NULL
)
2225 gfc_error ("The assumed-rank array at %L requires that the dummy "
2226 "argument %qs has assumed-rank", where
, name
);
2227 else if (rank1
== 0)
2228 gfc_error_opt (0, "Rank mismatch in argument %qs "
2229 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2230 else if (rank2
== 0)
2231 gfc_error_opt (0, "Rank mismatch in argument %qs "
2232 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2234 gfc_error_opt (0, "Rank mismatch in argument %qs "
2235 "at %L (rank-%d and rank-%d)", name
, where
, rank1
,
2240 gcc_assert (rank2
!= -1);
2242 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2243 "and actual argument at %L (scalar and rank-%d)",
2244 where
, where_formal
, rank2
);
2245 else if (rank2
== 0)
2246 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2247 "and actual argument at %L (rank-%d and scalar)",
2248 where
, where_formal
, rank1
);
2250 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2251 "and actual argument at %L (rank-%d and rank-%d)", where
,
2252 where_formal
, rank1
, rank2
);
2257 /* Under certain conditions, a scalar actual argument can be passed
2258 to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
2259 This function returns true for these conditions so that an error
2260 or warning for this can be suppressed later. Always return false
2261 for expressions with rank > 0. */
2264 maybe_dummy_array_arg (gfc_expr
*e
)
2268 bool array_pointer
= false;
2269 bool assumed_shape
= false;
2270 bool scalar_ref
= true;
2275 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
== 1)
2278 /* If this comes from a constructor, it has been an array element
2281 if (e
->expr_type
== EXPR_CONSTANT
)
2282 return e
->from_constructor
;
2284 if (e
->expr_type
!= EXPR_VARIABLE
)
2287 s
= e
->symtree
->n
.sym
;
2289 if (s
->attr
.dimension
)
2292 array_pointer
= s
->attr
.pointer
;
2295 if (s
->as
&& s
->as
->type
== AS_ASSUMED_SHAPE
)
2296 assumed_shape
= true;
2298 for (ref
=e
->ref
; ref
; ref
=ref
->next
)
2300 if (ref
->type
== REF_COMPONENT
)
2302 symbol_attribute
*attr
;
2303 attr
= &ref
->u
.c
.component
->attr
;
2304 if (attr
->dimension
)
2306 array_pointer
= attr
->pointer
;
2307 assumed_shape
= false;
2315 return !(scalar_ref
|| array_pointer
|| assumed_shape
);
2318 /* Given a symbol of a formal argument list and an expression, see if
2319 the two are compatible as arguments. Returns true if
2320 compatible, false if not compatible. */
2323 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2324 int ranks_must_agree
, int is_elemental
, locus
*where
)
2327 bool rank_check
, is_pointer
;
2331 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2332 procs c_f_pointer or c_f_procpointer, and we need to accept most
2333 pointers the user could give us. This should allow that. */
2334 if (formal
->ts
.type
== BT_VOID
)
2337 if (formal
->ts
.type
== BT_DERIVED
2338 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2339 && actual
->ts
.type
== BT_DERIVED
2340 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2343 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2344 /* Make sure the vtab symbol is present when
2345 the module variables are generated. */
2346 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2348 if (actual
->ts
.type
== BT_PROCEDURE
)
2350 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2352 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2355 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2359 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2360 sizeof(err
), NULL
, NULL
))
2363 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2364 " %s", formal
->name
, &actual
->where
, err
);
2368 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2370 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2371 &act_sym
->declared_at
);
2372 if (act_sym
->ts
.type
== BT_UNKNOWN
2373 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2376 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2377 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2378 &act_sym
->declared_at
);
2383 ppc
= gfc_get_proc_ptr_comp (actual
);
2384 if (ppc
&& ppc
->ts
.interface
)
2386 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2387 err
, sizeof(err
), NULL
, NULL
))
2390 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2391 " %s", formal
->name
, &actual
->where
, err
);
2397 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2398 && !gfc_is_simply_contiguous (actual
, true, false))
2401 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2402 "must be simply contiguous", formal
->name
, &actual
->where
);
2406 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2407 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2410 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2411 && actual
->ts
.type
!= BT_HOLLERITH
2412 && formal
->ts
.type
!= BT_ASSUMED
2413 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2414 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2415 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2416 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2417 CLASS_DATA (actual
)->ts
.u
.derived
)))
2421 if (formal
->attr
.artificial
)
2423 if (!flag_allow_argument_mismatch
|| !formal
->error
)
2424 gfc_error_opt (0, "Type mismatch between actual argument at %L "
2425 "and actual argument at %L (%s/%s).",
2427 &formal
->declared_at
,
2428 gfc_typename (actual
),
2429 gfc_dummy_typename (&formal
->ts
));
2434 gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
2435 "to %s", formal
->name
, where
, gfc_typename (actual
),
2436 gfc_dummy_typename (&formal
->ts
));
2441 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2444 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2445 "argument %qs is of assumed type", &actual
->where
,
2450 /* F2008, 12.5.2.5; IR F08/0073. */
2451 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2452 && actual
->expr_type
!= EXPR_NULL
2453 && ((CLASS_DATA (formal
)->attr
.class_pointer
2454 && formal
->attr
.intent
!= INTENT_IN
)
2455 || CLASS_DATA (formal
)->attr
.allocatable
))
2457 if (actual
->ts
.type
!= BT_CLASS
)
2460 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2461 formal
->name
, &actual
->where
);
2465 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2466 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2467 CLASS_DATA (formal
)->ts
.u
.derived
))
2470 gfc_error ("Actual argument to %qs at %L must have the same "
2471 "declared type", formal
->name
, &actual
->where
);
2476 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2477 is necessary also for F03, so retain error for both.
2478 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2479 compatible, no attempt has been made to channel to this one. */
2480 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2481 && (CLASS_DATA (formal
)->attr
.allocatable
2482 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2485 gfc_error ("Actual argument to %qs at %L must be unlimited "
2486 "polymorphic since the formal argument is a "
2487 "pointer or allocatable unlimited polymorphic "
2488 "entity [F2008: 12.5.2.5]", formal
->name
,
2493 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2496 gfc_error ("Actual argument to %qs at %L must be a coarray",
2497 formal
->name
, &actual
->where
);
2501 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2503 gfc_ref
*last
= NULL
;
2505 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2506 if (ref
->type
== REF_COMPONENT
)
2509 /* F2008, 12.5.2.6. */
2510 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2512 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2515 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2516 formal
->name
, &actual
->where
, formal
->as
->corank
,
2517 last
? last
->u
.c
.component
->as
->corank
2518 : actual
->symtree
->n
.sym
->as
->corank
);
2523 if (formal
->attr
.codimension
)
2525 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2526 /* F2018, 12.5.2.8. */
2527 if (formal
->attr
.dimension
2528 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2529 && actual_attr
.dimension
2530 && !gfc_is_simply_contiguous (actual
, true, true))
2533 gfc_error ("Actual argument to %qs at %L must be simply "
2534 "contiguous or an element of such an array",
2535 formal
->name
, &actual
->where
);
2539 /* F2008, C1303 and C1304. */
2540 if (formal
->attr
.intent
!= INTENT_INOUT
2541 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2542 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2543 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2544 || formal
->attr
.lock_comp
))
2548 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2549 "which is LOCK_TYPE or has a LOCK_TYPE component",
2550 formal
->name
, &actual
->where
);
2554 /* TS18508, C702/C703. */
2555 if (formal
->attr
.intent
!= INTENT_INOUT
2556 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2557 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2558 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2559 || formal
->attr
.event_comp
))
2563 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2564 "which is EVENT_TYPE or has a EVENT_TYPE component",
2565 formal
->name
, &actual
->where
);
2570 /* F2008, C1239/C1240. */
2571 if (actual
->expr_type
== EXPR_VARIABLE
2572 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2573 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2574 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2575 && actual
->rank
&& formal
->as
2576 && !gfc_is_simply_contiguous (actual
, true, false)
2577 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2578 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2579 || formal
->attr
.contiguous
))
2582 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2583 "assumed-rank array without CONTIGUOUS attribute - as actual"
2584 " argument at %L is not simply contiguous and both are "
2585 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2589 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2590 && actual_attr
.codimension
)
2592 if (formal
->attr
.intent
== INTENT_OUT
)
2595 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2596 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2600 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2601 gfc_warning (OPT_Wsurprising
,
2602 "Passing coarray at %L to allocatable, noncoarray dummy "
2603 "argument %qs, which is invalid if the allocation status"
2604 " is modified", &actual
->where
, formal
->name
);
2607 /* If the rank is the same or the formal argument has assumed-rank. */
2608 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2611 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2612 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2613 || formal
->as
->type
== AS_DEFERRED
)
2614 && actual
->expr_type
!= EXPR_NULL
;
2616 /* Skip rank checks for NO_ARG_CHECK. */
2617 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2620 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2621 if (rank_check
|| ranks_must_agree
2622 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2623 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2624 || (actual
->rank
== 0
2625 && ((formal
->ts
.type
== BT_CLASS
2626 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2627 || (formal
->ts
.type
!= BT_CLASS
2628 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2629 && actual
->expr_type
!= EXPR_NULL
)
2630 || (actual
->rank
== 0 && formal
->attr
.dimension
2631 && gfc_is_coindexed (actual
)))
2634 && (!formal
->attr
.artificial
|| (!formal
->maybe_array
2635 && !maybe_dummy_array_arg (actual
))))
2637 locus
*where_formal
;
2638 if (formal
->attr
.artificial
)
2639 where_formal
= &formal
->declared_at
;
2641 where_formal
= NULL
;
2643 argument_rank_mismatch (formal
->name
, &actual
->where
,
2644 symbol_rank (formal
), actual
->rank
,
2649 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2652 /* At this point, we are considering a scalar passed to an array. This
2653 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2654 - if the actual argument is (a substring of) an element of a
2655 non-assumed-shape/non-pointer/non-polymorphic array; or
2656 - (F2003) if the actual argument is of type character of default/c_char
2659 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2660 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2662 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2664 if (ref
->type
== REF_COMPONENT
)
2665 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2666 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2667 && ref
->u
.ar
.dimen
> 0
2669 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2673 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2676 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2677 "at %L", formal
->name
, &actual
->where
);
2681 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2682 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2686 if (formal
->attr
.artificial
)
2687 gfc_error ("Element of assumed-shape or pointer array "
2688 "as actual argument at %L cannot correspond to "
2689 "actual argument at %L",
2690 &actual
->where
, &formal
->declared_at
);
2692 gfc_error ("Element of assumed-shape or pointer "
2693 "array passed to array dummy argument %qs at %L",
2694 formal
->name
, &actual
->where
);
2699 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2700 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2702 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2705 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2706 "CHARACTER actual argument with array dummy argument "
2707 "%qs at %L", formal
->name
, &actual
->where
);
2711 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2713 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2714 "array dummy argument %qs at %L",
2715 formal
->name
, &actual
->where
);
2719 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2722 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2725 && (!formal
->attr
.artificial
|| (!formal
->maybe_array
2726 && !maybe_dummy_array_arg (actual
))))
2728 locus
*where_formal
;
2729 if (formal
->attr
.artificial
)
2730 where_formal
= &formal
->declared_at
;
2732 where_formal
= NULL
;
2734 argument_rank_mismatch (formal
->name
, &actual
->where
,
2735 symbol_rank (formal
), actual
->rank
,
2745 /* Returns the storage size of a symbol (formal argument) or
2746 zero if it cannot be determined. */
2748 static unsigned long
2749 get_sym_storage_size (gfc_symbol
*sym
)
2752 unsigned long strlen
, elements
;
2754 if (sym
->ts
.type
== BT_CHARACTER
)
2756 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2757 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2758 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2765 if (symbol_rank (sym
) == 0)
2769 if (sym
->as
->type
!= AS_EXPLICIT
)
2771 for (i
= 0; i
< sym
->as
->rank
; i
++)
2773 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2774 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2777 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2778 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2781 return strlen
*elements
;
2785 /* Returns the storage size of an expression (actual argument) or
2786 zero if it cannot be determined. For an array element, it returns
2787 the remaining size as the element sequence consists of all storage
2788 units of the actual argument up to the end of the array. */
2790 static unsigned long
2791 get_expr_storage_size (gfc_expr
*e
)
2794 long int strlen
, elements
;
2795 long int substrlen
= 0;
2796 bool is_str_storage
= false;
2802 if (e
->ts
.type
== BT_CHARACTER
)
2804 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2805 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2806 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2807 else if (e
->expr_type
== EXPR_CONSTANT
2808 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2809 strlen
= e
->value
.character
.length
;
2814 strlen
= 1; /* Length per element. */
2816 if (e
->rank
== 0 && !e
->ref
)
2824 for (i
= 0; i
< e
->rank
; i
++)
2825 elements
*= mpz_get_si (e
->shape
[i
]);
2826 return elements
*strlen
;
2829 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2831 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2832 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2836 /* The string length is the substring length.
2837 Set now to full string length. */
2838 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2839 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2842 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2844 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2848 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2849 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2851 long int start
, end
, stride
;
2854 if (ref
->u
.ar
.stride
[i
])
2856 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2857 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2862 if (ref
->u
.ar
.start
[i
])
2864 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2865 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2869 else if (ref
->u
.ar
.as
->lower
[i
]
2870 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2871 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2875 if (ref
->u
.ar
.end
[i
])
2877 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2878 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2882 else if (ref
->u
.ar
.as
->upper
[i
]
2883 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2884 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2888 elements
*= (end
- start
)/stride
+ 1L;
2890 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2891 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2893 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2894 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2895 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2896 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2897 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2898 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2899 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2904 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2905 && e
->expr_type
== EXPR_VARIABLE
)
2907 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2908 || e
->symtree
->n
.sym
->attr
.pointer
)
2914 /* Determine the number of remaining elements in the element
2915 sequence for array element designators. */
2916 is_str_storage
= true;
2917 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2919 if (ref
->u
.ar
.start
[i
] == NULL
2920 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2921 || ref
->u
.ar
.as
->upper
[i
] == NULL
2922 || ref
->u
.ar
.as
->lower
[i
] == NULL
2923 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2924 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2929 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2930 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2932 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2933 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2936 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2937 && ref
->u
.c
.component
->attr
.proc_pointer
2938 && ref
->u
.c
.component
->attr
.dimension
)
2940 /* Array-valued procedure-pointer components. */
2941 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2942 for (i
= 0; i
< as
->rank
; i
++)
2944 if (!as
->upper
[i
] || !as
->lower
[i
]
2945 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2946 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2950 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2951 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2957 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2960 return elements
*strlen
;
2964 /* Given an expression, check whether it is an array section
2965 which has a vector subscript. */
2968 gfc_has_vector_subscript (gfc_expr
*e
)
2973 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2976 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2977 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2978 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2979 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2987 is_procptr_result (gfc_expr
*expr
)
2989 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2991 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2993 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2994 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2998 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2999 number of total candidates in CANDIDATES_LEN. */
3002 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
3004 size_t &candidates_len
)
3006 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
3007 vec_push (candidates
, candidates_len
, p
->sym
->name
);
3011 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
3014 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
3016 char **candidates
= NULL
;
3017 size_t candidates_len
= 0;
3018 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
3019 return gfc_closest_fuzzy_match (arg
, candidates
);
3023 /* Given formal and actual argument lists, see if they are compatible.
3024 If they are compatible, the actual argument list is sorted to
3025 correspond with the formal list, and elements for missing optional
3026 arguments are inserted. If WHERE pointer is nonnull, then we issue
3027 errors when things don't match instead of just returning the status
3031 gfc_compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
3032 int ranks_must_agree
, int is_elemental
,
3033 bool in_statement_function
, locus
*where
)
3035 gfc_actual_arglist
**new_arg
, *a
, *actual
;
3036 gfc_formal_arglist
*f
;
3038 unsigned long actual_size
, formal_size
;
3039 bool full_array
= false;
3040 gfc_array_ref
*actual_arr_ref
;
3044 if (actual
== NULL
&& formal
== NULL
)
3048 for (f
= formal
; f
; f
= f
->next
)
3051 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
3053 for (i
= 0; i
< n
; i
++)
3060 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
3062 if (a
->name
!= NULL
&& in_statement_function
)
3064 gfc_error ("Keyword argument %qs at %L is invalid in "
3065 "a statement function", a
->name
, &a
->expr
->where
);
3069 /* Look for keywords but ignore g77 extensions like %VAL. */
3070 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3073 for (f
= formal
; f
; f
= f
->next
, i
++)
3077 if (strcmp (f
->sym
->name
, a
->name
) == 0)
3085 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
3087 gfc_error ("Keyword argument %qs at %L is not in "
3088 "the procedure; did you mean %qs?",
3089 a
->name
, &a
->expr
->where
, guessed
);
3091 gfc_error ("Keyword argument %qs at %L is not in "
3092 "the procedure", a
->name
, &a
->expr
->where
);
3097 if (new_arg
[i
] != NULL
)
3100 gfc_error ("Keyword argument %qs at %L is already associated "
3101 "with another actual argument", a
->name
,
3110 gfc_error ("More actual than formal arguments in procedure "
3111 "call at %L", where
);
3116 if (f
->sym
== NULL
&& a
->expr
== NULL
)
3121 /* These errors have to be issued, otherwise an ICE can occur.
3124 gfc_error_now ("Missing alternate return specifier in subroutine "
3125 "call at %L", where
);
3129 if (a
->expr
== NULL
)
3131 if (f
->sym
->attr
.optional
)
3136 gfc_error_now ("Unexpected alternate return specifier in "
3137 "subroutine call at %L", where
);
3142 /* Make sure that intrinsic vtables exist for calls to unlimited
3143 polymorphic formal arguments. */
3144 if (UNLIMITED_POLY (f
->sym
)
3145 && a
->expr
->ts
.type
!= BT_DERIVED
3146 && a
->expr
->ts
.type
!= BT_CLASS
3147 && a
->expr
->ts
.type
!= BT_ASSUMED
)
3148 gfc_find_vtab (&a
->expr
->ts
);
3150 if (a
->expr
->expr_type
== EXPR_NULL
3151 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
3152 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
3153 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
3154 || (f
->sym
->ts
.type
== BT_CLASS
3155 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3156 && (CLASS_DATA (f
->sym
)->attr
.allocatable
3157 || !f
->sym
->attr
.optional
3158 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
3161 && (!f
->sym
->attr
.optional
3162 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
3163 || (f
->sym
->ts
.type
== BT_CLASS
3164 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
3165 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
3166 where
, f
->sym
->name
);
3168 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3169 "dummy %qs", where
, f
->sym
->name
);
3174 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
3175 is_elemental
, where
))
3178 /* TS 29113, 6.3p2. */
3179 if (f
->sym
->ts
.type
== BT_ASSUMED
3180 && (a
->expr
->ts
.type
== BT_DERIVED
3181 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
3183 gfc_namespace
*f2k_derived
;
3185 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
3186 ? a
->expr
->ts
.u
.derived
->f2k_derived
3187 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
3190 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
3192 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3193 "derived type with type-bound or FINAL procedures",
3199 /* Special case for character arguments. For allocatable, pointer
3200 and assumed-shape dummies, the string length needs to match
3202 if (a
->expr
->ts
.type
== BT_CHARACTER
3203 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3204 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3205 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3206 && f
->sym
->ts
.u
.cl
->length
3207 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3208 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3209 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3210 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3211 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3213 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3214 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
3215 "argument and pointer or allocatable dummy argument "
3217 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3218 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3219 f
->sym
->name
, &a
->expr
->where
);
3221 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
3222 "argument and assumed-shape dummy argument %qs "
3224 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3225 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3226 f
->sym
->name
, &a
->expr
->where
);
3230 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3231 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3232 && a
->expr
->ts
.type
== BT_CHARACTER
)
3235 gfc_error ("Actual argument at %L to allocatable or "
3236 "pointer dummy argument %qs must have a deferred "
3237 "length type parameter if and only if the dummy has one",
3238 &a
->expr
->where
, f
->sym
->name
);
3242 if (f
->sym
->ts
.type
== BT_CLASS
)
3243 goto skip_size_check
;
3245 actual_size
= get_expr_storage_size (a
->expr
);
3246 formal_size
= get_sym_storage_size (f
->sym
);
3247 if (actual_size
!= 0 && actual_size
< formal_size
3248 && a
->expr
->ts
.type
!= BT_PROCEDURE
3249 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3251 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3252 gfc_warning (0, "Character length of actual argument shorter "
3253 "than of dummy argument %qs (%lu/%lu) at %L",
3254 f
->sym
->name
, actual_size
, formal_size
,
3258 /* Emit a warning for -std=legacy and an error otherwise. */
3259 if (gfc_option
.warn_std
== 0)
3260 gfc_warning (0, "Actual argument contains too few "
3261 "elements for dummy argument %qs (%lu/%lu) "
3262 "at %L", f
->sym
->name
, actual_size
,
3263 formal_size
, &a
->expr
->where
);
3265 gfc_error_now ("Actual argument contains too few "
3266 "elements for dummy argument %qs (%lu/%lu) "
3267 "at %L", f
->sym
->name
, actual_size
,
3268 formal_size
, &a
->expr
->where
);
3275 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3276 argument is provided for a procedure pointer formal argument. */
3277 if (f
->sym
->attr
.proc_pointer
3278 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3279 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3280 || gfc_is_proc_ptr_comp (a
->expr
)))
3281 || (a
->expr
->expr_type
== EXPR_FUNCTION
3282 && is_procptr_result (a
->expr
))))
3285 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3286 f
->sym
->name
, &a
->expr
->where
);
3290 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3291 provided for a procedure formal argument. */
3292 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3293 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3294 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3295 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3296 || gfc_is_proc_ptr_comp (a
->expr
)))
3297 || (a
->expr
->expr_type
== EXPR_FUNCTION
3298 && is_procptr_result (a
->expr
))))
3301 gfc_error ("Expected a procedure for argument %qs at %L",
3302 f
->sym
->name
, &a
->expr
->where
);
3307 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3308 || f
->sym
->as
->type
== AS_DEFERRED
3309 || (f
->sym
->as
->type
== AS_ASSUMED_RANK
&& f
->sym
->attr
.pointer
))
3310 && a
->expr
->expr_type
== EXPR_VARIABLE
3311 && a
->expr
->symtree
->n
.sym
->as
3312 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3313 && (a
->expr
->ref
== NULL
3314 || (a
->expr
->ref
->type
== REF_ARRAY
3315 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3318 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3319 " array at %L", f
->sym
->name
, where
);
3323 if (a
->expr
->expr_type
!= EXPR_NULL
3324 && compare_pointer (f
->sym
, a
->expr
) == 0)
3327 gfc_error ("Actual argument for %qs must be a pointer at %L",
3328 f
->sym
->name
, &a
->expr
->where
);
3332 if (a
->expr
->expr_type
!= EXPR_NULL
3333 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3334 && compare_pointer (f
->sym
, a
->expr
) == 2)
3337 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3338 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3343 /* Fortran 2008, C1242. */
3344 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3347 gfc_error ("Coindexed actual argument at %L to pointer "
3349 &a
->expr
->where
, f
->sym
->name
);
3353 /* Fortran 2008, 12.5.2.5 (no constraint). */
3354 if (a
->expr
->expr_type
== EXPR_VARIABLE
3355 && f
->sym
->attr
.intent
!= INTENT_IN
3356 && f
->sym
->attr
.allocatable
3357 && gfc_is_coindexed (a
->expr
))
3360 gfc_error ("Coindexed actual argument at %L to allocatable "
3361 "dummy %qs requires INTENT(IN)",
3362 &a
->expr
->where
, f
->sym
->name
);
3366 /* Fortran 2008, C1237. */
3367 if (a
->expr
->expr_type
== EXPR_VARIABLE
3368 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3369 && gfc_is_coindexed (a
->expr
)
3370 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3371 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3374 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3375 "%L requires that dummy %qs has neither "
3376 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3381 /* Fortran 2008, 12.5.2.4 (no constraint). */
3382 if (a
->expr
->expr_type
== EXPR_VARIABLE
3383 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3384 && gfc_is_coindexed (a
->expr
)
3385 && gfc_has_ultimate_allocatable (a
->expr
))
3388 gfc_error ("Coindexed actual argument at %L with allocatable "
3389 "ultimate component to dummy %qs requires either VALUE "
3390 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3394 if (f
->sym
->ts
.type
== BT_CLASS
3395 && CLASS_DATA (f
->sym
)->attr
.allocatable
3396 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3400 gfc_error ("Actual CLASS array argument for %qs must be a full "
3401 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3406 if (a
->expr
->expr_type
!= EXPR_NULL
3407 && !compare_allocatable (f
->sym
, a
->expr
))
3410 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3411 f
->sym
->name
, &a
->expr
->where
);
3415 /* Check intent = OUT/INOUT for definable actual argument. */
3416 if (!in_statement_function
3417 && (f
->sym
->attr
.intent
== INTENT_OUT
3418 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3420 const char* context
= (where
3421 ? _("actual argument to INTENT = OUT/INOUT")
3424 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3425 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3426 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3427 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3429 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3433 if ((f
->sym
->attr
.intent
== INTENT_OUT
3434 || f
->sym
->attr
.intent
== INTENT_INOUT
3435 || f
->sym
->attr
.volatile_
3436 || f
->sym
->attr
.asynchronous
)
3437 && gfc_has_vector_subscript (a
->expr
))
3440 gfc_error ("Array-section actual argument with vector "
3441 "subscripts at %L is incompatible with INTENT(OUT), "
3442 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3443 "of the dummy argument %qs",
3444 &a
->expr
->where
, f
->sym
->name
);
3448 /* C1232 (R1221) For an actual argument which is an array section or
3449 an assumed-shape array, the dummy argument shall be an assumed-
3450 shape array, if the dummy argument has the VOLATILE attribute. */
3452 if (f
->sym
->attr
.volatile_
3453 && a
->expr
->expr_type
== EXPR_VARIABLE
3454 && a
->expr
->symtree
->n
.sym
->as
3455 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3456 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3459 gfc_error ("Assumed-shape actual argument at %L is "
3460 "incompatible with the non-assumed-shape "
3461 "dummy argument %qs due to VOLATILE attribute",
3462 &a
->expr
->where
,f
->sym
->name
);
3466 /* Find the last array_ref. */
3467 actual_arr_ref
= NULL
;
3469 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3471 if (f
->sym
->attr
.volatile_
3472 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3473 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3476 gfc_error ("Array-section actual argument at %L is "
3477 "incompatible with the non-assumed-shape "
3478 "dummy argument %qs due to VOLATILE attribute",
3479 &a
->expr
->where
, f
->sym
->name
);
3483 /* C1233 (R1221) For an actual argument which is a pointer array, the
3484 dummy argument shall be an assumed-shape or pointer array, if the
3485 dummy argument has the VOLATILE attribute. */
3487 if (f
->sym
->attr
.volatile_
3488 && a
->expr
->expr_type
== EXPR_VARIABLE
3489 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3490 && a
->expr
->symtree
->n
.sym
->as
3492 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3493 || f
->sym
->attr
.pointer
)))
3496 gfc_error ("Pointer-array actual argument at %L requires "
3497 "an assumed-shape or pointer-array dummy "
3498 "argument %qs due to VOLATILE attribute",
3499 &a
->expr
->where
,f
->sym
->name
);
3510 /* Make sure missing actual arguments are optional. */
3512 for (f
= formal
; f
; f
= f
->next
, i
++)
3514 if (new_arg
[i
] != NULL
)
3519 gfc_error ("Missing alternate return spec in subroutine call "
3523 if (!f
->sym
->attr
.optional
3524 || (in_statement_function
&& f
->sym
->attr
.optional
))
3527 gfc_error ("Missing actual argument for argument %qs at %L",
3528 f
->sym
->name
, where
);
3533 /* We should have handled the cases where the formal arglist is null
3537 /* The argument lists are compatible. We now relink a new actual
3538 argument list with null arguments in the right places. The head
3539 of the list remains the head. */
3540 for (i
= 0; i
< n
; i
++)
3541 if (new_arg
[i
] == NULL
)
3542 new_arg
[i
] = gfc_get_actual_arglist ();
3546 std::swap (*new_arg
[0], *actual
);
3547 std::swap (new_arg
[0], new_arg
[na
]);
3550 for (i
= 0; i
< n
- 1; i
++)
3551 new_arg
[i
]->next
= new_arg
[i
+ 1];
3553 new_arg
[i
]->next
= NULL
;
3555 if (*ap
== NULL
&& n
> 0)
3558 /* Note the types of omitted optional arguments. */
3559 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3560 if (a
->expr
== NULL
&& a
->label
== NULL
)
3561 a
->missing_arg_type
= f
->sym
->ts
.type
;
3569 gfc_formal_arglist
*f
;
3570 gfc_actual_arglist
*a
;
3574 /* qsort comparison function for argument pairs, with the following
3576 - p->a->expr == NULL
3577 - p->a->expr->expr_type != EXPR_VARIABLE
3578 - by gfc_symbol pointer value (larger first). */
3581 pair_cmp (const void *p1
, const void *p2
)
3583 const gfc_actual_arglist
*a1
, *a2
;
3585 /* *p1 and *p2 are elements of the to-be-sorted array. */
3586 a1
= ((const argpair
*) p1
)->a
;
3587 a2
= ((const argpair
*) p2
)->a
;
3596 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3598 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3602 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3604 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3606 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3610 /* Given two expressions from some actual arguments, test whether they
3611 refer to the same expression. The analysis is conservative.
3612 Returning false will produce no warning. */
3615 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3617 const gfc_ref
*r1
, *r2
;
3620 || e1
->expr_type
!= EXPR_VARIABLE
3621 || e2
->expr_type
!= EXPR_VARIABLE
3622 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3625 /* TODO: improve comparison, see expr.c:show_ref(). */
3626 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3628 if (r1
->type
!= r2
->type
)
3633 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3635 /* TODO: At the moment, consider only full arrays;
3636 we could do better. */
3637 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3642 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3650 if (e1
->symtree
->n
.sym
->ts
.type
== BT_COMPLEX
3651 && e1
->ts
.type
== BT_REAL
&& e2
->ts
.type
== BT_REAL
3652 && r1
->u
.i
!= r2
->u
.i
)
3657 gfc_internal_error ("compare_actual_expr(): Bad component code");
3666 /* Given formal and actual argument lists that correspond to one
3667 another, check that identical actual arguments aren't not
3668 associated with some incompatible INTENTs. */
3671 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3673 sym_intent f1_intent
, f2_intent
;
3674 gfc_formal_arglist
*f1
;
3675 gfc_actual_arglist
*a1
;
3681 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3683 if (f1
== NULL
&& a1
== NULL
)
3685 if (f1
== NULL
|| a1
== NULL
)
3686 gfc_internal_error ("check_some_aliasing(): List mismatch");
3691 p
= XALLOCAVEC (argpair
, n
);
3693 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3699 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3701 for (i
= 0; i
< n
; i
++)
3704 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3705 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3707 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3708 for (j
= i
+ 1; j
< n
; j
++)
3710 /* Expected order after the sort. */
3711 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3712 gfc_internal_error ("check_some_aliasing(): corrupted data");
3714 /* Are the expression the same? */
3715 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3717 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3718 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3719 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3720 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3722 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3723 "argument %qs and INTENT(%s) argument %qs at %L",
3724 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3725 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3726 &p
[i
].a
->expr
->where
);
3736 /* Given formal and actual argument lists that correspond to one
3737 another, check that they are compatible in the sense that intents
3738 are not mismatched. */
3741 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3743 sym_intent f_intent
;
3745 for (;; f
= f
->next
, a
= a
->next
)
3749 if (f
== NULL
&& a
== NULL
)
3751 if (f
== NULL
|| a
== NULL
)
3752 gfc_internal_error ("check_intents(): List mismatch");
3754 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3755 && a
->expr
->value
.function
.isym
3756 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3757 expr
= a
->expr
->value
.function
.actual
->expr
;
3761 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3764 f_intent
= f
->sym
->attr
.intent
;
3766 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3768 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3769 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3770 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3772 gfc_error ("Procedure argument at %L is local to a PURE "
3773 "procedure and has the POINTER attribute",
3779 /* Fortran 2008, C1283. */
3780 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3782 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3784 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3785 "is passed to an INTENT(%s) argument",
3786 &expr
->where
, gfc_intent_string (f_intent
));
3790 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3791 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3792 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3794 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3795 "is passed to a POINTER dummy argument",
3801 /* F2008, Section 12.5.2.4. */
3802 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3803 && gfc_is_coindexed (expr
))
3805 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3806 "polymorphic dummy argument %qs",
3807 &expr
->where
, f
->sym
->name
);
3816 /* Check how a procedure is used against its interface. If all goes
3817 well, the actual argument list will also end up being properly
3821 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3823 gfc_actual_arglist
*a
;
3824 gfc_formal_arglist
*dummy_args
;
3825 bool implicit
= false;
3827 /* Warn about calls with an implicit interface. Special case
3828 for calling a ISO_C_BINDING because c_loc and c_funloc
3829 are pseudo-unknown. Additionally, warn about procedures not
3830 explicitly declared at all if requested. */
3831 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3833 bool has_implicit_none_export
= false;
3835 if (sym
->attr
.proc
== PROC_UNKNOWN
)
3836 for (gfc_namespace
*ns
= sym
->ns
; ns
; ns
= ns
->parent
)
3837 if (ns
->has_implicit_none_export
)
3839 has_implicit_none_export
= true;
3842 if (has_implicit_none_export
)
3845 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3847 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3848 "; did you mean %qs?",
3849 sym
->name
, where
, guessed
);
3851 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3855 if (warn_implicit_interface
)
3856 gfc_warning (OPT_Wimplicit_interface
,
3857 "Procedure %qs called with an implicit interface at %L",
3859 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3860 gfc_warning (OPT_Wimplicit_procedure
,
3861 "Procedure %qs called at %L is not explicitly declared",
3863 gfc_find_proc_namespace (sym
->ns
)->implicit_interface_calls
= 1;
3866 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3868 if (sym
->attr
.pointer
)
3870 gfc_error ("The pointer object %qs at %L must have an explicit "
3871 "function interface or be declared as array",
3876 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3878 gfc_error ("The allocatable object %qs at %L must have an explicit "
3879 "function interface or be declared as array",
3884 if (sym
->attr
.allocatable
)
3886 gfc_error ("Allocatable function %qs at %L must have an explicit "
3887 "function interface", sym
->name
, where
);
3891 for (a
= *ap
; a
; a
= a
->next
)
3893 if (a
->expr
&& a
->expr
->error
)
3896 /* F2018, 15.4.2.2 Explicit interface is required for a
3897 polymorphic dummy argument, so there is no way to
3898 legally have a class appear in an argument with an
3899 implicit interface. */
3901 if (implicit
&& a
->expr
&& a
->expr
->ts
.type
== BT_CLASS
)
3903 gfc_error ("Explicit interface required for polymorphic "
3904 "argument at %L",&a
->expr
->where
);
3909 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3910 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3912 gfc_error ("Keyword argument requires explicit interface "
3913 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3917 /* TS 29113, 6.2. */
3918 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3919 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3921 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3922 "interface", a
->expr
->symtree
->n
.sym
->name
,
3928 /* F2008, C1303 and C1304. */
3930 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3931 && a
->expr
->ts
.u
.derived
3932 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3933 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3934 || gfc_expr_attr (a
->expr
).lock_comp
))
3936 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3937 "component at %L requires an explicit interface for "
3938 "procedure %qs", &a
->expr
->where
, sym
->name
);
3944 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3945 && a
->expr
->ts
.u
.derived
3946 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3947 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3948 == ISOFORTRAN_EVENT_TYPE
)
3949 || gfc_expr_attr (a
->expr
).event_comp
))
3951 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3952 "component at %L requires an explicit interface for "
3953 "procedure %qs", &a
->expr
->where
, sym
->name
);
3958 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3959 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3961 gfc_error ("MOLD argument to NULL required at %L",
3967 /* TS 29113, C407b. */
3968 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3969 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3971 gfc_error ("Assumed-rank argument requires an explicit interface "
3972 "at %L", &a
->expr
->where
);
3981 dummy_args
= gfc_sym_get_dummy_args (sym
);
3983 /* For a statement function, check that types and type parameters of actual
3984 arguments and dummy arguments match. */
3985 if (!gfc_compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3986 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3989 if (!check_intents (dummy_args
, *ap
))
3993 check_some_aliasing (dummy_args
, *ap
);
3999 /* Check how a procedure pointer component is used against its interface.
4000 If all goes well, the actual argument list will also end up being properly
4001 sorted. Completely analogous to gfc_procedure_use. */
4004 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
4006 /* Warn about calls with an implicit interface. Special case
4007 for calling a ISO_C_BINDING because c_loc and c_funloc
4008 are pseudo-unknown. */
4009 if (warn_implicit_interface
4010 && comp
->attr
.if_source
== IFSRC_UNKNOWN
4011 && !comp
->attr
.is_iso_c
)
4012 gfc_warning (OPT_Wimplicit_interface
,
4013 "Procedure pointer component %qs called with an implicit "
4014 "interface at %L", comp
->name
, where
);
4016 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
4018 gfc_actual_arglist
*a
;
4019 for (a
= *ap
; a
; a
= a
->next
)
4021 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4022 if (a
->name
!= NULL
&& a
->name
[0] != '%')
4024 gfc_error ("Keyword argument requires explicit interface "
4025 "for procedure pointer component %qs at %L",
4026 comp
->name
, &a
->expr
->where
);
4034 if (!gfc_compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
4035 comp
->attr
.elemental
, false, where
))
4038 check_intents (comp
->ts
.interface
->formal
, *ap
);
4040 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
4044 /* Try if an actual argument list matches the formal list of a symbol,
4045 respecting the symbol's attributes like ELEMENTAL. This is used for
4046 GENERIC resolution. */
4049 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
4051 gfc_formal_arglist
*dummy_args
;
4054 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
4057 dummy_args
= gfc_sym_get_dummy_args (sym
);
4059 r
= !sym
->attr
.elemental
;
4060 if (gfc_compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
4062 check_intents (dummy_args
, *args
);
4064 check_some_aliasing (dummy_args
, *args
);
4072 /* Given an interface pointer and an actual argument list, search for
4073 a formal argument list that matches the actual. If found, returns
4074 a pointer to the symbol of the correct interface. Returns NULL if
4078 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
4079 gfc_actual_arglist
**ap
)
4081 gfc_symbol
*elem_sym
= NULL
;
4082 gfc_symbol
*null_sym
= NULL
;
4083 locus null_expr_loc
;
4084 gfc_actual_arglist
*a
;
4085 bool has_null_arg
= false;
4087 for (a
= *ap
; a
; a
= a
->next
)
4088 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
4089 && a
->expr
->ts
.type
== BT_UNKNOWN
)
4091 has_null_arg
= true;
4092 null_expr_loc
= a
->expr
->where
;
4096 for (; intr
; intr
= intr
->next
)
4098 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
4100 if (sub_flag
&& intr
->sym
->attr
.function
)
4102 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
4105 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
4107 if (has_null_arg
&& null_sym
)
4109 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
4110 "between specific functions %s and %s",
4111 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
4114 else if (has_null_arg
)
4116 null_sym
= intr
->sym
;
4120 /* Satisfy 12.4.4.1 such that an elemental match has lower
4121 weight than a non-elemental match. */
4122 if (intr
->sym
->attr
.elemental
)
4124 elem_sym
= intr
->sym
;
4134 return elem_sym
? elem_sym
: NULL
;
4138 /* Do a brute force recursive search for a symbol. */
4140 static gfc_symtree
*
4141 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
4145 if (root
->n
.sym
== sym
)
4150 st
= find_symtree0 (root
->left
, sym
);
4151 if (root
->right
&& ! st
)
4152 st
= find_symtree0 (root
->right
, sym
);
4157 /* Find a symtree for a symbol. */
4160 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
4165 /* First try to find it by name. */
4166 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
4167 if (st
&& st
->n
.sym
== sym
)
4170 /* If it's been renamed, resort to a brute-force search. */
4171 /* TODO: avoid having to do this search. If the symbol doesn't exist
4172 in the symtree for the current namespace, it should probably be added. */
4173 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4175 st
= find_symtree0 (ns
->sym_root
, sym
);
4179 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
4184 /* See if the arglist to an operator-call contains a derived-type argument
4185 with a matching type-bound operator. If so, return the matching specific
4186 procedure defined as operator-target as well as the base-object to use
4187 (which is the found derived-type argument with operator). The generic
4188 name, if any, is transmitted to the final expression via 'gname'. */
4190 static gfc_typebound_proc
*
4191 matching_typebound_op (gfc_expr
** tb_base
,
4192 gfc_actual_arglist
* args
,
4193 gfc_intrinsic_op op
, const char* uop
,
4194 const char ** gname
)
4196 gfc_actual_arglist
* base
;
4198 for (base
= args
; base
; base
= base
->next
)
4199 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
4201 gfc_typebound_proc
* tb
;
4202 gfc_symbol
* derived
;
4205 while (base
->expr
->expr_type
== EXPR_OP
4206 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4207 base
->expr
= base
->expr
->value
.op
.op1
;
4209 if (base
->expr
->ts
.type
== BT_CLASS
)
4211 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
4212 || !gfc_expr_attr (base
->expr
).class_ok
)
4214 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
4217 derived
= base
->expr
->ts
.u
.derived
;
4219 if (op
== INTRINSIC_USER
)
4221 gfc_symtree
* tb_uop
;
4224 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
4233 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
4236 /* This means we hit a PRIVATE operator which is use-associated and
4237 should thus not be seen. */
4241 /* Look through the super-type hierarchy for a matching specific
4243 for (; tb
; tb
= tb
->overridden
)
4247 gcc_assert (tb
->is_generic
);
4248 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4251 gfc_actual_arglist
* argcopy
;
4254 gcc_assert (g
->specific
);
4255 if (g
->specific
->error
)
4258 target
= g
->specific
->u
.specific
->n
.sym
;
4260 /* Check if this arglist matches the formal. */
4261 argcopy
= gfc_copy_actual_arglist (args
);
4262 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4263 gfc_free_actual_arglist (argcopy
);
4265 /* Return if we found a match. */
4268 *tb_base
= base
->expr
;
4269 *gname
= g
->specific_st
->name
;
4280 /* For the 'actual arglist' of an operator call and a specific typebound
4281 procedure that has been found the target of a type-bound operator, build the
4282 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4283 type-bound procedures rather than resolving type-bound operators 'directly'
4284 so that we can reuse the existing logic. */
4287 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4288 gfc_expr
* base
, gfc_typebound_proc
* target
,
4291 e
->expr_type
= EXPR_COMPCALL
;
4292 e
->value
.compcall
.tbp
= target
;
4293 e
->value
.compcall
.name
= gname
? gname
: "$op";
4294 e
->value
.compcall
.actual
= actual
;
4295 e
->value
.compcall
.base_object
= base
;
4296 e
->value
.compcall
.ignore_pass
= 1;
4297 e
->value
.compcall
.assign
= 0;
4298 if (e
->ts
.type
== BT_UNKNOWN
4299 && target
->function
)
4301 if (target
->is_generic
)
4302 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4304 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4309 /* This subroutine is called when an expression is being resolved.
4310 The expression node in question is either a user defined operator
4311 or an intrinsic operator with arguments that aren't compatible
4312 with the operator. This subroutine builds an actual argument list
4313 corresponding to the operands, then searches for a compatible
4314 interface. If one is found, the expression node is replaced with
4315 the appropriate function call. We use the 'match' enum to specify
4316 whether a replacement has been made or not, or if an error occurred. */
4319 gfc_extend_expr (gfc_expr
*e
)
4321 gfc_actual_arglist
*actual
;
4327 gfc_typebound_proc
* tbo
;
4332 actual
= gfc_get_actual_arglist ();
4333 actual
->expr
= e
->value
.op
.op1
;
4337 if (e
->value
.op
.op2
!= NULL
)
4339 actual
->next
= gfc_get_actual_arglist ();
4340 actual
->next
->expr
= e
->value
.op
.op2
;
4343 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4345 /* See if we find a matching type-bound operator. */
4346 if (i
== INTRINSIC_USER
)
4347 tbo
= matching_typebound_op (&tb_base
, actual
,
4348 i
, e
->value
.op
.uop
->name
, &gname
);
4352 #define CHECK_OS_COMPARISON(comp) \
4353 case INTRINSIC_##comp: \
4354 case INTRINSIC_##comp##_OS: \
4355 tbo = matching_typebound_op (&tb_base, actual, \
4356 INTRINSIC_##comp, NULL, &gname); \
4358 tbo = matching_typebound_op (&tb_base, actual, \
4359 INTRINSIC_##comp##_OS, NULL, &gname); \
4361 CHECK_OS_COMPARISON(EQ
)
4362 CHECK_OS_COMPARISON(NE
)
4363 CHECK_OS_COMPARISON(GT
)
4364 CHECK_OS_COMPARISON(GE
)
4365 CHECK_OS_COMPARISON(LT
)
4366 CHECK_OS_COMPARISON(LE
)
4367 #undef CHECK_OS_COMPARISON
4370 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4374 /* If there is a matching typebound-operator, replace the expression with
4375 a call to it and succeed. */
4378 gcc_assert (tb_base
);
4379 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4381 if (!gfc_resolve_expr (e
))
4387 if (i
== INTRINSIC_USER
)
4389 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4391 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4395 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4402 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4404 /* Due to the distinction between '==' and '.eq.' and friends, one has
4405 to check if either is defined. */
4408 #define CHECK_OS_COMPARISON(comp) \
4409 case INTRINSIC_##comp: \
4410 case INTRINSIC_##comp##_OS: \
4411 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4413 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4415 CHECK_OS_COMPARISON(EQ
)
4416 CHECK_OS_COMPARISON(NE
)
4417 CHECK_OS_COMPARISON(GT
)
4418 CHECK_OS_COMPARISON(GE
)
4419 CHECK_OS_COMPARISON(LT
)
4420 CHECK_OS_COMPARISON(LE
)
4421 #undef CHECK_OS_COMPARISON
4424 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4432 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4433 found rather than just taking the first one and not checking further. */
4437 /* Don't use gfc_free_actual_arglist(). */
4438 free (actual
->next
);
4443 /* Change the expression node to a function call. */
4444 e
->expr_type
= EXPR_FUNCTION
;
4445 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4446 e
->value
.function
.actual
= actual
;
4447 e
->value
.function
.esym
= NULL
;
4448 e
->value
.function
.isym
= NULL
;
4449 e
->value
.function
.name
= NULL
;
4450 e
->user_operator
= 1;
4452 if (!gfc_resolve_expr (e
))
4459 /* Tries to replace an assignment code node with a subroutine call to the
4460 subroutine associated with the assignment operator. Return true if the node
4461 was replaced. On false, no error is generated. */
4464 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4466 gfc_actual_arglist
*actual
;
4467 gfc_expr
*lhs
, *rhs
, *tb_base
;
4468 gfc_symbol
*sym
= NULL
;
4469 const char *gname
= NULL
;
4470 gfc_typebound_proc
* tbo
;
4475 /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
4476 if (c
->op
== EXEC_ASSIGN
4477 && c
->expr1
->expr_type
== EXPR_VARIABLE
4478 && c
->expr2
->expr_type
== EXPR_CONSTANT
&& c
->expr2
->ts
.type
== BT_BOZ
)
4481 /* Don't allow an intrinsic assignment to be replaced. */
4482 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4483 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4484 && (lhs
->ts
.type
== rhs
->ts
.type
4485 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4488 actual
= gfc_get_actual_arglist ();
4491 actual
->next
= gfc_get_actual_arglist ();
4492 actual
->next
->expr
= rhs
;
4494 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4496 /* See if we find a matching type-bound assignment. */
4497 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4502 /* Success: Replace the expression with a type-bound call. */
4503 gcc_assert (tb_base
);
4504 c
->expr1
= gfc_get_expr ();
4505 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4506 c
->expr1
->value
.compcall
.assign
= 1;
4507 c
->expr1
->where
= c
->loc
;
4509 c
->op
= EXEC_COMPCALL
;
4513 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4514 for (; ns
; ns
= ns
->parent
)
4516 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4523 /* Success: Replace the assignment with the call. */
4524 c
->op
= EXEC_ASSIGN_CALL
;
4525 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4528 c
->ext
.actual
= actual
;
4532 /* Failure: No assignment procedure found. */
4533 free (actual
->next
);
4539 /* Make sure that the interface just parsed is not already present in
4540 the given interface list. Ambiguity isn't checked yet since module
4541 procedures can be present without interfaces. */
4544 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4548 for (ip
= base
; ip
; ip
= ip
->next
)
4550 if (ip
->sym
== new_sym
)
4552 gfc_error ("Entity %qs at %L is already present in the interface",
4553 new_sym
->name
, &loc
);
4562 /* Add a symbol to the current interface. */
4565 gfc_add_interface (gfc_symbol
*new_sym
)
4567 gfc_interface
**head
, *intr
;
4571 switch (current_interface
.type
)
4573 case INTERFACE_NAMELESS
:
4574 case INTERFACE_ABSTRACT
:
4577 case INTERFACE_INTRINSIC_OP
:
4578 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4579 switch (current_interface
.op
)
4582 case INTRINSIC_EQ_OS
:
4583 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4585 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4586 new_sym
, gfc_current_locus
))
4591 case INTRINSIC_NE_OS
:
4592 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4594 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4595 new_sym
, gfc_current_locus
))
4600 case INTRINSIC_GT_OS
:
4601 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4602 new_sym
, gfc_current_locus
)
4603 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4604 new_sym
, gfc_current_locus
))
4609 case INTRINSIC_GE_OS
:
4610 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4611 new_sym
, gfc_current_locus
)
4612 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4613 new_sym
, gfc_current_locus
))
4618 case INTRINSIC_LT_OS
:
4619 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4620 new_sym
, gfc_current_locus
)
4621 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4622 new_sym
, gfc_current_locus
))
4627 case INTRINSIC_LE_OS
:
4628 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4629 new_sym
, gfc_current_locus
)
4630 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4631 new_sym
, gfc_current_locus
))
4636 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4637 new_sym
, gfc_current_locus
))
4641 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4644 case INTERFACE_GENERIC
:
4645 case INTERFACE_DTIO
:
4646 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4648 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4652 if (!gfc_check_new_interface (sym
->generic
,
4653 new_sym
, gfc_current_locus
))
4657 head
= ¤t_interface
.sym
->generic
;
4660 case INTERFACE_USER_OP
:
4661 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4662 new_sym
, gfc_current_locus
))
4665 head
= ¤t_interface
.uop
->op
;
4669 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4672 intr
= gfc_get_interface ();
4673 intr
->sym
= new_sym
;
4674 intr
->where
= gfc_current_locus
;
4684 gfc_current_interface_head (void)
4686 switch (current_interface
.type
)
4688 case INTERFACE_INTRINSIC_OP
:
4689 return current_interface
.ns
->op
[current_interface
.op
];
4691 case INTERFACE_GENERIC
:
4692 case INTERFACE_DTIO
:
4693 return current_interface
.sym
->generic
;
4695 case INTERFACE_USER_OP
:
4696 return current_interface
.uop
->op
;
4705 gfc_set_current_interface_head (gfc_interface
*i
)
4707 switch (current_interface
.type
)
4709 case INTERFACE_INTRINSIC_OP
:
4710 current_interface
.ns
->op
[current_interface
.op
] = i
;
4713 case INTERFACE_GENERIC
:
4714 case INTERFACE_DTIO
:
4715 current_interface
.sym
->generic
= i
;
4718 case INTERFACE_USER_OP
:
4719 current_interface
.uop
->op
= i
;
4728 /* Gets rid of a formal argument list. We do not free symbols.
4729 Symbols are freed when a namespace is freed. */
4732 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4734 gfc_formal_arglist
*q
;
4744 /* Check that it is ok for the type-bound procedure 'proc' to override the
4745 procedure 'old', cf. F08:4.5.7.3. */
4748 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4751 gfc_symbol
*proc_target
, *old_target
;
4752 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4753 gfc_formal_arglist
*proc_formal
, *old_formal
;
4757 /* This procedure should only be called for non-GENERIC proc. */
4758 gcc_assert (!proc
->n
.tb
->is_generic
);
4760 /* If the overwritten procedure is GENERIC, this is an error. */
4761 if (old
->n
.tb
->is_generic
)
4763 gfc_error ("Cannot overwrite GENERIC %qs at %L",
4764 old
->name
, &proc
->n
.tb
->where
);
4768 where
= proc
->n
.tb
->where
;
4769 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4770 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4772 /* Check that overridden binding is not NON_OVERRIDABLE. */
4773 if (old
->n
.tb
->non_overridable
)
4775 gfc_error ("%qs at %L overrides a procedure binding declared"
4776 " NON_OVERRIDABLE", proc
->name
, &where
);
4780 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4781 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4783 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4784 " non-DEFERRED binding", proc
->name
, &where
);
4788 /* If the overridden binding is PURE, the overriding must be, too. */
4789 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4791 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4792 proc
->name
, &where
);
4796 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4797 is not, the overriding must not be either. */
4798 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4800 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4801 " ELEMENTAL", proc
->name
, &where
);
4804 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4806 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4807 " be ELEMENTAL, either", proc
->name
, &where
);
4811 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4813 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4815 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4816 " SUBROUTINE", proc
->name
, &where
);
4820 /* If the overridden binding is a FUNCTION, the overriding must also be a
4821 FUNCTION and have the same characteristics. */
4822 if (old_target
->attr
.function
)
4824 if (!proc_target
->attr
.function
)
4826 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4827 " FUNCTION", proc
->name
, &where
);
4831 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4834 gfc_error ("Result mismatch for the overriding procedure "
4835 "%qs at %L: %s", proc
->name
, &where
, err
);
4840 /* If the overridden binding is PUBLIC, the overriding one must not be
4842 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4843 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4845 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4846 " PRIVATE", proc
->name
, &where
);
4850 /* Compare the formal argument lists of both procedures. This is also abused
4851 to find the position of the passed-object dummy arguments of both
4852 bindings as at least the overridden one might not yet be resolved and we
4853 need those positions in the check below. */
4854 proc_pass_arg
= old_pass_arg
= 0;
4855 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4857 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4860 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4861 old_formal
= gfc_sym_get_dummy_args (old_target
);
4862 for ( ; proc_formal
&& old_formal
;
4863 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4865 if (proc
->n
.tb
->pass_arg
4866 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4867 proc_pass_arg
= argpos
;
4868 if (old
->n
.tb
->pass_arg
4869 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4870 old_pass_arg
= argpos
;
4872 /* Check that the names correspond. */
4873 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4875 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4876 " to match the corresponding argument of the overridden"
4877 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4878 old_formal
->sym
->name
);
4882 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4883 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4884 check_type
, err
, sizeof(err
)))
4886 gfc_error_opt (0, "Argument mismatch for the overriding procedure "
4887 "%qs at %L: %s", proc
->name
, &where
, err
);
4893 if (proc_formal
|| old_formal
)
4895 gfc_error ("%qs at %L must have the same number of formal arguments as"
4896 " the overridden procedure", proc
->name
, &where
);
4900 /* If the overridden binding is NOPASS, the overriding one must also be
4902 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4904 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4905 " NOPASS", proc
->name
, &where
);
4909 /* If the overridden binding is PASS(x), the overriding one must also be
4910 PASS and the passed-object dummy arguments must correspond. */
4911 if (!old
->n
.tb
->nopass
)
4913 if (proc
->n
.tb
->nopass
)
4915 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4916 " PASS", proc
->name
, &where
);
4920 if (proc_pass_arg
!= old_pass_arg
)
4922 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4923 " the same position as the passed-object dummy argument of"
4924 " the overridden procedure", proc
->name
, &where
);
4933 /* The following three functions check that the formal arguments
4934 of user defined derived type IO procedures are compliant with
4935 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4938 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4939 int kind
, int rank
, sym_intent intent
)
4941 if (fsym
->ts
.type
!= type
)
4943 gfc_error ("DTIO dummy argument at %L must be of type %s",
4944 &fsym
->declared_at
, gfc_basic_typename (type
));
4948 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4949 && fsym
->ts
.kind
!= kind
)
4950 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4951 &fsym
->declared_at
, kind
);
4955 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4956 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4957 gfc_error ("DTIO dummy argument at %L must be a scalar",
4958 &fsym
->declared_at
);
4960 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4961 gfc_error ("DTIO dummy argument at %L must be an "
4962 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4964 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4965 gfc_error ("DTIO character argument at %L must have assumed length",
4966 &fsym
->declared_at
);
4968 if (fsym
->attr
.intent
!= intent
)
4969 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4970 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4976 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4977 bool typebound
, bool formatted
, int code
)
4979 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4980 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4981 gfc_interface
*intr
;
4982 gfc_formal_arglist
*formal
;
4985 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4986 || ((dtio_codes
)code
== DTIO_RUF
);
4994 /* Typebound DTIO binding. */
4995 tb_io_proc
= tb_io_st
->n
.tb
;
4996 if (tb_io_proc
== NULL
)
4999 gcc_assert (tb_io_proc
->is_generic
);
5001 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5002 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
5005 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5009 generic_proc
= tb_io_st
->n
.sym
;
5010 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
5013 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
5015 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
5016 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
5017 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
5019 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
5020 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
5022 dtio_sub
= intr
->sym
;
5025 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
5027 gfc_error ("Alternate return at %L is not permitted in a DTIO "
5028 "procedure", &intr
->sym
->declared_at
);
5033 if (dtio_sub
== NULL
)
5037 gcc_assert (dtio_sub
);
5038 if (!dtio_sub
->attr
.subroutine
)
5039 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
5040 dtio_sub
->name
, &dtio_sub
->declared_at
);
5042 if (!dtio_sub
->resolve_symbol_called
)
5043 gfc_resolve_formal_arglist (dtio_sub
);
5046 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
5049 if (arg_num
< (formatted
? 6 : 4))
5051 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
5052 dtio_sub
->name
, &dtio_sub
->declared_at
);
5056 if (arg_num
> (formatted
? 6 : 4))
5058 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
5059 dtio_sub
->name
, &dtio_sub
->declared_at
);
5063 /* Now go through the formal arglist. */
5065 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
5067 if (!formatted
&& arg_num
== 3)
5073 gfc_error ("Alternate return at %L is not permitted in a DTIO "
5074 "procedure", &dtio_sub
->declared_at
);
5081 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
5082 BT_DERIVED
: BT_CLASS
;
5084 intent
= read
? INTENT_INOUT
: INTENT_IN
;
5085 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5091 kind
= gfc_default_integer_kind
;
5093 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5096 case(3): /* IOTYPE */
5097 type
= BT_CHARACTER
;
5098 kind
= gfc_default_character_kind
;
5100 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5103 case(4): /* VLIST */
5105 kind
= gfc_default_integer_kind
;
5107 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5110 case(5): /* IOSTAT */
5112 kind
= gfc_default_integer_kind
;
5113 intent
= INTENT_OUT
;
5114 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5117 case(6): /* IOMSG */
5118 type
= BT_CHARACTER
;
5119 kind
= gfc_default_character_kind
;
5120 intent
= INTENT_INOUT
;
5121 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5128 derived
->attr
.has_dtio_procs
= 1;
5133 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
5135 gfc_symtree
*tb_io_st
;
5140 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
5143 /* Check typebound DTIO bindings. */
5144 for (code
= 0; code
< 4; code
++)
5146 formatted
= ((dtio_codes
)code
== DTIO_RF
)
5147 || ((dtio_codes
)code
== DTIO_WF
);
5149 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5150 gfc_code2string (dtio_procs
, code
),
5151 true, &derived
->declared_at
);
5152 if (tb_io_st
!= NULL
)
5153 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
5156 /* Check generic DTIO interfaces. */
5157 for (code
= 0; code
< 4; code
++)
5159 formatted
= ((dtio_codes
)code
== DTIO_RF
)
5160 || ((dtio_codes
)code
== DTIO_WF
);
5162 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
5163 gfc_code2string (dtio_procs
, code
));
5164 if (tb_io_st
!= NULL
)
5165 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
5171 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
5173 gfc_symtree
*tb_io_st
= NULL
;
5176 if (!derived
|| !derived
->resolve_symbol_called
5177 || derived
->attr
.flavor
!= FL_DERIVED
)
5180 /* Try to find a typebound DTIO binding. */
5181 if (formatted
== true)
5184 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5185 gfc_code2string (dtio_procs
,
5188 &derived
->declared_at
);
5190 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5191 gfc_code2string (dtio_procs
,
5194 &derived
->declared_at
);
5199 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5200 gfc_code2string (dtio_procs
,
5203 &derived
->declared_at
);
5205 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5206 gfc_code2string (dtio_procs
,
5209 &derived
->declared_at
);
5216 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
5218 gfc_symtree
*tb_io_st
= NULL
;
5219 gfc_symbol
*dtio_sub
= NULL
;
5220 gfc_symbol
*extended
;
5221 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
5223 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
5225 if (tb_io_st
!= NULL
)
5227 const char *genname
;
5230 tb_io_proc
= tb_io_st
->n
.tb
;
5231 gcc_assert (tb_io_proc
!= NULL
);
5232 gcc_assert (tb_io_proc
->is_generic
);
5233 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
5235 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5236 gcc_assert (!specific_proc
->is_generic
);
5238 /* Go back and make sure that we have the right specific procedure.
5239 Here we most likely have a procedure from the parent type, which
5240 can be overridden in extensions. */
5241 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
5242 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
5243 true, &tb_io_proc
->where
);
5245 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
5247 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5252 /* If there is not a typebound binding, look for a generic
5254 for (extended
= derived
; extended
;
5255 extended
= gfc_get_derived_super_type (extended
))
5257 if (extended
== NULL
|| extended
->ns
== NULL
5258 || extended
->attr
.flavor
== FL_UNKNOWN
)
5261 if (formatted
== true)
5264 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5265 gfc_code2string (dtio_procs
,
5268 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5269 gfc_code2string (dtio_procs
,
5275 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5276 gfc_code2string (dtio_procs
,
5279 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5280 gfc_code2string (dtio_procs
,
5284 if (tb_io_st
!= NULL
5286 && tb_io_st
->n
.sym
->generic
)
5288 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5289 intr
&& intr
->sym
; intr
= intr
->next
)
5291 if (intr
->sym
->formal
)
5293 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5294 if ((fsym
->ts
.type
== BT_CLASS
5295 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5296 || (fsym
->ts
.type
== BT_DERIVED
5297 && fsym
->ts
.u
.derived
== extended
))
5299 dtio_sub
= intr
->sym
;
5308 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5309 gfc_find_derived_vtab (derived
);
5314 /* Helper function - if we do not find an interface for a procedure,
5315 construct it from the actual arglist. Luckily, this can only
5316 happen for call by reference, so the information we actually need
5317 to provide (and which would be impossible to guess from the call
5318 itself) is not actually needed. */
5321 gfc_get_formal_from_actual_arglist (gfc_symbol
*sym
,
5322 gfc_actual_arglist
*actual_args
)
5324 gfc_actual_arglist
*a
;
5325 gfc_formal_arglist
**f
;
5327 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5331 for (a
= actual_args
; a
!= NULL
; a
= a
->next
)
5333 (*f
) = gfc_get_formal_arglist ();
5336 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "_formal_%d", var_num
++);
5337 gfc_get_symbol (name
, gfc_current_ns
, &s
);
5338 if (a
->expr
->ts
.type
== BT_PROCEDURE
)
5340 s
->attr
.flavor
= FL_PROCEDURE
;
5344 s
->ts
= a
->expr
->ts
;
5346 if (s
->ts
.type
== BT_CHARACTER
)
5347 s
->ts
.u
.cl
= gfc_get_charlen ();
5351 s
->ts
.is_c_interop
= 0;
5352 s
->attr
.flavor
= FL_VARIABLE
;
5353 if (a
->expr
->rank
> 0)
5355 s
->attr
.dimension
= 1;
5356 s
->as
= gfc_get_array_spec ();
5358 s
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
,
5359 &a
->expr
->where
, 1);
5360 s
->as
->upper
[0] = NULL
;
5361 s
->as
->type
= AS_ASSUMED_SIZE
;
5364 s
->maybe_array
= maybe_dummy_array_arg (a
->expr
);
5367 s
->attr
.artificial
= 1;
5368 s
->declared_at
= a
->expr
->where
;
5369 s
->attr
.intent
= INTENT_UNKNOWN
;
5372 else /* If a->expr is NULL, this is an alternate rerturn. */