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
) ? CLASS_DATA (s1
)->as
: s1
->as
;
758 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
760 r1
= as1
? as1
->rank
: 0;
761 r2
= as2
? as2
->rank
: 0;
763 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
764 return false; /* Ranks differ. */
770 /* Given two symbols that are formal arguments, compare their ranks
771 and types. Returns true if they have the same rank and type,
775 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
777 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
781 /* Given two symbols that are formal arguments, compare their types
782 and rank and their formal interfaces if they are both dummy
783 procedures. Returns true if the same, false if different. */
786 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
788 if (s1
== NULL
|| s2
== NULL
)
794 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
795 return compare_type_rank (s1
, s2
);
797 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
800 /* At this point, both symbols are procedures. It can happen that
801 external procedures are compared, where one is identified by usage
802 to be a function or subroutine but the other is not. Check TKR
803 nonetheless for these cases. */
804 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
805 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
807 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
808 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
810 /* Now the type of procedure has been identified. */
811 if (s1
->attr
.function
!= s2
->attr
.function
812 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
815 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
818 /* Originally, gfortran recursed here to check the interfaces of passed
819 procedures. This is explicitly not required by the standard. */
824 /* Given a formal argument list and a keyword name, search the list
825 for that keyword. Returns the correct symbol node if found, NULL
829 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
831 for (; f
; f
= f
->next
)
832 if (strcmp (f
->sym
->name
, name
) == 0)
839 /******** Interface checking subroutines **********/
842 /* Given an operator interface and the operator, make sure that all
843 interfaces for that operator are legal. */
846 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
849 gfc_formal_arglist
*formal
;
852 int args
, r1
, r2
, k1
, k2
;
857 t1
= t2
= BT_UNKNOWN
;
858 i1
= i2
= INTENT_UNKNOWN
;
862 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
864 gfc_symbol
*fsym
= formal
->sym
;
867 gfc_error ("Alternate return cannot appear in operator "
868 "interface at %L", &sym
->declared_at
);
874 i1
= fsym
->attr
.intent
;
875 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
881 i2
= fsym
->attr
.intent
;
882 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
888 /* Only +, - and .not. can be unary operators.
889 .not. cannot be a binary operator. */
890 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
891 && op
!= INTRINSIC_MINUS
892 && op
!= INTRINSIC_NOT
)
893 || (args
== 2 && op
== INTRINSIC_NOT
))
895 if (op
== INTRINSIC_ASSIGN
)
896 gfc_error ("Assignment operator interface at %L must have "
897 "two arguments", &sym
->declared_at
);
899 gfc_error ("Operator interface at %L has the wrong number of arguments",
904 /* Check that intrinsics are mapped to functions, except
905 INTRINSIC_ASSIGN which should map to a subroutine. */
906 if (op
== INTRINSIC_ASSIGN
)
908 gfc_formal_arglist
*dummy_args
;
910 if (!sym
->attr
.subroutine
)
912 gfc_error ("Assignment operator interface at %L must be "
913 "a SUBROUTINE", &sym
->declared_at
);
917 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
918 - First argument an array with different rank than second,
919 - First argument is a scalar and second an array,
920 - Types and kinds do not conform, or
921 - First argument is of derived type. */
922 dummy_args
= gfc_sym_get_dummy_args (sym
);
923 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
924 && dummy_args
->sym
->ts
.type
!= BT_CLASS
925 && (r2
== 0 || r1
== r2
)
926 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
927 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
928 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
930 gfc_error ("Assignment operator interface at %L must not redefine "
931 "an INTRINSIC type assignment", &sym
->declared_at
);
937 if (!sym
->attr
.function
)
939 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
945 /* Check intents on operator interfaces. */
946 if (op
== INTRINSIC_ASSIGN
)
948 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
950 gfc_error ("First argument of defined assignment at %L must be "
951 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
957 gfc_error ("Second argument of defined assignment at %L must be "
958 "INTENT(IN)", &sym
->declared_at
);
966 gfc_error ("First argument of operator interface at %L must be "
967 "INTENT(IN)", &sym
->declared_at
);
971 if (args
== 2 && i2
!= INTENT_IN
)
973 gfc_error ("Second argument of operator interface at %L must be "
974 "INTENT(IN)", &sym
->declared_at
);
979 /* From now on, all we have to do is check that the operator definition
980 doesn't conflict with an intrinsic operator. The rules for this
981 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
982 as well as 12.3.2.1.1 of Fortran 2003:
984 "If the operator is an intrinsic-operator (R310), the number of
985 function arguments shall be consistent with the intrinsic uses of
986 that operator, and the types, kind type parameters, or ranks of the
987 dummy arguments shall differ from those required for the intrinsic
988 operation (7.1.2)." */
990 #define IS_NUMERIC_TYPE(t) \
991 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
993 /* Unary ops are easy, do them first. */
994 if (op
== INTRINSIC_NOT
)
996 if (t1
== BT_LOGICAL
)
1002 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1004 if (IS_NUMERIC_TYPE (t1
))
1010 /* Character intrinsic operators have same character kind, thus
1011 operator definitions with operands of different character kinds
1013 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1016 /* Intrinsic operators always perform on arguments of same rank,
1017 so different ranks is also always safe. (rank == 0) is an exception
1018 to that, because all intrinsic operators are elemental. */
1019 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1025 case INTRINSIC_EQ_OS
:
1027 case INTRINSIC_NE_OS
:
1028 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1032 case INTRINSIC_PLUS
:
1033 case INTRINSIC_MINUS
:
1034 case INTRINSIC_TIMES
:
1035 case INTRINSIC_DIVIDE
:
1036 case INTRINSIC_POWER
:
1037 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1042 case INTRINSIC_GT_OS
:
1044 case INTRINSIC_GE_OS
:
1046 case INTRINSIC_LT_OS
:
1048 case INTRINSIC_LE_OS
:
1049 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1051 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1052 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1056 case INTRINSIC_CONCAT
:
1057 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1064 case INTRINSIC_NEQV
:
1065 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1075 #undef IS_NUMERIC_TYPE
1078 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1084 /* Given a pair of formal argument lists, we see if the two lists can
1085 be distinguished by counting the number of nonoptional arguments of
1086 a given type/rank in f1 and seeing if there are less then that
1087 number of those arguments in f2 (including optional arguments).
1088 Since this test is asymmetric, it has to be called twice to make it
1089 symmetric. Returns nonzero if the argument lists are incompatible
1090 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1091 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1094 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1095 const char *p1
, const char *p2
)
1097 int ac1
, ac2
, i
, j
, k
, n1
;
1098 gfc_formal_arglist
*f
;
1111 for (f
= f1
; f
; f
= f
->next
)
1114 /* Build an array of integers that gives the same integer to
1115 arguments of the same type/rank. */
1116 arg
= XCNEWVEC (arginfo
, n1
);
1119 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1122 arg
[i
].sym
= f
->sym
;
1127 for (i
= 0; i
< n1
; i
++)
1129 if (arg
[i
].flag
!= -1)
1132 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1133 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1134 continue; /* Skip OPTIONAL and PASS arguments. */
1138 /* Find other non-optional, non-pass arguments of the same type/rank. */
1139 for (j
= i
+ 1; j
< n1
; j
++)
1140 if ((arg
[j
].sym
== NULL
1141 || !(arg
[j
].sym
->attr
.optional
1142 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1143 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1144 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1150 /* Now loop over each distinct type found in f1. */
1154 for (i
= 0; i
< n1
; i
++)
1156 if (arg
[i
].flag
!= k
)
1160 for (j
= i
+ 1; j
< n1
; j
++)
1161 if (arg
[j
].flag
== k
)
1164 /* Count the number of non-pass arguments in f2 with that type,
1165 including those that are optional. */
1168 for (f
= f2
; f
; f
= f
->next
)
1169 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1170 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1171 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1189 /* Perform the correspondence test in rule (3) of F08:C1215.
1190 Returns zero if no argument is found that satisfies this rule,
1191 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1194 This test is also not symmetric in f1 and f2 and must be called
1195 twice. This test finds problems caused by sorting the actual
1196 argument list with keywords. For example:
1200 INTEGER :: A ; REAL :: B
1204 INTEGER :: A ; REAL :: B
1208 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1211 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1212 const char *p1
, const char *p2
)
1214 gfc_formal_arglist
*f2_save
, *g
;
1221 if (f1
->sym
->attr
.optional
)
1224 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1226 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1229 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1230 || compare_type_rank (f2
->sym
, f1
->sym
))
1231 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1232 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1233 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1236 /* Now search for a disambiguating keyword argument starting at
1237 the current non-match. */
1238 for (g
= f1
; g
; g
= g
->next
)
1240 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1243 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1244 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1245 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1246 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1247 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1263 symbol_rank (gfc_symbol
*sym
)
1265 gfc_array_spec
*as
= NULL
;
1267 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
) && CLASS_DATA (sym
)->as
)
1268 as
= CLASS_DATA (sym
)->as
;
1272 return as
? as
->rank
: 0;
1276 /* Check if the characteristics of two dummy arguments match,
1280 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1281 bool type_must_agree
, char *errmsg
,
1284 if (s1
== NULL
|| s2
== NULL
)
1285 return s1
== s2
? true : false;
1287 /* Check type and rank. */
1288 if (type_must_agree
)
1290 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1292 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1293 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1296 if (!compare_rank (s1
, s2
))
1298 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1299 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1305 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1307 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1312 /* Check OPTIONAL attribute. */
1313 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1315 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1320 /* Check ALLOCATABLE attribute. */
1321 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1323 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1328 /* Check POINTER attribute. */
1329 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1331 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1336 /* Check TARGET attribute. */
1337 if (s1
->attr
.target
!= s2
->attr
.target
)
1339 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1344 /* Check ASYNCHRONOUS attribute. */
1345 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1347 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1352 /* Check CONTIGUOUS attribute. */
1353 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1355 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1360 /* Check VALUE attribute. */
1361 if (s1
->attr
.value
!= s2
->attr
.value
)
1363 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1368 /* Check VOLATILE attribute. */
1369 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1371 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1376 /* Check interface of dummy procedures. */
1377 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1380 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1383 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1384 "'%s': %s", s1
->name
, err
);
1389 /* Check string length. */
1390 if (s1
->ts
.type
== BT_CHARACTER
1391 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1392 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1394 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1395 s2
->ts
.u
.cl
->length
);
1401 snprintf (errmsg
, err_len
, "Character length mismatch "
1402 "in argument '%s'", s1
->name
);
1406 /* FIXME: Implement a warning for this case.
1407 gfc_warning (0, "Possible character length mismatch in argument %qs",
1415 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1416 "%i of gfc_dep_compare_expr", compval
);
1421 /* Check array shape. */
1422 if (s1
->as
&& s2
->as
)
1425 gfc_expr
*shape1
, *shape2
;
1427 if (s1
->as
->type
!= s2
->as
->type
)
1429 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1434 if (s1
->as
->corank
!= s2
->as
->corank
)
1436 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1437 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1441 if (s1
->as
->type
== AS_EXPLICIT
)
1442 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1444 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1445 gfc_copy_expr (s1
->as
->lower
[i
]));
1446 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1447 gfc_copy_expr (s2
->as
->lower
[i
]));
1448 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1449 gfc_free_expr (shape1
);
1450 gfc_free_expr (shape2
);
1456 if (i
< s1
->as
->rank
)
1457 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1458 " argument '%s'", i
+ 1, s1
->name
);
1460 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1461 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1465 /* FIXME: Implement a warning for this case.
1466 gfc_warning (0, "Possible shape mismatch in argument %qs",
1474 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1475 "result %i of gfc_dep_compare_expr",
1486 /* Check if the characteristics of two function results match,
1490 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1491 char *errmsg
, int err_len
)
1493 gfc_symbol
*r1
, *r2
;
1495 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1496 r1
= s1
->ts
.interface
->result
;
1498 r1
= s1
->result
? s1
->result
: s1
;
1500 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1501 r2
= s2
->ts
.interface
->result
;
1503 r2
= s2
->result
? s2
->result
: s2
;
1505 if (r1
->ts
.type
== BT_UNKNOWN
)
1508 /* Check type and rank. */
1509 if (!compare_type (r1
, r2
))
1511 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1512 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1515 if (!compare_rank (r1
, r2
))
1517 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1518 symbol_rank (r1
), symbol_rank (r2
));
1522 /* Check ALLOCATABLE attribute. */
1523 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1525 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1530 /* Check POINTER attribute. */
1531 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1533 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1538 /* Check CONTIGUOUS attribute. */
1539 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1541 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1546 /* Check PROCEDURE POINTER attribute. */
1547 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1549 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1554 /* Check string length. */
1555 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1557 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1559 snprintf (errmsg
, err_len
, "Character length mismatch "
1560 "in function result");
1564 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1566 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1567 r2
->ts
.u
.cl
->length
);
1573 snprintf (errmsg
, err_len
, "Character length mismatch "
1574 "in function result");
1578 /* FIXME: Implement a warning for this case.
1579 snprintf (errmsg, err_len, "Possible character length mismatch "
1580 "in function result");*/
1587 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1588 "result %i of gfc_dep_compare_expr", compval
);
1594 /* Check array shape. */
1595 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1598 gfc_expr
*shape1
, *shape2
;
1600 if (r1
->as
->type
!= r2
->as
->type
)
1602 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1606 if (r1
->as
->type
== AS_EXPLICIT
)
1607 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1609 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1610 gfc_copy_expr (r1
->as
->lower
[i
]));
1611 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1612 gfc_copy_expr (r2
->as
->lower
[i
]));
1613 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1614 gfc_free_expr (shape1
);
1615 gfc_free_expr (shape2
);
1621 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1622 "function result", i
+ 1);
1626 /* FIXME: Implement a warning for this case.
1627 gfc_warning (0, "Possible shape mismatch in return value");*/
1634 gfc_internal_error ("check_result_characteristics (2): "
1635 "Unexpected result %i of "
1636 "gfc_dep_compare_expr", compval
);
1646 /* 'Compare' two formal interfaces associated with a pair of symbols.
1647 We return true if there exists an actual argument list that
1648 would be ambiguous between the two interfaces, zero otherwise.
1649 'strict_flag' specifies whether all the characteristics are
1650 required to match, which is not the case for ambiguity checks.
1651 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1654 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1655 int generic_flag
, int strict_flag
,
1656 char *errmsg
, int err_len
,
1657 const char *p1
, const char *p2
)
1659 gfc_formal_arglist
*f1
, *f2
;
1661 gcc_assert (name2
!= NULL
);
1663 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1664 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1665 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1668 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1672 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1675 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1679 /* Do strict checks on all characteristics
1680 (for dummy procedures and procedure pointer assignments). */
1681 if (!generic_flag
&& strict_flag
)
1683 if (s1
->attr
.function
&& s2
->attr
.function
)
1685 /* If both are functions, check result characteristics. */
1686 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1687 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1691 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1693 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1696 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1698 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1703 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1704 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1707 f1
= gfc_sym_get_dummy_args (s1
);
1708 f2
= gfc_sym_get_dummy_args (s2
);
1710 /* Special case: No arguments. */
1711 if (f1
== NULL
&& f2
== NULL
)
1716 if (count_types_test (f1
, f2
, p1
, p2
)
1717 || count_types_test (f2
, f1
, p2
, p1
))
1720 /* Special case: alternate returns. If both f1->sym and f2->sym are
1721 NULL, then the leading formal arguments are alternate returns.
1722 The previous conditional should catch argument lists with
1723 different number of argument. */
1724 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1727 if (generic_correspondence (f1
, f2
, p1
, p2
)
1728 || generic_correspondence (f2
, f1
, p2
, p1
))
1732 /* Perform the abbreviated correspondence test for operators (the
1733 arguments cannot be optional and are always ordered correctly).
1734 This is also done when comparing interfaces for dummy procedures and in
1735 procedure pointer assignments. */
1737 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1739 /* Check existence. */
1740 if (f1
== NULL
|| f2
== NULL
)
1743 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1744 "arguments", name2
);
1750 /* Check all characteristics. */
1751 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1757 /* Only check type and rank. */
1758 if (!compare_type (f2
->sym
, f1
->sym
))
1761 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1762 "(%s/%s)", f1
->sym
->name
,
1763 gfc_typename (&f1
->sym
->ts
),
1764 gfc_typename (&f2
->sym
->ts
));
1767 if (!compare_rank (f2
->sym
, f1
->sym
))
1770 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1771 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1772 symbol_rank (f2
->sym
));
1782 /* Given a pointer to an interface pointer, remove duplicate
1783 interfaces and make sure that all symbols are either functions
1784 or subroutines, and all of the same kind. Returns true if
1785 something goes wrong. */
1788 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1790 gfc_interface
*psave
, *q
, *qlast
;
1793 for (; p
; p
= p
->next
)
1795 /* Make sure all symbols in the interface have been defined as
1796 functions or subroutines. */
1797 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1798 || !p
->sym
->attr
.if_source
)
1799 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1802 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1804 if (p
->sym
->attr
.external
)
1806 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1807 "; did you mean %qs?",
1808 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1811 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1812 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1815 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1816 "subroutine; did you mean %qs?", p
->sym
->name
,
1817 interface_name
, &p
->sym
->declared_at
, guessed
);
1819 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1820 "subroutine", p
->sym
->name
, interface_name
,
1821 &p
->sym
->declared_at
);
1825 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1826 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1827 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1828 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1830 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1831 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1832 " or all FUNCTIONs", interface_name
,
1833 &p
->sym
->declared_at
);
1834 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1835 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1836 "generic name is also the name of a derived type",
1837 interface_name
, &p
->sym
->declared_at
);
1841 /* F2003, C1207. F2008, C1207. */
1842 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1843 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1844 "%qs in %s at %L", p
->sym
->name
,
1845 interface_name
, &p
->sym
->declared_at
))
1850 /* Remove duplicate interfaces in this interface list. */
1851 for (; p
; p
= p
->next
)
1855 for (q
= p
->next
; q
;)
1857 if (p
->sym
!= q
->sym
)
1864 /* Duplicate interface. */
1865 qlast
->next
= q
->next
;
1876 /* Check lists of interfaces to make sure that no two interfaces are
1877 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1880 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1881 int generic_flag
, const char *interface_name
,
1885 for (; p
; p
= p
->next
)
1886 for (q
= q0
; q
; q
= q
->next
)
1888 if (p
->sym
== q
->sym
)
1889 continue; /* Duplicates OK here. */
1891 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1894 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1895 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1896 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1897 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1900 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1901 "and %qs at %L", interface_name
,
1902 q
->sym
->name
, &q
->sym
->declared_at
,
1903 p
->sym
->name
, &p
->sym
->declared_at
);
1904 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1905 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1906 "and %qs at %L", interface_name
,
1907 q
->sym
->name
, &q
->sym
->declared_at
,
1908 p
->sym
->name
, &p
->sym
->declared_at
);
1910 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1911 "interfaces at %L", interface_name
, &p
->where
);
1919 /* Check the generic and operator interfaces of symbols to make sure
1920 that none of the interfaces conflict. The check has to be done
1921 after all of the symbols are actually loaded. */
1924 check_sym_interfaces (gfc_symbol
*sym
)
1926 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("generic interface ''")];
1929 if (sym
->ns
!= gfc_current_ns
)
1932 if (sym
->generic
!= NULL
)
1934 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1935 if (check_interface0 (sym
->generic
, interface_name
))
1938 for (p
= sym
->generic
; p
; p
= p
->next
)
1940 if (p
->sym
->attr
.mod_proc
1941 && !p
->sym
->attr
.module_procedure
1942 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1943 || p
->sym
->attr
.procedure
))
1945 gfc_error ("%qs at %L is not a module procedure",
1946 p
->sym
->name
, &p
->where
);
1951 /* Originally, this test was applied to host interfaces too;
1952 this is incorrect since host associated symbols, from any
1953 source, cannot be ambiguous with local symbols. */
1954 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1955 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1961 check_uop_interfaces (gfc_user_op
*uop
)
1963 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
1967 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1968 if (check_interface0 (uop
->op
, interface_name
))
1971 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1973 uop2
= gfc_find_uop (uop
->name
, ns
);
1977 check_interface1 (uop
->op
, uop2
->op
, 0,
1978 interface_name
, true);
1982 /* Given an intrinsic op, return an equivalent op if one exists,
1983 or INTRINSIC_NONE otherwise. */
1986 gfc_equivalent_op (gfc_intrinsic_op op
)
1991 return INTRINSIC_EQ_OS
;
1993 case INTRINSIC_EQ_OS
:
1994 return INTRINSIC_EQ
;
1997 return INTRINSIC_NE_OS
;
1999 case INTRINSIC_NE_OS
:
2000 return INTRINSIC_NE
;
2003 return INTRINSIC_GT_OS
;
2005 case INTRINSIC_GT_OS
:
2006 return INTRINSIC_GT
;
2009 return INTRINSIC_GE_OS
;
2011 case INTRINSIC_GE_OS
:
2012 return INTRINSIC_GE
;
2015 return INTRINSIC_LT_OS
;
2017 case INTRINSIC_LT_OS
:
2018 return INTRINSIC_LT
;
2021 return INTRINSIC_LE_OS
;
2023 case INTRINSIC_LE_OS
:
2024 return INTRINSIC_LE
;
2027 return INTRINSIC_NONE
;
2031 /* For the namespace, check generic, user operator and intrinsic
2032 operator interfaces for consistency and to remove duplicate
2033 interfaces. We traverse the whole namespace, counting on the fact
2034 that most symbols will not have generic or operator interfaces. */
2037 gfc_check_interfaces (gfc_namespace
*ns
)
2039 gfc_namespace
*old_ns
, *ns2
;
2040 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2043 old_ns
= gfc_current_ns
;
2044 gfc_current_ns
= ns
;
2046 gfc_traverse_ns (ns
, check_sym_interfaces
);
2048 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2050 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2052 if (i
== INTRINSIC_USER
)
2055 if (i
== INTRINSIC_ASSIGN
)
2056 strcpy (interface_name
, "intrinsic assignment operator");
2058 sprintf (interface_name
, "intrinsic '%s' operator",
2059 gfc_op2string ((gfc_intrinsic_op
) i
));
2061 if (check_interface0 (ns
->op
[i
], interface_name
))
2065 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2068 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2070 gfc_intrinsic_op other_op
;
2072 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2073 interface_name
, true))
2076 /* i should be gfc_intrinsic_op, but has to be int with this cast
2077 here for stupid C++ compatibility rules. */
2078 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2079 if (other_op
!= INTRINSIC_NONE
2080 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2081 0, interface_name
, true))
2087 gfc_current_ns
= old_ns
;
2091 /* Given a symbol of a formal argument list and an expression, if the
2092 formal argument is allocatable, check that the actual argument is
2093 allocatable. Returns true if compatible, zero if not compatible. */
2096 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2098 if (formal
->attr
.allocatable
2099 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2101 symbol_attribute attr
= gfc_expr_attr (actual
);
2102 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2104 else if (!attr
.allocatable
)
2112 /* Given a symbol of a formal argument list and an expression, if the
2113 formal argument is a pointer, see if the actual argument is a
2114 pointer. Returns nonzero if compatible, zero if not compatible. */
2117 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2119 symbol_attribute attr
;
2121 if (formal
->attr
.pointer
2122 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2123 && CLASS_DATA (formal
)->attr
.class_pointer
))
2125 attr
= gfc_expr_attr (actual
);
2127 /* Fortran 2008 allows non-pointer actual arguments. */
2128 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2139 /* Emit clear error messages for rank mismatch. */
2142 argument_rank_mismatch (const char *name
, locus
*where
,
2143 int rank1
, int rank2
)
2146 /* TS 29113, C407b. */
2148 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2149 " %qs has assumed-rank", where
, name
);
2150 else if (rank1
== 0)
2151 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2152 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2153 else if (rank2
== 0)
2154 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2155 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2157 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2158 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2162 /* Given a symbol of a formal argument list and an expression, see if
2163 the two are compatible as arguments. Returns true if
2164 compatible, false if not compatible. */
2167 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2168 int ranks_must_agree
, int is_elemental
, locus
*where
)
2171 bool rank_check
, is_pointer
;
2175 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2176 procs c_f_pointer or c_f_procpointer, and we need to accept most
2177 pointers the user could give us. This should allow that. */
2178 if (formal
->ts
.type
== BT_VOID
)
2181 if (formal
->ts
.type
== BT_DERIVED
2182 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2183 && actual
->ts
.type
== BT_DERIVED
2184 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2187 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2188 /* Make sure the vtab symbol is present when
2189 the module variables are generated. */
2190 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2192 if (actual
->ts
.type
== BT_PROCEDURE
)
2194 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2196 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2199 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2203 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2204 sizeof(err
), NULL
, NULL
))
2207 gfc_error_opt (OPT_Wargument_mismatch
,
2208 "Interface mismatch in dummy procedure %qs at %L:"
2209 " %s", formal
->name
, &actual
->where
, err
);
2213 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2215 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2216 &act_sym
->declared_at
);
2217 if (act_sym
->ts
.type
== BT_UNKNOWN
2218 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2221 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2222 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2223 &act_sym
->declared_at
);
2228 ppc
= gfc_get_proc_ptr_comp (actual
);
2229 if (ppc
&& ppc
->ts
.interface
)
2231 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2232 err
, sizeof(err
), NULL
, NULL
))
2235 gfc_error_opt (OPT_Wargument_mismatch
,
2236 "Interface mismatch in dummy procedure %qs at %L:"
2237 " %s", formal
->name
, &actual
->where
, err
);
2243 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2244 && !gfc_is_simply_contiguous (actual
, true, false))
2247 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2248 "must be simply contiguous", formal
->name
, &actual
->where
);
2252 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2253 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2256 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2257 && actual
->ts
.type
!= BT_HOLLERITH
2258 && formal
->ts
.type
!= BT_ASSUMED
2259 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2260 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2261 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2262 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2263 CLASS_DATA (actual
)->ts
.u
.derived
)))
2266 gfc_error_opt (OPT_Wargument_mismatch
,
2267 "Type mismatch in argument %qs at %L; passed %s to %s",
2268 formal
->name
, where
, gfc_typename (&actual
->ts
),
2269 gfc_typename (&formal
->ts
));
2273 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2276 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2277 "argument %qs is of assumed type", &actual
->where
,
2282 /* F2008, 12.5.2.5; IR F08/0073. */
2283 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2284 && actual
->expr_type
!= EXPR_NULL
2285 && ((CLASS_DATA (formal
)->attr
.class_pointer
2286 && formal
->attr
.intent
!= INTENT_IN
)
2287 || CLASS_DATA (formal
)->attr
.allocatable
))
2289 if (actual
->ts
.type
!= BT_CLASS
)
2292 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2293 formal
->name
, &actual
->where
);
2297 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2298 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2299 CLASS_DATA (formal
)->ts
.u
.derived
))
2302 gfc_error ("Actual argument to %qs at %L must have the same "
2303 "declared type", formal
->name
, &actual
->where
);
2308 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2309 is necessary also for F03, so retain error for both.
2310 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2311 compatible, no attempt has been made to channel to this one. */
2312 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2313 && (CLASS_DATA (formal
)->attr
.allocatable
2314 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2317 gfc_error ("Actual argument to %qs at %L must be unlimited "
2318 "polymorphic since the formal argument is a "
2319 "pointer or allocatable unlimited polymorphic "
2320 "entity [F2008: 12.5.2.5]", formal
->name
,
2325 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2328 gfc_error ("Actual argument to %qs at %L must be a coarray",
2329 formal
->name
, &actual
->where
);
2333 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2335 gfc_ref
*last
= NULL
;
2337 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2338 if (ref
->type
== REF_COMPONENT
)
2341 /* F2008, 12.5.2.6. */
2342 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2344 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2347 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2348 formal
->name
, &actual
->where
, formal
->as
->corank
,
2349 last
? last
->u
.c
.component
->as
->corank
2350 : actual
->symtree
->n
.sym
->as
->corank
);
2355 if (formal
->attr
.codimension
)
2357 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2358 /* F2018, 12.5.2.8. */
2359 if (formal
->attr
.dimension
2360 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2361 && actual_attr
.dimension
2362 && !gfc_is_simply_contiguous (actual
, true, true))
2365 gfc_error ("Actual argument to %qs at %L must be simply "
2366 "contiguous or an element of such an array",
2367 formal
->name
, &actual
->where
);
2371 /* F2008, C1303 and C1304. */
2372 if (formal
->attr
.intent
!= INTENT_INOUT
2373 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2374 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2375 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2376 || formal
->attr
.lock_comp
))
2380 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2381 "which is LOCK_TYPE or has a LOCK_TYPE component",
2382 formal
->name
, &actual
->where
);
2386 /* TS18508, C702/C703. */
2387 if (formal
->attr
.intent
!= INTENT_INOUT
2388 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2389 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2390 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2391 || formal
->attr
.event_comp
))
2395 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2396 "which is EVENT_TYPE or has a EVENT_TYPE component",
2397 formal
->name
, &actual
->where
);
2402 /* F2008, C1239/C1240. */
2403 if (actual
->expr_type
== EXPR_VARIABLE
2404 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2405 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2406 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2407 && actual
->rank
&& formal
->as
2408 && !gfc_is_simply_contiguous (actual
, true, false)
2409 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2410 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2411 || formal
->attr
.contiguous
))
2414 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2415 "assumed-rank array without CONTIGUOUS attribute - as actual"
2416 " argument at %L is not simply contiguous and both are "
2417 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2421 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2422 && actual_attr
.codimension
)
2424 if (formal
->attr
.intent
== INTENT_OUT
)
2427 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2428 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2432 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2433 gfc_warning (OPT_Wsurprising
,
2434 "Passing coarray at %L to allocatable, noncoarray dummy "
2435 "argument %qs, which is invalid if the allocation status"
2436 " is modified", &actual
->where
, formal
->name
);
2439 /* If the rank is the same or the formal argument has assumed-rank. */
2440 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2443 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2444 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2445 || formal
->as
->type
== AS_DEFERRED
)
2446 && actual
->expr_type
!= EXPR_NULL
;
2448 /* Skip rank checks for NO_ARG_CHECK. */
2449 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2452 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2453 if (rank_check
|| ranks_must_agree
2454 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2455 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2456 || (actual
->rank
== 0
2457 && ((formal
->ts
.type
== BT_CLASS
2458 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2459 || (formal
->ts
.type
!= BT_CLASS
2460 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2461 && actual
->expr_type
!= EXPR_NULL
)
2462 || (actual
->rank
== 0 && formal
->attr
.dimension
2463 && gfc_is_coindexed (actual
)))
2466 argument_rank_mismatch (formal
->name
, &actual
->where
,
2467 symbol_rank (formal
), actual
->rank
);
2470 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2473 /* At this point, we are considering a scalar passed to an array. This
2474 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2475 - if the actual argument is (a substring of) an element of a
2476 non-assumed-shape/non-pointer/non-polymorphic array; or
2477 - (F2003) if the actual argument is of type character of default/c_char
2480 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2481 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2483 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2485 if (ref
->type
== REF_COMPONENT
)
2486 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2487 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2488 && ref
->u
.ar
.dimen
> 0
2490 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2494 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2497 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2498 "at %L", formal
->name
, &actual
->where
);
2502 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2503 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2506 gfc_error ("Element of assumed-shaped or pointer "
2507 "array passed to array dummy argument %qs at %L",
2508 formal
->name
, &actual
->where
);
2512 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2513 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2515 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2518 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2519 "CHARACTER actual argument with array dummy argument "
2520 "%qs at %L", formal
->name
, &actual
->where
);
2524 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2526 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2527 "array dummy argument %qs at %L",
2528 formal
->name
, &actual
->where
);
2532 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2535 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2538 argument_rank_mismatch (formal
->name
, &actual
->where
,
2539 symbol_rank (formal
), actual
->rank
);
2547 /* Returns the storage size of a symbol (formal argument) or
2548 zero if it cannot be determined. */
2550 static unsigned long
2551 get_sym_storage_size (gfc_symbol
*sym
)
2554 unsigned long strlen
, elements
;
2556 if (sym
->ts
.type
== BT_CHARACTER
)
2558 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2559 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2560 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2567 if (symbol_rank (sym
) == 0)
2571 if (sym
->as
->type
!= AS_EXPLICIT
)
2573 for (i
= 0; i
< sym
->as
->rank
; i
++)
2575 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2576 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2579 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2580 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2583 return strlen
*elements
;
2587 /* Returns the storage size of an expression (actual argument) or
2588 zero if it cannot be determined. For an array element, it returns
2589 the remaining size as the element sequence consists of all storage
2590 units of the actual argument up to the end of the array. */
2592 static unsigned long
2593 get_expr_storage_size (gfc_expr
*e
)
2596 long int strlen
, elements
;
2597 long int substrlen
= 0;
2598 bool is_str_storage
= false;
2604 if (e
->ts
.type
== BT_CHARACTER
)
2606 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2607 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2608 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2609 else if (e
->expr_type
== EXPR_CONSTANT
2610 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2611 strlen
= e
->value
.character
.length
;
2616 strlen
= 1; /* Length per element. */
2618 if (e
->rank
== 0 && !e
->ref
)
2626 for (i
= 0; i
< e
->rank
; i
++)
2627 elements
*= mpz_get_si (e
->shape
[i
]);
2628 return elements
*strlen
;
2631 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2633 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2634 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2638 /* The string length is the substring length.
2639 Set now to full string length. */
2640 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2641 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2644 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2646 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2650 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2651 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2653 long int start
, end
, stride
;
2656 if (ref
->u
.ar
.stride
[i
])
2658 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2659 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2664 if (ref
->u
.ar
.start
[i
])
2666 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2667 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2671 else if (ref
->u
.ar
.as
->lower
[i
]
2672 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2673 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2677 if (ref
->u
.ar
.end
[i
])
2679 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2680 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2684 else if (ref
->u
.ar
.as
->upper
[i
]
2685 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2686 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2690 elements
*= (end
- start
)/stride
+ 1L;
2692 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2693 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2695 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2696 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2697 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2698 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2699 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2700 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2701 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2706 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2707 && e
->expr_type
== EXPR_VARIABLE
)
2709 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2710 || e
->symtree
->n
.sym
->attr
.pointer
)
2716 /* Determine the number of remaining elements in the element
2717 sequence for array element designators. */
2718 is_str_storage
= true;
2719 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2721 if (ref
->u
.ar
.start
[i
] == NULL
2722 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2723 || ref
->u
.ar
.as
->upper
[i
] == NULL
2724 || ref
->u
.ar
.as
->lower
[i
] == NULL
2725 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2726 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2731 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2732 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2734 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2735 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2738 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2739 && ref
->u
.c
.component
->attr
.proc_pointer
2740 && ref
->u
.c
.component
->attr
.dimension
)
2742 /* Array-valued procedure-pointer components. */
2743 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2744 for (i
= 0; i
< as
->rank
; i
++)
2746 if (!as
->upper
[i
] || !as
->lower
[i
]
2747 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2748 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2752 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2753 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2759 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2762 return elements
*strlen
;
2766 /* Given an expression, check whether it is an array section
2767 which has a vector subscript. */
2770 gfc_has_vector_subscript (gfc_expr
*e
)
2775 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2778 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2779 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2780 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2781 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2789 is_procptr_result (gfc_expr
*expr
)
2791 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2793 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2795 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2796 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2800 /* Recursively append candidate argument ARG to CANDIDATES. Store the
2801 number of total candidates in CANDIDATES_LEN. */
2804 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
2806 size_t &candidates_len
)
2808 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
2809 vec_push (candidates
, candidates_len
, p
->sym
->name
);
2813 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
2816 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
2818 char **candidates
= NULL
;
2819 size_t candidates_len
= 0;
2820 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
2821 return gfc_closest_fuzzy_match (arg
, candidates
);
2825 /* Given formal and actual argument lists, see if they are compatible.
2826 If they are compatible, the actual argument list is sorted to
2827 correspond with the formal list, and elements for missing optional
2828 arguments are inserted. If WHERE pointer is nonnull, then we issue
2829 errors when things don't match instead of just returning the status
2833 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2834 int ranks_must_agree
, int is_elemental
, locus
*where
)
2836 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2837 gfc_formal_arglist
*f
;
2839 unsigned long actual_size
, formal_size
;
2840 bool full_array
= false;
2841 gfc_array_ref
*actual_arr_ref
;
2845 if (actual
== NULL
&& formal
== NULL
)
2849 for (f
= formal
; f
; f
= f
->next
)
2852 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2854 for (i
= 0; i
< n
; i
++)
2861 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2863 /* Look for keywords but ignore g77 extensions like %VAL. */
2864 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2867 for (f
= formal
; f
; f
= f
->next
, i
++)
2871 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2879 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
2881 gfc_error ("Keyword argument %qs at %L is not in "
2882 "the procedure; did you mean %qs?",
2883 a
->name
, &a
->expr
->where
, guessed
);
2885 gfc_error ("Keyword argument %qs at %L is not in "
2886 "the procedure", a
->name
, &a
->expr
->where
);
2891 if (new_arg
[i
] != NULL
)
2894 gfc_error ("Keyword argument %qs at %L is already associated "
2895 "with another actual argument", a
->name
,
2904 gfc_error ("More actual than formal arguments in procedure "
2905 "call at %L", where
);
2910 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2916 gfc_error ("Missing alternate return spec in subroutine call "
2921 if (a
->expr
== NULL
)
2924 gfc_error ("Unexpected alternate return spec in subroutine "
2925 "call at %L", where
);
2929 /* Make sure that intrinsic vtables exist for calls to unlimited
2930 polymorphic formal arguments. */
2931 if (UNLIMITED_POLY (f
->sym
)
2932 && a
->expr
->ts
.type
!= BT_DERIVED
2933 && a
->expr
->ts
.type
!= BT_CLASS
)
2934 gfc_find_vtab (&a
->expr
->ts
);
2936 if (a
->expr
->expr_type
== EXPR_NULL
2937 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2938 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2939 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2940 || (f
->sym
->ts
.type
== BT_CLASS
2941 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2942 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2943 || !f
->sym
->attr
.optional
2944 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2947 && (!f
->sym
->attr
.optional
2948 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2949 || (f
->sym
->ts
.type
== BT_CLASS
2950 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2951 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2952 where
, f
->sym
->name
);
2954 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2955 "dummy %qs", where
, f
->sym
->name
);
2960 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2961 is_elemental
, where
))
2964 /* TS 29113, 6.3p2. */
2965 if (f
->sym
->ts
.type
== BT_ASSUMED
2966 && (a
->expr
->ts
.type
== BT_DERIVED
2967 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2969 gfc_namespace
*f2k_derived
;
2971 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2972 ? a
->expr
->ts
.u
.derived
->f2k_derived
2973 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2976 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2978 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2979 "derived type with type-bound or FINAL procedures",
2985 /* Special case for character arguments. For allocatable, pointer
2986 and assumed-shape dummies, the string length needs to match
2988 if (a
->expr
->ts
.type
== BT_CHARACTER
2989 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2990 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2991 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
2992 && f
->sym
->ts
.u
.cl
->length
2993 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2994 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2995 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2996 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2997 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2999 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3000 gfc_warning (OPT_Wargument_mismatch
,
3001 "Character length mismatch (%ld/%ld) between actual "
3002 "argument and pointer or allocatable dummy argument "
3004 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3005 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3006 f
->sym
->name
, &a
->expr
->where
);
3008 gfc_warning (OPT_Wargument_mismatch
,
3009 "Character length mismatch (%ld/%ld) between actual "
3010 "argument and assumed-shape dummy argument %qs "
3012 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3013 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3014 f
->sym
->name
, &a
->expr
->where
);
3018 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3019 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3020 && a
->expr
->ts
.type
== BT_CHARACTER
)
3023 gfc_error ("Actual argument at %L to allocatable or "
3024 "pointer dummy argument %qs must have a deferred "
3025 "length type parameter if and only if the dummy has one",
3026 &a
->expr
->where
, f
->sym
->name
);
3030 if (f
->sym
->ts
.type
== BT_CLASS
)
3031 goto skip_size_check
;
3033 actual_size
= get_expr_storage_size (a
->expr
);
3034 formal_size
= get_sym_storage_size (f
->sym
);
3035 if (actual_size
!= 0 && actual_size
< formal_size
3036 && a
->expr
->ts
.type
!= BT_PROCEDURE
3037 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3039 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3040 gfc_warning (OPT_Wargument_mismatch
,
3041 "Character length of actual argument shorter "
3042 "than of dummy argument %qs (%lu/%lu) at %L",
3043 f
->sym
->name
, actual_size
, formal_size
,
3047 /* Emit a warning for -std=legacy and an error otherwise. */
3048 if (gfc_option
.warn_std
== 0)
3049 gfc_warning (OPT_Wargument_mismatch
,
3050 "Actual argument contains too few "
3051 "elements for dummy argument %qs (%lu/%lu) "
3052 "at %L", f
->sym
->name
, actual_size
,
3053 formal_size
, &a
->expr
->where
);
3055 gfc_error_now ("Actual argument contains too few "
3056 "elements for dummy argument %qs (%lu/%lu) "
3057 "at %L", f
->sym
->name
, actual_size
,
3058 formal_size
, &a
->expr
->where
);
3065 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3066 argument is provided for a procedure pointer formal argument. */
3067 if (f
->sym
->attr
.proc_pointer
3068 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3069 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3070 || gfc_is_proc_ptr_comp (a
->expr
)))
3071 || (a
->expr
->expr_type
== EXPR_FUNCTION
3072 && is_procptr_result (a
->expr
))))
3075 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3076 f
->sym
->name
, &a
->expr
->where
);
3080 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3081 provided for a procedure formal argument. */
3082 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3083 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3084 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3085 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3086 || gfc_is_proc_ptr_comp (a
->expr
)))
3087 || (a
->expr
->expr_type
== EXPR_FUNCTION
3088 && is_procptr_result (a
->expr
))))
3091 gfc_error ("Expected a procedure for argument %qs at %L",
3092 f
->sym
->name
, &a
->expr
->where
);
3096 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3097 && a
->expr
->expr_type
== EXPR_VARIABLE
3098 && a
->expr
->symtree
->n
.sym
->as
3099 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3100 && (a
->expr
->ref
== NULL
3101 || (a
->expr
->ref
->type
== REF_ARRAY
3102 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3105 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3106 " array at %L", f
->sym
->name
, where
);
3110 if (a
->expr
->expr_type
!= EXPR_NULL
3111 && compare_pointer (f
->sym
, a
->expr
) == 0)
3114 gfc_error ("Actual argument for %qs must be a pointer at %L",
3115 f
->sym
->name
, &a
->expr
->where
);
3119 if (a
->expr
->expr_type
!= EXPR_NULL
3120 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3121 && compare_pointer (f
->sym
, a
->expr
) == 2)
3124 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3125 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3130 /* Fortran 2008, C1242. */
3131 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3134 gfc_error ("Coindexed actual argument at %L to pointer "
3136 &a
->expr
->where
, f
->sym
->name
);
3140 /* Fortran 2008, 12.5.2.5 (no constraint). */
3141 if (a
->expr
->expr_type
== EXPR_VARIABLE
3142 && f
->sym
->attr
.intent
!= INTENT_IN
3143 && f
->sym
->attr
.allocatable
3144 && gfc_is_coindexed (a
->expr
))
3147 gfc_error ("Coindexed actual argument at %L to allocatable "
3148 "dummy %qs requires INTENT(IN)",
3149 &a
->expr
->where
, f
->sym
->name
);
3153 /* Fortran 2008, C1237. */
3154 if (a
->expr
->expr_type
== EXPR_VARIABLE
3155 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3156 && gfc_is_coindexed (a
->expr
)
3157 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3158 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3161 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3162 "%L requires that dummy %qs has neither "
3163 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3168 /* Fortran 2008, 12.5.2.4 (no constraint). */
3169 if (a
->expr
->expr_type
== EXPR_VARIABLE
3170 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3171 && gfc_is_coindexed (a
->expr
)
3172 && gfc_has_ultimate_allocatable (a
->expr
))
3175 gfc_error ("Coindexed actual argument at %L with allocatable "
3176 "ultimate component to dummy %qs requires either VALUE "
3177 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3181 if (f
->sym
->ts
.type
== BT_CLASS
3182 && CLASS_DATA (f
->sym
)->attr
.allocatable
3183 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3187 gfc_error ("Actual CLASS array argument for %qs must be a full "
3188 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3193 if (a
->expr
->expr_type
!= EXPR_NULL
3194 && !compare_allocatable (f
->sym
, a
->expr
))
3197 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3198 f
->sym
->name
, &a
->expr
->where
);
3202 /* Check intent = OUT/INOUT for definable actual argument. */
3203 if ((f
->sym
->attr
.intent
== INTENT_OUT
3204 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3206 const char* context
= (where
3207 ? _("actual argument to INTENT = OUT/INOUT")
3210 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3211 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3212 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3213 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3215 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3219 if ((f
->sym
->attr
.intent
== INTENT_OUT
3220 || f
->sym
->attr
.intent
== INTENT_INOUT
3221 || f
->sym
->attr
.volatile_
3222 || f
->sym
->attr
.asynchronous
)
3223 && gfc_has_vector_subscript (a
->expr
))
3226 gfc_error ("Array-section actual argument with vector "
3227 "subscripts at %L is incompatible with INTENT(OUT), "
3228 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3229 "of the dummy argument %qs",
3230 &a
->expr
->where
, f
->sym
->name
);
3234 /* C1232 (R1221) For an actual argument which is an array section or
3235 an assumed-shape array, the dummy argument shall be an assumed-
3236 shape array, if the dummy argument has the VOLATILE attribute. */
3238 if (f
->sym
->attr
.volatile_
3239 && a
->expr
->expr_type
== EXPR_VARIABLE
3240 && a
->expr
->symtree
->n
.sym
->as
3241 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3242 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3245 gfc_error ("Assumed-shape actual argument at %L is "
3246 "incompatible with the non-assumed-shape "
3247 "dummy argument %qs due to VOLATILE attribute",
3248 &a
->expr
->where
,f
->sym
->name
);
3252 /* Find the last array_ref. */
3253 actual_arr_ref
= NULL
;
3255 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3257 if (f
->sym
->attr
.volatile_
3258 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3259 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3262 gfc_error ("Array-section actual argument at %L is "
3263 "incompatible with the non-assumed-shape "
3264 "dummy argument %qs due to VOLATILE attribute",
3265 &a
->expr
->where
, f
->sym
->name
);
3269 /* C1233 (R1221) For an actual argument which is a pointer array, the
3270 dummy argument shall be an assumed-shape or pointer array, if the
3271 dummy argument has the VOLATILE attribute. */
3273 if (f
->sym
->attr
.volatile_
3274 && a
->expr
->expr_type
== EXPR_VARIABLE
3275 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3276 && a
->expr
->symtree
->n
.sym
->as
3278 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3279 || f
->sym
->attr
.pointer
)))
3282 gfc_error ("Pointer-array actual argument at %L requires "
3283 "an assumed-shape or pointer-array dummy "
3284 "argument %qs due to VOLATILE attribute",
3285 &a
->expr
->where
,f
->sym
->name
);
3296 /* Make sure missing actual arguments are optional. */
3298 for (f
= formal
; f
; f
= f
->next
, i
++)
3300 if (new_arg
[i
] != NULL
)
3305 gfc_error ("Missing alternate return spec in subroutine call "
3309 if (!f
->sym
->attr
.optional
)
3312 gfc_error ("Missing actual argument for argument %qs at %L",
3313 f
->sym
->name
, where
);
3318 /* The argument lists are compatible. We now relink a new actual
3319 argument list with null arguments in the right places. The head
3320 of the list remains the head. */
3321 for (i
= 0; i
< n
; i
++)
3322 if (new_arg
[i
] == NULL
)
3323 new_arg
[i
] = gfc_get_actual_arglist ();
3327 std::swap (*new_arg
[0], *actual
);
3328 std::swap (new_arg
[0], new_arg
[na
]);
3331 for (i
= 0; i
< n
- 1; i
++)
3332 new_arg
[i
]->next
= new_arg
[i
+ 1];
3334 new_arg
[i
]->next
= NULL
;
3336 if (*ap
== NULL
&& n
> 0)
3339 /* Note the types of omitted optional arguments. */
3340 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3341 if (a
->expr
== NULL
&& a
->label
== NULL
)
3342 a
->missing_arg_type
= f
->sym
->ts
.type
;
3350 gfc_formal_arglist
*f
;
3351 gfc_actual_arglist
*a
;
3355 /* qsort comparison function for argument pairs, with the following
3357 - p->a->expr == NULL
3358 - p->a->expr->expr_type != EXPR_VARIABLE
3359 - by gfc_symbol pointer value (larger first). */
3362 pair_cmp (const void *p1
, const void *p2
)
3364 const gfc_actual_arglist
*a1
, *a2
;
3366 /* *p1 and *p2 are elements of the to-be-sorted array. */
3367 a1
= ((const argpair
*) p1
)->a
;
3368 a2
= ((const argpair
*) p2
)->a
;
3377 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3379 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3383 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3385 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3387 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3391 /* Given two expressions from some actual arguments, test whether they
3392 refer to the same expression. The analysis is conservative.
3393 Returning false will produce no warning. */
3396 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3398 const gfc_ref
*r1
, *r2
;
3401 || e1
->expr_type
!= EXPR_VARIABLE
3402 || e2
->expr_type
!= EXPR_VARIABLE
3403 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3406 /* TODO: improve comparison, see expr.c:show_ref(). */
3407 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3409 if (r1
->type
!= r2
->type
)
3414 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3416 /* TODO: At the moment, consider only full arrays;
3417 we could do better. */
3418 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3423 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3431 gfc_internal_error ("compare_actual_expr(): Bad component code");
3440 /* Given formal and actual argument lists that correspond to one
3441 another, check that identical actual arguments aren't not
3442 associated with some incompatible INTENTs. */
3445 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3447 sym_intent f1_intent
, f2_intent
;
3448 gfc_formal_arglist
*f1
;
3449 gfc_actual_arglist
*a1
;
3455 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3457 if (f1
== NULL
&& a1
== NULL
)
3459 if (f1
== NULL
|| a1
== NULL
)
3460 gfc_internal_error ("check_some_aliasing(): List mismatch");
3465 p
= XALLOCAVEC (argpair
, n
);
3467 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3473 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3475 for (i
= 0; i
< n
; i
++)
3478 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3479 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3481 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3482 for (j
= i
+ 1; j
< n
; j
++)
3484 /* Expected order after the sort. */
3485 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3486 gfc_internal_error ("check_some_aliasing(): corrupted data");
3488 /* Are the expression the same? */
3489 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3491 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3492 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3493 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3494 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3496 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3497 "argument %qs and INTENT(%s) argument %qs at %L",
3498 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3499 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3500 &p
[i
].a
->expr
->where
);
3510 /* Given formal and actual argument lists that correspond to one
3511 another, check that they are compatible in the sense that intents
3512 are not mismatched. */
3515 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3517 sym_intent f_intent
;
3519 for (;; f
= f
->next
, a
= a
->next
)
3523 if (f
== NULL
&& a
== NULL
)
3525 if (f
== NULL
|| a
== NULL
)
3526 gfc_internal_error ("check_intents(): List mismatch");
3528 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3529 && a
->expr
->value
.function
.isym
3530 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3531 expr
= a
->expr
->value
.function
.actual
->expr
;
3535 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3538 f_intent
= f
->sym
->attr
.intent
;
3540 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3542 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3543 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3544 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3546 gfc_error ("Procedure argument at %L is local to a PURE "
3547 "procedure and has the POINTER attribute",
3553 /* Fortran 2008, C1283. */
3554 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3556 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3558 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3559 "is passed to an INTENT(%s) argument",
3560 &expr
->where
, gfc_intent_string (f_intent
));
3564 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3565 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3566 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3568 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3569 "is passed to a POINTER dummy argument",
3575 /* F2008, Section 12.5.2.4. */
3576 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3577 && gfc_is_coindexed (expr
))
3579 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3580 "polymorphic dummy argument %qs",
3581 &expr
->where
, f
->sym
->name
);
3590 /* Check how a procedure is used against its interface. If all goes
3591 well, the actual argument list will also end up being properly
3595 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3597 gfc_formal_arglist
*dummy_args
;
3599 /* Warn about calls with an implicit interface. Special case
3600 for calling a ISO_C_BINDING because c_loc and c_funloc
3601 are pseudo-unknown. Additionally, warn about procedures not
3602 explicitly declared at all if requested. */
3603 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3605 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3608 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3610 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3611 "; did you mean %qs?",
3612 sym
->name
, where
, guessed
);
3614 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3618 if (warn_implicit_interface
)
3619 gfc_warning (OPT_Wimplicit_interface
,
3620 "Procedure %qs called with an implicit interface at %L",
3622 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3623 gfc_warning (OPT_Wimplicit_procedure
,
3624 "Procedure %qs called at %L is not explicitly declared",
3628 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3630 gfc_actual_arglist
*a
;
3632 if (sym
->attr
.pointer
)
3634 gfc_error ("The pointer object %qs at %L must have an explicit "
3635 "function interface or be declared as array",
3640 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3642 gfc_error ("The allocatable object %qs at %L must have an explicit "
3643 "function interface or be declared as array",
3648 if (sym
->attr
.allocatable
)
3650 gfc_error ("Allocatable function %qs at %L must have an explicit "
3651 "function interface", sym
->name
, where
);
3655 for (a
= *ap
; a
; a
= a
->next
)
3657 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3658 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3660 gfc_error ("Keyword argument requires explicit interface "
3661 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3665 /* TS 29113, 6.2. */
3666 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3667 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3669 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3670 "interface", a
->expr
->symtree
->n
.sym
->name
,
3675 /* F2008, C1303 and C1304. */
3677 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3678 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3679 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3680 || gfc_expr_attr (a
->expr
).lock_comp
))
3682 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3683 "component at %L requires an explicit interface for "
3684 "procedure %qs", &a
->expr
->where
, sym
->name
);
3689 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3690 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3691 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3692 == ISOFORTRAN_EVENT_TYPE
)
3693 || gfc_expr_attr (a
->expr
).event_comp
))
3695 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3696 "component at %L requires an explicit interface for "
3697 "procedure %qs", &a
->expr
->where
, sym
->name
);
3701 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3702 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3704 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3708 /* TS 29113, C407b. */
3709 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3710 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3712 gfc_error ("Assumed-rank argument requires an explicit interface "
3713 "at %L", &a
->expr
->where
);
3721 dummy_args
= gfc_sym_get_dummy_args (sym
);
3723 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3726 if (!check_intents (dummy_args
, *ap
))
3730 check_some_aliasing (dummy_args
, *ap
);
3736 /* Check how a procedure pointer component is used against its interface.
3737 If all goes well, the actual argument list will also end up being properly
3738 sorted. Completely analogous to gfc_procedure_use. */
3741 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3743 /* Warn about calls with an implicit interface. Special case
3744 for calling a ISO_C_BINDING because c_loc and c_funloc
3745 are pseudo-unknown. */
3746 if (warn_implicit_interface
3747 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3748 && !comp
->attr
.is_iso_c
)
3749 gfc_warning (OPT_Wimplicit_interface
,
3750 "Procedure pointer component %qs called with an implicit "
3751 "interface at %L", comp
->name
, where
);
3753 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3755 gfc_actual_arglist
*a
;
3756 for (a
= *ap
; a
; a
= a
->next
)
3758 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3759 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3761 gfc_error ("Keyword argument requires explicit interface "
3762 "for procedure pointer component %qs at %L",
3763 comp
->name
, &a
->expr
->where
);
3771 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3772 comp
->attr
.elemental
, where
))
3775 check_intents (comp
->ts
.interface
->formal
, *ap
);
3777 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3781 /* Try if an actual argument list matches the formal list of a symbol,
3782 respecting the symbol's attributes like ELEMENTAL. This is used for
3783 GENERIC resolution. */
3786 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3788 gfc_formal_arglist
*dummy_args
;
3791 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3794 dummy_args
= gfc_sym_get_dummy_args (sym
);
3796 r
= !sym
->attr
.elemental
;
3797 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3799 check_intents (dummy_args
, *args
);
3801 check_some_aliasing (dummy_args
, *args
);
3809 /* Given an interface pointer and an actual argument list, search for
3810 a formal argument list that matches the actual. If found, returns
3811 a pointer to the symbol of the correct interface. Returns NULL if
3815 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3816 gfc_actual_arglist
**ap
)
3818 gfc_symbol
*elem_sym
= NULL
;
3819 gfc_symbol
*null_sym
= NULL
;
3820 locus null_expr_loc
;
3821 gfc_actual_arglist
*a
;
3822 bool has_null_arg
= false;
3824 for (a
= *ap
; a
; a
= a
->next
)
3825 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3826 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3828 has_null_arg
= true;
3829 null_expr_loc
= a
->expr
->where
;
3833 for (; intr
; intr
= intr
->next
)
3835 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3837 if (sub_flag
&& intr
->sym
->attr
.function
)
3839 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3842 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3844 if (has_null_arg
&& null_sym
)
3846 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3847 "between specific functions %s and %s",
3848 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3851 else if (has_null_arg
)
3853 null_sym
= intr
->sym
;
3857 /* Satisfy 12.4.4.1 such that an elemental match has lower
3858 weight than a non-elemental match. */
3859 if (intr
->sym
->attr
.elemental
)
3861 elem_sym
= intr
->sym
;
3871 return elem_sym
? elem_sym
: NULL
;
3875 /* Do a brute force recursive search for a symbol. */
3877 static gfc_symtree
*
3878 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3882 if (root
->n
.sym
== sym
)
3887 st
= find_symtree0 (root
->left
, sym
);
3888 if (root
->right
&& ! st
)
3889 st
= find_symtree0 (root
->right
, sym
);
3894 /* Find a symtree for a symbol. */
3897 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3902 /* First try to find it by name. */
3903 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3904 if (st
&& st
->n
.sym
== sym
)
3907 /* If it's been renamed, resort to a brute-force search. */
3908 /* TODO: avoid having to do this search. If the symbol doesn't exist
3909 in the symtree for the current namespace, it should probably be added. */
3910 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3912 st
= find_symtree0 (ns
->sym_root
, sym
);
3916 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3921 /* See if the arglist to an operator-call contains a derived-type argument
3922 with a matching type-bound operator. If so, return the matching specific
3923 procedure defined as operator-target as well as the base-object to use
3924 (which is the found derived-type argument with operator). The generic
3925 name, if any, is transmitted to the final expression via 'gname'. */
3927 static gfc_typebound_proc
*
3928 matching_typebound_op (gfc_expr
** tb_base
,
3929 gfc_actual_arglist
* args
,
3930 gfc_intrinsic_op op
, const char* uop
,
3931 const char ** gname
)
3933 gfc_actual_arglist
* base
;
3935 for (base
= args
; base
; base
= base
->next
)
3936 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3938 gfc_typebound_proc
* tb
;
3939 gfc_symbol
* derived
;
3942 while (base
->expr
->expr_type
== EXPR_OP
3943 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3944 base
->expr
= base
->expr
->value
.op
.op1
;
3946 if (base
->expr
->ts
.type
== BT_CLASS
)
3948 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
3949 || !gfc_expr_attr (base
->expr
).class_ok
)
3951 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3954 derived
= base
->expr
->ts
.u
.derived
;
3956 if (op
== INTRINSIC_USER
)
3958 gfc_symtree
* tb_uop
;
3961 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3970 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3973 /* This means we hit a PRIVATE operator which is use-associated and
3974 should thus not be seen. */
3978 /* Look through the super-type hierarchy for a matching specific
3980 for (; tb
; tb
= tb
->overridden
)
3984 gcc_assert (tb
->is_generic
);
3985 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3988 gfc_actual_arglist
* argcopy
;
3991 gcc_assert (g
->specific
);
3992 if (g
->specific
->error
)
3995 target
= g
->specific
->u
.specific
->n
.sym
;
3997 /* Check if this arglist matches the formal. */
3998 argcopy
= gfc_copy_actual_arglist (args
);
3999 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4000 gfc_free_actual_arglist (argcopy
);
4002 /* Return if we found a match. */
4005 *tb_base
= base
->expr
;
4006 *gname
= g
->specific_st
->name
;
4017 /* For the 'actual arglist' of an operator call and a specific typebound
4018 procedure that has been found the target of a type-bound operator, build the
4019 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4020 type-bound procedures rather than resolving type-bound operators 'directly'
4021 so that we can reuse the existing logic. */
4024 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4025 gfc_expr
* base
, gfc_typebound_proc
* target
,
4028 e
->expr_type
= EXPR_COMPCALL
;
4029 e
->value
.compcall
.tbp
= target
;
4030 e
->value
.compcall
.name
= gname
? gname
: "$op";
4031 e
->value
.compcall
.actual
= actual
;
4032 e
->value
.compcall
.base_object
= base
;
4033 e
->value
.compcall
.ignore_pass
= 1;
4034 e
->value
.compcall
.assign
= 0;
4035 if (e
->ts
.type
== BT_UNKNOWN
4036 && target
->function
)
4038 if (target
->is_generic
)
4039 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4041 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4046 /* This subroutine is called when an expression is being resolved.
4047 The expression node in question is either a user defined operator
4048 or an intrinsic operator with arguments that aren't compatible
4049 with the operator. This subroutine builds an actual argument list
4050 corresponding to the operands, then searches for a compatible
4051 interface. If one is found, the expression node is replaced with
4052 the appropriate function call. We use the 'match' enum to specify
4053 whether a replacement has been made or not, or if an error occurred. */
4056 gfc_extend_expr (gfc_expr
*e
)
4058 gfc_actual_arglist
*actual
;
4064 gfc_typebound_proc
* tbo
;
4069 actual
= gfc_get_actual_arglist ();
4070 actual
->expr
= e
->value
.op
.op1
;
4074 if (e
->value
.op
.op2
!= NULL
)
4076 actual
->next
= gfc_get_actual_arglist ();
4077 actual
->next
->expr
= e
->value
.op
.op2
;
4080 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4082 /* See if we find a matching type-bound operator. */
4083 if (i
== INTRINSIC_USER
)
4084 tbo
= matching_typebound_op (&tb_base
, actual
,
4085 i
, e
->value
.op
.uop
->name
, &gname
);
4089 #define CHECK_OS_COMPARISON(comp) \
4090 case INTRINSIC_##comp: \
4091 case INTRINSIC_##comp##_OS: \
4092 tbo = matching_typebound_op (&tb_base, actual, \
4093 INTRINSIC_##comp, NULL, &gname); \
4095 tbo = matching_typebound_op (&tb_base, actual, \
4096 INTRINSIC_##comp##_OS, NULL, &gname); \
4098 CHECK_OS_COMPARISON(EQ
)
4099 CHECK_OS_COMPARISON(NE
)
4100 CHECK_OS_COMPARISON(GT
)
4101 CHECK_OS_COMPARISON(GE
)
4102 CHECK_OS_COMPARISON(LT
)
4103 CHECK_OS_COMPARISON(LE
)
4104 #undef CHECK_OS_COMPARISON
4107 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4111 /* If there is a matching typebound-operator, replace the expression with
4112 a call to it and succeed. */
4115 gcc_assert (tb_base
);
4116 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4118 if (!gfc_resolve_expr (e
))
4124 if (i
== INTRINSIC_USER
)
4126 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4128 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4132 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4139 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4141 /* Due to the distinction between '==' and '.eq.' and friends, one has
4142 to check if either is defined. */
4145 #define CHECK_OS_COMPARISON(comp) \
4146 case INTRINSIC_##comp: \
4147 case INTRINSIC_##comp##_OS: \
4148 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4150 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4152 CHECK_OS_COMPARISON(EQ
)
4153 CHECK_OS_COMPARISON(NE
)
4154 CHECK_OS_COMPARISON(GT
)
4155 CHECK_OS_COMPARISON(GE
)
4156 CHECK_OS_COMPARISON(LT
)
4157 CHECK_OS_COMPARISON(LE
)
4158 #undef CHECK_OS_COMPARISON
4161 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4169 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4170 found rather than just taking the first one and not checking further. */
4174 /* Don't use gfc_free_actual_arglist(). */
4175 free (actual
->next
);
4180 /* Change the expression node to a function call. */
4181 e
->expr_type
= EXPR_FUNCTION
;
4182 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4183 e
->value
.function
.actual
= actual
;
4184 e
->value
.function
.esym
= NULL
;
4185 e
->value
.function
.isym
= NULL
;
4186 e
->value
.function
.name
= NULL
;
4187 e
->user_operator
= 1;
4189 if (!gfc_resolve_expr (e
))
4196 /* Tries to replace an assignment code node with a subroutine call to the
4197 subroutine associated with the assignment operator. Return true if the node
4198 was replaced. On false, no error is generated. */
4201 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4203 gfc_actual_arglist
*actual
;
4204 gfc_expr
*lhs
, *rhs
, *tb_base
;
4205 gfc_symbol
*sym
= NULL
;
4206 const char *gname
= NULL
;
4207 gfc_typebound_proc
* tbo
;
4212 /* Don't allow an intrinsic assignment to be replaced. */
4213 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4214 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4215 && (lhs
->ts
.type
== rhs
->ts
.type
4216 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4219 actual
= gfc_get_actual_arglist ();
4222 actual
->next
= gfc_get_actual_arglist ();
4223 actual
->next
->expr
= rhs
;
4225 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4227 /* See if we find a matching type-bound assignment. */
4228 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4233 /* Success: Replace the expression with a type-bound call. */
4234 gcc_assert (tb_base
);
4235 c
->expr1
= gfc_get_expr ();
4236 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4237 c
->expr1
->value
.compcall
.assign
= 1;
4238 c
->expr1
->where
= c
->loc
;
4240 c
->op
= EXEC_COMPCALL
;
4244 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4245 for (; ns
; ns
= ns
->parent
)
4247 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4254 /* Success: Replace the assignment with the call. */
4255 c
->op
= EXEC_ASSIGN_CALL
;
4256 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4259 c
->ext
.actual
= actual
;
4263 /* Failure: No assignment procedure found. */
4264 free (actual
->next
);
4270 /* Make sure that the interface just parsed is not already present in
4271 the given interface list. Ambiguity isn't checked yet since module
4272 procedures can be present without interfaces. */
4275 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4279 for (ip
= base
; ip
; ip
= ip
->next
)
4281 if (ip
->sym
== new_sym
)
4283 gfc_error ("Entity %qs at %L is already present in the interface",
4284 new_sym
->name
, &loc
);
4293 /* Add a symbol to the current interface. */
4296 gfc_add_interface (gfc_symbol
*new_sym
)
4298 gfc_interface
**head
, *intr
;
4302 switch (current_interface
.type
)
4304 case INTERFACE_NAMELESS
:
4305 case INTERFACE_ABSTRACT
:
4308 case INTERFACE_INTRINSIC_OP
:
4309 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4310 switch (current_interface
.op
)
4313 case INTRINSIC_EQ_OS
:
4314 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4316 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4317 new_sym
, gfc_current_locus
))
4322 case INTRINSIC_NE_OS
:
4323 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4325 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4326 new_sym
, gfc_current_locus
))
4331 case INTRINSIC_GT_OS
:
4332 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4333 new_sym
, gfc_current_locus
)
4334 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4335 new_sym
, gfc_current_locus
))
4340 case INTRINSIC_GE_OS
:
4341 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4342 new_sym
, gfc_current_locus
)
4343 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4344 new_sym
, gfc_current_locus
))
4349 case INTRINSIC_LT_OS
:
4350 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4351 new_sym
, gfc_current_locus
)
4352 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4353 new_sym
, gfc_current_locus
))
4358 case INTRINSIC_LE_OS
:
4359 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4360 new_sym
, gfc_current_locus
)
4361 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4362 new_sym
, gfc_current_locus
))
4367 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4368 new_sym
, gfc_current_locus
))
4372 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4375 case INTERFACE_GENERIC
:
4376 case INTERFACE_DTIO
:
4377 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4379 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4383 if (!gfc_check_new_interface (sym
->generic
,
4384 new_sym
, gfc_current_locus
))
4388 head
= ¤t_interface
.sym
->generic
;
4391 case INTERFACE_USER_OP
:
4392 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4393 new_sym
, gfc_current_locus
))
4396 head
= ¤t_interface
.uop
->op
;
4400 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4403 intr
= gfc_get_interface ();
4404 intr
->sym
= new_sym
;
4405 intr
->where
= gfc_current_locus
;
4415 gfc_current_interface_head (void)
4417 switch (current_interface
.type
)
4419 case INTERFACE_INTRINSIC_OP
:
4420 return current_interface
.ns
->op
[current_interface
.op
];
4422 case INTERFACE_GENERIC
:
4423 case INTERFACE_DTIO
:
4424 return current_interface
.sym
->generic
;
4426 case INTERFACE_USER_OP
:
4427 return current_interface
.uop
->op
;
4436 gfc_set_current_interface_head (gfc_interface
*i
)
4438 switch (current_interface
.type
)
4440 case INTERFACE_INTRINSIC_OP
:
4441 current_interface
.ns
->op
[current_interface
.op
] = i
;
4444 case INTERFACE_GENERIC
:
4445 case INTERFACE_DTIO
:
4446 current_interface
.sym
->generic
= i
;
4449 case INTERFACE_USER_OP
:
4450 current_interface
.uop
->op
= i
;
4459 /* Gets rid of a formal argument list. We do not free symbols.
4460 Symbols are freed when a namespace is freed. */
4463 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4465 gfc_formal_arglist
*q
;
4475 /* Check that it is ok for the type-bound procedure 'proc' to override the
4476 procedure 'old', cf. F08:4.5.7.3. */
4479 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4482 gfc_symbol
*proc_target
, *old_target
;
4483 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4484 gfc_formal_arglist
*proc_formal
, *old_formal
;
4488 /* This procedure should only be called for non-GENERIC proc. */
4489 gcc_assert (!proc
->n
.tb
->is_generic
);
4491 /* If the overwritten procedure is GENERIC, this is an error. */
4492 if (old
->n
.tb
->is_generic
)
4494 gfc_error ("Can't overwrite GENERIC %qs at %L",
4495 old
->name
, &proc
->n
.tb
->where
);
4499 where
= proc
->n
.tb
->where
;
4500 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4501 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4503 /* Check that overridden binding is not NON_OVERRIDABLE. */
4504 if (old
->n
.tb
->non_overridable
)
4506 gfc_error ("%qs at %L overrides a procedure binding declared"
4507 " NON_OVERRIDABLE", proc
->name
, &where
);
4511 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4512 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4514 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4515 " non-DEFERRED binding", proc
->name
, &where
);
4519 /* If the overridden binding is PURE, the overriding must be, too. */
4520 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4522 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4523 proc
->name
, &where
);
4527 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4528 is not, the overriding must not be either. */
4529 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4531 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4532 " ELEMENTAL", proc
->name
, &where
);
4535 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4537 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4538 " be ELEMENTAL, either", proc
->name
, &where
);
4542 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4544 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4546 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4547 " SUBROUTINE", proc
->name
, &where
);
4551 /* If the overridden binding is a FUNCTION, the overriding must also be a
4552 FUNCTION and have the same characteristics. */
4553 if (old_target
->attr
.function
)
4555 if (!proc_target
->attr
.function
)
4557 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4558 " FUNCTION", proc
->name
, &where
);
4562 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4565 gfc_error ("Result mismatch for the overriding procedure "
4566 "%qs at %L: %s", proc
->name
, &where
, err
);
4571 /* If the overridden binding is PUBLIC, the overriding one must not be
4573 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4574 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4576 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4577 " PRIVATE", proc
->name
, &where
);
4581 /* Compare the formal argument lists of both procedures. This is also abused
4582 to find the position of the passed-object dummy arguments of both
4583 bindings as at least the overridden one might not yet be resolved and we
4584 need those positions in the check below. */
4585 proc_pass_arg
= old_pass_arg
= 0;
4586 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4588 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4591 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4592 old_formal
= gfc_sym_get_dummy_args (old_target
);
4593 for ( ; proc_formal
&& old_formal
;
4594 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4596 if (proc
->n
.tb
->pass_arg
4597 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4598 proc_pass_arg
= argpos
;
4599 if (old
->n
.tb
->pass_arg
4600 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4601 old_pass_arg
= argpos
;
4603 /* Check that the names correspond. */
4604 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4606 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4607 " to match the corresponding argument of the overridden"
4608 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4609 old_formal
->sym
->name
);
4613 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4614 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4615 check_type
, err
, sizeof(err
)))
4617 gfc_error_opt (OPT_Wargument_mismatch
,
4618 "Argument mismatch for the overriding procedure "
4619 "%qs at %L: %s", proc
->name
, &where
, err
);
4625 if (proc_formal
|| old_formal
)
4627 gfc_error ("%qs at %L must have the same number of formal arguments as"
4628 " the overridden procedure", proc
->name
, &where
);
4632 /* If the overridden binding is NOPASS, the overriding one must also be
4634 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4636 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4637 " NOPASS", proc
->name
, &where
);
4641 /* If the overridden binding is PASS(x), the overriding one must also be
4642 PASS and the passed-object dummy arguments must correspond. */
4643 if (!old
->n
.tb
->nopass
)
4645 if (proc
->n
.tb
->nopass
)
4647 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4648 " PASS", proc
->name
, &where
);
4652 if (proc_pass_arg
!= old_pass_arg
)
4654 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4655 " the same position as the passed-object dummy argument of"
4656 " the overridden procedure", proc
->name
, &where
);
4665 /* The following three functions check that the formal arguments
4666 of user defined derived type IO procedures are compliant with
4667 the requirements of the standard. */
4670 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4671 int kind
, int rank
, sym_intent intent
)
4673 if (fsym
->ts
.type
!= type
)
4675 gfc_error ("DTIO dummy argument at %L must be of type %s",
4676 &fsym
->declared_at
, gfc_basic_typename (type
));
4680 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4681 && fsym
->ts
.kind
!= kind
)
4682 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4683 &fsym
->declared_at
, kind
);
4687 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4688 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4689 gfc_error ("DTIO dummy argument at %L must be a scalar",
4690 &fsym
->declared_at
);
4692 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4693 gfc_error ("DTIO dummy argument at %L must be an "
4694 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4696 if (fsym
->attr
.intent
!= intent
)
4697 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4698 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4704 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4705 bool typebound
, bool formatted
, int code
)
4707 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4708 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4709 gfc_interface
*intr
;
4710 gfc_formal_arglist
*formal
;
4713 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4714 || ((dtio_codes
)code
== DTIO_RUF
);
4722 /* Typebound DTIO binding. */
4723 tb_io_proc
= tb_io_st
->n
.tb
;
4724 if (tb_io_proc
== NULL
)
4727 gcc_assert (tb_io_proc
->is_generic
);
4728 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4730 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4731 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4734 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4738 generic_proc
= tb_io_st
->n
.sym
;
4739 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4742 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4744 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4745 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4746 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4748 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4749 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4751 dtio_sub
= intr
->sym
;
4754 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4756 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4757 "procedure", &intr
->sym
->declared_at
);
4762 if (dtio_sub
== NULL
)
4766 gcc_assert (dtio_sub
);
4767 if (!dtio_sub
->attr
.subroutine
)
4768 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4769 dtio_sub
->name
, &dtio_sub
->declared_at
);
4772 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4775 if (arg_num
< (formatted
? 6 : 4))
4777 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4778 dtio_sub
->name
, &dtio_sub
->declared_at
);
4782 if (arg_num
> (formatted
? 6 : 4))
4784 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4785 dtio_sub
->name
, &dtio_sub
->declared_at
);
4790 /* Now go through the formal arglist. */
4792 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4794 if (!formatted
&& arg_num
== 3)
4800 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4801 "procedure", &dtio_sub
->declared_at
);
4808 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4809 BT_DERIVED
: BT_CLASS
;
4811 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4812 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4818 kind
= gfc_default_integer_kind
;
4820 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4823 case(3): /* IOTYPE */
4824 type
= BT_CHARACTER
;
4825 kind
= gfc_default_character_kind
;
4827 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4830 case(4): /* VLIST */
4832 kind
= gfc_default_integer_kind
;
4834 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4837 case(5): /* IOSTAT */
4839 kind
= gfc_default_integer_kind
;
4840 intent
= INTENT_OUT
;
4841 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4844 case(6): /* IOMSG */
4845 type
= BT_CHARACTER
;
4846 kind
= gfc_default_character_kind
;
4847 intent
= INTENT_INOUT
;
4848 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4855 derived
->attr
.has_dtio_procs
= 1;
4860 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4862 gfc_symtree
*tb_io_st
;
4867 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4870 /* Check typebound DTIO bindings. */
4871 for (code
= 0; code
< 4; code
++)
4873 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4874 || ((dtio_codes
)code
== DTIO_WF
);
4876 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4877 gfc_code2string (dtio_procs
, code
),
4878 true, &derived
->declared_at
);
4879 if (tb_io_st
!= NULL
)
4880 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4883 /* Check generic DTIO interfaces. */
4884 for (code
= 0; code
< 4; code
++)
4886 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4887 || ((dtio_codes
)code
== DTIO_WF
);
4889 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4890 gfc_code2string (dtio_procs
, code
));
4891 if (tb_io_st
!= NULL
)
4892 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4898 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4900 gfc_symtree
*tb_io_st
= NULL
;
4903 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4906 /* Try to find a typebound DTIO binding. */
4907 if (formatted
== true)
4910 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4911 gfc_code2string (dtio_procs
,
4914 &derived
->declared_at
);
4916 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4917 gfc_code2string (dtio_procs
,
4920 &derived
->declared_at
);
4925 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4926 gfc_code2string (dtio_procs
,
4929 &derived
->declared_at
);
4931 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4932 gfc_code2string (dtio_procs
,
4935 &derived
->declared_at
);
4942 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4944 gfc_symtree
*tb_io_st
= NULL
;
4945 gfc_symbol
*dtio_sub
= NULL
;
4946 gfc_symbol
*extended
;
4947 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4949 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
4951 if (tb_io_st
!= NULL
)
4953 const char *genname
;
4956 tb_io_proc
= tb_io_st
->n
.tb
;
4957 gcc_assert (tb_io_proc
!= NULL
);
4958 gcc_assert (tb_io_proc
->is_generic
);
4959 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4961 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4962 gcc_assert (!specific_proc
->is_generic
);
4964 /* Go back and make sure that we have the right specific procedure.
4965 Here we most likely have a procedure from the parent type, which
4966 can be overridden in extensions. */
4967 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4968 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4969 true, &tb_io_proc
->where
);
4971 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4973 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4978 /* If there is not a typebound binding, look for a generic
4980 for (extended
= derived
; extended
;
4981 extended
= gfc_get_derived_super_type (extended
))
4983 if (extended
== NULL
|| extended
->ns
== NULL
4984 || extended
->attr
.flavor
== FL_UNKNOWN
)
4987 if (formatted
== true)
4990 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4991 gfc_code2string (dtio_procs
,
4994 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4995 gfc_code2string (dtio_procs
,
5001 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5002 gfc_code2string (dtio_procs
,
5005 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5006 gfc_code2string (dtio_procs
,
5010 if (tb_io_st
!= NULL
5012 && tb_io_st
->n
.sym
->generic
)
5014 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5015 intr
&& intr
->sym
; intr
= intr
->next
)
5017 if (intr
->sym
->formal
)
5019 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5020 if ((fsym
->ts
.type
== BT_CLASS
5021 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5022 || (fsym
->ts
.type
== BT_DERIVED
5023 && fsym
->ts
.u
.derived
== extended
))
5025 dtio_sub
= intr
->sym
;
5034 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5035 gfc_find_derived_vtab (derived
);