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 /* Perform the correspondence test in rule (3) of F08:C1215.
1194 Returns zero if no argument is found that satisfies this rule,
1195 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1198 This test is also not symmetric in f1 and f2 and must be called
1199 twice. This test finds problems caused by sorting the actual
1200 argument list with keywords. For example:
1204 INTEGER :: A ; REAL :: B
1208 INTEGER :: A ; REAL :: B
1212 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1215 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1216 const char *p1
, const char *p2
)
1218 gfc_formal_arglist
*f2_save
, *g
;
1225 if (f1
->sym
->attr
.optional
)
1228 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1230 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1233 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1234 || compare_type_rank (f2
->sym
, f1
->sym
))
1235 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1236 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1237 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1240 /* Now search for a disambiguating keyword argument starting at
1241 the current non-match. */
1242 for (g
= f1
; g
; g
= g
->next
)
1244 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1247 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1248 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1249 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1250 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1251 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1267 symbol_rank (gfc_symbol
*sym
)
1269 gfc_array_spec
*as
= NULL
;
1271 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1272 as
= CLASS_DATA (sym
)->as
;
1276 return as
? as
->rank
: 0;
1280 /* Check if the characteristics of two dummy arguments match,
1284 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1285 bool type_must_agree
, char *errmsg
,
1288 if (s1
== NULL
|| s2
== NULL
)
1289 return s1
== s2
? true : false;
1291 /* Check type and rank. */
1292 if (type_must_agree
)
1294 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1296 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1297 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1300 if (!compare_rank (s1
, s2
))
1302 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1303 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1309 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1311 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1316 /* Check OPTIONAL attribute. */
1317 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1319 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1324 /* Check ALLOCATABLE attribute. */
1325 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1327 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1332 /* Check POINTER attribute. */
1333 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1335 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1340 /* Check TARGET attribute. */
1341 if (s1
->attr
.target
!= s2
->attr
.target
)
1343 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1348 /* Check ASYNCHRONOUS attribute. */
1349 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1351 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1356 /* Check CONTIGUOUS attribute. */
1357 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1359 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1364 /* Check VALUE attribute. */
1365 if (s1
->attr
.value
!= s2
->attr
.value
)
1367 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1372 /* Check VOLATILE attribute. */
1373 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1375 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1380 /* Check interface of dummy procedures. */
1381 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1384 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1387 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1388 "'%s': %s", s1
->name
, err
);
1393 /* Check string length. */
1394 if (s1
->ts
.type
== BT_CHARACTER
1395 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1396 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1398 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1399 s2
->ts
.u
.cl
->length
);
1405 snprintf (errmsg
, err_len
, "Character length mismatch "
1406 "in argument '%s'", s1
->name
);
1410 /* FIXME: Implement a warning for this case.
1411 gfc_warning (0, "Possible character length mismatch in argument %qs",
1419 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1420 "%i of gfc_dep_compare_expr", compval
);
1425 /* Check array shape. */
1426 if (s1
->as
&& s2
->as
)
1429 gfc_expr
*shape1
, *shape2
;
1431 if (s1
->as
->type
!= s2
->as
->type
)
1433 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1438 if (s1
->as
->corank
!= s2
->as
->corank
)
1440 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1441 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1445 if (s1
->as
->type
== AS_EXPLICIT
)
1446 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1448 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1449 gfc_copy_expr (s1
->as
->lower
[i
]));
1450 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1451 gfc_copy_expr (s2
->as
->lower
[i
]));
1452 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1453 gfc_free_expr (shape1
);
1454 gfc_free_expr (shape2
);
1460 if (i
< s1
->as
->rank
)
1461 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1462 " argument '%s'", i
+ 1, s1
->name
);
1464 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1465 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1469 /* FIXME: Implement a warning for this case.
1470 gfc_warning (0, "Possible shape mismatch in argument %qs",
1478 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1479 "result %i of gfc_dep_compare_expr",
1490 /* Check if the characteristics of two function results match,
1494 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1495 char *errmsg
, int err_len
)
1497 gfc_symbol
*r1
, *r2
;
1499 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1500 r1
= s1
->ts
.interface
->result
;
1502 r1
= s1
->result
? s1
->result
: s1
;
1504 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1505 r2
= s2
->ts
.interface
->result
;
1507 r2
= s2
->result
? s2
->result
: s2
;
1509 if (r1
->ts
.type
== BT_UNKNOWN
)
1512 /* Check type and rank. */
1513 if (!compare_type (r1
, r2
))
1515 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1516 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1519 if (!compare_rank (r1
, r2
))
1521 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1522 symbol_rank (r1
), symbol_rank (r2
));
1526 /* Check ALLOCATABLE attribute. */
1527 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1529 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1534 /* Check POINTER attribute. */
1535 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1537 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1542 /* Check CONTIGUOUS attribute. */
1543 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1545 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1550 /* Check PROCEDURE POINTER attribute. */
1551 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1553 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1558 /* Check string length. */
1559 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1561 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1563 snprintf (errmsg
, err_len
, "Character length mismatch "
1564 "in function result");
1568 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1570 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1571 r2
->ts
.u
.cl
->length
);
1577 snprintf (errmsg
, err_len
, "Character length mismatch "
1578 "in function result");
1582 /* FIXME: Implement a warning for this case.
1583 snprintf (errmsg, err_len, "Possible character length mismatch "
1584 "in function result");*/
1591 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1592 "result %i of gfc_dep_compare_expr", compval
);
1598 /* Check array shape. */
1599 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1602 gfc_expr
*shape1
, *shape2
;
1604 if (r1
->as
->type
!= r2
->as
->type
)
1606 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1610 if (r1
->as
->type
== AS_EXPLICIT
)
1611 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1613 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1614 gfc_copy_expr (r1
->as
->lower
[i
]));
1615 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1616 gfc_copy_expr (r2
->as
->lower
[i
]));
1617 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1618 gfc_free_expr (shape1
);
1619 gfc_free_expr (shape2
);
1625 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1626 "function result", i
+ 1);
1630 /* FIXME: Implement a warning for this case.
1631 gfc_warning (0, "Possible shape mismatch in return value");*/
1638 gfc_internal_error ("check_result_characteristics (2): "
1639 "Unexpected result %i of "
1640 "gfc_dep_compare_expr", compval
);
1650 /* 'Compare' two formal interfaces associated with a pair of symbols.
1651 We return true if there exists an actual argument list that
1652 would be ambiguous between the two interfaces, zero otherwise.
1653 'strict_flag' specifies whether all the characteristics are
1654 required to match, which is not the case for ambiguity checks.
1655 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1658 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1659 int generic_flag
, int strict_flag
,
1660 char *errmsg
, int err_len
,
1661 const char *p1
, const char *p2
)
1663 gfc_formal_arglist
*f1
, *f2
;
1665 gcc_assert (name2
!= NULL
);
1667 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1668 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1669 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1672 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1676 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1679 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1683 /* Do strict checks on all characteristics
1684 (for dummy procedures and procedure pointer assignments). */
1685 if (!generic_flag
&& strict_flag
)
1687 if (s1
->attr
.function
&& s2
->attr
.function
)
1689 /* If both are functions, check result characteristics. */
1690 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1691 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1695 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1697 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1700 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1702 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1707 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1708 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1711 f1
= gfc_sym_get_dummy_args (s1
);
1712 f2
= gfc_sym_get_dummy_args (s2
);
1714 /* Special case: No arguments. */
1715 if (f1
== NULL
&& f2
== NULL
)
1720 if (count_types_test (f1
, f2
, p1
, p2
)
1721 || count_types_test (f2
, f1
, p2
, p1
))
1724 /* Special case: alternate returns. If both f1->sym and f2->sym are
1725 NULL, then the leading formal arguments are alternate returns.
1726 The previous conditional should catch argument lists with
1727 different number of argument. */
1728 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1731 if (generic_correspondence (f1
, f2
, p1
, p2
)
1732 || generic_correspondence (f2
, f1
, p2
, p1
))
1736 /* Perform the abbreviated correspondence test for operators (the
1737 arguments cannot be optional and are always ordered correctly).
1738 This is also done when comparing interfaces for dummy procedures and in
1739 procedure pointer assignments. */
1741 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1743 /* Check existence. */
1744 if (f1
== NULL
|| f2
== NULL
)
1747 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1748 "arguments", name2
);
1754 /* Check all characteristics. */
1755 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1761 /* Only check type and rank. */
1762 if (!compare_type (f2
->sym
, f1
->sym
))
1765 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1766 "(%s/%s)", f1
->sym
->name
,
1767 gfc_typename (&f1
->sym
->ts
),
1768 gfc_typename (&f2
->sym
->ts
));
1771 if (!compare_rank (f2
->sym
, f1
->sym
))
1774 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1775 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1776 symbol_rank (f2
->sym
));
1786 /* Given a pointer to an interface pointer, remove duplicate
1787 interfaces and make sure that all symbols are either functions
1788 or subroutines, and all of the same kind. Returns true if
1789 something goes wrong. */
1792 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1794 gfc_interface
*psave
, *q
, *qlast
;
1797 for (; p
; p
= p
->next
)
1799 /* Make sure all symbols in the interface have been defined as
1800 functions or subroutines. */
1801 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1802 || !p
->sym
->attr
.if_source
)
1803 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1806 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1808 if (p
->sym
->attr
.external
)
1810 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1811 "; did you mean %qs?",
1812 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1815 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1816 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1819 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1820 "subroutine; did you mean %qs?", p
->sym
->name
,
1821 interface_name
, &p
->sym
->declared_at
, guessed
);
1823 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1824 "subroutine", p
->sym
->name
, interface_name
,
1825 &p
->sym
->declared_at
);
1829 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1830 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1831 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1832 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1834 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1835 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1836 " or all FUNCTIONs", interface_name
,
1837 &p
->sym
->declared_at
);
1838 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1839 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1840 "generic name is also the name of a derived type",
1841 interface_name
, &p
->sym
->declared_at
);
1845 /* F2003, C1207. F2008, C1207. */
1846 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1847 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1848 "%qs in %s at %L", p
->sym
->name
,
1849 interface_name
, &p
->sym
->declared_at
))
1854 /* Remove duplicate interfaces in this interface list. */
1855 for (; p
; p
= p
->next
)
1859 for (q
= p
->next
; q
;)
1861 if (p
->sym
!= q
->sym
)
1868 /* Duplicate interface. */
1869 qlast
->next
= q
->next
;
1880 /* Check lists of interfaces to make sure that no two interfaces are
1881 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1884 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1885 int generic_flag
, const char *interface_name
,
1889 for (; p
; p
= p
->next
)
1890 for (q
= q0
; q
; q
= q
->next
)
1892 if (p
->sym
== q
->sym
)
1893 continue; /* Duplicates OK here. */
1895 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1898 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1899 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1900 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1901 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1904 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1905 "and %qs at %L", interface_name
,
1906 q
->sym
->name
, &q
->sym
->declared_at
,
1907 p
->sym
->name
, &p
->sym
->declared_at
);
1908 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1909 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1910 "and %qs at %L", interface_name
,
1911 q
->sym
->name
, &q
->sym
->declared_at
,
1912 p
->sym
->name
, &p
->sym
->declared_at
);
1914 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1915 "interfaces at %L", interface_name
, &p
->where
);
1923 /* Check the generic and operator interfaces of symbols to make sure
1924 that none of the interfaces conflict. The check has to be done
1925 after all of the symbols are actually loaded. */
1928 check_sym_interfaces (gfc_symbol
*sym
)
1930 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("generic interface ''")];
1933 if (sym
->ns
!= gfc_current_ns
)
1936 if (sym
->generic
!= NULL
)
1938 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1939 if (check_interface0 (sym
->generic
, interface_name
))
1942 for (p
= sym
->generic
; p
; p
= p
->next
)
1944 if (p
->sym
->attr
.mod_proc
1945 && !p
->sym
->attr
.module_procedure
1946 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1947 || p
->sym
->attr
.procedure
))
1949 gfc_error ("%qs at %L is not a module procedure",
1950 p
->sym
->name
, &p
->where
);
1955 /* Originally, this test was applied to host interfaces too;
1956 this is incorrect since host associated symbols, from any
1957 source, cannot be ambiguous with local symbols. */
1958 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1959 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1965 check_uop_interfaces (gfc_user_op
*uop
)
1967 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
1971 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1972 if (check_interface0 (uop
->op
, interface_name
))
1975 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1977 uop2
= gfc_find_uop (uop
->name
, ns
);
1981 check_interface1 (uop
->op
, uop2
->op
, 0,
1982 interface_name
, true);
1986 /* Given an intrinsic op, return an equivalent op if one exists,
1987 or INTRINSIC_NONE otherwise. */
1990 gfc_equivalent_op (gfc_intrinsic_op op
)
1995 return INTRINSIC_EQ_OS
;
1997 case INTRINSIC_EQ_OS
:
1998 return INTRINSIC_EQ
;
2001 return INTRINSIC_NE_OS
;
2003 case INTRINSIC_NE_OS
:
2004 return INTRINSIC_NE
;
2007 return INTRINSIC_GT_OS
;
2009 case INTRINSIC_GT_OS
:
2010 return INTRINSIC_GT
;
2013 return INTRINSIC_GE_OS
;
2015 case INTRINSIC_GE_OS
:
2016 return INTRINSIC_GE
;
2019 return INTRINSIC_LT_OS
;
2021 case INTRINSIC_LT_OS
:
2022 return INTRINSIC_LT
;
2025 return INTRINSIC_LE_OS
;
2027 case INTRINSIC_LE_OS
:
2028 return INTRINSIC_LE
;
2031 return INTRINSIC_NONE
;
2035 /* For the namespace, check generic, user operator and intrinsic
2036 operator interfaces for consistency and to remove duplicate
2037 interfaces. We traverse the whole namespace, counting on the fact
2038 that most symbols will not have generic or operator interfaces. */
2041 gfc_check_interfaces (gfc_namespace
*ns
)
2043 gfc_namespace
*old_ns
, *ns2
;
2044 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2047 old_ns
= gfc_current_ns
;
2048 gfc_current_ns
= ns
;
2050 gfc_traverse_ns (ns
, check_sym_interfaces
);
2052 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2054 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2056 if (i
== INTRINSIC_USER
)
2059 if (i
== INTRINSIC_ASSIGN
)
2060 strcpy (interface_name
, "intrinsic assignment operator");
2062 sprintf (interface_name
, "intrinsic '%s' operator",
2063 gfc_op2string ((gfc_intrinsic_op
) i
));
2065 if (check_interface0 (ns
->op
[i
], interface_name
))
2069 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2072 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2074 gfc_intrinsic_op other_op
;
2076 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2077 interface_name
, true))
2080 /* i should be gfc_intrinsic_op, but has to be int with this cast
2081 here for stupid C++ compatibility rules. */
2082 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2083 if (other_op
!= INTRINSIC_NONE
2084 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2085 0, interface_name
, true))
2091 gfc_current_ns
= old_ns
;
2095 /* Given a symbol of a formal argument list and an expression, if the
2096 formal argument is allocatable, check that the actual argument is
2097 allocatable. Returns true if compatible, zero if not compatible. */
2100 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2102 if (formal
->attr
.allocatable
2103 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2105 symbol_attribute attr
= gfc_expr_attr (actual
);
2106 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2108 else if (!attr
.allocatable
)
2116 /* Given a symbol of a formal argument list and an expression, if the
2117 formal argument is a pointer, see if the actual argument is a
2118 pointer. Returns nonzero if compatible, zero if not compatible. */
2121 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2123 symbol_attribute attr
;
2125 if (formal
->attr
.pointer
2126 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2127 && CLASS_DATA (formal
)->attr
.class_pointer
))
2129 attr
= gfc_expr_attr (actual
);
2131 /* Fortran 2008 allows non-pointer actual arguments. */
2132 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2143 /* Emit clear error messages for rank mismatch. */
2146 argument_rank_mismatch (const char *name
, locus
*where
,
2147 int rank1
, int rank2
)
2150 /* TS 29113, C407b. */
2152 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2153 " %qs has assumed-rank", where
, name
);
2154 else if (rank1
== 0)
2155 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2156 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2157 else if (rank2
== 0)
2158 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2159 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2161 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2162 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2166 /* Given a symbol of a formal argument list and an expression, see if
2167 the two are compatible as arguments. Returns true if
2168 compatible, false if not compatible. */
2171 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2172 int ranks_must_agree
, int is_elemental
, locus
*where
)
2175 bool rank_check
, is_pointer
;
2179 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2180 procs c_f_pointer or c_f_procpointer, and we need to accept most
2181 pointers the user could give us. This should allow that. */
2182 if (formal
->ts
.type
== BT_VOID
)
2185 if (formal
->ts
.type
== BT_DERIVED
2186 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2187 && actual
->ts
.type
== BT_DERIVED
2188 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2191 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2192 /* Make sure the vtab symbol is present when
2193 the module variables are generated. */
2194 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2196 if (actual
->ts
.type
== BT_PROCEDURE
)
2198 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2200 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2203 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2207 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2208 sizeof(err
), NULL
, NULL
))
2211 gfc_error_opt (OPT_Wargument_mismatch
,
2212 "Interface mismatch in dummy procedure %qs at %L:"
2213 " %s", formal
->name
, &actual
->where
, err
);
2217 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2219 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2220 &act_sym
->declared_at
);
2221 if (act_sym
->ts
.type
== BT_UNKNOWN
2222 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2225 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2226 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2227 &act_sym
->declared_at
);
2232 ppc
= gfc_get_proc_ptr_comp (actual
);
2233 if (ppc
&& ppc
->ts
.interface
)
2235 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2236 err
, sizeof(err
), NULL
, NULL
))
2239 gfc_error_opt (OPT_Wargument_mismatch
,
2240 "Interface mismatch in dummy procedure %qs at %L:"
2241 " %s", formal
->name
, &actual
->where
, err
);
2247 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2248 && !gfc_is_simply_contiguous (actual
, true, false))
2251 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2252 "must be simply contiguous", formal
->name
, &actual
->where
);
2256 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2257 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2260 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2261 && actual
->ts
.type
!= BT_HOLLERITH
2262 && formal
->ts
.type
!= BT_ASSUMED
2263 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2264 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2265 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2266 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2267 CLASS_DATA (actual
)->ts
.u
.derived
)))
2270 gfc_error_opt (OPT_Wargument_mismatch
,
2271 "Type mismatch in argument %qs at %L; passed %s to %s",
2272 formal
->name
, where
, gfc_typename (&actual
->ts
),
2273 gfc_typename (&formal
->ts
));
2277 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2280 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2281 "argument %qs is of assumed type", &actual
->where
,
2286 /* F2008, 12.5.2.5; IR F08/0073. */
2287 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2288 && actual
->expr_type
!= EXPR_NULL
2289 && ((CLASS_DATA (formal
)->attr
.class_pointer
2290 && formal
->attr
.intent
!= INTENT_IN
)
2291 || CLASS_DATA (formal
)->attr
.allocatable
))
2293 if (actual
->ts
.type
!= BT_CLASS
)
2296 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2297 formal
->name
, &actual
->where
);
2301 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2302 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2303 CLASS_DATA (formal
)->ts
.u
.derived
))
2306 gfc_error ("Actual argument to %qs at %L must have the same "
2307 "declared type", formal
->name
, &actual
->where
);
2312 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2313 is necessary also for F03, so retain error for both.
2314 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2315 compatible, no attempt has been made to channel to this one. */
2316 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2317 && (CLASS_DATA (formal
)->attr
.allocatable
2318 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2321 gfc_error ("Actual argument to %qs at %L must be unlimited "
2322 "polymorphic since the formal argument is a "
2323 "pointer or allocatable unlimited polymorphic "
2324 "entity [F2008: 12.5.2.5]", formal
->name
,
2329 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2332 gfc_error ("Actual argument to %qs at %L must be a coarray",
2333 formal
->name
, &actual
->where
);
2337 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2339 gfc_ref
*last
= NULL
;
2341 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2342 if (ref
->type
== REF_COMPONENT
)
2345 /* F2008, 12.5.2.6. */
2346 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2348 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2351 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2352 formal
->name
, &actual
->where
, formal
->as
->corank
,
2353 last
? last
->u
.c
.component
->as
->corank
2354 : actual
->symtree
->n
.sym
->as
->corank
);
2359 if (formal
->attr
.codimension
)
2361 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2362 /* F2018, 12.5.2.8. */
2363 if (formal
->attr
.dimension
2364 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2365 && actual_attr
.dimension
2366 && !gfc_is_simply_contiguous (actual
, true, true))
2369 gfc_error ("Actual argument to %qs at %L must be simply "
2370 "contiguous or an element of such an array",
2371 formal
->name
, &actual
->where
);
2375 /* F2008, C1303 and C1304. */
2376 if (formal
->attr
.intent
!= INTENT_INOUT
2377 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2378 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2379 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2380 || formal
->attr
.lock_comp
))
2384 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2385 "which is LOCK_TYPE or has a LOCK_TYPE component",
2386 formal
->name
, &actual
->where
);
2390 /* TS18508, C702/C703. */
2391 if (formal
->attr
.intent
!= INTENT_INOUT
2392 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2393 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2394 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2395 || formal
->attr
.event_comp
))
2399 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2400 "which is EVENT_TYPE or has a EVENT_TYPE component",
2401 formal
->name
, &actual
->where
);
2406 /* F2008, C1239/C1240. */
2407 if (actual
->expr_type
== EXPR_VARIABLE
2408 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2409 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2410 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2411 && actual
->rank
&& formal
->as
2412 && !gfc_is_simply_contiguous (actual
, true, false)
2413 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2414 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2415 || formal
->attr
.contiguous
))
2418 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2419 "assumed-rank array without CONTIGUOUS attribute - as actual"
2420 " argument at %L is not simply contiguous and both are "
2421 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2425 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2426 && actual_attr
.codimension
)
2428 if (formal
->attr
.intent
== INTENT_OUT
)
2431 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2432 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2436 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2437 gfc_warning (OPT_Wsurprising
,
2438 "Passing coarray at %L to allocatable, noncoarray dummy "
2439 "argument %qs, which is invalid if the allocation status"
2440 " is modified", &actual
->where
, formal
->name
);
2443 /* If the rank is the same or the formal argument has assumed-rank. */
2444 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2447 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2448 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2449 || formal
->as
->type
== AS_DEFERRED
)
2450 && actual
->expr_type
!= EXPR_NULL
;
2452 /* Skip rank checks for NO_ARG_CHECK. */
2453 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2456 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2457 if (rank_check
|| ranks_must_agree
2458 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2459 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2460 || (actual
->rank
== 0
2461 && ((formal
->ts
.type
== BT_CLASS
2462 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2463 || (formal
->ts
.type
!= BT_CLASS
2464 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2465 && actual
->expr_type
!= EXPR_NULL
)
2466 || (actual
->rank
== 0 && formal
->attr
.dimension
2467 && gfc_is_coindexed (actual
)))
2470 argument_rank_mismatch (formal
->name
, &actual
->where
,
2471 symbol_rank (formal
), actual
->rank
);
2474 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2477 /* At this point, we are considering a scalar passed to an array. This
2478 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2479 - if the actual argument is (a substring of) an element of a
2480 non-assumed-shape/non-pointer/non-polymorphic array; or
2481 - (F2003) if the actual argument is of type character of default/c_char
2484 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2485 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2487 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2489 if (ref
->type
== REF_COMPONENT
)
2490 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2491 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2492 && ref
->u
.ar
.dimen
> 0
2494 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2498 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2501 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2502 "at %L", formal
->name
, &actual
->where
);
2506 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2507 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2510 gfc_error ("Element of assumed-shaped or pointer "
2511 "array passed to array dummy argument %qs at %L",
2512 formal
->name
, &actual
->where
);
2516 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2517 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2519 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2522 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2523 "CHARACTER actual argument with array dummy argument "
2524 "%qs at %L", formal
->name
, &actual
->where
);
2528 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2530 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2531 "array dummy argument %qs at %L",
2532 formal
->name
, &actual
->where
);
2536 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2539 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2542 argument_rank_mismatch (formal
->name
, &actual
->where
,
2543 symbol_rank (formal
), actual
->rank
);
2551 /* Returns the storage size of a symbol (formal argument) or
2552 zero if it cannot be determined. */
2554 static unsigned long
2555 get_sym_storage_size (gfc_symbol
*sym
)
2558 unsigned long strlen
, elements
;
2560 if (sym
->ts
.type
== BT_CHARACTER
)
2562 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2563 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2564 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2571 if (symbol_rank (sym
) == 0)
2575 if (sym
->as
->type
!= AS_EXPLICIT
)
2577 for (i
= 0; i
< sym
->as
->rank
; i
++)
2579 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2580 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2583 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2584 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2587 return strlen
*elements
;
2591 /* Returns the storage size of an expression (actual argument) or
2592 zero if it cannot be determined. For an array element, it returns
2593 the remaining size as the element sequence consists of all storage
2594 units of the actual argument up to the end of the array. */
2596 static unsigned long
2597 get_expr_storage_size (gfc_expr
*e
)
2600 long int strlen
, elements
;
2601 long int substrlen
= 0;
2602 bool is_str_storage
= false;
2608 if (e
->ts
.type
== BT_CHARACTER
)
2610 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2611 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2612 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2613 else if (e
->expr_type
== EXPR_CONSTANT
2614 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2615 strlen
= e
->value
.character
.length
;
2620 strlen
= 1; /* Length per element. */
2622 if (e
->rank
== 0 && !e
->ref
)
2630 for (i
= 0; i
< e
->rank
; i
++)
2631 elements
*= mpz_get_si (e
->shape
[i
]);
2632 return elements
*strlen
;
2635 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2637 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2638 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2642 /* The string length is the substring length.
2643 Set now to full string length. */
2644 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2645 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2648 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2650 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2654 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2655 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2657 long int start
, end
, stride
;
2660 if (ref
->u
.ar
.stride
[i
])
2662 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2663 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2668 if (ref
->u
.ar
.start
[i
])
2670 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2671 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2675 else if (ref
->u
.ar
.as
->lower
[i
]
2676 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2677 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2681 if (ref
->u
.ar
.end
[i
])
2683 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2684 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2688 else if (ref
->u
.ar
.as
->upper
[i
]
2689 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2690 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2694 elements
*= (end
- start
)/stride
+ 1L;
2696 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2697 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2699 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2700 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2701 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2702 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2703 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2704 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2705 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2710 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2711 && e
->expr_type
== EXPR_VARIABLE
)
2713 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2714 || e
->symtree
->n
.sym
->attr
.pointer
)
2720 /* Determine the number of remaining elements in the element
2721 sequence for array element designators. */
2722 is_str_storage
= true;
2723 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2725 if (ref
->u
.ar
.start
[i
] == NULL
2726 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2727 || ref
->u
.ar
.as
->upper
[i
] == NULL
2728 || ref
->u
.ar
.as
->lower
[i
] == NULL
2729 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2730 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2735 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2736 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2738 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2739 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2742 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2743 && ref
->u
.c
.component
->attr
.proc_pointer
2744 && ref
->u
.c
.component
->attr
.dimension
)
2746 /* Array-valued procedure-pointer components. */
2747 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2748 for (i
= 0; i
< as
->rank
; i
++)
2750 if (!as
->upper
[i
] || !as
->lower
[i
]
2751 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2752 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2756 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2757 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2763 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2766 return elements
*strlen
;
2770 /* Given an expression, check whether it is an array section
2771 which has a vector subscript. */
2774 gfc_has_vector_subscript (gfc_expr
*e
)
2779 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2782 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2783 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2784 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2785 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2793 is_procptr_result (gfc_expr
*expr
)
2795 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2797 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2799 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2800 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2804 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2805 number of total candidates in CANDIDATES_LEN. */
2808 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
2810 size_t &candidates_len
)
2812 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
2813 vec_push (candidates
, candidates_len
, p
->sym
->name
);
2817 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2820 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
2822 char **candidates
= NULL
;
2823 size_t candidates_len
= 0;
2824 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
2825 return gfc_closest_fuzzy_match (arg
, candidates
);
2829 /* Given formal and actual argument lists, see if they are compatible.
2830 If they are compatible, the actual argument list is sorted to
2831 correspond with the formal list, and elements for missing optional
2832 arguments are inserted. If WHERE pointer is nonnull, then we issue
2833 errors when things don't match instead of just returning the status
2837 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2838 int ranks_must_agree
, int is_elemental
,
2839 bool in_statement_function
, locus
*where
)
2841 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2842 gfc_formal_arglist
*f
;
2844 unsigned long actual_size
, formal_size
;
2845 bool full_array
= false;
2846 gfc_array_ref
*actual_arr_ref
;
2850 if (actual
== NULL
&& formal
== NULL
)
2854 for (f
= formal
; f
; f
= f
->next
)
2857 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2859 for (i
= 0; i
< n
; i
++)
2866 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2868 if (a
->name
!= NULL
&& in_statement_function
)
2870 gfc_error ("Keyword argument %qs at %L is invalid in "
2871 "a statement function", a
->name
, &a
->expr
->where
);
2875 /* Look for keywords but ignore g77 extensions like %VAL. */
2876 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2879 for (f
= formal
; f
; f
= f
->next
, i
++)
2883 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2891 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
2893 gfc_error ("Keyword argument %qs at %L is not in "
2894 "the procedure; did you mean %qs?",
2895 a
->name
, &a
->expr
->where
, guessed
);
2897 gfc_error ("Keyword argument %qs at %L is not in "
2898 "the procedure", a
->name
, &a
->expr
->where
);
2903 if (new_arg
[i
] != NULL
)
2906 gfc_error ("Keyword argument %qs at %L is already associated "
2907 "with another actual argument", a
->name
,
2916 gfc_error ("More actual than formal arguments in procedure "
2917 "call at %L", where
);
2922 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2928 gfc_error ("Missing alternate return spec in subroutine call "
2933 if (a
->expr
== NULL
)
2936 gfc_error ("Unexpected alternate return spec in subroutine "
2937 "call at %L", where
);
2941 /* Make sure that intrinsic vtables exist for calls to unlimited
2942 polymorphic formal arguments. */
2943 if (UNLIMITED_POLY (f
->sym
)
2944 && a
->expr
->ts
.type
!= BT_DERIVED
2945 && a
->expr
->ts
.type
!= BT_CLASS
)
2946 gfc_find_vtab (&a
->expr
->ts
);
2948 if (a
->expr
->expr_type
== EXPR_NULL
2949 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2950 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2951 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2952 || (f
->sym
->ts
.type
== BT_CLASS
2953 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2954 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2955 || !f
->sym
->attr
.optional
2956 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2959 && (!f
->sym
->attr
.optional
2960 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2961 || (f
->sym
->ts
.type
== BT_CLASS
2962 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2963 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2964 where
, f
->sym
->name
);
2966 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2967 "dummy %qs", where
, f
->sym
->name
);
2972 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2973 is_elemental
, where
))
2976 /* TS 29113, 6.3p2. */
2977 if (f
->sym
->ts
.type
== BT_ASSUMED
2978 && (a
->expr
->ts
.type
== BT_DERIVED
2979 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2981 gfc_namespace
*f2k_derived
;
2983 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2984 ? a
->expr
->ts
.u
.derived
->f2k_derived
2985 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2988 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2990 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2991 "derived type with type-bound or FINAL procedures",
2997 /* Special case for character arguments. For allocatable, pointer
2998 and assumed-shape dummies, the string length needs to match
3000 if (a
->expr
->ts
.type
== BT_CHARACTER
3001 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3002 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3003 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3004 && f
->sym
->ts
.u
.cl
->length
3005 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3006 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3007 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3008 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3009 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3011 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3012 gfc_warning (OPT_Wargument_mismatch
,
3013 "Character length mismatch (%ld/%ld) between actual "
3014 "argument and pointer or allocatable dummy argument "
3016 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3017 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3018 f
->sym
->name
, &a
->expr
->where
);
3020 gfc_warning (OPT_Wargument_mismatch
,
3021 "Character length mismatch (%ld/%ld) between actual "
3022 "argument and assumed-shape dummy argument %qs "
3024 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3025 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3026 f
->sym
->name
, &a
->expr
->where
);
3030 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3031 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3032 && a
->expr
->ts
.type
== BT_CHARACTER
)
3035 gfc_error ("Actual argument at %L to allocatable or "
3036 "pointer dummy argument %qs must have a deferred "
3037 "length type parameter if and only if the dummy has one",
3038 &a
->expr
->where
, f
->sym
->name
);
3042 if (f
->sym
->ts
.type
== BT_CLASS
)
3043 goto skip_size_check
;
3045 actual_size
= get_expr_storage_size (a
->expr
);
3046 formal_size
= get_sym_storage_size (f
->sym
);
3047 if (actual_size
!= 0 && actual_size
< formal_size
3048 && a
->expr
->ts
.type
!= BT_PROCEDURE
3049 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3051 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3052 gfc_warning (OPT_Wargument_mismatch
,
3053 "Character length of actual argument shorter "
3054 "than of dummy argument %qs (%lu/%lu) at %L",
3055 f
->sym
->name
, actual_size
, formal_size
,
3059 /* Emit a warning for -std=legacy and an error otherwise. */
3060 if (gfc_option
.warn_std
== 0)
3061 gfc_warning (OPT_Wargument_mismatch
,
3062 "Actual argument contains too few "
3063 "elements for dummy argument %qs (%lu/%lu) "
3064 "at %L", f
->sym
->name
, actual_size
,
3065 formal_size
, &a
->expr
->where
);
3067 gfc_error_now ("Actual argument contains too few "
3068 "elements for dummy argument %qs (%lu/%lu) "
3069 "at %L", f
->sym
->name
, actual_size
,
3070 formal_size
, &a
->expr
->where
);
3077 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3078 argument is provided for a procedure pointer formal argument. */
3079 if (f
->sym
->attr
.proc_pointer
3080 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3081 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3082 || gfc_is_proc_ptr_comp (a
->expr
)))
3083 || (a
->expr
->expr_type
== EXPR_FUNCTION
3084 && is_procptr_result (a
->expr
))))
3087 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3088 f
->sym
->name
, &a
->expr
->where
);
3092 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3093 provided for a procedure formal argument. */
3094 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3095 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3096 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3097 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3098 || gfc_is_proc_ptr_comp (a
->expr
)))
3099 || (a
->expr
->expr_type
== EXPR_FUNCTION
3100 && is_procptr_result (a
->expr
))))
3103 gfc_error ("Expected a procedure for argument %qs at %L",
3104 f
->sym
->name
, &a
->expr
->where
);
3108 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3109 && a
->expr
->expr_type
== EXPR_VARIABLE
3110 && a
->expr
->symtree
->n
.sym
->as
3111 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3112 && (a
->expr
->ref
== NULL
3113 || (a
->expr
->ref
->type
== REF_ARRAY
3114 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3117 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3118 " array at %L", f
->sym
->name
, where
);
3122 if (a
->expr
->expr_type
!= EXPR_NULL
3123 && compare_pointer (f
->sym
, a
->expr
) == 0)
3126 gfc_error ("Actual argument for %qs must be a pointer at %L",
3127 f
->sym
->name
, &a
->expr
->where
);
3131 if (a
->expr
->expr_type
!= EXPR_NULL
3132 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3133 && compare_pointer (f
->sym
, a
->expr
) == 2)
3136 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3137 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3142 /* Fortran 2008, C1242. */
3143 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3146 gfc_error ("Coindexed actual argument at %L to pointer "
3148 &a
->expr
->where
, f
->sym
->name
);
3152 /* Fortran 2008, 12.5.2.5 (no constraint). */
3153 if (a
->expr
->expr_type
== EXPR_VARIABLE
3154 && f
->sym
->attr
.intent
!= INTENT_IN
3155 && f
->sym
->attr
.allocatable
3156 && gfc_is_coindexed (a
->expr
))
3159 gfc_error ("Coindexed actual argument at %L to allocatable "
3160 "dummy %qs requires INTENT(IN)",
3161 &a
->expr
->where
, f
->sym
->name
);
3165 /* Fortran 2008, C1237. */
3166 if (a
->expr
->expr_type
== EXPR_VARIABLE
3167 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3168 && gfc_is_coindexed (a
->expr
)
3169 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3170 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3173 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3174 "%L requires that dummy %qs has neither "
3175 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3180 /* Fortran 2008, 12.5.2.4 (no constraint). */
3181 if (a
->expr
->expr_type
== EXPR_VARIABLE
3182 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3183 && gfc_is_coindexed (a
->expr
)
3184 && gfc_has_ultimate_allocatable (a
->expr
))
3187 gfc_error ("Coindexed actual argument at %L with allocatable "
3188 "ultimate component to dummy %qs requires either VALUE "
3189 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3193 if (f
->sym
->ts
.type
== BT_CLASS
3194 && CLASS_DATA (f
->sym
)->attr
.allocatable
3195 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3199 gfc_error ("Actual CLASS array argument for %qs must be a full "
3200 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3205 if (a
->expr
->expr_type
!= EXPR_NULL
3206 && !compare_allocatable (f
->sym
, a
->expr
))
3209 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3210 f
->sym
->name
, &a
->expr
->where
);
3214 /* Check intent = OUT/INOUT for definable actual argument. */
3215 if (!in_statement_function
3216 && (f
->sym
->attr
.intent
== INTENT_OUT
3217 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3219 const char* context
= (where
3220 ? _("actual argument to INTENT = OUT/INOUT")
3223 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3224 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3225 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3226 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3228 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3232 if ((f
->sym
->attr
.intent
== INTENT_OUT
3233 || f
->sym
->attr
.intent
== INTENT_INOUT
3234 || f
->sym
->attr
.volatile_
3235 || f
->sym
->attr
.asynchronous
)
3236 && gfc_has_vector_subscript (a
->expr
))
3239 gfc_error ("Array-section actual argument with vector "
3240 "subscripts at %L is incompatible with INTENT(OUT), "
3241 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3242 "of the dummy argument %qs",
3243 &a
->expr
->where
, f
->sym
->name
);
3247 /* C1232 (R1221) For an actual argument which is an array section or
3248 an assumed-shape array, the dummy argument shall be an assumed-
3249 shape array, if the dummy argument has the VOLATILE attribute. */
3251 if (f
->sym
->attr
.volatile_
3252 && a
->expr
->expr_type
== EXPR_VARIABLE
3253 && a
->expr
->symtree
->n
.sym
->as
3254 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3255 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3258 gfc_error ("Assumed-shape actual argument at %L is "
3259 "incompatible with the non-assumed-shape "
3260 "dummy argument %qs due to VOLATILE attribute",
3261 &a
->expr
->where
,f
->sym
->name
);
3265 /* Find the last array_ref. */
3266 actual_arr_ref
= NULL
;
3268 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3270 if (f
->sym
->attr
.volatile_
3271 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3272 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3275 gfc_error ("Array-section actual argument at %L is "
3276 "incompatible with the non-assumed-shape "
3277 "dummy argument %qs due to VOLATILE attribute",
3278 &a
->expr
->where
, f
->sym
->name
);
3282 /* C1233 (R1221) For an actual argument which is a pointer array, the
3283 dummy argument shall be an assumed-shape or pointer array, if the
3284 dummy argument has the VOLATILE attribute. */
3286 if (f
->sym
->attr
.volatile_
3287 && a
->expr
->expr_type
== EXPR_VARIABLE
3288 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3289 && a
->expr
->symtree
->n
.sym
->as
3291 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3292 || f
->sym
->attr
.pointer
)))
3295 gfc_error ("Pointer-array actual argument at %L requires "
3296 "an assumed-shape or pointer-array dummy "
3297 "argument %qs due to VOLATILE attribute",
3298 &a
->expr
->where
,f
->sym
->name
);
3309 /* Make sure missing actual arguments are optional. */
3311 for (f
= formal
; f
; f
= f
->next
, i
++)
3313 if (new_arg
[i
] != NULL
)
3318 gfc_error ("Missing alternate return spec in subroutine call "
3322 if (!f
->sym
->attr
.optional
3323 || (in_statement_function
&& f
->sym
->attr
.optional
))
3326 gfc_error ("Missing actual argument for argument %qs at %L",
3327 f
->sym
->name
, where
);
3332 /* The argument lists are compatible. We now relink a new actual
3333 argument list with null arguments in the right places. The head
3334 of the list remains the head. */
3335 for (i
= 0; i
< n
; i
++)
3336 if (new_arg
[i
] == NULL
)
3337 new_arg
[i
] = gfc_get_actual_arglist ();
3341 std::swap (*new_arg
[0], *actual
);
3342 std::swap (new_arg
[0], new_arg
[na
]);
3345 for (i
= 0; i
< n
- 1; i
++)
3346 new_arg
[i
]->next
= new_arg
[i
+ 1];
3348 new_arg
[i
]->next
= NULL
;
3350 if (*ap
== NULL
&& n
> 0)
3353 /* Note the types of omitted optional arguments. */
3354 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3355 if (a
->expr
== NULL
&& a
->label
== NULL
)
3356 a
->missing_arg_type
= f
->sym
->ts
.type
;
3364 gfc_formal_arglist
*f
;
3365 gfc_actual_arglist
*a
;
3369 /* qsort comparison function for argument pairs, with the following
3371 - p->a->expr == NULL
3372 - p->a->expr->expr_type != EXPR_VARIABLE
3373 - by gfc_symbol pointer value (larger first). */
3376 pair_cmp (const void *p1
, const void *p2
)
3378 const gfc_actual_arglist
*a1
, *a2
;
3380 /* *p1 and *p2 are elements of the to-be-sorted array. */
3381 a1
= ((const argpair
*) p1
)->a
;
3382 a2
= ((const argpair
*) p2
)->a
;
3391 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3393 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3397 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3399 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3401 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3405 /* Given two expressions from some actual arguments, test whether they
3406 refer to the same expression. The analysis is conservative.
3407 Returning false will produce no warning. */
3410 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3412 const gfc_ref
*r1
, *r2
;
3415 || e1
->expr_type
!= EXPR_VARIABLE
3416 || e2
->expr_type
!= EXPR_VARIABLE
3417 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3420 /* TODO: improve comparison, see expr.c:show_ref(). */
3421 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3423 if (r1
->type
!= r2
->type
)
3428 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3430 /* TODO: At the moment, consider only full arrays;
3431 we could do better. */
3432 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3437 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3445 gfc_internal_error ("compare_actual_expr(): Bad component code");
3454 /* Given formal and actual argument lists that correspond to one
3455 another, check that identical actual arguments aren't not
3456 associated with some incompatible INTENTs. */
3459 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3461 sym_intent f1_intent
, f2_intent
;
3462 gfc_formal_arglist
*f1
;
3463 gfc_actual_arglist
*a1
;
3469 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3471 if (f1
== NULL
&& a1
== NULL
)
3473 if (f1
== NULL
|| a1
== NULL
)
3474 gfc_internal_error ("check_some_aliasing(): List mismatch");
3479 p
= XALLOCAVEC (argpair
, n
);
3481 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3487 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3489 for (i
= 0; i
< n
; i
++)
3492 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3493 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3495 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3496 for (j
= i
+ 1; j
< n
; j
++)
3498 /* Expected order after the sort. */
3499 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3500 gfc_internal_error ("check_some_aliasing(): corrupted data");
3502 /* Are the expression the same? */
3503 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3505 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3506 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3507 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3508 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3510 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3511 "argument %qs and INTENT(%s) argument %qs at %L",
3512 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3513 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3514 &p
[i
].a
->expr
->where
);
3524 /* Given formal and actual argument lists that correspond to one
3525 another, check that they are compatible in the sense that intents
3526 are not mismatched. */
3529 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3531 sym_intent f_intent
;
3533 for (;; f
= f
->next
, a
= a
->next
)
3537 if (f
== NULL
&& a
== NULL
)
3539 if (f
== NULL
|| a
== NULL
)
3540 gfc_internal_error ("check_intents(): List mismatch");
3542 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3543 && a
->expr
->value
.function
.isym
3544 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3545 expr
= a
->expr
->value
.function
.actual
->expr
;
3549 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3552 f_intent
= f
->sym
->attr
.intent
;
3554 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3556 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3557 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3558 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3560 gfc_error ("Procedure argument at %L is local to a PURE "
3561 "procedure and has the POINTER attribute",
3567 /* Fortran 2008, C1283. */
3568 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3570 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3572 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3573 "is passed to an INTENT(%s) argument",
3574 &expr
->where
, gfc_intent_string (f_intent
));
3578 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3579 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3580 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3582 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3583 "is passed to a POINTER dummy argument",
3589 /* F2008, Section 12.5.2.4. */
3590 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3591 && gfc_is_coindexed (expr
))
3593 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3594 "polymorphic dummy argument %qs",
3595 &expr
->where
, f
->sym
->name
);
3604 /* Check how a procedure is used against its interface. If all goes
3605 well, the actual argument list will also end up being properly
3609 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3611 gfc_actual_arglist
*a
;
3612 gfc_formal_arglist
*dummy_args
;
3614 /* Warn about calls with an implicit interface. Special case
3615 for calling a ISO_C_BINDING because c_loc and c_funloc
3616 are pseudo-unknown. Additionally, warn about procedures not
3617 explicitly declared at all if requested. */
3618 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3620 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3623 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3625 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3626 "; did you mean %qs?",
3627 sym
->name
, where
, guessed
);
3629 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3633 if (warn_implicit_interface
)
3634 gfc_warning (OPT_Wimplicit_interface
,
3635 "Procedure %qs called with an implicit interface at %L",
3637 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3638 gfc_warning (OPT_Wimplicit_procedure
,
3639 "Procedure %qs called at %L is not explicitly declared",
3643 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3645 if (sym
->attr
.pointer
)
3647 gfc_error ("The pointer object %qs at %L must have an explicit "
3648 "function interface or be declared as array",
3653 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3655 gfc_error ("The allocatable object %qs at %L must have an explicit "
3656 "function interface or be declared as array",
3661 if (sym
->attr
.allocatable
)
3663 gfc_error ("Allocatable function %qs at %L must have an explicit "
3664 "function interface", sym
->name
, where
);
3668 for (a
= *ap
; a
; a
= a
->next
)
3670 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3671 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3673 gfc_error ("Keyword argument requires explicit interface "
3674 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3678 /* TS 29113, 6.2. */
3679 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3680 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3682 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3683 "interface", a
->expr
->symtree
->n
.sym
->name
,
3688 /* F2008, C1303 and C1304. */
3690 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3691 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3692 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3693 || gfc_expr_attr (a
->expr
).lock_comp
))
3695 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3696 "component at %L requires an explicit interface for "
3697 "procedure %qs", &a
->expr
->where
, sym
->name
);
3702 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3703 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3704 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3705 == ISOFORTRAN_EVENT_TYPE
)
3706 || gfc_expr_attr (a
->expr
).event_comp
))
3708 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3709 "component at %L requires an explicit interface for "
3710 "procedure %qs", &a
->expr
->where
, sym
->name
);
3714 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3715 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3717 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3721 /* TS 29113, C407b. */
3722 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3723 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3725 gfc_error ("Assumed-rank argument requires an explicit interface "
3726 "at %L", &a
->expr
->where
);
3734 dummy_args
= gfc_sym_get_dummy_args (sym
);
3736 /* For a statement function, check that types and type parameters of actual
3737 arguments and dummy arguments match. */
3738 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3739 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3742 if (!check_intents (dummy_args
, *ap
))
3746 check_some_aliasing (dummy_args
, *ap
);
3752 /* Check how a procedure pointer component is used against its interface.
3753 If all goes well, the actual argument list will also end up being properly
3754 sorted. Completely analogous to gfc_procedure_use. */
3757 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3759 /* Warn about calls with an implicit interface. Special case
3760 for calling a ISO_C_BINDING because c_loc and c_funloc
3761 are pseudo-unknown. */
3762 if (warn_implicit_interface
3763 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3764 && !comp
->attr
.is_iso_c
)
3765 gfc_warning (OPT_Wimplicit_interface
,
3766 "Procedure pointer component %qs called with an implicit "
3767 "interface at %L", comp
->name
, where
);
3769 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3771 gfc_actual_arglist
*a
;
3772 for (a
= *ap
; a
; a
= a
->next
)
3774 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3775 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3777 gfc_error ("Keyword argument requires explicit interface "
3778 "for procedure pointer component %qs at %L",
3779 comp
->name
, &a
->expr
->where
);
3787 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3788 comp
->attr
.elemental
, false, where
))
3791 check_intents (comp
->ts
.interface
->formal
, *ap
);
3793 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3797 /* Try if an actual argument list matches the formal list of a symbol,
3798 respecting the symbol's attributes like ELEMENTAL. This is used for
3799 GENERIC resolution. */
3802 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3804 gfc_formal_arglist
*dummy_args
;
3807 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3810 dummy_args
= gfc_sym_get_dummy_args (sym
);
3812 r
= !sym
->attr
.elemental
;
3813 if (compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
3815 check_intents (dummy_args
, *args
);
3817 check_some_aliasing (dummy_args
, *args
);
3825 /* Given an interface pointer and an actual argument list, search for
3826 a formal argument list that matches the actual. If found, returns
3827 a pointer to the symbol of the correct interface. Returns NULL if
3831 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3832 gfc_actual_arglist
**ap
)
3834 gfc_symbol
*elem_sym
= NULL
;
3835 gfc_symbol
*null_sym
= NULL
;
3836 locus null_expr_loc
;
3837 gfc_actual_arglist
*a
;
3838 bool has_null_arg
= false;
3840 for (a
= *ap
; a
; a
= a
->next
)
3841 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3842 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3844 has_null_arg
= true;
3845 null_expr_loc
= a
->expr
->where
;
3849 for (; intr
; intr
= intr
->next
)
3851 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3853 if (sub_flag
&& intr
->sym
->attr
.function
)
3855 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3858 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3860 if (has_null_arg
&& null_sym
)
3862 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3863 "between specific functions %s and %s",
3864 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3867 else if (has_null_arg
)
3869 null_sym
= intr
->sym
;
3873 /* Satisfy 12.4.4.1 such that an elemental match has lower
3874 weight than a non-elemental match. */
3875 if (intr
->sym
->attr
.elemental
)
3877 elem_sym
= intr
->sym
;
3887 return elem_sym
? elem_sym
: NULL
;
3891 /* Do a brute force recursive search for a symbol. */
3893 static gfc_symtree
*
3894 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3898 if (root
->n
.sym
== sym
)
3903 st
= find_symtree0 (root
->left
, sym
);
3904 if (root
->right
&& ! st
)
3905 st
= find_symtree0 (root
->right
, sym
);
3910 /* Find a symtree for a symbol. */
3913 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3918 /* First try to find it by name. */
3919 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3920 if (st
&& st
->n
.sym
== sym
)
3923 /* If it's been renamed, resort to a brute-force search. */
3924 /* TODO: avoid having to do this search. If the symbol doesn't exist
3925 in the symtree for the current namespace, it should probably be added. */
3926 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3928 st
= find_symtree0 (ns
->sym_root
, sym
);
3932 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3937 /* See if the arglist to an operator-call contains a derived-type argument
3938 with a matching type-bound operator. If so, return the matching specific
3939 procedure defined as operator-target as well as the base-object to use
3940 (which is the found derived-type argument with operator). The generic
3941 name, if any, is transmitted to the final expression via 'gname'. */
3943 static gfc_typebound_proc
*
3944 matching_typebound_op (gfc_expr
** tb_base
,
3945 gfc_actual_arglist
* args
,
3946 gfc_intrinsic_op op
, const char* uop
,
3947 const char ** gname
)
3949 gfc_actual_arglist
* base
;
3951 for (base
= args
; base
; base
= base
->next
)
3952 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3954 gfc_typebound_proc
* tb
;
3955 gfc_symbol
* derived
;
3958 while (base
->expr
->expr_type
== EXPR_OP
3959 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3960 base
->expr
= base
->expr
->value
.op
.op1
;
3962 if (base
->expr
->ts
.type
== BT_CLASS
)
3964 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
3965 || !gfc_expr_attr (base
->expr
).class_ok
)
3967 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3970 derived
= base
->expr
->ts
.u
.derived
;
3972 if (op
== INTRINSIC_USER
)
3974 gfc_symtree
* tb_uop
;
3977 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3986 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3989 /* This means we hit a PRIVATE operator which is use-associated and
3990 should thus not be seen. */
3994 /* Look through the super-type hierarchy for a matching specific
3996 for (; tb
; tb
= tb
->overridden
)
4000 gcc_assert (tb
->is_generic
);
4001 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4004 gfc_actual_arglist
* argcopy
;
4007 gcc_assert (g
->specific
);
4008 if (g
->specific
->error
)
4011 target
= g
->specific
->u
.specific
->n
.sym
;
4013 /* Check if this arglist matches the formal. */
4014 argcopy
= gfc_copy_actual_arglist (args
);
4015 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4016 gfc_free_actual_arglist (argcopy
);
4018 /* Return if we found a match. */
4021 *tb_base
= base
->expr
;
4022 *gname
= g
->specific_st
->name
;
4033 /* For the 'actual arglist' of an operator call and a specific typebound
4034 procedure that has been found the target of a type-bound operator, build the
4035 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4036 type-bound procedures rather than resolving type-bound operators 'directly'
4037 so that we can reuse the existing logic. */
4040 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4041 gfc_expr
* base
, gfc_typebound_proc
* target
,
4044 e
->expr_type
= EXPR_COMPCALL
;
4045 e
->value
.compcall
.tbp
= target
;
4046 e
->value
.compcall
.name
= gname
? gname
: "$op";
4047 e
->value
.compcall
.actual
= actual
;
4048 e
->value
.compcall
.base_object
= base
;
4049 e
->value
.compcall
.ignore_pass
= 1;
4050 e
->value
.compcall
.assign
= 0;
4051 if (e
->ts
.type
== BT_UNKNOWN
4052 && target
->function
)
4054 if (target
->is_generic
)
4055 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4057 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4062 /* This subroutine is called when an expression is being resolved.
4063 The expression node in question is either a user defined operator
4064 or an intrinsic operator with arguments that aren't compatible
4065 with the operator. This subroutine builds an actual argument list
4066 corresponding to the operands, then searches for a compatible
4067 interface. If one is found, the expression node is replaced with
4068 the appropriate function call. We use the 'match' enum to specify
4069 whether a replacement has been made or not, or if an error occurred. */
4072 gfc_extend_expr (gfc_expr
*e
)
4074 gfc_actual_arglist
*actual
;
4080 gfc_typebound_proc
* tbo
;
4085 actual
= gfc_get_actual_arglist ();
4086 actual
->expr
= e
->value
.op
.op1
;
4090 if (e
->value
.op
.op2
!= NULL
)
4092 actual
->next
= gfc_get_actual_arglist ();
4093 actual
->next
->expr
= e
->value
.op
.op2
;
4096 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4098 /* See if we find a matching type-bound operator. */
4099 if (i
== INTRINSIC_USER
)
4100 tbo
= matching_typebound_op (&tb_base
, actual
,
4101 i
, e
->value
.op
.uop
->name
, &gname
);
4105 #define CHECK_OS_COMPARISON(comp) \
4106 case INTRINSIC_##comp: \
4107 case INTRINSIC_##comp##_OS: \
4108 tbo = matching_typebound_op (&tb_base, actual, \
4109 INTRINSIC_##comp, NULL, &gname); \
4111 tbo = matching_typebound_op (&tb_base, actual, \
4112 INTRINSIC_##comp##_OS, NULL, &gname); \
4114 CHECK_OS_COMPARISON(EQ
)
4115 CHECK_OS_COMPARISON(NE
)
4116 CHECK_OS_COMPARISON(GT
)
4117 CHECK_OS_COMPARISON(GE
)
4118 CHECK_OS_COMPARISON(LT
)
4119 CHECK_OS_COMPARISON(LE
)
4120 #undef CHECK_OS_COMPARISON
4123 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4127 /* If there is a matching typebound-operator, replace the expression with
4128 a call to it and succeed. */
4131 gcc_assert (tb_base
);
4132 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4134 if (!gfc_resolve_expr (e
))
4140 if (i
== INTRINSIC_USER
)
4142 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4144 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4148 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4155 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4157 /* Due to the distinction between '==' and '.eq.' and friends, one has
4158 to check if either is defined. */
4161 #define CHECK_OS_COMPARISON(comp) \
4162 case INTRINSIC_##comp: \
4163 case INTRINSIC_##comp##_OS: \
4164 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4166 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4168 CHECK_OS_COMPARISON(EQ
)
4169 CHECK_OS_COMPARISON(NE
)
4170 CHECK_OS_COMPARISON(GT
)
4171 CHECK_OS_COMPARISON(GE
)
4172 CHECK_OS_COMPARISON(LT
)
4173 CHECK_OS_COMPARISON(LE
)
4174 #undef CHECK_OS_COMPARISON
4177 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4185 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4186 found rather than just taking the first one and not checking further. */
4190 /* Don't use gfc_free_actual_arglist(). */
4191 free (actual
->next
);
4196 /* Change the expression node to a function call. */
4197 e
->expr_type
= EXPR_FUNCTION
;
4198 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4199 e
->value
.function
.actual
= actual
;
4200 e
->value
.function
.esym
= NULL
;
4201 e
->value
.function
.isym
= NULL
;
4202 e
->value
.function
.name
= NULL
;
4203 e
->user_operator
= 1;
4205 if (!gfc_resolve_expr (e
))
4212 /* Tries to replace an assignment code node with a subroutine call to the
4213 subroutine associated with the assignment operator. Return true if the node
4214 was replaced. On false, no error is generated. */
4217 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4219 gfc_actual_arglist
*actual
;
4220 gfc_expr
*lhs
, *rhs
, *tb_base
;
4221 gfc_symbol
*sym
= NULL
;
4222 const char *gname
= NULL
;
4223 gfc_typebound_proc
* tbo
;
4228 /* Don't allow an intrinsic assignment to be replaced. */
4229 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4230 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4231 && (lhs
->ts
.type
== rhs
->ts
.type
4232 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4235 actual
= gfc_get_actual_arglist ();
4238 actual
->next
= gfc_get_actual_arglist ();
4239 actual
->next
->expr
= rhs
;
4241 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4243 /* See if we find a matching type-bound assignment. */
4244 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4249 /* Success: Replace the expression with a type-bound call. */
4250 gcc_assert (tb_base
);
4251 c
->expr1
= gfc_get_expr ();
4252 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4253 c
->expr1
->value
.compcall
.assign
= 1;
4254 c
->expr1
->where
= c
->loc
;
4256 c
->op
= EXEC_COMPCALL
;
4260 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4261 for (; ns
; ns
= ns
->parent
)
4263 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4270 /* Success: Replace the assignment with the call. */
4271 c
->op
= EXEC_ASSIGN_CALL
;
4272 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4275 c
->ext
.actual
= actual
;
4279 /* Failure: No assignment procedure found. */
4280 free (actual
->next
);
4286 /* Make sure that the interface just parsed is not already present in
4287 the given interface list. Ambiguity isn't checked yet since module
4288 procedures can be present without interfaces. */
4291 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4295 for (ip
= base
; ip
; ip
= ip
->next
)
4297 if (ip
->sym
== new_sym
)
4299 gfc_error ("Entity %qs at %L is already present in the interface",
4300 new_sym
->name
, &loc
);
4309 /* Add a symbol to the current interface. */
4312 gfc_add_interface (gfc_symbol
*new_sym
)
4314 gfc_interface
**head
, *intr
;
4318 switch (current_interface
.type
)
4320 case INTERFACE_NAMELESS
:
4321 case INTERFACE_ABSTRACT
:
4324 case INTERFACE_INTRINSIC_OP
:
4325 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4326 switch (current_interface
.op
)
4329 case INTRINSIC_EQ_OS
:
4330 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4332 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4333 new_sym
, gfc_current_locus
))
4338 case INTRINSIC_NE_OS
:
4339 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4341 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4342 new_sym
, gfc_current_locus
))
4347 case INTRINSIC_GT_OS
:
4348 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4349 new_sym
, gfc_current_locus
)
4350 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4351 new_sym
, gfc_current_locus
))
4356 case INTRINSIC_GE_OS
:
4357 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4358 new_sym
, gfc_current_locus
)
4359 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4360 new_sym
, gfc_current_locus
))
4365 case INTRINSIC_LT_OS
:
4366 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4367 new_sym
, gfc_current_locus
)
4368 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4369 new_sym
, gfc_current_locus
))
4374 case INTRINSIC_LE_OS
:
4375 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4376 new_sym
, gfc_current_locus
)
4377 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4378 new_sym
, gfc_current_locus
))
4383 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4384 new_sym
, gfc_current_locus
))
4388 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4391 case INTERFACE_GENERIC
:
4392 case INTERFACE_DTIO
:
4393 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4395 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4399 if (!gfc_check_new_interface (sym
->generic
,
4400 new_sym
, gfc_current_locus
))
4404 head
= ¤t_interface
.sym
->generic
;
4407 case INTERFACE_USER_OP
:
4408 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4409 new_sym
, gfc_current_locus
))
4412 head
= ¤t_interface
.uop
->op
;
4416 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4419 intr
= gfc_get_interface ();
4420 intr
->sym
= new_sym
;
4421 intr
->where
= gfc_current_locus
;
4431 gfc_current_interface_head (void)
4433 switch (current_interface
.type
)
4435 case INTERFACE_INTRINSIC_OP
:
4436 return current_interface
.ns
->op
[current_interface
.op
];
4438 case INTERFACE_GENERIC
:
4439 case INTERFACE_DTIO
:
4440 return current_interface
.sym
->generic
;
4442 case INTERFACE_USER_OP
:
4443 return current_interface
.uop
->op
;
4452 gfc_set_current_interface_head (gfc_interface
*i
)
4454 switch (current_interface
.type
)
4456 case INTERFACE_INTRINSIC_OP
:
4457 current_interface
.ns
->op
[current_interface
.op
] = i
;
4460 case INTERFACE_GENERIC
:
4461 case INTERFACE_DTIO
:
4462 current_interface
.sym
->generic
= i
;
4465 case INTERFACE_USER_OP
:
4466 current_interface
.uop
->op
= i
;
4475 /* Gets rid of a formal argument list. We do not free symbols.
4476 Symbols are freed when a namespace is freed. */
4479 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4481 gfc_formal_arglist
*q
;
4491 /* Check that it is ok for the type-bound procedure 'proc' to override the
4492 procedure 'old', cf. F08:4.5.7.3. */
4495 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4498 gfc_symbol
*proc_target
, *old_target
;
4499 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4500 gfc_formal_arglist
*proc_formal
, *old_formal
;
4504 /* This procedure should only be called for non-GENERIC proc. */
4505 gcc_assert (!proc
->n
.tb
->is_generic
);
4507 /* If the overwritten procedure is GENERIC, this is an error. */
4508 if (old
->n
.tb
->is_generic
)
4510 gfc_error ("Can't overwrite GENERIC %qs at %L",
4511 old
->name
, &proc
->n
.tb
->where
);
4515 where
= proc
->n
.tb
->where
;
4516 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4517 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4519 /* Check that overridden binding is not NON_OVERRIDABLE. */
4520 if (old
->n
.tb
->non_overridable
)
4522 gfc_error ("%qs at %L overrides a procedure binding declared"
4523 " NON_OVERRIDABLE", proc
->name
, &where
);
4527 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4528 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4530 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4531 " non-DEFERRED binding", proc
->name
, &where
);
4535 /* If the overridden binding is PURE, the overriding must be, too. */
4536 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4538 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4539 proc
->name
, &where
);
4543 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4544 is not, the overriding must not be either. */
4545 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4547 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4548 " ELEMENTAL", proc
->name
, &where
);
4551 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4553 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4554 " be ELEMENTAL, either", proc
->name
, &where
);
4558 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4560 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4562 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4563 " SUBROUTINE", proc
->name
, &where
);
4567 /* If the overridden binding is a FUNCTION, the overriding must also be a
4568 FUNCTION and have the same characteristics. */
4569 if (old_target
->attr
.function
)
4571 if (!proc_target
->attr
.function
)
4573 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4574 " FUNCTION", proc
->name
, &where
);
4578 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4581 gfc_error ("Result mismatch for the overriding procedure "
4582 "%qs at %L: %s", proc
->name
, &where
, err
);
4587 /* If the overridden binding is PUBLIC, the overriding one must not be
4589 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4590 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4592 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4593 " PRIVATE", proc
->name
, &where
);
4597 /* Compare the formal argument lists of both procedures. This is also abused
4598 to find the position of the passed-object dummy arguments of both
4599 bindings as at least the overridden one might not yet be resolved and we
4600 need those positions in the check below. */
4601 proc_pass_arg
= old_pass_arg
= 0;
4602 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4604 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4607 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4608 old_formal
= gfc_sym_get_dummy_args (old_target
);
4609 for ( ; proc_formal
&& old_formal
;
4610 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4612 if (proc
->n
.tb
->pass_arg
4613 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4614 proc_pass_arg
= argpos
;
4615 if (old
->n
.tb
->pass_arg
4616 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4617 old_pass_arg
= argpos
;
4619 /* Check that the names correspond. */
4620 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4622 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4623 " to match the corresponding argument of the overridden"
4624 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4625 old_formal
->sym
->name
);
4629 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4630 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4631 check_type
, err
, sizeof(err
)))
4633 gfc_error_opt (OPT_Wargument_mismatch
,
4634 "Argument mismatch for the overriding procedure "
4635 "%qs at %L: %s", proc
->name
, &where
, err
);
4641 if (proc_formal
|| old_formal
)
4643 gfc_error ("%qs at %L must have the same number of formal arguments as"
4644 " the overridden procedure", proc
->name
, &where
);
4648 /* If the overridden binding is NOPASS, the overriding one must also be
4650 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4652 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4653 " NOPASS", proc
->name
, &where
);
4657 /* If the overridden binding is PASS(x), the overriding one must also be
4658 PASS and the passed-object dummy arguments must correspond. */
4659 if (!old
->n
.tb
->nopass
)
4661 if (proc
->n
.tb
->nopass
)
4663 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4664 " PASS", proc
->name
, &where
);
4668 if (proc_pass_arg
!= old_pass_arg
)
4670 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4671 " the same position as the passed-object dummy argument of"
4672 " the overridden procedure", proc
->name
, &where
);
4681 /* The following three functions check that the formal arguments
4682 of user defined derived type IO procedures are compliant with
4683 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4686 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4687 int kind
, int rank
, sym_intent intent
)
4689 if (fsym
->ts
.type
!= type
)
4691 gfc_error ("DTIO dummy argument at %L must be of type %s",
4692 &fsym
->declared_at
, gfc_basic_typename (type
));
4696 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4697 && fsym
->ts
.kind
!= kind
)
4698 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4699 &fsym
->declared_at
, kind
);
4703 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4704 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4705 gfc_error ("DTIO dummy argument at %L must be a scalar",
4706 &fsym
->declared_at
);
4708 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4709 gfc_error ("DTIO dummy argument at %L must be an "
4710 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4712 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4713 gfc_error ("DTIO character argument at %L must have assumed length",
4714 &fsym
->declared_at
);
4716 if (fsym
->attr
.intent
!= intent
)
4717 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4718 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4724 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4725 bool typebound
, bool formatted
, int code
)
4727 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4728 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4729 gfc_interface
*intr
;
4730 gfc_formal_arglist
*formal
;
4733 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4734 || ((dtio_codes
)code
== DTIO_RUF
);
4742 /* Typebound DTIO binding. */
4743 tb_io_proc
= tb_io_st
->n
.tb
;
4744 if (tb_io_proc
== NULL
)
4747 gcc_assert (tb_io_proc
->is_generic
);
4748 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4750 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4751 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4754 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4758 generic_proc
= tb_io_st
->n
.sym
;
4759 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4762 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4764 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4765 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4766 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4768 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4769 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4771 dtio_sub
= intr
->sym
;
4774 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4776 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4777 "procedure", &intr
->sym
->declared_at
);
4782 if (dtio_sub
== NULL
)
4786 gcc_assert (dtio_sub
);
4787 if (!dtio_sub
->attr
.subroutine
)
4788 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4789 dtio_sub
->name
, &dtio_sub
->declared_at
);
4792 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4795 if (arg_num
< (formatted
? 6 : 4))
4797 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4798 dtio_sub
->name
, &dtio_sub
->declared_at
);
4802 if (arg_num
> (formatted
? 6 : 4))
4804 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4805 dtio_sub
->name
, &dtio_sub
->declared_at
);
4810 /* Now go through the formal arglist. */
4812 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4814 if (!formatted
&& arg_num
== 3)
4820 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4821 "procedure", &dtio_sub
->declared_at
);
4828 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4829 BT_DERIVED
: BT_CLASS
;
4831 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4832 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4838 kind
= gfc_default_integer_kind
;
4840 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4843 case(3): /* IOTYPE */
4844 type
= BT_CHARACTER
;
4845 kind
= gfc_default_character_kind
;
4847 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4850 case(4): /* VLIST */
4852 kind
= gfc_default_integer_kind
;
4854 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4857 case(5): /* IOSTAT */
4859 kind
= gfc_default_integer_kind
;
4860 intent
= INTENT_OUT
;
4861 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4864 case(6): /* IOMSG */
4865 type
= BT_CHARACTER
;
4866 kind
= gfc_default_character_kind
;
4867 intent
= INTENT_INOUT
;
4868 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4875 derived
->attr
.has_dtio_procs
= 1;
4880 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4882 gfc_symtree
*tb_io_st
;
4887 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4890 /* Check typebound DTIO bindings. */
4891 for (code
= 0; code
< 4; code
++)
4893 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4894 || ((dtio_codes
)code
== DTIO_WF
);
4896 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4897 gfc_code2string (dtio_procs
, code
),
4898 true, &derived
->declared_at
);
4899 if (tb_io_st
!= NULL
)
4900 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4903 /* Check generic DTIO interfaces. */
4904 for (code
= 0; code
< 4; code
++)
4906 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4907 || ((dtio_codes
)code
== DTIO_WF
);
4909 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4910 gfc_code2string (dtio_procs
, code
));
4911 if (tb_io_st
!= NULL
)
4912 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4918 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4920 gfc_symtree
*tb_io_st
= NULL
;
4923 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4926 /* Try to find a typebound DTIO binding. */
4927 if (formatted
== true)
4930 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4931 gfc_code2string (dtio_procs
,
4934 &derived
->declared_at
);
4936 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4937 gfc_code2string (dtio_procs
,
4940 &derived
->declared_at
);
4945 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4946 gfc_code2string (dtio_procs
,
4949 &derived
->declared_at
);
4951 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4952 gfc_code2string (dtio_procs
,
4955 &derived
->declared_at
);
4962 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4964 gfc_symtree
*tb_io_st
= NULL
;
4965 gfc_symbol
*dtio_sub
= NULL
;
4966 gfc_symbol
*extended
;
4967 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4969 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
4971 if (tb_io_st
!= NULL
)
4973 const char *genname
;
4976 tb_io_proc
= tb_io_st
->n
.tb
;
4977 gcc_assert (tb_io_proc
!= NULL
);
4978 gcc_assert (tb_io_proc
->is_generic
);
4979 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4981 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4982 gcc_assert (!specific_proc
->is_generic
);
4984 /* Go back and make sure that we have the right specific procedure.
4985 Here we most likely have a procedure from the parent type, which
4986 can be overridden in extensions. */
4987 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4988 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4989 true, &tb_io_proc
->where
);
4991 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4993 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4998 /* If there is not a typebound binding, look for a generic
5000 for (extended
= derived
; extended
;
5001 extended
= gfc_get_derived_super_type (extended
))
5003 if (extended
== NULL
|| extended
->ns
== NULL
5004 || extended
->attr
.flavor
== FL_UNKNOWN
)
5007 if (formatted
== true)
5010 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5011 gfc_code2string (dtio_procs
,
5014 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5015 gfc_code2string (dtio_procs
,
5021 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5022 gfc_code2string (dtio_procs
,
5025 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5026 gfc_code2string (dtio_procs
,
5030 if (tb_io_st
!= NULL
5032 && tb_io_st
->n
.sym
->generic
)
5034 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5035 intr
&& intr
->sym
; intr
= intr
->next
)
5037 if (intr
->sym
->formal
)
5039 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5040 if ((fsym
->ts
.type
== BT_CLASS
5041 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5042 || (fsym
->ts
.type
== BT_DERIVED
5043 && fsym
->ts
.u
.derived
== extended
))
5045 dtio_sub
= intr
->sym
;
5054 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5055 gfc_find_derived_vtab (derived
);