1 /* Deal with interfaces.
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface
;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface
*intr
)
88 for (; intr
; intr
= next
)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op
)
104 case INTRINSIC_UPLUS
:
107 case INTRINSIC_UMINUS
:
108 op
= INTRINSIC_MINUS
;
118 /* Return the operator depending on the DTIO moded string. Note that
119 these are not operators in the normal sense and so have been placed
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
122 static gfc_intrinsic_op
125 if (strncmp (mode
, "formatted", 9) == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strncmp (mode
, "unformatted", 9) == 0)
128 return INTRINSIC_UNFORMATTED
;
129 return INTRINSIC_NONE
;
133 /* Match a generic specification. Depending on which type of
134 interface is found, the 'name' or 'op' pointers may be set.
135 This subroutine doesn't return MATCH_NO. */
138 gfc_match_generic_spec (interface_type
*type
,
140 gfc_intrinsic_op
*op
)
142 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
146 if (gfc_match (" assignment ( = )") == MATCH_YES
)
148 *type
= INTERFACE_INTRINSIC_OP
;
149 *op
= INTRINSIC_ASSIGN
;
153 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
155 *type
= INTERFACE_INTRINSIC_OP
;
156 *op
= fold_unary_intrinsic (i
);
160 *op
= INTRINSIC_NONE
;
161 if (gfc_match (" operator ( ") == MATCH_YES
)
163 m
= gfc_match_defined_op_name (buffer
, 1);
169 m
= gfc_match_char (')');
175 strcpy (name
, buffer
);
176 *type
= INTERFACE_USER_OP
;
180 if (gfc_match (" read ( %n )", buffer
) == MATCH_YES
)
182 *op
= dtio_op (buffer
);
183 if (*op
== INTRINSIC_FORMATTED
)
185 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RF
));
186 *type
= INTERFACE_DTIO
;
188 if (*op
== INTRINSIC_UNFORMATTED
)
190 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RUF
));
191 *type
= INTERFACE_DTIO
;
193 if (*op
!= INTRINSIC_NONE
)
197 if (gfc_match (" write ( %n )", buffer
) == MATCH_YES
)
199 *op
= dtio_op (buffer
);
200 if (*op
== INTRINSIC_FORMATTED
)
202 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WF
));
203 *type
= INTERFACE_DTIO
;
205 if (*op
== INTRINSIC_UNFORMATTED
)
207 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WUF
));
208 *type
= INTERFACE_DTIO
;
210 if (*op
!= INTRINSIC_NONE
)
214 if (gfc_match_name (buffer
) == MATCH_YES
)
216 strcpy (name
, buffer
);
217 *type
= INTERFACE_GENERIC
;
221 *type
= INTERFACE_NAMELESS
;
225 gfc_error ("Syntax error in generic specification at %C");
230 /* Match one of the five F95 forms of an interface statement. The
231 matcher for the abstract interface follows. */
234 gfc_match_interface (void)
236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
242 m
= gfc_match_space ();
244 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
247 /* If we're not looking at the end of the statement now, or if this
248 is not a nameless interface but we did not see a space, punt. */
249 if (gfc_match_eos () != MATCH_YES
250 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
257 current_interface
.type
= type
;
262 case INTERFACE_GENERIC
:
263 if (gfc_get_symbol (name
, NULL
, &sym
))
266 if (!sym
->attr
.generic
267 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
272 gfc_error ("Dummy procedure %qs at %C cannot have a "
273 "generic interface", sym
->name
);
277 current_interface
.sym
= gfc_new_block
= sym
;
280 case INTERFACE_USER_OP
:
281 current_interface
.uop
= gfc_get_uop (name
);
284 case INTERFACE_INTRINSIC_OP
:
285 current_interface
.op
= op
;
288 case INTERFACE_NAMELESS
:
289 case INTERFACE_ABSTRACT
:
298 /* Match a F2003 abstract interface. */
301 gfc_match_abstract_interface (void)
305 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
308 m
= gfc_match_eos ();
312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
316 current_interface
.type
= INTERFACE_ABSTRACT
;
322 /* Match the different sort of generic-specs that can be present after
323 the END INTERFACE itself. */
326 gfc_match_end_interface (void)
328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
333 m
= gfc_match_space ();
335 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
338 /* If we're not looking at the end of the statement now, or if this
339 is not a nameless interface but we did not see a space, punt. */
340 if (gfc_match_eos () != MATCH_YES
341 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
350 switch (current_interface
.type
)
352 case INTERFACE_NAMELESS
:
353 case INTERFACE_ABSTRACT
:
354 if (type
!= INTERFACE_NAMELESS
)
356 gfc_error ("Expected a nameless interface at %C");
362 case INTERFACE_INTRINSIC_OP
:
363 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
366 if (current_interface
.op
== INTRINSIC_ASSIGN
)
369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
374 s1
= gfc_op2string (current_interface
.op
);
375 s2
= gfc_op2string (op
);
377 /* The following if-statements are used to enforce C1202
379 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
380 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
382 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
383 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
385 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
386 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
388 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
389 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
391 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
392 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
394 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
395 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
399 if (strcmp(s2
, "none") == 0)
400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
404 "but got %qs", s1
, s2
);
411 case INTERFACE_USER_OP
:
412 /* Comparing the symbol node names is OK because only use-associated
413 symbols can be renamed. */
414 if (type
!= current_interface
.type
415 || strcmp (current_interface
.uop
->name
, name
) != 0)
417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
418 current_interface
.uop
->name
);
425 case INTERFACE_GENERIC
:
426 if (type
!= current_interface
.type
427 || strcmp (current_interface
.sym
->name
, name
) != 0)
429 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
430 current_interface
.sym
->name
);
441 /* Return whether the component was defined anonymously. */
444 is_anonymous_component (gfc_component
*cmp
)
446 /* Only UNION and MAP components are anonymous. In the case of a MAP,
447 the derived type symbol is FL_STRUCT and the component name looks like mM*.
448 This is the only case in which the second character of a component name is
450 return cmp
->ts
.type
== BT_UNION
451 || (cmp
->ts
.type
== BT_DERIVED
452 && cmp
->ts
.u
.derived
->attr
.flavor
== FL_STRUCT
453 && cmp
->name
[0] && cmp
->name
[1] && ISUPPER (cmp
->name
[1]));
457 /* Return whether the derived type was defined anonymously. */
460 is_anonymous_dt (gfc_symbol
*derived
)
462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
464 and the type name looks like XX*. This is the only case in which the
465 second character of a type name is uppercase. */
466 return derived
->attr
.flavor
== FL_UNION
467 || (derived
->attr
.flavor
== FL_STRUCT
468 && derived
->name
[0] && derived
->name
[1] && ISUPPER (derived
->name
[1]));
472 /* Compare components according to 4.4.2 of the Fortran standard. */
475 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
476 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
478 /* Compare names, but not for anonymous components such as UNION or MAP. */
479 if (!is_anonymous_component (cmp1
) && !is_anonymous_component (cmp2
)
480 && strcmp (cmp1
->name
, cmp2
->name
) != 0)
483 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
486 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
489 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
492 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
495 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
498 if (cmp1
->ts
.type
== BT_CHARACTER
&& cmp2
->ts
.type
== BT_CHARACTER
)
500 gfc_charlen
*l1
= cmp1
->ts
.u
.cl
;
501 gfc_charlen
*l2
= cmp2
->ts
.u
.cl
;
502 if (l1
&& l2
&& l1
->length
&& l2
->length
503 && l1
->length
->expr_type
== EXPR_CONSTANT
504 && l2
->length
->expr_type
== EXPR_CONSTANT
505 && gfc_dep_compare_expr (l1
->length
, l2
->length
) != 0)
509 /* Make sure that link lists do not put this function into an
510 endless recursive loop! */
511 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
512 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
513 && !gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
))
516 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
517 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
520 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
521 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
528 /* Compare two union types by comparing the components of their maps.
529 Because unions and maps are anonymous their types get special internal
530 names; therefore the usual derived type comparison will fail on them.
532 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
533 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
534 definitions' than 'equivalent structure'. */
537 compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
539 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
540 gfc_symbol
*map1_t
, *map2_t
;
542 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
545 if (un1
->attr
.zero_comp
!= un2
->attr
.zero_comp
)
548 if (un1
->attr
.zero_comp
)
551 map1
= un1
->components
;
552 map2
= un2
->components
;
554 /* In terms of 'equality' here we are worried about types which are
555 declared the same in two places, not types that represent equivalent
556 structures. (This is common because of FORTRAN's weird scoping rules.)
557 Though two unions with their maps in different orders could be equivalent,
558 we will say they are not equal for the purposes of this test; therefore
559 we compare the maps sequentially. */
562 map1_t
= map1
->ts
.u
.derived
;
563 map2_t
= map2
->ts
.u
.derived
;
565 cmp1
= map1_t
->components
;
566 cmp2
= map2_t
->components
;
568 /* Protect against null components. */
569 if (map1_t
->attr
.zero_comp
!= map2_t
->attr
.zero_comp
)
572 if (map1_t
->attr
.zero_comp
)
577 /* No two fields will ever point to the same map type unless they are
578 the same component, because one map field is created with its type
579 declaration. Therefore don't worry about recursion here. */
580 /* TODO: worry about recursion into parent types of the unions? */
581 if (!compare_components (cmp1
, cmp2
, map1_t
, map2_t
))
587 if (cmp1
== NULL
&& cmp2
== NULL
)
589 if (cmp1
== NULL
|| cmp2
== NULL
)
596 if (map1
== NULL
&& map2
== NULL
)
598 if (map1
== NULL
|| map2
== NULL
)
607 /* Compare two derived types using the criteria in 4.4.2 of the standard,
608 recursing through gfc_compare_types for the components. */
611 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
613 gfc_component
*cmp1
, *cmp2
;
615 if (derived1
== derived2
)
618 if (!derived1
|| !derived2
)
619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
621 /* Compare UNION types specially. */
622 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
623 return compare_union_types (derived1
, derived2
);
625 /* Special case for comparing derived types across namespaces. If the
626 true names and module names are the same and the module name is
627 nonnull, then they are equal. */
628 if (strcmp (derived1
->name
, derived2
->name
) == 0
629 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
630 && strcmp (derived1
->module
, derived2
->module
) == 0)
633 /* Compare type via the rules of the standard. Both types must have
634 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
635 because they can be anonymous; therefore two structures with different
636 names may be equal. */
638 /* Compare names, but not for anonymous types such as UNION or MAP. */
639 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
640 && strcmp (derived1
->name
, derived2
->name
) != 0)
643 if (derived1
->component_access
== ACCESS_PRIVATE
644 || derived2
->component_access
== ACCESS_PRIVATE
)
647 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
648 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
)
649 && !(derived1
->attr
.pdt_type
&& derived2
->attr
.pdt_type
))
652 /* Protect against null components. */
653 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
656 if (derived1
->attr
.zero_comp
)
659 cmp1
= derived1
->components
;
660 cmp2
= derived2
->components
;
662 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
663 simple test can speed things up. Otherwise, lots of things have to
667 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
673 if (cmp1
== NULL
&& cmp2
== NULL
)
675 if (cmp1
== NULL
|| cmp2
== NULL
)
683 /* Compare two typespecs, recursively if necessary. */
686 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
688 /* See if one of the typespecs is a BT_VOID, which is what is being used
689 to allow the funcs like c_f_pointer to accept any pointer type.
690 TODO: Possibly should narrow this to just the one typespec coming in
691 that is for the formal arg, but oh well. */
692 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
695 /* The _data component is not always present, therefore check for its
696 presence before assuming, that its derived->attr is available.
697 When the _data component is not present, then nevertheless the
698 unlimited_polymorphic flag may be set in the derived type's attr. */
699 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
700 && ((ts1
->u
.derived
->attr
.is_class
701 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
702 .unlimited_polymorphic
)
703 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
707 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
708 && ts2
->u
.derived
->components
709 && ((ts2
->u
.derived
->attr
.is_class
710 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
711 .unlimited_polymorphic
)
712 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
713 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
716 if (ts1
->type
!= ts2
->type
717 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
718 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
721 if (ts1
->type
== BT_UNION
)
722 return compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
724 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
725 return (ts1
->kind
== ts2
->kind
);
727 /* Compare derived types. */
728 return gfc_type_compatible (ts1
, ts2
);
733 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
735 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
738 /* TYPE and CLASS of the same declared type are type compatible,
739 but have different characteristics. */
740 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
741 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
744 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
749 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
751 gfc_array_spec
*as1
, *as2
;
754 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
757 as1
= (s1
->ts
.type
== BT_CLASS
758 && !s1
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
759 ? CLASS_DATA (s1
)->as
: s1
->as
;
760 as2
= (s2
->ts
.type
== BT_CLASS
761 && !s2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
762 ? CLASS_DATA (s2
)->as
: s2
->as
;
764 r1
= as1
? as1
->rank
: 0;
765 r2
= as2
? as2
->rank
: 0;
767 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
768 return false; /* Ranks differ. */
774 /* Given two symbols that are formal arguments, compare their ranks
775 and types. Returns true if they have the same rank and type,
779 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
781 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
785 /* Given two symbols that are formal arguments, compare their types
786 and rank and their formal interfaces if they are both dummy
787 procedures. Returns true if the same, false if different. */
790 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
792 if (s1
== NULL
|| s2
== NULL
)
798 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
799 return compare_type_rank (s1
, s2
);
801 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
804 /* At this point, both symbols are procedures. It can happen that
805 external procedures are compared, where one is identified by usage
806 to be a function or subroutine but the other is not. Check TKR
807 nonetheless for these cases. */
808 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
809 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
811 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
812 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
814 /* Now the type of procedure has been identified. */
815 if (s1
->attr
.function
!= s2
->attr
.function
816 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
819 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
822 /* Originally, gfortran recursed here to check the interfaces of passed
823 procedures. This is explicitly not required by the standard. */
828 /* Given a formal argument list and a keyword name, search the list
829 for that keyword. Returns the correct symbol node if found, NULL
833 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
835 for (; f
; f
= f
->next
)
836 if (strcmp (f
->sym
->name
, name
) == 0)
843 /******** Interface checking subroutines **********/
846 /* Given an operator interface and the operator, make sure that all
847 interfaces for that operator are legal. */
850 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
853 gfc_formal_arglist
*formal
;
856 int args
, r1
, r2
, k1
, k2
;
861 t1
= t2
= BT_UNKNOWN
;
862 i1
= i2
= INTENT_UNKNOWN
;
866 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
868 gfc_symbol
*fsym
= formal
->sym
;
871 gfc_error ("Alternate return cannot appear in operator "
872 "interface at %L", &sym
->declared_at
);
878 i1
= fsym
->attr
.intent
;
879 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
885 i2
= fsym
->attr
.intent
;
886 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
892 /* Only +, - and .not. can be unary operators.
893 .not. cannot be a binary operator. */
894 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
895 && op
!= INTRINSIC_MINUS
896 && op
!= INTRINSIC_NOT
)
897 || (args
== 2 && op
== INTRINSIC_NOT
))
899 if (op
== INTRINSIC_ASSIGN
)
900 gfc_error ("Assignment operator interface at %L must have "
901 "two arguments", &sym
->declared_at
);
903 gfc_error ("Operator interface at %L has the wrong number of arguments",
908 /* Check that intrinsics are mapped to functions, except
909 INTRINSIC_ASSIGN which should map to a subroutine. */
910 if (op
== INTRINSIC_ASSIGN
)
912 gfc_formal_arglist
*dummy_args
;
914 if (!sym
->attr
.subroutine
)
916 gfc_error ("Assignment operator interface at %L must be "
917 "a SUBROUTINE", &sym
->declared_at
);
921 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
922 - First argument an array with different rank than second,
923 - First argument is a scalar and second an array,
924 - Types and kinds do not conform, or
925 - First argument is of derived type. */
926 dummy_args
= gfc_sym_get_dummy_args (sym
);
927 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
928 && dummy_args
->sym
->ts
.type
!= BT_CLASS
929 && (r2
== 0 || r1
== r2
)
930 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
931 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
932 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
934 gfc_error ("Assignment operator interface at %L must not redefine "
935 "an INTRINSIC type assignment", &sym
->declared_at
);
941 if (!sym
->attr
.function
)
943 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
949 /* Check intents on operator interfaces. */
950 if (op
== INTRINSIC_ASSIGN
)
952 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
954 gfc_error ("First argument of defined assignment at %L must be "
955 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
961 gfc_error ("Second argument of defined assignment at %L must be "
962 "INTENT(IN)", &sym
->declared_at
);
970 gfc_error ("First argument of operator interface at %L must be "
971 "INTENT(IN)", &sym
->declared_at
);
975 if (args
== 2 && i2
!= INTENT_IN
)
977 gfc_error ("Second argument of operator interface at %L must be "
978 "INTENT(IN)", &sym
->declared_at
);
983 /* From now on, all we have to do is check that the operator definition
984 doesn't conflict with an intrinsic operator. The rules for this
985 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
986 as well as 12.3.2.1.1 of Fortran 2003:
988 "If the operator is an intrinsic-operator (R310), the number of
989 function arguments shall be consistent with the intrinsic uses of
990 that operator, and the types, kind type parameters, or ranks of the
991 dummy arguments shall differ from those required for the intrinsic
992 operation (7.1.2)." */
994 #define IS_NUMERIC_TYPE(t) \
995 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
997 /* Unary ops are easy, do them first. */
998 if (op
== INTRINSIC_NOT
)
1000 if (t1
== BT_LOGICAL
)
1006 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1008 if (IS_NUMERIC_TYPE (t1
))
1014 /* Character intrinsic operators have same character kind, thus
1015 operator definitions with operands of different character kinds
1017 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1020 /* Intrinsic operators always perform on arguments of same rank,
1021 so different ranks is also always safe. (rank == 0) is an exception
1022 to that, because all intrinsic operators are elemental. */
1023 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1029 case INTRINSIC_EQ_OS
:
1031 case INTRINSIC_NE_OS
:
1032 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1036 case INTRINSIC_PLUS
:
1037 case INTRINSIC_MINUS
:
1038 case INTRINSIC_TIMES
:
1039 case INTRINSIC_DIVIDE
:
1040 case INTRINSIC_POWER
:
1041 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1046 case INTRINSIC_GT_OS
:
1048 case INTRINSIC_GE_OS
:
1050 case INTRINSIC_LT_OS
:
1052 case INTRINSIC_LE_OS
:
1053 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1055 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1056 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1060 case INTRINSIC_CONCAT
:
1061 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1068 case INTRINSIC_NEQV
:
1069 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1079 #undef IS_NUMERIC_TYPE
1082 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1088 /* Given a pair of formal argument lists, we see if the two lists can
1089 be distinguished by counting the number of nonoptional arguments of
1090 a given type/rank in f1 and seeing if there are less then that
1091 number of those arguments in f2 (including optional arguments).
1092 Since this test is asymmetric, it has to be called twice to make it
1093 symmetric. Returns nonzero if the argument lists are incompatible
1094 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1095 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1098 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1099 const char *p1
, const char *p2
)
1101 int ac1
, ac2
, i
, j
, k
, n1
;
1102 gfc_formal_arglist
*f
;
1115 for (f
= f1
; f
; f
= f
->next
)
1118 /* Build an array of integers that gives the same integer to
1119 arguments of the same type/rank. */
1120 arg
= XCNEWVEC (arginfo
, n1
);
1123 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1126 arg
[i
].sym
= f
->sym
;
1131 for (i
= 0; i
< n1
; i
++)
1133 if (arg
[i
].flag
!= -1)
1136 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1137 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1138 continue; /* Skip OPTIONAL and PASS arguments. */
1142 /* Find other non-optional, non-pass arguments of the same type/rank. */
1143 for (j
= i
+ 1; j
< n1
; j
++)
1144 if ((arg
[j
].sym
== NULL
1145 || !(arg
[j
].sym
->attr
.optional
1146 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1147 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1148 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1154 /* Now loop over each distinct type found in f1. */
1158 for (i
= 0; i
< n1
; i
++)
1160 if (arg
[i
].flag
!= k
)
1164 for (j
= i
+ 1; j
< n1
; j
++)
1165 if (arg
[j
].flag
== k
)
1168 /* Count the number of non-pass arguments in f2 with that type,
1169 including those that are optional. */
1172 for (f
= f2
; f
; f
= f
->next
)
1173 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1174 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1175 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1193 /* Returns true if two dummy arguments are distinguishable due to their POINTER
1194 and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
1195 The function is asymmetric wrt to the arguments s1 and s2 and should always
1196 be called twice (with flipped arguments in the second call). */
1199 compare_ptr_alloc(gfc_symbol
*s1
, gfc_symbol
*s2
)
1201 /* Is s1 allocatable? */
1202 const bool a1
= s1
->ts
.type
== BT_CLASS
?
1203 CLASS_DATA(s1
)->attr
.allocatable
: s1
->attr
.allocatable
;
1204 /* Is s2 a pointer? */
1205 const bool p2
= s2
->ts
.type
== BT_CLASS
?
1206 CLASS_DATA(s2
)->attr
.class_pointer
: s2
->attr
.pointer
;
1207 return a1
&& p2
&& (s2
->attr
.intent
!= INTENT_IN
);
1211 /* Perform the correspondence test in rule (3) of F08:C1215.
1212 Returns zero if no argument is found that satisfies this rule,
1213 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1216 This test is also not symmetric in f1 and f2 and must be called
1217 twice. This test finds problems caused by sorting the actual
1218 argument list with keywords. For example:
1222 INTEGER :: A ; REAL :: B
1226 INTEGER :: A ; REAL :: B
1230 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1233 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1234 const char *p1
, const char *p2
)
1236 gfc_formal_arglist
*f2_save
, *g
;
1243 if (f1
->sym
->attr
.optional
)
1246 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1248 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1251 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1252 || compare_type_rank (f2
->sym
, f1
->sym
))
1253 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1254 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1255 || compare_ptr_alloc(f2
->sym
, f1
->sym
))))
1258 /* Now search for a disambiguating keyword argument starting at
1259 the current non-match. */
1260 for (g
= f1
; g
; g
= g
->next
)
1262 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1265 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1266 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1267 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1268 && (compare_ptr_alloc(sym
, g
->sym
)
1269 || compare_ptr_alloc(g
->sym
, sym
))))
1285 symbol_rank (gfc_symbol
*sym
)
1287 gfc_array_spec
*as
= NULL
;
1289 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1290 as
= CLASS_DATA (sym
)->as
;
1294 return as
? as
->rank
: 0;
1298 /* Check if the characteristics of two dummy arguments match,
1302 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1303 bool type_must_agree
, char *errmsg
,
1306 if (s1
== NULL
|| s2
== NULL
)
1307 return s1
== s2
? true : false;
1309 /* Check type and rank. */
1310 if (type_must_agree
)
1312 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1314 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1315 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1318 if (!compare_rank (s1
, s2
))
1320 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1321 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1327 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1329 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1334 /* Check OPTIONAL attribute. */
1335 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1337 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1342 /* Check ALLOCATABLE attribute. */
1343 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1345 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1350 /* Check POINTER attribute. */
1351 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1353 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1358 /* Check TARGET attribute. */
1359 if (s1
->attr
.target
!= s2
->attr
.target
)
1361 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1366 /* Check ASYNCHRONOUS attribute. */
1367 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1369 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1374 /* Check CONTIGUOUS attribute. */
1375 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1377 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1382 /* Check VALUE attribute. */
1383 if (s1
->attr
.value
!= s2
->attr
.value
)
1385 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1390 /* Check VOLATILE attribute. */
1391 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1393 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1398 /* Check interface of dummy procedures. */
1399 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1402 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1405 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1406 "'%s': %s", s1
->name
, err
);
1411 /* Check string length. */
1412 if (s1
->ts
.type
== BT_CHARACTER
1413 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1414 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1416 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1417 s2
->ts
.u
.cl
->length
);
1423 snprintf (errmsg
, err_len
, "Character length mismatch "
1424 "in argument '%s'", s1
->name
);
1428 /* FIXME: Implement a warning for this case.
1429 gfc_warning (0, "Possible character length mismatch in argument %qs",
1437 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1438 "%i of gfc_dep_compare_expr", compval
);
1443 /* Check array shape. */
1444 if (s1
->as
&& s2
->as
)
1447 gfc_expr
*shape1
, *shape2
;
1449 if (s1
->as
->type
!= s2
->as
->type
)
1451 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1456 if (s1
->as
->corank
!= s2
->as
->corank
)
1458 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1459 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1463 if (s1
->as
->type
== AS_EXPLICIT
)
1464 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1466 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1467 gfc_copy_expr (s1
->as
->lower
[i
]));
1468 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1469 gfc_copy_expr (s2
->as
->lower
[i
]));
1470 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1471 gfc_free_expr (shape1
);
1472 gfc_free_expr (shape2
);
1478 if (i
< s1
->as
->rank
)
1479 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1480 " argument '%s'", i
+ 1, s1
->name
);
1482 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1483 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1487 /* FIXME: Implement a warning for this case.
1488 gfc_warning (0, "Possible shape mismatch in argument %qs",
1496 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1497 "result %i of gfc_dep_compare_expr",
1508 /* Check if the characteristics of two function results match,
1512 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1513 char *errmsg
, int err_len
)
1515 gfc_symbol
*r1
, *r2
;
1517 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1518 r1
= s1
->ts
.interface
->result
;
1520 r1
= s1
->result
? s1
->result
: s1
;
1522 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1523 r2
= s2
->ts
.interface
->result
;
1525 r2
= s2
->result
? s2
->result
: s2
;
1527 if (r1
->ts
.type
== BT_UNKNOWN
)
1530 /* Check type and rank. */
1531 if (!compare_type (r1
, r2
))
1533 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1534 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1537 if (!compare_rank (r1
, r2
))
1539 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1540 symbol_rank (r1
), symbol_rank (r2
));
1544 /* Check ALLOCATABLE attribute. */
1545 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1547 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1552 /* Check POINTER attribute. */
1553 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1555 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1560 /* Check CONTIGUOUS attribute. */
1561 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1563 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1568 /* Check PROCEDURE POINTER attribute. */
1569 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1571 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1576 /* Check string length. */
1577 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1579 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1581 snprintf (errmsg
, err_len
, "Character length mismatch "
1582 "in function result");
1586 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1588 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1589 r2
->ts
.u
.cl
->length
);
1595 snprintf (errmsg
, err_len
, "Character length mismatch "
1596 "in function result");
1600 /* FIXME: Implement a warning for this case.
1601 snprintf (errmsg, err_len, "Possible character length mismatch "
1602 "in function result");*/
1609 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1610 "result %i of gfc_dep_compare_expr", compval
);
1616 /* Check array shape. */
1617 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1620 gfc_expr
*shape1
, *shape2
;
1622 if (r1
->as
->type
!= r2
->as
->type
)
1624 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1628 if (r1
->as
->type
== AS_EXPLICIT
)
1629 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1631 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1632 gfc_copy_expr (r1
->as
->lower
[i
]));
1633 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1634 gfc_copy_expr (r2
->as
->lower
[i
]));
1635 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1636 gfc_free_expr (shape1
);
1637 gfc_free_expr (shape2
);
1643 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1644 "function result", i
+ 1);
1648 /* FIXME: Implement a warning for this case.
1649 gfc_warning (0, "Possible shape mismatch in return value");*/
1656 gfc_internal_error ("check_result_characteristics (2): "
1657 "Unexpected result %i of "
1658 "gfc_dep_compare_expr", compval
);
1668 /* 'Compare' two formal interfaces associated with a pair of symbols.
1669 We return true if there exists an actual argument list that
1670 would be ambiguous between the two interfaces, zero otherwise.
1671 'strict_flag' specifies whether all the characteristics are
1672 required to match, which is not the case for ambiguity checks.
1673 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1676 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1677 int generic_flag
, int strict_flag
,
1678 char *errmsg
, int err_len
,
1679 const char *p1
, const char *p2
)
1681 gfc_formal_arglist
*f1
, *f2
;
1683 gcc_assert (name2
!= NULL
);
1685 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1686 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1687 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1690 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1694 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1697 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1701 /* Do strict checks on all characteristics
1702 (for dummy procedures and procedure pointer assignments). */
1703 if (!generic_flag
&& strict_flag
)
1705 if (s1
->attr
.function
&& s2
->attr
.function
)
1707 /* If both are functions, check result characteristics. */
1708 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1709 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1713 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1715 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1718 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1720 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1725 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1726 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1729 f1
= gfc_sym_get_dummy_args (s1
);
1730 f2
= gfc_sym_get_dummy_args (s2
);
1732 /* Special case: No arguments. */
1733 if (f1
== NULL
&& f2
== NULL
)
1738 if (count_types_test (f1
, f2
, p1
, p2
)
1739 || count_types_test (f2
, f1
, p2
, p1
))
1742 /* Special case: alternate returns. If both f1->sym and f2->sym are
1743 NULL, then the leading formal arguments are alternate returns.
1744 The previous conditional should catch argument lists with
1745 different number of argument. */
1746 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1749 if (generic_correspondence (f1
, f2
, p1
, p2
)
1750 || generic_correspondence (f2
, f1
, p2
, p1
))
1754 /* Perform the abbreviated correspondence test for operators (the
1755 arguments cannot be optional and are always ordered correctly).
1756 This is also done when comparing interfaces for dummy procedures and in
1757 procedure pointer assignments. */
1759 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1761 /* Check existence. */
1762 if (f1
== NULL
|| f2
== NULL
)
1765 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1766 "arguments", name2
);
1772 /* Check all characteristics. */
1773 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1779 /* Operators: Only check type and rank of arguments. */
1780 if (!compare_type (f2
->sym
, f1
->sym
))
1783 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1784 "(%s/%s)", f1
->sym
->name
,
1785 gfc_typename (&f1
->sym
->ts
),
1786 gfc_typename (&f2
->sym
->ts
));
1789 if (!compare_rank (f2
->sym
, f1
->sym
))
1792 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1793 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1794 symbol_rank (f2
->sym
));
1797 if ((gfc_option
.allow_std
& GFC_STD_F2008
)
1798 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1799 || compare_ptr_alloc(f2
->sym
, f1
->sym
)))
1802 snprintf (errmsg
, err_len
, "Mismatching POINTER/ALLOCATABLE "
1803 "attribute in argument '%s' ", f1
->sym
->name
);
1813 /* Given a pointer to an interface pointer, remove duplicate
1814 interfaces and make sure that all symbols are either functions
1815 or subroutines, and all of the same kind. Returns true if
1816 something goes wrong. */
1819 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1821 gfc_interface
*psave
, *q
, *qlast
;
1824 for (; p
; p
= p
->next
)
1826 /* Make sure all symbols in the interface have been defined as
1827 functions or subroutines. */
1828 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1829 || !p
->sym
->attr
.if_source
)
1830 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1833 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1835 if (p
->sym
->attr
.external
)
1837 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1838 "; did you mean %qs?",
1839 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1842 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1843 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1846 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1847 "subroutine; did you mean %qs?", p
->sym
->name
,
1848 interface_name
, &p
->sym
->declared_at
, guessed
);
1850 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1851 "subroutine", p
->sym
->name
, interface_name
,
1852 &p
->sym
->declared_at
);
1856 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1857 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1858 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1859 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1861 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1862 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1863 " or all FUNCTIONs", interface_name
,
1864 &p
->sym
->declared_at
);
1865 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1866 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1867 "generic name is also the name of a derived type",
1868 interface_name
, &p
->sym
->declared_at
);
1872 /* F2003, C1207. F2008, C1207. */
1873 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1874 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1875 "%qs in %s at %L", p
->sym
->name
,
1876 interface_name
, &p
->sym
->declared_at
))
1881 /* Remove duplicate interfaces in this interface list. */
1882 for (; p
; p
= p
->next
)
1886 for (q
= p
->next
; q
;)
1888 if (p
->sym
!= q
->sym
)
1895 /* Duplicate interface. */
1896 qlast
->next
= q
->next
;
1907 /* Check lists of interfaces to make sure that no two interfaces are
1908 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1911 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1912 int generic_flag
, const char *interface_name
,
1916 for (; p
; p
= p
->next
)
1917 for (q
= q0
; q
; q
= q
->next
)
1919 if (p
->sym
== q
->sym
)
1920 continue; /* Duplicates OK here. */
1922 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1925 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1926 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1927 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1928 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1931 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1932 "and %qs at %L", interface_name
,
1933 q
->sym
->name
, &q
->sym
->declared_at
,
1934 p
->sym
->name
, &p
->sym
->declared_at
);
1935 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1936 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1937 "and %qs at %L", interface_name
,
1938 q
->sym
->name
, &q
->sym
->declared_at
,
1939 p
->sym
->name
, &p
->sym
->declared_at
);
1941 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1942 "interfaces at %L", interface_name
, &p
->where
);
1950 /* Check the generic and operator interfaces of symbols to make sure
1951 that none of the interfaces conflict. The check has to be done
1952 after all of the symbols are actually loaded. */
1955 check_sym_interfaces (gfc_symbol
*sym
)
1957 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("generic interface ''")];
1960 if (sym
->ns
!= gfc_current_ns
)
1963 if (sym
->generic
!= NULL
)
1965 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1966 if (check_interface0 (sym
->generic
, interface_name
))
1969 for (p
= sym
->generic
; p
; p
= p
->next
)
1971 if (p
->sym
->attr
.mod_proc
1972 && !p
->sym
->attr
.module_procedure
1973 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1974 || p
->sym
->attr
.procedure
))
1976 gfc_error ("%qs at %L is not a module procedure",
1977 p
->sym
->name
, &p
->where
);
1982 /* Originally, this test was applied to host interfaces too;
1983 this is incorrect since host associated symbols, from any
1984 source, cannot be ambiguous with local symbols. */
1985 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1986 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1992 check_uop_interfaces (gfc_user_op
*uop
)
1994 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
1998 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1999 if (check_interface0 (uop
->op
, interface_name
))
2002 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2004 uop2
= gfc_find_uop (uop
->name
, ns
);
2008 check_interface1 (uop
->op
, uop2
->op
, 0,
2009 interface_name
, true);
2013 /* Given an intrinsic op, return an equivalent op if one exists,
2014 or INTRINSIC_NONE otherwise. */
2017 gfc_equivalent_op (gfc_intrinsic_op op
)
2022 return INTRINSIC_EQ_OS
;
2024 case INTRINSIC_EQ_OS
:
2025 return INTRINSIC_EQ
;
2028 return INTRINSIC_NE_OS
;
2030 case INTRINSIC_NE_OS
:
2031 return INTRINSIC_NE
;
2034 return INTRINSIC_GT_OS
;
2036 case INTRINSIC_GT_OS
:
2037 return INTRINSIC_GT
;
2040 return INTRINSIC_GE_OS
;
2042 case INTRINSIC_GE_OS
:
2043 return INTRINSIC_GE
;
2046 return INTRINSIC_LT_OS
;
2048 case INTRINSIC_LT_OS
:
2049 return INTRINSIC_LT
;
2052 return INTRINSIC_LE_OS
;
2054 case INTRINSIC_LE_OS
:
2055 return INTRINSIC_LE
;
2058 return INTRINSIC_NONE
;
2062 /* For the namespace, check generic, user operator and intrinsic
2063 operator interfaces for consistency and to remove duplicate
2064 interfaces. We traverse the whole namespace, counting on the fact
2065 that most symbols will not have generic or operator interfaces. */
2068 gfc_check_interfaces (gfc_namespace
*ns
)
2070 gfc_namespace
*old_ns
, *ns2
;
2071 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2074 old_ns
= gfc_current_ns
;
2075 gfc_current_ns
= ns
;
2077 gfc_traverse_ns (ns
, check_sym_interfaces
);
2079 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2081 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2083 if (i
== INTRINSIC_USER
)
2086 if (i
== INTRINSIC_ASSIGN
)
2087 strcpy (interface_name
, "intrinsic assignment operator");
2089 sprintf (interface_name
, "intrinsic '%s' operator",
2090 gfc_op2string ((gfc_intrinsic_op
) i
));
2092 if (check_interface0 (ns
->op
[i
], interface_name
))
2096 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2099 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2101 gfc_intrinsic_op other_op
;
2103 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2104 interface_name
, true))
2107 /* i should be gfc_intrinsic_op, but has to be int with this cast
2108 here for stupid C++ compatibility rules. */
2109 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2110 if (other_op
!= INTRINSIC_NONE
2111 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2112 0, interface_name
, true))
2118 gfc_current_ns
= old_ns
;
2122 /* Given a symbol of a formal argument list and an expression, if the
2123 formal argument is allocatable, check that the actual argument is
2124 allocatable. Returns true if compatible, zero if not compatible. */
2127 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2129 if (formal
->attr
.allocatable
2130 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2132 symbol_attribute attr
= gfc_expr_attr (actual
);
2133 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2135 else if (!attr
.allocatable
)
2143 /* Given a symbol of a formal argument list and an expression, if the
2144 formal argument is a pointer, see if the actual argument is a
2145 pointer. Returns nonzero if compatible, zero if not compatible. */
2148 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2150 symbol_attribute attr
;
2152 if (formal
->attr
.pointer
2153 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2154 && CLASS_DATA (formal
)->attr
.class_pointer
))
2156 attr
= gfc_expr_attr (actual
);
2158 /* Fortran 2008 allows non-pointer actual arguments. */
2159 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2170 /* Emit clear error messages for rank mismatch. */
2173 argument_rank_mismatch (const char *name
, locus
*where
,
2174 int rank1
, int rank2
)
2177 /* TS 29113, C407b. */
2179 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2180 " %qs has assumed-rank", where
, name
);
2181 else if (rank1
== 0)
2182 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2183 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2184 else if (rank2
== 0)
2185 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2186 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2188 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2189 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2193 /* Given a symbol of a formal argument list and an expression, see if
2194 the two are compatible as arguments. Returns true if
2195 compatible, false if not compatible. */
2198 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2199 int ranks_must_agree
, int is_elemental
, locus
*where
)
2202 bool rank_check
, is_pointer
;
2206 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2207 procs c_f_pointer or c_f_procpointer, and we need to accept most
2208 pointers the user could give us. This should allow that. */
2209 if (formal
->ts
.type
== BT_VOID
)
2212 if (formal
->ts
.type
== BT_DERIVED
2213 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2214 && actual
->ts
.type
== BT_DERIVED
2215 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2218 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2219 /* Make sure the vtab symbol is present when
2220 the module variables are generated. */
2221 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2223 if (actual
->ts
.type
== BT_PROCEDURE
)
2225 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2227 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2230 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2234 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2235 sizeof(err
), NULL
, NULL
))
2238 gfc_error_opt (OPT_Wargument_mismatch
,
2239 "Interface mismatch in dummy procedure %qs at %L:"
2240 " %s", formal
->name
, &actual
->where
, err
);
2244 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2246 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2247 &act_sym
->declared_at
);
2248 if (act_sym
->ts
.type
== BT_UNKNOWN
2249 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2252 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2253 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2254 &act_sym
->declared_at
);
2259 ppc
= gfc_get_proc_ptr_comp (actual
);
2260 if (ppc
&& ppc
->ts
.interface
)
2262 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2263 err
, sizeof(err
), NULL
, NULL
))
2266 gfc_error_opt (OPT_Wargument_mismatch
,
2267 "Interface mismatch in dummy procedure %qs at %L:"
2268 " %s", formal
->name
, &actual
->where
, err
);
2274 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2275 && !gfc_is_simply_contiguous (actual
, true, false))
2278 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2279 "must be simply contiguous", formal
->name
, &actual
->where
);
2283 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2284 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2287 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2288 && actual
->ts
.type
!= BT_HOLLERITH
2289 && formal
->ts
.type
!= BT_ASSUMED
2290 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2291 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2292 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2293 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2294 CLASS_DATA (actual
)->ts
.u
.derived
)))
2297 gfc_error_opt (OPT_Wargument_mismatch
,
2298 "Type mismatch in argument %qs at %L; passed %s to %s",
2299 formal
->name
, where
, gfc_typename (&actual
->ts
),
2300 gfc_typename (&formal
->ts
));
2304 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2307 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2308 "argument %qs is of assumed type", &actual
->where
,
2313 /* F2008, 12.5.2.5; IR F08/0073. */
2314 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2315 && actual
->expr_type
!= EXPR_NULL
2316 && ((CLASS_DATA (formal
)->attr
.class_pointer
2317 && formal
->attr
.intent
!= INTENT_IN
)
2318 || CLASS_DATA (formal
)->attr
.allocatable
))
2320 if (actual
->ts
.type
!= BT_CLASS
)
2323 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2324 formal
->name
, &actual
->where
);
2328 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2329 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2330 CLASS_DATA (formal
)->ts
.u
.derived
))
2333 gfc_error ("Actual argument to %qs at %L must have the same "
2334 "declared type", formal
->name
, &actual
->where
);
2339 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2340 is necessary also for F03, so retain error for both.
2341 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2342 compatible, no attempt has been made to channel to this one. */
2343 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2344 && (CLASS_DATA (formal
)->attr
.allocatable
2345 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2348 gfc_error ("Actual argument to %qs at %L must be unlimited "
2349 "polymorphic since the formal argument is a "
2350 "pointer or allocatable unlimited polymorphic "
2351 "entity [F2008: 12.5.2.5]", formal
->name
,
2356 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2359 gfc_error ("Actual argument to %qs at %L must be a coarray",
2360 formal
->name
, &actual
->where
);
2364 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2366 gfc_ref
*last
= NULL
;
2368 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2369 if (ref
->type
== REF_COMPONENT
)
2372 /* F2008, 12.5.2.6. */
2373 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2375 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2378 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2379 formal
->name
, &actual
->where
, formal
->as
->corank
,
2380 last
? last
->u
.c
.component
->as
->corank
2381 : actual
->symtree
->n
.sym
->as
->corank
);
2386 if (formal
->attr
.codimension
)
2388 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2389 /* F2018, 12.5.2.8. */
2390 if (formal
->attr
.dimension
2391 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2392 && actual_attr
.dimension
2393 && !gfc_is_simply_contiguous (actual
, true, true))
2396 gfc_error ("Actual argument to %qs at %L must be simply "
2397 "contiguous or an element of such an array",
2398 formal
->name
, &actual
->where
);
2402 /* F2008, C1303 and C1304. */
2403 if (formal
->attr
.intent
!= INTENT_INOUT
2404 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2405 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2406 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2407 || formal
->attr
.lock_comp
))
2411 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2412 "which is LOCK_TYPE or has a LOCK_TYPE component",
2413 formal
->name
, &actual
->where
);
2417 /* TS18508, C702/C703. */
2418 if (formal
->attr
.intent
!= INTENT_INOUT
2419 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2420 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2421 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2422 || formal
->attr
.event_comp
))
2426 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2427 "which is EVENT_TYPE or has a EVENT_TYPE component",
2428 formal
->name
, &actual
->where
);
2433 /* F2008, C1239/C1240. */
2434 if (actual
->expr_type
== EXPR_VARIABLE
2435 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2436 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2437 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2438 && actual
->rank
&& formal
->as
2439 && !gfc_is_simply_contiguous (actual
, true, false)
2440 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2441 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2442 || formal
->attr
.contiguous
))
2445 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2446 "assumed-rank array without CONTIGUOUS attribute - as actual"
2447 " argument at %L is not simply contiguous and both are "
2448 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2452 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2453 && actual_attr
.codimension
)
2455 if (formal
->attr
.intent
== INTENT_OUT
)
2458 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2459 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2463 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2464 gfc_warning (OPT_Wsurprising
,
2465 "Passing coarray at %L to allocatable, noncoarray dummy "
2466 "argument %qs, which is invalid if the allocation status"
2467 " is modified", &actual
->where
, formal
->name
);
2470 /* If the rank is the same or the formal argument has assumed-rank. */
2471 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2474 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2475 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2476 || formal
->as
->type
== AS_DEFERRED
)
2477 && actual
->expr_type
!= EXPR_NULL
;
2479 /* Skip rank checks for NO_ARG_CHECK. */
2480 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2483 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2484 if (rank_check
|| ranks_must_agree
2485 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2486 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2487 || (actual
->rank
== 0
2488 && ((formal
->ts
.type
== BT_CLASS
2489 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2490 || (formal
->ts
.type
!= BT_CLASS
2491 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2492 && actual
->expr_type
!= EXPR_NULL
)
2493 || (actual
->rank
== 0 && formal
->attr
.dimension
2494 && gfc_is_coindexed (actual
)))
2497 argument_rank_mismatch (formal
->name
, &actual
->where
,
2498 symbol_rank (formal
), actual
->rank
);
2501 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2504 /* At this point, we are considering a scalar passed to an array. This
2505 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2506 - if the actual argument is (a substring of) an element of a
2507 non-assumed-shape/non-pointer/non-polymorphic array; or
2508 - (F2003) if the actual argument is of type character of default/c_char
2511 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2512 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2514 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2516 if (ref
->type
== REF_COMPONENT
)
2517 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2518 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2519 && ref
->u
.ar
.dimen
> 0
2521 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2525 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2528 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2529 "at %L", formal
->name
, &actual
->where
);
2533 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2534 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2537 gfc_error ("Element of assumed-shaped or pointer "
2538 "array passed to array dummy argument %qs at %L",
2539 formal
->name
, &actual
->where
);
2543 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2544 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2546 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2549 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2550 "CHARACTER actual argument with array dummy argument "
2551 "%qs at %L", formal
->name
, &actual
->where
);
2555 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2557 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2558 "array dummy argument %qs at %L",
2559 formal
->name
, &actual
->where
);
2563 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2566 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2569 argument_rank_mismatch (formal
->name
, &actual
->where
,
2570 symbol_rank (formal
), actual
->rank
);
2578 /* Returns the storage size of a symbol (formal argument) or
2579 zero if it cannot be determined. */
2581 static unsigned long
2582 get_sym_storage_size (gfc_symbol
*sym
)
2585 unsigned long strlen
, elements
;
2587 if (sym
->ts
.type
== BT_CHARACTER
)
2589 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2590 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2591 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2598 if (symbol_rank (sym
) == 0)
2602 if (sym
->as
->type
!= AS_EXPLICIT
)
2604 for (i
= 0; i
< sym
->as
->rank
; i
++)
2606 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2607 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2610 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2611 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2614 return strlen
*elements
;
2618 /* Returns the storage size of an expression (actual argument) or
2619 zero if it cannot be determined. For an array element, it returns
2620 the remaining size as the element sequence consists of all storage
2621 units of the actual argument up to the end of the array. */
2623 static unsigned long
2624 get_expr_storage_size (gfc_expr
*e
)
2627 long int strlen
, elements
;
2628 long int substrlen
= 0;
2629 bool is_str_storage
= false;
2635 if (e
->ts
.type
== BT_CHARACTER
)
2637 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2638 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2639 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2640 else if (e
->expr_type
== EXPR_CONSTANT
2641 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2642 strlen
= e
->value
.character
.length
;
2647 strlen
= 1; /* Length per element. */
2649 if (e
->rank
== 0 && !e
->ref
)
2657 for (i
= 0; i
< e
->rank
; i
++)
2658 elements
*= mpz_get_si (e
->shape
[i
]);
2659 return elements
*strlen
;
2662 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2664 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2665 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2669 /* The string length is the substring length.
2670 Set now to full string length. */
2671 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2672 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2675 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2677 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2681 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2682 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2684 long int start
, end
, stride
;
2687 if (ref
->u
.ar
.stride
[i
])
2689 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2690 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2695 if (ref
->u
.ar
.start
[i
])
2697 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2698 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2702 else if (ref
->u
.ar
.as
->lower
[i
]
2703 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2704 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2708 if (ref
->u
.ar
.end
[i
])
2710 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2711 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2715 else if (ref
->u
.ar
.as
->upper
[i
]
2716 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2717 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2721 elements
*= (end
- start
)/stride
+ 1L;
2723 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2724 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2726 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2727 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2728 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2729 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2730 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2731 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2732 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2737 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2738 && e
->expr_type
== EXPR_VARIABLE
)
2740 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2741 || e
->symtree
->n
.sym
->attr
.pointer
)
2747 /* Determine the number of remaining elements in the element
2748 sequence for array element designators. */
2749 is_str_storage
= true;
2750 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2752 if (ref
->u
.ar
.start
[i
] == NULL
2753 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2754 || ref
->u
.ar
.as
->upper
[i
] == NULL
2755 || ref
->u
.ar
.as
->lower
[i
] == NULL
2756 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2757 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2762 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2763 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2765 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2766 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2769 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2770 && ref
->u
.c
.component
->attr
.proc_pointer
2771 && ref
->u
.c
.component
->attr
.dimension
)
2773 /* Array-valued procedure-pointer components. */
2774 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2775 for (i
= 0; i
< as
->rank
; i
++)
2777 if (!as
->upper
[i
] || !as
->lower
[i
]
2778 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2779 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2783 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2784 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2790 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2793 return elements
*strlen
;
2797 /* Given an expression, check whether it is an array section
2798 which has a vector subscript. */
2801 gfc_has_vector_subscript (gfc_expr
*e
)
2806 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2809 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2810 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2811 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2812 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2820 is_procptr_result (gfc_expr
*expr
)
2822 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2824 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2826 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2827 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2831 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2832 number of total candidates in CANDIDATES_LEN. */
2835 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
2837 size_t &candidates_len
)
2839 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
2840 vec_push (candidates
, candidates_len
, p
->sym
->name
);
2844 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2847 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
2849 char **candidates
= NULL
;
2850 size_t candidates_len
= 0;
2851 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
2852 return gfc_closest_fuzzy_match (arg
, candidates
);
2856 /* Given formal and actual argument lists, see if they are compatible.
2857 If they are compatible, the actual argument list is sorted to
2858 correspond with the formal list, and elements for missing optional
2859 arguments are inserted. If WHERE pointer is nonnull, then we issue
2860 errors when things don't match instead of just returning the status
2864 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2865 int ranks_must_agree
, int is_elemental
,
2866 bool in_statement_function
, locus
*where
)
2868 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2869 gfc_formal_arglist
*f
;
2871 unsigned long actual_size
, formal_size
;
2872 bool full_array
= false;
2873 gfc_array_ref
*actual_arr_ref
;
2877 if (actual
== NULL
&& formal
== NULL
)
2881 for (f
= formal
; f
; f
= f
->next
)
2884 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2886 for (i
= 0; i
< n
; i
++)
2893 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2895 if (a
->name
!= NULL
&& in_statement_function
)
2897 gfc_error ("Keyword argument %qs at %L is invalid in "
2898 "a statement function", a
->name
, &a
->expr
->where
);
2902 /* Look for keywords but ignore g77 extensions like %VAL. */
2903 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2906 for (f
= formal
; f
; f
= f
->next
, i
++)
2910 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2918 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
2920 gfc_error ("Keyword argument %qs at %L is not in "
2921 "the procedure; did you mean %qs?",
2922 a
->name
, &a
->expr
->where
, guessed
);
2924 gfc_error ("Keyword argument %qs at %L is not in "
2925 "the procedure", a
->name
, &a
->expr
->where
);
2930 if (new_arg
[i
] != NULL
)
2933 gfc_error ("Keyword argument %qs at %L is already associated "
2934 "with another actual argument", a
->name
,
2943 gfc_error ("More actual than formal arguments in procedure "
2944 "call at %L", where
);
2949 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2955 gfc_error ("Missing alternate return spec in subroutine call "
2960 if (a
->expr
== NULL
)
2963 gfc_error ("Unexpected alternate return spec in subroutine "
2964 "call at %L", where
);
2968 /* Make sure that intrinsic vtables exist for calls to unlimited
2969 polymorphic formal arguments. */
2970 if (UNLIMITED_POLY (f
->sym
)
2971 && a
->expr
->ts
.type
!= BT_DERIVED
2972 && a
->expr
->ts
.type
!= BT_CLASS
)
2973 gfc_find_vtab (&a
->expr
->ts
);
2975 if (a
->expr
->expr_type
== EXPR_NULL
2976 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2977 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2978 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2979 || (f
->sym
->ts
.type
== BT_CLASS
2980 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2981 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2982 || !f
->sym
->attr
.optional
2983 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2986 && (!f
->sym
->attr
.optional
2987 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2988 || (f
->sym
->ts
.type
== BT_CLASS
2989 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2990 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2991 where
, f
->sym
->name
);
2993 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2994 "dummy %qs", where
, f
->sym
->name
);
2999 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
3000 is_elemental
, where
))
3003 /* TS 29113, 6.3p2. */
3004 if (f
->sym
->ts
.type
== BT_ASSUMED
3005 && (a
->expr
->ts
.type
== BT_DERIVED
3006 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
3008 gfc_namespace
*f2k_derived
;
3010 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
3011 ? a
->expr
->ts
.u
.derived
->f2k_derived
3012 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
3015 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
3017 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3018 "derived type with type-bound or FINAL procedures",
3024 /* Special case for character arguments. For allocatable, pointer
3025 and assumed-shape dummies, the string length needs to match
3027 if (a
->expr
->ts
.type
== BT_CHARACTER
3028 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3029 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3030 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3031 && f
->sym
->ts
.u
.cl
->length
3032 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3033 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3034 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3035 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3036 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3038 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3039 gfc_warning (OPT_Wargument_mismatch
,
3040 "Character length mismatch (%ld/%ld) between actual "
3041 "argument and pointer or allocatable dummy argument "
3043 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3044 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3045 f
->sym
->name
, &a
->expr
->where
);
3047 gfc_warning (OPT_Wargument_mismatch
,
3048 "Character length mismatch (%ld/%ld) between actual "
3049 "argument and assumed-shape dummy argument %qs "
3051 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3052 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3053 f
->sym
->name
, &a
->expr
->where
);
3057 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3058 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3059 && a
->expr
->ts
.type
== BT_CHARACTER
)
3062 gfc_error ("Actual argument at %L to allocatable or "
3063 "pointer dummy argument %qs must have a deferred "
3064 "length type parameter if and only if the dummy has one",
3065 &a
->expr
->where
, f
->sym
->name
);
3069 if (f
->sym
->ts
.type
== BT_CLASS
)
3070 goto skip_size_check
;
3072 actual_size
= get_expr_storage_size (a
->expr
);
3073 formal_size
= get_sym_storage_size (f
->sym
);
3074 if (actual_size
!= 0 && actual_size
< formal_size
3075 && a
->expr
->ts
.type
!= BT_PROCEDURE
3076 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3078 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3079 gfc_warning (OPT_Wargument_mismatch
,
3080 "Character length of actual argument shorter "
3081 "than of dummy argument %qs (%lu/%lu) at %L",
3082 f
->sym
->name
, actual_size
, formal_size
,
3086 /* Emit a warning for -std=legacy and an error otherwise. */
3087 if (gfc_option
.warn_std
== 0)
3088 gfc_warning (OPT_Wargument_mismatch
,
3089 "Actual argument contains too few "
3090 "elements for dummy argument %qs (%lu/%lu) "
3091 "at %L", f
->sym
->name
, actual_size
,
3092 formal_size
, &a
->expr
->where
);
3094 gfc_error_now ("Actual argument contains too few "
3095 "elements for dummy argument %qs (%lu/%lu) "
3096 "at %L", f
->sym
->name
, actual_size
,
3097 formal_size
, &a
->expr
->where
);
3104 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3105 argument is provided for a procedure pointer formal argument. */
3106 if (f
->sym
->attr
.proc_pointer
3107 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3108 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3109 || gfc_is_proc_ptr_comp (a
->expr
)))
3110 || (a
->expr
->expr_type
== EXPR_FUNCTION
3111 && is_procptr_result (a
->expr
))))
3114 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3115 f
->sym
->name
, &a
->expr
->where
);
3119 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3120 provided for a procedure formal argument. */
3121 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3122 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3123 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3124 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3125 || gfc_is_proc_ptr_comp (a
->expr
)))
3126 || (a
->expr
->expr_type
== EXPR_FUNCTION
3127 && is_procptr_result (a
->expr
))))
3130 gfc_error ("Expected a procedure for argument %qs at %L",
3131 f
->sym
->name
, &a
->expr
->where
);
3135 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3136 && a
->expr
->expr_type
== EXPR_VARIABLE
3137 && a
->expr
->symtree
->n
.sym
->as
3138 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3139 && (a
->expr
->ref
== NULL
3140 || (a
->expr
->ref
->type
== REF_ARRAY
3141 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3144 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3145 " array at %L", f
->sym
->name
, where
);
3149 if (a
->expr
->expr_type
!= EXPR_NULL
3150 && compare_pointer (f
->sym
, a
->expr
) == 0)
3153 gfc_error ("Actual argument for %qs must be a pointer at %L",
3154 f
->sym
->name
, &a
->expr
->where
);
3158 if (a
->expr
->expr_type
!= EXPR_NULL
3159 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3160 && compare_pointer (f
->sym
, a
->expr
) == 2)
3163 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3164 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3169 /* Fortran 2008, C1242. */
3170 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3173 gfc_error ("Coindexed actual argument at %L to pointer "
3175 &a
->expr
->where
, f
->sym
->name
);
3179 /* Fortran 2008, 12.5.2.5 (no constraint). */
3180 if (a
->expr
->expr_type
== EXPR_VARIABLE
3181 && f
->sym
->attr
.intent
!= INTENT_IN
3182 && f
->sym
->attr
.allocatable
3183 && gfc_is_coindexed (a
->expr
))
3186 gfc_error ("Coindexed actual argument at %L to allocatable "
3187 "dummy %qs requires INTENT(IN)",
3188 &a
->expr
->where
, f
->sym
->name
);
3192 /* Fortran 2008, C1237. */
3193 if (a
->expr
->expr_type
== EXPR_VARIABLE
3194 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3195 && gfc_is_coindexed (a
->expr
)
3196 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3197 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3200 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3201 "%L requires that dummy %qs has neither "
3202 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3207 /* Fortran 2008, 12.5.2.4 (no constraint). */
3208 if (a
->expr
->expr_type
== EXPR_VARIABLE
3209 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3210 && gfc_is_coindexed (a
->expr
)
3211 && gfc_has_ultimate_allocatable (a
->expr
))
3214 gfc_error ("Coindexed actual argument at %L with allocatable "
3215 "ultimate component to dummy %qs requires either VALUE "
3216 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3220 if (f
->sym
->ts
.type
== BT_CLASS
3221 && CLASS_DATA (f
->sym
)->attr
.allocatable
3222 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3226 gfc_error ("Actual CLASS array argument for %qs must be a full "
3227 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3232 if (a
->expr
->expr_type
!= EXPR_NULL
3233 && !compare_allocatable (f
->sym
, a
->expr
))
3236 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3237 f
->sym
->name
, &a
->expr
->where
);
3241 /* Check intent = OUT/INOUT for definable actual argument. */
3242 if (!in_statement_function
3243 && (f
->sym
->attr
.intent
== INTENT_OUT
3244 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3246 const char* context
= (where
3247 ? _("actual argument to INTENT = OUT/INOUT")
3250 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3251 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3252 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3253 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3255 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3259 if ((f
->sym
->attr
.intent
== INTENT_OUT
3260 || f
->sym
->attr
.intent
== INTENT_INOUT
3261 || f
->sym
->attr
.volatile_
3262 || f
->sym
->attr
.asynchronous
)
3263 && gfc_has_vector_subscript (a
->expr
))
3266 gfc_error ("Array-section actual argument with vector "
3267 "subscripts at %L is incompatible with INTENT(OUT), "
3268 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3269 "of the dummy argument %qs",
3270 &a
->expr
->where
, f
->sym
->name
);
3274 /* C1232 (R1221) For an actual argument which is an array section or
3275 an assumed-shape array, the dummy argument shall be an assumed-
3276 shape array, if the dummy argument has the VOLATILE attribute. */
3278 if (f
->sym
->attr
.volatile_
3279 && a
->expr
->expr_type
== EXPR_VARIABLE
3280 && a
->expr
->symtree
->n
.sym
->as
3281 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3282 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3285 gfc_error ("Assumed-shape actual argument at %L is "
3286 "incompatible with the non-assumed-shape "
3287 "dummy argument %qs due to VOLATILE attribute",
3288 &a
->expr
->where
,f
->sym
->name
);
3292 /* Find the last array_ref. */
3293 actual_arr_ref
= NULL
;
3295 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3297 if (f
->sym
->attr
.volatile_
3298 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3299 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3302 gfc_error ("Array-section actual argument at %L is "
3303 "incompatible with the non-assumed-shape "
3304 "dummy argument %qs due to VOLATILE attribute",
3305 &a
->expr
->where
, f
->sym
->name
);
3309 /* C1233 (R1221) For an actual argument which is a pointer array, the
3310 dummy argument shall be an assumed-shape or pointer array, if the
3311 dummy argument has the VOLATILE attribute. */
3313 if (f
->sym
->attr
.volatile_
3314 && a
->expr
->expr_type
== EXPR_VARIABLE
3315 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3316 && a
->expr
->symtree
->n
.sym
->as
3318 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3319 || f
->sym
->attr
.pointer
)))
3322 gfc_error ("Pointer-array actual argument at %L requires "
3323 "an assumed-shape or pointer-array dummy "
3324 "argument %qs due to VOLATILE attribute",
3325 &a
->expr
->where
,f
->sym
->name
);
3336 /* Make sure missing actual arguments are optional. */
3338 for (f
= formal
; f
; f
= f
->next
, i
++)
3340 if (new_arg
[i
] != NULL
)
3345 gfc_error ("Missing alternate return spec in subroutine call "
3349 if (!f
->sym
->attr
.optional
3350 || (in_statement_function
&& f
->sym
->attr
.optional
))
3353 gfc_error ("Missing actual argument for argument %qs at %L",
3354 f
->sym
->name
, where
);
3359 /* The argument lists are compatible. We now relink a new actual
3360 argument list with null arguments in the right places. The head
3361 of the list remains the head. */
3362 for (i
= 0; i
< n
; i
++)
3363 if (new_arg
[i
] == NULL
)
3364 new_arg
[i
] = gfc_get_actual_arglist ();
3368 std::swap (*new_arg
[0], *actual
);
3369 std::swap (new_arg
[0], new_arg
[na
]);
3372 for (i
= 0; i
< n
- 1; i
++)
3373 new_arg
[i
]->next
= new_arg
[i
+ 1];
3375 new_arg
[i
]->next
= NULL
;
3377 if (*ap
== NULL
&& n
> 0)
3380 /* Note the types of omitted optional arguments. */
3381 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3382 if (a
->expr
== NULL
&& a
->label
== NULL
)
3383 a
->missing_arg_type
= f
->sym
->ts
.type
;
3391 gfc_formal_arglist
*f
;
3392 gfc_actual_arglist
*a
;
3396 /* qsort comparison function for argument pairs, with the following
3398 - p->a->expr == NULL
3399 - p->a->expr->expr_type != EXPR_VARIABLE
3400 - by gfc_symbol pointer value (larger first). */
3403 pair_cmp (const void *p1
, const void *p2
)
3405 const gfc_actual_arglist
*a1
, *a2
;
3407 /* *p1 and *p2 are elements of the to-be-sorted array. */
3408 a1
= ((const argpair
*) p1
)->a
;
3409 a2
= ((const argpair
*) p2
)->a
;
3418 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3420 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3424 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3426 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3428 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3432 /* Given two expressions from some actual arguments, test whether they
3433 refer to the same expression. The analysis is conservative.
3434 Returning false will produce no warning. */
3437 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3439 const gfc_ref
*r1
, *r2
;
3442 || e1
->expr_type
!= EXPR_VARIABLE
3443 || e2
->expr_type
!= EXPR_VARIABLE
3444 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3447 /* TODO: improve comparison, see expr.c:show_ref(). */
3448 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3450 if (r1
->type
!= r2
->type
)
3455 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3457 /* TODO: At the moment, consider only full arrays;
3458 we could do better. */
3459 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3464 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3472 gfc_internal_error ("compare_actual_expr(): Bad component code");
3481 /* Given formal and actual argument lists that correspond to one
3482 another, check that identical actual arguments aren't not
3483 associated with some incompatible INTENTs. */
3486 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3488 sym_intent f1_intent
, f2_intent
;
3489 gfc_formal_arglist
*f1
;
3490 gfc_actual_arglist
*a1
;
3496 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3498 if (f1
== NULL
&& a1
== NULL
)
3500 if (f1
== NULL
|| a1
== NULL
)
3501 gfc_internal_error ("check_some_aliasing(): List mismatch");
3506 p
= XALLOCAVEC (argpair
, n
);
3508 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3514 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3516 for (i
= 0; i
< n
; i
++)
3519 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3520 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3522 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3523 for (j
= i
+ 1; j
< n
; j
++)
3525 /* Expected order after the sort. */
3526 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3527 gfc_internal_error ("check_some_aliasing(): corrupted data");
3529 /* Are the expression the same? */
3530 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3532 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3533 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3534 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3535 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3537 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3538 "argument %qs and INTENT(%s) argument %qs at %L",
3539 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3540 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3541 &p
[i
].a
->expr
->where
);
3551 /* Given formal and actual argument lists that correspond to one
3552 another, check that they are compatible in the sense that intents
3553 are not mismatched. */
3556 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3558 sym_intent f_intent
;
3560 for (;; f
= f
->next
, a
= a
->next
)
3564 if (f
== NULL
&& a
== NULL
)
3566 if (f
== NULL
|| a
== NULL
)
3567 gfc_internal_error ("check_intents(): List mismatch");
3569 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3570 && a
->expr
->value
.function
.isym
3571 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3572 expr
= a
->expr
->value
.function
.actual
->expr
;
3576 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3579 f_intent
= f
->sym
->attr
.intent
;
3581 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3583 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3584 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3585 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3587 gfc_error ("Procedure argument at %L is local to a PURE "
3588 "procedure and has the POINTER attribute",
3594 /* Fortran 2008, C1283. */
3595 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3597 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3599 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3600 "is passed to an INTENT(%s) argument",
3601 &expr
->where
, gfc_intent_string (f_intent
));
3605 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3606 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3607 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3609 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3610 "is passed to a POINTER dummy argument",
3616 /* F2008, Section 12.5.2.4. */
3617 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3618 && gfc_is_coindexed (expr
))
3620 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3621 "polymorphic dummy argument %qs",
3622 &expr
->where
, f
->sym
->name
);
3631 /* Check how a procedure is used against its interface. If all goes
3632 well, the actual argument list will also end up being properly
3636 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3638 gfc_actual_arglist
*a
;
3639 gfc_formal_arglist
*dummy_args
;
3641 /* Warn about calls with an implicit interface. Special case
3642 for calling a ISO_C_BINDING because c_loc and c_funloc
3643 are pseudo-unknown. Additionally, warn about procedures not
3644 explicitly declared at all if requested. */
3645 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3647 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3650 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3652 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3653 "; did you mean %qs?",
3654 sym
->name
, where
, guessed
);
3656 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3660 if (warn_implicit_interface
)
3661 gfc_warning (OPT_Wimplicit_interface
,
3662 "Procedure %qs called with an implicit interface at %L",
3664 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3665 gfc_warning (OPT_Wimplicit_procedure
,
3666 "Procedure %qs called at %L is not explicitly declared",
3670 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3672 if (sym
->attr
.pointer
)
3674 gfc_error ("The pointer object %qs at %L must have an explicit "
3675 "function interface or be declared as array",
3680 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3682 gfc_error ("The allocatable object %qs at %L must have an explicit "
3683 "function interface or be declared as array",
3688 if (sym
->attr
.allocatable
)
3690 gfc_error ("Allocatable function %qs at %L must have an explicit "
3691 "function interface", sym
->name
, where
);
3695 for (a
= *ap
; a
; a
= a
->next
)
3697 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3698 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3700 gfc_error ("Keyword argument requires explicit interface "
3701 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3705 /* TS 29113, 6.2. */
3706 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3707 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3709 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3710 "interface", a
->expr
->symtree
->n
.sym
->name
,
3715 /* F2008, C1303 and C1304. */
3717 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3718 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3719 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3720 || gfc_expr_attr (a
->expr
).lock_comp
))
3722 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3723 "component at %L requires an explicit interface for "
3724 "procedure %qs", &a
->expr
->where
, sym
->name
);
3729 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3730 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3731 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3732 == ISOFORTRAN_EVENT_TYPE
)
3733 || gfc_expr_attr (a
->expr
).event_comp
))
3735 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3736 "component at %L requires an explicit interface for "
3737 "procedure %qs", &a
->expr
->where
, sym
->name
);
3741 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3742 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3744 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3748 /* TS 29113, C407b. */
3749 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3750 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3752 gfc_error ("Assumed-rank argument requires an explicit interface "
3753 "at %L", &a
->expr
->where
);
3761 dummy_args
= gfc_sym_get_dummy_args (sym
);
3763 /* For a statement function, check that types and type parameters of actual
3764 arguments and dummy arguments match. */
3765 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3766 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3769 if (!check_intents (dummy_args
, *ap
))
3773 check_some_aliasing (dummy_args
, *ap
);
3779 /* Check how a procedure pointer component is used against its interface.
3780 If all goes well, the actual argument list will also end up being properly
3781 sorted. Completely analogous to gfc_procedure_use. */
3784 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3786 /* Warn about calls with an implicit interface. Special case
3787 for calling a ISO_C_BINDING because c_loc and c_funloc
3788 are pseudo-unknown. */
3789 if (warn_implicit_interface
3790 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3791 && !comp
->attr
.is_iso_c
)
3792 gfc_warning (OPT_Wimplicit_interface
,
3793 "Procedure pointer component %qs called with an implicit "
3794 "interface at %L", comp
->name
, where
);
3796 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3798 gfc_actual_arglist
*a
;
3799 for (a
= *ap
; a
; a
= a
->next
)
3801 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3802 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3804 gfc_error ("Keyword argument requires explicit interface "
3805 "for procedure pointer component %qs at %L",
3806 comp
->name
, &a
->expr
->where
);
3814 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3815 comp
->attr
.elemental
, false, where
))
3818 check_intents (comp
->ts
.interface
->formal
, *ap
);
3820 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3824 /* Try if an actual argument list matches the formal list of a symbol,
3825 respecting the symbol's attributes like ELEMENTAL. This is used for
3826 GENERIC resolution. */
3829 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3831 gfc_formal_arglist
*dummy_args
;
3834 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3837 dummy_args
= gfc_sym_get_dummy_args (sym
);
3839 r
= !sym
->attr
.elemental
;
3840 if (compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
3842 check_intents (dummy_args
, *args
);
3844 check_some_aliasing (dummy_args
, *args
);
3852 /* Given an interface pointer and an actual argument list, search for
3853 a formal argument list that matches the actual. If found, returns
3854 a pointer to the symbol of the correct interface. Returns NULL if
3858 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3859 gfc_actual_arglist
**ap
)
3861 gfc_symbol
*elem_sym
= NULL
;
3862 gfc_symbol
*null_sym
= NULL
;
3863 locus null_expr_loc
;
3864 gfc_actual_arglist
*a
;
3865 bool has_null_arg
= false;
3867 for (a
= *ap
; a
; a
= a
->next
)
3868 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3869 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3871 has_null_arg
= true;
3872 null_expr_loc
= a
->expr
->where
;
3876 for (; intr
; intr
= intr
->next
)
3878 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3880 if (sub_flag
&& intr
->sym
->attr
.function
)
3882 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3885 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3887 if (has_null_arg
&& null_sym
)
3889 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3890 "between specific functions %s and %s",
3891 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3894 else if (has_null_arg
)
3896 null_sym
= intr
->sym
;
3900 /* Satisfy 12.4.4.1 such that an elemental match has lower
3901 weight than a non-elemental match. */
3902 if (intr
->sym
->attr
.elemental
)
3904 elem_sym
= intr
->sym
;
3914 return elem_sym
? elem_sym
: NULL
;
3918 /* Do a brute force recursive search for a symbol. */
3920 static gfc_symtree
*
3921 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3925 if (root
->n
.sym
== sym
)
3930 st
= find_symtree0 (root
->left
, sym
);
3931 if (root
->right
&& ! st
)
3932 st
= find_symtree0 (root
->right
, sym
);
3937 /* Find a symtree for a symbol. */
3940 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3945 /* First try to find it by name. */
3946 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3947 if (st
&& st
->n
.sym
== sym
)
3950 /* If it's been renamed, resort to a brute-force search. */
3951 /* TODO: avoid having to do this search. If the symbol doesn't exist
3952 in the symtree for the current namespace, it should probably be added. */
3953 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3955 st
= find_symtree0 (ns
->sym_root
, sym
);
3959 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3964 /* See if the arglist to an operator-call contains a derived-type argument
3965 with a matching type-bound operator. If so, return the matching specific
3966 procedure defined as operator-target as well as the base-object to use
3967 (which is the found derived-type argument with operator). The generic
3968 name, if any, is transmitted to the final expression via 'gname'. */
3970 static gfc_typebound_proc
*
3971 matching_typebound_op (gfc_expr
** tb_base
,
3972 gfc_actual_arglist
* args
,
3973 gfc_intrinsic_op op
, const char* uop
,
3974 const char ** gname
)
3976 gfc_actual_arglist
* base
;
3978 for (base
= args
; base
; base
= base
->next
)
3979 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3981 gfc_typebound_proc
* tb
;
3982 gfc_symbol
* derived
;
3985 while (base
->expr
->expr_type
== EXPR_OP
3986 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3987 base
->expr
= base
->expr
->value
.op
.op1
;
3989 if (base
->expr
->ts
.type
== BT_CLASS
)
3991 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
3992 || !gfc_expr_attr (base
->expr
).class_ok
)
3994 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3997 derived
= base
->expr
->ts
.u
.derived
;
3999 if (op
== INTRINSIC_USER
)
4001 gfc_symtree
* tb_uop
;
4004 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
4013 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
4016 /* This means we hit a PRIVATE operator which is use-associated and
4017 should thus not be seen. */
4021 /* Look through the super-type hierarchy for a matching specific
4023 for (; tb
; tb
= tb
->overridden
)
4027 gcc_assert (tb
->is_generic
);
4028 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4031 gfc_actual_arglist
* argcopy
;
4034 gcc_assert (g
->specific
);
4035 if (g
->specific
->error
)
4038 target
= g
->specific
->u
.specific
->n
.sym
;
4040 /* Check if this arglist matches the formal. */
4041 argcopy
= gfc_copy_actual_arglist (args
);
4042 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4043 gfc_free_actual_arglist (argcopy
);
4045 /* Return if we found a match. */
4048 *tb_base
= base
->expr
;
4049 *gname
= g
->specific_st
->name
;
4060 /* For the 'actual arglist' of an operator call and a specific typebound
4061 procedure that has been found the target of a type-bound operator, build the
4062 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4063 type-bound procedures rather than resolving type-bound operators 'directly'
4064 so that we can reuse the existing logic. */
4067 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4068 gfc_expr
* base
, gfc_typebound_proc
* target
,
4071 e
->expr_type
= EXPR_COMPCALL
;
4072 e
->value
.compcall
.tbp
= target
;
4073 e
->value
.compcall
.name
= gname
? gname
: "$op";
4074 e
->value
.compcall
.actual
= actual
;
4075 e
->value
.compcall
.base_object
= base
;
4076 e
->value
.compcall
.ignore_pass
= 1;
4077 e
->value
.compcall
.assign
= 0;
4078 if (e
->ts
.type
== BT_UNKNOWN
4079 && target
->function
)
4081 if (target
->is_generic
)
4082 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4084 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4089 /* This subroutine is called when an expression is being resolved.
4090 The expression node in question is either a user defined operator
4091 or an intrinsic operator with arguments that aren't compatible
4092 with the operator. This subroutine builds an actual argument list
4093 corresponding to the operands, then searches for a compatible
4094 interface. If one is found, the expression node is replaced with
4095 the appropriate function call. We use the 'match' enum to specify
4096 whether a replacement has been made or not, or if an error occurred. */
4099 gfc_extend_expr (gfc_expr
*e
)
4101 gfc_actual_arglist
*actual
;
4107 gfc_typebound_proc
* tbo
;
4112 actual
= gfc_get_actual_arglist ();
4113 actual
->expr
= e
->value
.op
.op1
;
4117 if (e
->value
.op
.op2
!= NULL
)
4119 actual
->next
= gfc_get_actual_arglist ();
4120 actual
->next
->expr
= e
->value
.op
.op2
;
4123 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4125 /* See if we find a matching type-bound operator. */
4126 if (i
== INTRINSIC_USER
)
4127 tbo
= matching_typebound_op (&tb_base
, actual
,
4128 i
, e
->value
.op
.uop
->name
, &gname
);
4132 #define CHECK_OS_COMPARISON(comp) \
4133 case INTRINSIC_##comp: \
4134 case INTRINSIC_##comp##_OS: \
4135 tbo = matching_typebound_op (&tb_base, actual, \
4136 INTRINSIC_##comp, NULL, &gname); \
4138 tbo = matching_typebound_op (&tb_base, actual, \
4139 INTRINSIC_##comp##_OS, NULL, &gname); \
4141 CHECK_OS_COMPARISON(EQ
)
4142 CHECK_OS_COMPARISON(NE
)
4143 CHECK_OS_COMPARISON(GT
)
4144 CHECK_OS_COMPARISON(GE
)
4145 CHECK_OS_COMPARISON(LT
)
4146 CHECK_OS_COMPARISON(LE
)
4147 #undef CHECK_OS_COMPARISON
4150 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4154 /* If there is a matching typebound-operator, replace the expression with
4155 a call to it and succeed. */
4158 gcc_assert (tb_base
);
4159 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4161 if (!gfc_resolve_expr (e
))
4167 if (i
== INTRINSIC_USER
)
4169 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4171 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4175 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4182 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4184 /* Due to the distinction between '==' and '.eq.' and friends, one has
4185 to check if either is defined. */
4188 #define CHECK_OS_COMPARISON(comp) \
4189 case INTRINSIC_##comp: \
4190 case INTRINSIC_##comp##_OS: \
4191 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4193 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4195 CHECK_OS_COMPARISON(EQ
)
4196 CHECK_OS_COMPARISON(NE
)
4197 CHECK_OS_COMPARISON(GT
)
4198 CHECK_OS_COMPARISON(GE
)
4199 CHECK_OS_COMPARISON(LT
)
4200 CHECK_OS_COMPARISON(LE
)
4201 #undef CHECK_OS_COMPARISON
4204 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4212 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4213 found rather than just taking the first one and not checking further. */
4217 /* Don't use gfc_free_actual_arglist(). */
4218 free (actual
->next
);
4223 /* Change the expression node to a function call. */
4224 e
->expr_type
= EXPR_FUNCTION
;
4225 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4226 e
->value
.function
.actual
= actual
;
4227 e
->value
.function
.esym
= NULL
;
4228 e
->value
.function
.isym
= NULL
;
4229 e
->value
.function
.name
= NULL
;
4230 e
->user_operator
= 1;
4232 if (!gfc_resolve_expr (e
))
4239 /* Tries to replace an assignment code node with a subroutine call to the
4240 subroutine associated with the assignment operator. Return true if the node
4241 was replaced. On false, no error is generated. */
4244 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4246 gfc_actual_arglist
*actual
;
4247 gfc_expr
*lhs
, *rhs
, *tb_base
;
4248 gfc_symbol
*sym
= NULL
;
4249 const char *gname
= NULL
;
4250 gfc_typebound_proc
* tbo
;
4255 /* Don't allow an intrinsic assignment to be replaced. */
4256 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4257 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4258 && (lhs
->ts
.type
== rhs
->ts
.type
4259 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4262 actual
= gfc_get_actual_arglist ();
4265 actual
->next
= gfc_get_actual_arglist ();
4266 actual
->next
->expr
= rhs
;
4268 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4270 /* See if we find a matching type-bound assignment. */
4271 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4276 /* Success: Replace the expression with a type-bound call. */
4277 gcc_assert (tb_base
);
4278 c
->expr1
= gfc_get_expr ();
4279 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4280 c
->expr1
->value
.compcall
.assign
= 1;
4281 c
->expr1
->where
= c
->loc
;
4283 c
->op
= EXEC_COMPCALL
;
4287 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4288 for (; ns
; ns
= ns
->parent
)
4290 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4297 /* Success: Replace the assignment with the call. */
4298 c
->op
= EXEC_ASSIGN_CALL
;
4299 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4302 c
->ext
.actual
= actual
;
4306 /* Failure: No assignment procedure found. */
4307 free (actual
->next
);
4313 /* Make sure that the interface just parsed is not already present in
4314 the given interface list. Ambiguity isn't checked yet since module
4315 procedures can be present without interfaces. */
4318 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4322 for (ip
= base
; ip
; ip
= ip
->next
)
4324 if (ip
->sym
== new_sym
)
4326 gfc_error ("Entity %qs at %L is already present in the interface",
4327 new_sym
->name
, &loc
);
4336 /* Add a symbol to the current interface. */
4339 gfc_add_interface (gfc_symbol
*new_sym
)
4341 gfc_interface
**head
, *intr
;
4345 switch (current_interface
.type
)
4347 case INTERFACE_NAMELESS
:
4348 case INTERFACE_ABSTRACT
:
4351 case INTERFACE_INTRINSIC_OP
:
4352 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4353 switch (current_interface
.op
)
4356 case INTRINSIC_EQ_OS
:
4357 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4359 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4360 new_sym
, gfc_current_locus
))
4365 case INTRINSIC_NE_OS
:
4366 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4368 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4369 new_sym
, gfc_current_locus
))
4374 case INTRINSIC_GT_OS
:
4375 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4376 new_sym
, gfc_current_locus
)
4377 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4378 new_sym
, gfc_current_locus
))
4383 case INTRINSIC_GE_OS
:
4384 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4385 new_sym
, gfc_current_locus
)
4386 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4387 new_sym
, gfc_current_locus
))
4392 case INTRINSIC_LT_OS
:
4393 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4394 new_sym
, gfc_current_locus
)
4395 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4396 new_sym
, gfc_current_locus
))
4401 case INTRINSIC_LE_OS
:
4402 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4403 new_sym
, gfc_current_locus
)
4404 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4405 new_sym
, gfc_current_locus
))
4410 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4411 new_sym
, gfc_current_locus
))
4415 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4418 case INTERFACE_GENERIC
:
4419 case INTERFACE_DTIO
:
4420 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4422 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4426 if (!gfc_check_new_interface (sym
->generic
,
4427 new_sym
, gfc_current_locus
))
4431 head
= ¤t_interface
.sym
->generic
;
4434 case INTERFACE_USER_OP
:
4435 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4436 new_sym
, gfc_current_locus
))
4439 head
= ¤t_interface
.uop
->op
;
4443 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4446 intr
= gfc_get_interface ();
4447 intr
->sym
= new_sym
;
4448 intr
->where
= gfc_current_locus
;
4458 gfc_current_interface_head (void)
4460 switch (current_interface
.type
)
4462 case INTERFACE_INTRINSIC_OP
:
4463 return current_interface
.ns
->op
[current_interface
.op
];
4465 case INTERFACE_GENERIC
:
4466 case INTERFACE_DTIO
:
4467 return current_interface
.sym
->generic
;
4469 case INTERFACE_USER_OP
:
4470 return current_interface
.uop
->op
;
4479 gfc_set_current_interface_head (gfc_interface
*i
)
4481 switch (current_interface
.type
)
4483 case INTERFACE_INTRINSIC_OP
:
4484 current_interface
.ns
->op
[current_interface
.op
] = i
;
4487 case INTERFACE_GENERIC
:
4488 case INTERFACE_DTIO
:
4489 current_interface
.sym
->generic
= i
;
4492 case INTERFACE_USER_OP
:
4493 current_interface
.uop
->op
= i
;
4502 /* Gets rid of a formal argument list. We do not free symbols.
4503 Symbols are freed when a namespace is freed. */
4506 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4508 gfc_formal_arglist
*q
;
4518 /* Check that it is ok for the type-bound procedure 'proc' to override the
4519 procedure 'old', cf. F08:4.5.7.3. */
4522 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4525 gfc_symbol
*proc_target
, *old_target
;
4526 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4527 gfc_formal_arglist
*proc_formal
, *old_formal
;
4531 /* This procedure should only be called for non-GENERIC proc. */
4532 gcc_assert (!proc
->n
.tb
->is_generic
);
4534 /* If the overwritten procedure is GENERIC, this is an error. */
4535 if (old
->n
.tb
->is_generic
)
4537 gfc_error ("Can't overwrite GENERIC %qs at %L",
4538 old
->name
, &proc
->n
.tb
->where
);
4542 where
= proc
->n
.tb
->where
;
4543 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4544 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4546 /* Check that overridden binding is not NON_OVERRIDABLE. */
4547 if (old
->n
.tb
->non_overridable
)
4549 gfc_error ("%qs at %L overrides a procedure binding declared"
4550 " NON_OVERRIDABLE", proc
->name
, &where
);
4554 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4555 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4557 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4558 " non-DEFERRED binding", proc
->name
, &where
);
4562 /* If the overridden binding is PURE, the overriding must be, too. */
4563 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4565 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4566 proc
->name
, &where
);
4570 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4571 is not, the overriding must not be either. */
4572 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4574 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4575 " ELEMENTAL", proc
->name
, &where
);
4578 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4580 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4581 " be ELEMENTAL, either", proc
->name
, &where
);
4585 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4587 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4589 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4590 " SUBROUTINE", proc
->name
, &where
);
4594 /* If the overridden binding is a FUNCTION, the overriding must also be a
4595 FUNCTION and have the same characteristics. */
4596 if (old_target
->attr
.function
)
4598 if (!proc_target
->attr
.function
)
4600 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4601 " FUNCTION", proc
->name
, &where
);
4605 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4608 gfc_error ("Result mismatch for the overriding procedure "
4609 "%qs at %L: %s", proc
->name
, &where
, err
);
4614 /* If the overridden binding is PUBLIC, the overriding one must not be
4616 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4617 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4619 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4620 " PRIVATE", proc
->name
, &where
);
4624 /* Compare the formal argument lists of both procedures. This is also abused
4625 to find the position of the passed-object dummy arguments of both
4626 bindings as at least the overridden one might not yet be resolved and we
4627 need those positions in the check below. */
4628 proc_pass_arg
= old_pass_arg
= 0;
4629 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4631 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4634 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4635 old_formal
= gfc_sym_get_dummy_args (old_target
);
4636 for ( ; proc_formal
&& old_formal
;
4637 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4639 if (proc
->n
.tb
->pass_arg
4640 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4641 proc_pass_arg
= argpos
;
4642 if (old
->n
.tb
->pass_arg
4643 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4644 old_pass_arg
= argpos
;
4646 /* Check that the names correspond. */
4647 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4649 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4650 " to match the corresponding argument of the overridden"
4651 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4652 old_formal
->sym
->name
);
4656 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4657 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4658 check_type
, err
, sizeof(err
)))
4660 gfc_error_opt (OPT_Wargument_mismatch
,
4661 "Argument mismatch for the overriding procedure "
4662 "%qs at %L: %s", proc
->name
, &where
, err
);
4668 if (proc_formal
|| old_formal
)
4670 gfc_error ("%qs at %L must have the same number of formal arguments as"
4671 " the overridden procedure", proc
->name
, &where
);
4675 /* If the overridden binding is NOPASS, the overriding one must also be
4677 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4679 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4680 " NOPASS", proc
->name
, &where
);
4684 /* If the overridden binding is PASS(x), the overriding one must also be
4685 PASS and the passed-object dummy arguments must correspond. */
4686 if (!old
->n
.tb
->nopass
)
4688 if (proc
->n
.tb
->nopass
)
4690 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4691 " PASS", proc
->name
, &where
);
4695 if (proc_pass_arg
!= old_pass_arg
)
4697 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4698 " the same position as the passed-object dummy argument of"
4699 " the overridden procedure", proc
->name
, &where
);
4708 /* The following three functions check that the formal arguments
4709 of user defined derived type IO procedures are compliant with
4710 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4713 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4714 int kind
, int rank
, sym_intent intent
)
4716 if (fsym
->ts
.type
!= type
)
4718 gfc_error ("DTIO dummy argument at %L must be of type %s",
4719 &fsym
->declared_at
, gfc_basic_typename (type
));
4723 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4724 && fsym
->ts
.kind
!= kind
)
4725 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4726 &fsym
->declared_at
, kind
);
4730 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4731 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4732 gfc_error ("DTIO dummy argument at %L must be a scalar",
4733 &fsym
->declared_at
);
4735 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4736 gfc_error ("DTIO dummy argument at %L must be an "
4737 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4739 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4740 gfc_error ("DTIO character argument at %L must have assumed length",
4741 &fsym
->declared_at
);
4743 if (fsym
->attr
.intent
!= intent
)
4744 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4745 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4751 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4752 bool typebound
, bool formatted
, int code
)
4754 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4755 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4756 gfc_interface
*intr
;
4757 gfc_formal_arglist
*formal
;
4760 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4761 || ((dtio_codes
)code
== DTIO_RUF
);
4769 /* Typebound DTIO binding. */
4770 tb_io_proc
= tb_io_st
->n
.tb
;
4771 if (tb_io_proc
== NULL
)
4774 gcc_assert (tb_io_proc
->is_generic
);
4776 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4777 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4780 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4784 generic_proc
= tb_io_st
->n
.sym
;
4785 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4788 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4790 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4791 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4792 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4794 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4795 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4797 dtio_sub
= intr
->sym
;
4800 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4802 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4803 "procedure", &intr
->sym
->declared_at
);
4808 if (dtio_sub
== NULL
)
4812 gcc_assert (dtio_sub
);
4813 if (!dtio_sub
->attr
.subroutine
)
4814 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4815 dtio_sub
->name
, &dtio_sub
->declared_at
);
4818 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4821 if (arg_num
< (formatted
? 6 : 4))
4823 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4824 dtio_sub
->name
, &dtio_sub
->declared_at
);
4828 if (arg_num
> (formatted
? 6 : 4))
4830 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4831 dtio_sub
->name
, &dtio_sub
->declared_at
);
4836 /* Now go through the formal arglist. */
4838 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4840 if (!formatted
&& arg_num
== 3)
4846 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4847 "procedure", &dtio_sub
->declared_at
);
4854 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4855 BT_DERIVED
: BT_CLASS
;
4857 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4858 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4864 kind
= gfc_default_integer_kind
;
4866 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4869 case(3): /* IOTYPE */
4870 type
= BT_CHARACTER
;
4871 kind
= gfc_default_character_kind
;
4873 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4876 case(4): /* VLIST */
4878 kind
= gfc_default_integer_kind
;
4880 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4883 case(5): /* IOSTAT */
4885 kind
= gfc_default_integer_kind
;
4886 intent
= INTENT_OUT
;
4887 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4890 case(6): /* IOMSG */
4891 type
= BT_CHARACTER
;
4892 kind
= gfc_default_character_kind
;
4893 intent
= INTENT_INOUT
;
4894 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4901 derived
->attr
.has_dtio_procs
= 1;
4906 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4908 gfc_symtree
*tb_io_st
;
4913 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4916 /* Check typebound DTIO bindings. */
4917 for (code
= 0; code
< 4; code
++)
4919 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4920 || ((dtio_codes
)code
== DTIO_WF
);
4922 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4923 gfc_code2string (dtio_procs
, code
),
4924 true, &derived
->declared_at
);
4925 if (tb_io_st
!= NULL
)
4926 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4929 /* Check generic DTIO interfaces. */
4930 for (code
= 0; code
< 4; code
++)
4932 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4933 || ((dtio_codes
)code
== DTIO_WF
);
4935 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4936 gfc_code2string (dtio_procs
, code
));
4937 if (tb_io_st
!= NULL
)
4938 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4944 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4946 gfc_symtree
*tb_io_st
= NULL
;
4949 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4952 /* Try to find a typebound DTIO binding. */
4953 if (formatted
== true)
4956 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4957 gfc_code2string (dtio_procs
,
4960 &derived
->declared_at
);
4962 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4963 gfc_code2string (dtio_procs
,
4966 &derived
->declared_at
);
4971 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4972 gfc_code2string (dtio_procs
,
4975 &derived
->declared_at
);
4977 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4978 gfc_code2string (dtio_procs
,
4981 &derived
->declared_at
);
4988 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4990 gfc_symtree
*tb_io_st
= NULL
;
4991 gfc_symbol
*dtio_sub
= NULL
;
4992 gfc_symbol
*extended
;
4993 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4995 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
4997 if (tb_io_st
!= NULL
)
4999 const char *genname
;
5002 tb_io_proc
= tb_io_st
->n
.tb
;
5003 gcc_assert (tb_io_proc
!= NULL
);
5004 gcc_assert (tb_io_proc
->is_generic
);
5005 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
5007 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5008 gcc_assert (!specific_proc
->is_generic
);
5010 /* Go back and make sure that we have the right specific procedure.
5011 Here we most likely have a procedure from the parent type, which
5012 can be overridden in extensions. */
5013 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
5014 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
5015 true, &tb_io_proc
->where
);
5017 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
5019 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5024 /* If there is not a typebound binding, look for a generic
5026 for (extended
= derived
; extended
;
5027 extended
= gfc_get_derived_super_type (extended
))
5029 if (extended
== NULL
|| extended
->ns
== NULL
5030 || extended
->attr
.flavor
== FL_UNKNOWN
)
5033 if (formatted
== true)
5036 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5037 gfc_code2string (dtio_procs
,
5040 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5041 gfc_code2string (dtio_procs
,
5047 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5048 gfc_code2string (dtio_procs
,
5051 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5052 gfc_code2string (dtio_procs
,
5056 if (tb_io_st
!= NULL
5058 && tb_io_st
->n
.sym
->generic
)
5060 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5061 intr
&& intr
->sym
; intr
= intr
->next
)
5063 if (intr
->sym
->formal
)
5065 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5066 if ((fsym
->ts
.type
== BT_CLASS
5067 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5068 || (fsym
->ts
.type
== BT_DERIVED
5069 && fsym
->ts
.u
.derived
== extended
))
5071 dtio_sub
= intr
->sym
;
5080 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5081 gfc_find_derived_vtab (derived
);