1 /* Deal with interfaces.
2 Copyright (C) 2000-2016 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 %s", 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
) == 0)
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 gfc_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
) == 0)
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 gcc_assert (derived1
&& derived2
);
620 /* Compare UNION types specially. */
621 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
622 return gfc_compare_union_types (derived1
, derived2
);
624 /* Special case for comparing derived types across namespaces. If the
625 true names and module names are the same and the module name is
626 nonnull, then they are equal. */
627 if (strcmp (derived1
->name
, derived2
->name
) == 0
628 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
629 && strcmp (derived1
->module
, derived2
->module
) == 0)
632 /* Compare type via the rules of the standard. Both types must have
633 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
634 because they can be anonymous; therefore two structures with different
635 names may be equal. */
637 /* Compare names, but not for anonymous types such as UNION or MAP. */
638 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
639 && strcmp (derived1
->name
, derived2
->name
) != 0)
642 if (derived1
->component_access
== ACCESS_PRIVATE
643 || derived2
->component_access
== ACCESS_PRIVATE
)
646 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
647 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
650 /* Protect against null components. */
651 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
654 if (derived1
->attr
.zero_comp
)
657 cmp1
= derived1
->components
;
658 cmp2
= derived2
->components
;
660 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
661 simple test can speed things up. Otherwise, lots of things have to
665 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
671 if (cmp1
== NULL
&& cmp2
== NULL
)
673 if (cmp1
== NULL
|| cmp2
== NULL
)
681 /* Compare two typespecs, recursively if necessary. */
684 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
686 /* See if one of the typespecs is a BT_VOID, which is what is being used
687 to allow the funcs like c_f_pointer to accept any pointer type.
688 TODO: Possibly should narrow this to just the one typespec coming in
689 that is for the formal arg, but oh well. */
690 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
693 /* The _data component is not always present, therefore check for its
694 presence before assuming, that its derived->attr is available.
695 When the _data component is not present, then nevertheless the
696 unlimited_polymorphic flag may be set in the derived type's attr. */
697 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
698 && ((ts1
->u
.derived
->attr
.is_class
699 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
700 .unlimited_polymorphic
)
701 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
705 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
706 && ts2
->u
.derived
->components
707 && ((ts2
->u
.derived
->attr
.is_class
708 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
709 .unlimited_polymorphic
)
710 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
711 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
714 if (ts1
->type
!= ts2
->type
715 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
716 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
719 if (ts1
->type
== BT_UNION
)
720 return gfc_compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
722 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
723 return (ts1
->kind
== ts2
->kind
);
725 /* Compare derived types. */
726 return gfc_type_compatible (ts1
, ts2
);
731 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
733 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
736 /* TYPE and CLASS of the same declared type are type compatible,
737 but have different characteristics. */
738 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
739 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
742 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
747 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
749 gfc_array_spec
*as1
, *as2
;
752 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
755 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
756 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
758 r1
= as1
? as1
->rank
: 0;
759 r2
= as2
? as2
->rank
: 0;
761 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
762 return 0; /* Ranks differ. */
768 /* Given two symbols that are formal arguments, compare their ranks
769 and types. Returns nonzero if they have the same rank and type,
773 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
775 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
779 /* Given two symbols that are formal arguments, compare their types
780 and rank and their formal interfaces if they are both dummy
781 procedures. Returns nonzero if the same, zero if different. */
784 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
786 if (s1
== NULL
|| s2
== NULL
)
787 return s1
== s2
? 1 : 0;
792 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
793 return compare_type_rank (s1
, s2
);
795 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
798 /* At this point, both symbols are procedures. It can happen that
799 external procedures are compared, where one is identified by usage
800 to be a function or subroutine but the other is not. Check TKR
801 nonetheless for these cases. */
802 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
803 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
805 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
806 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
808 /* Now the type of procedure has been identified. */
809 if (s1
->attr
.function
!= s2
->attr
.function
810 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
813 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
816 /* Originally, gfortran recursed here to check the interfaces of passed
817 procedures. This is explicitly not required by the standard. */
822 /* Given a formal argument list and a keyword name, search the list
823 for that keyword. Returns the correct symbol node if found, NULL
827 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
829 for (; f
; f
= f
->next
)
830 if (strcmp (f
->sym
->name
, name
) == 0)
837 /******** Interface checking subroutines **********/
840 /* Given an operator interface and the operator, make sure that all
841 interfaces for that operator are legal. */
844 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
847 gfc_formal_arglist
*formal
;
850 int args
, r1
, r2
, k1
, k2
;
855 t1
= t2
= BT_UNKNOWN
;
856 i1
= i2
= INTENT_UNKNOWN
;
860 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
862 gfc_symbol
*fsym
= formal
->sym
;
865 gfc_error ("Alternate return cannot appear in operator "
866 "interface at %L", &sym
->declared_at
);
872 i1
= fsym
->attr
.intent
;
873 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
879 i2
= fsym
->attr
.intent
;
880 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
886 /* Only +, - and .not. can be unary operators.
887 .not. cannot be a binary operator. */
888 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
889 && op
!= INTRINSIC_MINUS
890 && op
!= INTRINSIC_NOT
)
891 || (args
== 2 && op
== INTRINSIC_NOT
))
893 if (op
== INTRINSIC_ASSIGN
)
894 gfc_error ("Assignment operator interface at %L must have "
895 "two arguments", &sym
->declared_at
);
897 gfc_error ("Operator interface at %L has the wrong number of arguments",
902 /* Check that intrinsics are mapped to functions, except
903 INTRINSIC_ASSIGN which should map to a subroutine. */
904 if (op
== INTRINSIC_ASSIGN
)
906 gfc_formal_arglist
*dummy_args
;
908 if (!sym
->attr
.subroutine
)
910 gfc_error ("Assignment operator interface at %L must be "
911 "a SUBROUTINE", &sym
->declared_at
);
915 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
916 - First argument an array with different rank than second,
917 - First argument is a scalar and second an array,
918 - Types and kinds do not conform, or
919 - First argument is of derived type. */
920 dummy_args
= gfc_sym_get_dummy_args (sym
);
921 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
922 && dummy_args
->sym
->ts
.type
!= BT_CLASS
923 && (r2
== 0 || r1
== r2
)
924 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
925 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
926 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
928 gfc_error ("Assignment operator interface at %L must not redefine "
929 "an INTRINSIC type assignment", &sym
->declared_at
);
935 if (!sym
->attr
.function
)
937 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
943 /* Check intents on operator interfaces. */
944 if (op
== INTRINSIC_ASSIGN
)
946 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
948 gfc_error ("First argument of defined assignment at %L must be "
949 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
955 gfc_error ("Second argument of defined assignment at %L must be "
956 "INTENT(IN)", &sym
->declared_at
);
964 gfc_error ("First argument of operator interface at %L must be "
965 "INTENT(IN)", &sym
->declared_at
);
969 if (args
== 2 && i2
!= INTENT_IN
)
971 gfc_error ("Second argument of operator interface at %L must be "
972 "INTENT(IN)", &sym
->declared_at
);
977 /* From now on, all we have to do is check that the operator definition
978 doesn't conflict with an intrinsic operator. The rules for this
979 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
980 as well as 12.3.2.1.1 of Fortran 2003:
982 "If the operator is an intrinsic-operator (R310), the number of
983 function arguments shall be consistent with the intrinsic uses of
984 that operator, and the types, kind type parameters, or ranks of the
985 dummy arguments shall differ from those required for the intrinsic
986 operation (7.1.2)." */
988 #define IS_NUMERIC_TYPE(t) \
989 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
991 /* Unary ops are easy, do them first. */
992 if (op
== INTRINSIC_NOT
)
994 if (t1
== BT_LOGICAL
)
1000 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1002 if (IS_NUMERIC_TYPE (t1
))
1008 /* Character intrinsic operators have same character kind, thus
1009 operator definitions with operands of different character kinds
1011 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1014 /* Intrinsic operators always perform on arguments of same rank,
1015 so different ranks is also always safe. (rank == 0) is an exception
1016 to that, because all intrinsic operators are elemental. */
1017 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1023 case INTRINSIC_EQ_OS
:
1025 case INTRINSIC_NE_OS
:
1026 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1030 case INTRINSIC_PLUS
:
1031 case INTRINSIC_MINUS
:
1032 case INTRINSIC_TIMES
:
1033 case INTRINSIC_DIVIDE
:
1034 case INTRINSIC_POWER
:
1035 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1040 case INTRINSIC_GT_OS
:
1042 case INTRINSIC_GE_OS
:
1044 case INTRINSIC_LT_OS
:
1046 case INTRINSIC_LE_OS
:
1047 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1049 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1050 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1054 case INTRINSIC_CONCAT
:
1055 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1062 case INTRINSIC_NEQV
:
1063 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1073 #undef IS_NUMERIC_TYPE
1076 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1082 /* Given a pair of formal argument lists, we see if the two lists can
1083 be distinguished by counting the number of nonoptional arguments of
1084 a given type/rank in f1 and seeing if there are less then that
1085 number of those arguments in f2 (including optional arguments).
1086 Since this test is asymmetric, it has to be called twice to make it
1087 symmetric. Returns nonzero if the argument lists are incompatible
1088 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1089 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1092 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1093 const char *p1
, const char *p2
)
1095 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
1096 gfc_formal_arglist
*f
;
1109 for (f
= f1
; f
; f
= f
->next
)
1112 /* Build an array of integers that gives the same integer to
1113 arguments of the same type/rank. */
1114 arg
= XCNEWVEC (arginfo
, n1
);
1117 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1120 arg
[i
].sym
= f
->sym
;
1125 for (i
= 0; i
< n1
; i
++)
1127 if (arg
[i
].flag
!= -1)
1130 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1131 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1132 continue; /* Skip OPTIONAL and PASS arguments. */
1136 /* Find other non-optional, non-pass arguments of the same type/rank. */
1137 for (j
= i
+ 1; j
< n1
; j
++)
1138 if ((arg
[j
].sym
== NULL
1139 || !(arg
[j
].sym
->attr
.optional
1140 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1141 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1142 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1148 /* Now loop over each distinct type found in f1. */
1152 for (i
= 0; i
< n1
; i
++)
1154 if (arg
[i
].flag
!= k
)
1158 for (j
= i
+ 1; j
< n1
; j
++)
1159 if (arg
[j
].flag
== k
)
1162 /* Count the number of non-pass arguments in f2 with that type,
1163 including those that are optional. */
1166 for (f
= f2
; f
; f
= f
->next
)
1167 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1168 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1169 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1187 /* Perform the correspondence test in rule (3) of F08:C1215.
1188 Returns zero if no argument is found that satisfies this rule,
1189 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1192 This test is also not symmetric in f1 and f2 and must be called
1193 twice. This test finds problems caused by sorting the actual
1194 argument list with keywords. For example:
1198 INTEGER :: A ; REAL :: B
1202 INTEGER :: A ; REAL :: B
1206 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1209 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1210 const char *p1
, const char *p2
)
1212 gfc_formal_arglist
*f2_save
, *g
;
1219 if (f1
->sym
->attr
.optional
)
1222 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1224 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1227 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1228 || compare_type_rank (f2
->sym
, f1
->sym
))
1229 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1230 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1231 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1234 /* Now search for a disambiguating keyword argument starting at
1235 the current non-match. */
1236 for (g
= f1
; g
; g
= g
->next
)
1238 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1241 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1242 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1243 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1244 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1245 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1261 symbol_rank (gfc_symbol
*sym
)
1264 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1265 return as
? as
->rank
: 0;
1269 /* Check if the characteristics of two dummy arguments match,
1273 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1274 bool type_must_agree
, char *errmsg
,
1277 if (s1
== NULL
|| s2
== NULL
)
1278 return s1
== s2
? true : false;
1280 /* Check type and rank. */
1281 if (type_must_agree
)
1283 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1285 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1286 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1289 if (!compare_rank (s1
, s2
))
1291 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1292 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1298 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1300 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1305 /* Check OPTIONAL attribute. */
1306 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1308 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1313 /* Check ALLOCATABLE attribute. */
1314 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1316 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1321 /* Check POINTER attribute. */
1322 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1324 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1329 /* Check TARGET attribute. */
1330 if (s1
->attr
.target
!= s2
->attr
.target
)
1332 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1337 /* Check ASYNCHRONOUS attribute. */
1338 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1340 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1345 /* Check CONTIGUOUS attribute. */
1346 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1348 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1353 /* Check VALUE attribute. */
1354 if (s1
->attr
.value
!= s2
->attr
.value
)
1356 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1361 /* Check VOLATILE attribute. */
1362 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1364 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1369 /* Check interface of dummy procedures. */
1370 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1373 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1376 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1377 "'%s': %s", s1
->name
, err
);
1382 /* Check string length. */
1383 if (s1
->ts
.type
== BT_CHARACTER
1384 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1385 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1387 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1388 s2
->ts
.u
.cl
->length
);
1394 snprintf (errmsg
, err_len
, "Character length mismatch "
1395 "in argument '%s'", s1
->name
);
1399 /* FIXME: Implement a warning for this case.
1400 gfc_warning (0, "Possible character length mismatch in argument %qs",
1408 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1409 "%i of gfc_dep_compare_expr", compval
);
1414 /* Check array shape. */
1415 if (s1
->as
&& s2
->as
)
1418 gfc_expr
*shape1
, *shape2
;
1420 if (s1
->as
->type
!= s2
->as
->type
)
1422 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1427 if (s1
->as
->corank
!= s2
->as
->corank
)
1429 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1430 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1434 if (s1
->as
->type
== AS_EXPLICIT
)
1435 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1437 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1438 gfc_copy_expr (s1
->as
->lower
[i
]));
1439 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1440 gfc_copy_expr (s2
->as
->lower
[i
]));
1441 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1442 gfc_free_expr (shape1
);
1443 gfc_free_expr (shape2
);
1449 if (i
< s1
->as
->rank
)
1450 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1451 " argument '%s'", i
+ 1, s1
->name
);
1453 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1454 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1458 /* FIXME: Implement a warning for this case.
1459 gfc_warning (0, "Possible shape mismatch in argument %qs",
1467 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1468 "result %i of gfc_dep_compare_expr",
1479 /* Check if the characteristics of two function results match,
1483 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1484 char *errmsg
, int err_len
)
1486 gfc_symbol
*r1
, *r2
;
1488 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1489 r1
= s1
->ts
.interface
->result
;
1491 r1
= s1
->result
? s1
->result
: s1
;
1493 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1494 r2
= s2
->ts
.interface
->result
;
1496 r2
= s2
->result
? s2
->result
: s2
;
1498 if (r1
->ts
.type
== BT_UNKNOWN
)
1501 /* Check type and rank. */
1502 if (!compare_type (r1
, r2
))
1504 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1505 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1508 if (!compare_rank (r1
, r2
))
1510 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1511 symbol_rank (r1
), symbol_rank (r2
));
1515 /* Check ALLOCATABLE attribute. */
1516 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1518 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1523 /* Check POINTER attribute. */
1524 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1526 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1531 /* Check CONTIGUOUS attribute. */
1532 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1534 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1539 /* Check PROCEDURE POINTER attribute. */
1540 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1542 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1547 /* Check string length. */
1548 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1550 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1552 snprintf (errmsg
, err_len
, "Character length mismatch "
1553 "in function result");
1557 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1559 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1560 r2
->ts
.u
.cl
->length
);
1566 snprintf (errmsg
, err_len
, "Character length mismatch "
1567 "in function result");
1571 /* FIXME: Implement a warning for this case.
1572 snprintf (errmsg, err_len, "Possible character length mismatch "
1573 "in function result");*/
1580 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1581 "result %i of gfc_dep_compare_expr", compval
);
1587 /* Check array shape. */
1588 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1591 gfc_expr
*shape1
, *shape2
;
1593 if (r1
->as
->type
!= r2
->as
->type
)
1595 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1599 if (r1
->as
->type
== AS_EXPLICIT
)
1600 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1602 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1603 gfc_copy_expr (r1
->as
->lower
[i
]));
1604 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1605 gfc_copy_expr (r2
->as
->lower
[i
]));
1606 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1607 gfc_free_expr (shape1
);
1608 gfc_free_expr (shape2
);
1614 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1615 "function result", i
+ 1);
1619 /* FIXME: Implement a warning for this case.
1620 gfc_warning (0, "Possible shape mismatch in return value");*/
1627 gfc_internal_error ("check_result_characteristics (2): "
1628 "Unexpected result %i of "
1629 "gfc_dep_compare_expr", compval
);
1639 /* 'Compare' two formal interfaces associated with a pair of symbols.
1640 We return nonzero if there exists an actual argument list that
1641 would be ambiguous between the two interfaces, zero otherwise.
1642 'strict_flag' specifies whether all the characteristics are
1643 required to match, which is not the case for ambiguity checks.
1644 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1647 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1648 int generic_flag
, int strict_flag
,
1649 char *errmsg
, int err_len
,
1650 const char *p1
, const char *p2
)
1652 gfc_formal_arglist
*f1
, *f2
;
1654 gcc_assert (name2
!= NULL
);
1656 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1657 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1658 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1661 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1665 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1668 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1672 /* Do strict checks on all characteristics
1673 (for dummy procedures and procedure pointer assignments). */
1674 if (!generic_flag
&& strict_flag
)
1676 if (s1
->attr
.function
&& s2
->attr
.function
)
1678 /* If both are functions, check result characteristics. */
1679 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1680 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1684 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1686 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1689 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1691 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1696 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1697 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1700 f1
= gfc_sym_get_dummy_args (s1
);
1701 f2
= gfc_sym_get_dummy_args (s2
);
1703 /* Special case: No arguments. */
1704 if (f1
== NULL
&& f2
== NULL
)
1709 if (count_types_test (f1
, f2
, p1
, p2
)
1710 || count_types_test (f2
, f1
, p2
, p1
))
1713 /* Special case: alternate returns. If both f1->sym and f2->sym are
1714 NULL, then the leading formal arguments are alternate returns.
1715 The previous conditional should catch argument lists with
1716 different number of argument. */
1717 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1720 if (generic_correspondence (f1
, f2
, p1
, p2
)
1721 || generic_correspondence (f2
, f1
, p2
, p1
))
1725 /* Perform the abbreviated correspondence test for operators (the
1726 arguments cannot be optional and are always ordered correctly).
1727 This is also done when comparing interfaces for dummy procedures and in
1728 procedure pointer assignments. */
1732 /* Check existence. */
1733 if (f1
== NULL
&& f2
== NULL
)
1735 if (f1
== NULL
|| f2
== NULL
)
1738 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1739 "arguments", name2
);
1743 if (UNLIMITED_POLY (f1
->sym
))
1748 /* Check all characteristics. */
1749 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1755 /* Only check type and rank. */
1756 if (!compare_type (f2
->sym
, f1
->sym
))
1759 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1760 "(%s/%s)", f1
->sym
->name
,
1761 gfc_typename (&f1
->sym
->ts
),
1762 gfc_typename (&f2
->sym
->ts
));
1765 if (!compare_rank (f2
->sym
, f1
->sym
))
1768 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1769 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1770 symbol_rank (f2
->sym
));
1783 /* Given a pointer to an interface pointer, remove duplicate
1784 interfaces and make sure that all symbols are either functions
1785 or subroutines, and all of the same kind. Returns nonzero if
1786 something goes wrong. */
1789 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1791 gfc_interface
*psave
, *q
, *qlast
;
1794 for (; p
; p
= p
->next
)
1796 /* Make sure all symbols in the interface have been defined as
1797 functions or subroutines. */
1798 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1799 || !p
->sym
->attr
.if_source
)
1800 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1802 if (p
->sym
->attr
.external
)
1803 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1804 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1806 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1807 "subroutine", p
->sym
->name
, interface_name
,
1808 &p
->sym
->declared_at
);
1812 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1813 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1814 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1815 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1817 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1818 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1819 " or all FUNCTIONs", interface_name
,
1820 &p
->sym
->declared_at
);
1821 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1822 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1823 "generic name is also the name of a derived type",
1824 interface_name
, &p
->sym
->declared_at
);
1828 /* F2003, C1207. F2008, C1207. */
1829 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1830 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1831 "%qs in %s at %L", p
->sym
->name
,
1832 interface_name
, &p
->sym
->declared_at
))
1837 /* Remove duplicate interfaces in this interface list. */
1838 for (; p
; p
= p
->next
)
1842 for (q
= p
->next
; q
;)
1844 if (p
->sym
!= q
->sym
)
1851 /* Duplicate interface. */
1852 qlast
->next
= q
->next
;
1863 /* Check lists of interfaces to make sure that no two interfaces are
1864 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1867 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1868 int generic_flag
, const char *interface_name
,
1872 for (; p
; p
= p
->next
)
1873 for (q
= q0
; q
; q
= q
->next
)
1875 if (p
->sym
== q
->sym
)
1876 continue; /* Duplicates OK here. */
1878 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1881 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1882 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1883 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1884 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1887 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1888 "and %qs at %L", interface_name
,
1889 q
->sym
->name
, &q
->sym
->declared_at
,
1890 p
->sym
->name
, &p
->sym
->declared_at
);
1891 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1892 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1893 "and %qs at %L", interface_name
,
1894 q
->sym
->name
, &q
->sym
->declared_at
,
1895 p
->sym
->name
, &p
->sym
->declared_at
);
1897 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1898 "interfaces at %L", interface_name
, &p
->where
);
1906 /* Check the generic and operator interfaces of symbols to make sure
1907 that none of the interfaces conflict. The check has to be done
1908 after all of the symbols are actually loaded. */
1911 check_sym_interfaces (gfc_symbol
*sym
)
1913 char interface_name
[100];
1916 if (sym
->ns
!= gfc_current_ns
)
1919 if (sym
->generic
!= NULL
)
1921 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1922 if (check_interface0 (sym
->generic
, interface_name
))
1925 for (p
= sym
->generic
; p
; p
= p
->next
)
1927 if (p
->sym
->attr
.mod_proc
1928 && !p
->sym
->attr
.module_procedure
1929 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1930 || p
->sym
->attr
.procedure
))
1932 gfc_error ("%qs at %L is not a module procedure",
1933 p
->sym
->name
, &p
->where
);
1938 /* Originally, this test was applied to host interfaces too;
1939 this is incorrect since host associated symbols, from any
1940 source, cannot be ambiguous with local symbols. */
1941 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1942 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1948 check_uop_interfaces (gfc_user_op
*uop
)
1950 char interface_name
[100];
1954 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1955 if (check_interface0 (uop
->op
, interface_name
))
1958 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1960 uop2
= gfc_find_uop (uop
->name
, ns
);
1964 check_interface1 (uop
->op
, uop2
->op
, 0,
1965 interface_name
, true);
1969 /* Given an intrinsic op, return an equivalent op if one exists,
1970 or INTRINSIC_NONE otherwise. */
1973 gfc_equivalent_op (gfc_intrinsic_op op
)
1978 return INTRINSIC_EQ_OS
;
1980 case INTRINSIC_EQ_OS
:
1981 return INTRINSIC_EQ
;
1984 return INTRINSIC_NE_OS
;
1986 case INTRINSIC_NE_OS
:
1987 return INTRINSIC_NE
;
1990 return INTRINSIC_GT_OS
;
1992 case INTRINSIC_GT_OS
:
1993 return INTRINSIC_GT
;
1996 return INTRINSIC_GE_OS
;
1998 case INTRINSIC_GE_OS
:
1999 return INTRINSIC_GE
;
2002 return INTRINSIC_LT_OS
;
2004 case INTRINSIC_LT_OS
:
2005 return INTRINSIC_LT
;
2008 return INTRINSIC_LE_OS
;
2010 case INTRINSIC_LE_OS
:
2011 return INTRINSIC_LE
;
2014 return INTRINSIC_NONE
;
2018 /* For the namespace, check generic, user operator and intrinsic
2019 operator interfaces for consistency and to remove duplicate
2020 interfaces. We traverse the whole namespace, counting on the fact
2021 that most symbols will not have generic or operator interfaces. */
2024 gfc_check_interfaces (gfc_namespace
*ns
)
2026 gfc_namespace
*old_ns
, *ns2
;
2027 char interface_name
[100];
2030 old_ns
= gfc_current_ns
;
2031 gfc_current_ns
= ns
;
2033 gfc_traverse_ns (ns
, check_sym_interfaces
);
2035 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2037 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2039 if (i
== INTRINSIC_USER
)
2042 if (i
== INTRINSIC_ASSIGN
)
2043 strcpy (interface_name
, "intrinsic assignment operator");
2045 sprintf (interface_name
, "intrinsic '%s' operator",
2046 gfc_op2string ((gfc_intrinsic_op
) i
));
2048 if (check_interface0 (ns
->op
[i
], interface_name
))
2052 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2055 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2057 gfc_intrinsic_op other_op
;
2059 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2060 interface_name
, true))
2063 /* i should be gfc_intrinsic_op, but has to be int with this cast
2064 here for stupid C++ compatibility rules. */
2065 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2066 if (other_op
!= INTRINSIC_NONE
2067 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2068 0, interface_name
, true))
2074 gfc_current_ns
= old_ns
;
2078 /* Given a symbol of a formal argument list and an expression, if the
2079 formal argument is allocatable, check that the actual argument is
2080 allocatable. Returns nonzero if compatible, zero if not compatible. */
2083 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2085 symbol_attribute attr
;
2087 if (formal
->attr
.allocatable
2088 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2090 attr
= gfc_expr_attr (actual
);
2091 if (!attr
.allocatable
)
2099 /* Given a symbol of a formal argument list and an expression, if the
2100 formal argument is a pointer, see if the actual argument is a
2101 pointer. Returns nonzero if compatible, zero if not compatible. */
2104 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2106 symbol_attribute attr
;
2108 if (formal
->attr
.pointer
2109 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2110 && CLASS_DATA (formal
)->attr
.class_pointer
))
2112 attr
= gfc_expr_attr (actual
);
2114 /* Fortran 2008 allows non-pointer actual arguments. */
2115 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2126 /* Emit clear error messages for rank mismatch. */
2129 argument_rank_mismatch (const char *name
, locus
*where
,
2130 int rank1
, int rank2
)
2133 /* TS 29113, C407b. */
2136 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2137 " %qs has assumed-rank", where
, name
);
2139 else if (rank1
== 0)
2141 gfc_error ("Rank mismatch in argument %qs at %L "
2142 "(scalar and rank-%d)", name
, where
, rank2
);
2144 else if (rank2
== 0)
2146 gfc_error ("Rank mismatch in argument %qs at %L "
2147 "(rank-%d and scalar)", name
, where
, rank1
);
2151 gfc_error ("Rank mismatch in argument %qs at %L "
2152 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2157 /* Given a symbol of a formal argument list and an expression, see if
2158 the two are compatible as arguments. Returns nonzero if
2159 compatible, zero if not compatible. */
2162 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2163 int ranks_must_agree
, int is_elemental
, locus
*where
)
2166 bool rank_check
, is_pointer
;
2170 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2171 procs c_f_pointer or c_f_procpointer, and we need to accept most
2172 pointers the user could give us. This should allow that. */
2173 if (formal
->ts
.type
== BT_VOID
)
2176 if (formal
->ts
.type
== BT_DERIVED
2177 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2178 && actual
->ts
.type
== BT_DERIVED
2179 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2182 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2183 /* Make sure the vtab symbol is present when
2184 the module variables are generated. */
2185 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2187 if (actual
->ts
.type
== BT_PROCEDURE
)
2189 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2191 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2194 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2198 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2199 sizeof(err
), NULL
, NULL
))
2202 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2203 formal
->name
, &actual
->where
, err
);
2207 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2209 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2210 &act_sym
->declared_at
);
2211 if (act_sym
->ts
.type
== BT_UNKNOWN
2212 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2215 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2216 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2217 &act_sym
->declared_at
);
2222 ppc
= gfc_get_proc_ptr_comp (actual
);
2223 if (ppc
&& ppc
->ts
.interface
)
2225 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2226 err
, sizeof(err
), NULL
, NULL
))
2229 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2230 formal
->name
, &actual
->where
, err
);
2236 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2237 && !gfc_is_simply_contiguous (actual
, true, false))
2240 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2241 "must be simply contiguous", formal
->name
, &actual
->where
);
2245 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2246 && actual
->ts
.type
!= BT_HOLLERITH
2247 && formal
->ts
.type
!= BT_ASSUMED
2248 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2249 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2250 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2251 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2252 CLASS_DATA (actual
)->ts
.u
.derived
)))
2255 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2256 formal
->name
, where
, gfc_typename (&actual
->ts
),
2257 gfc_typename (&formal
->ts
));
2261 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2264 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2265 "argument %qs is of assumed type", &actual
->where
,
2270 /* F2008, 12.5.2.5; IR F08/0073. */
2271 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2272 && actual
->expr_type
!= EXPR_NULL
2273 && ((CLASS_DATA (formal
)->attr
.class_pointer
2274 && formal
->attr
.intent
!= INTENT_IN
)
2275 || CLASS_DATA (formal
)->attr
.allocatable
))
2277 if (actual
->ts
.type
!= BT_CLASS
)
2280 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2281 formal
->name
, &actual
->where
);
2285 if (!gfc_expr_attr (actual
).class_ok
)
2288 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2289 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2290 CLASS_DATA (formal
)->ts
.u
.derived
))
2293 gfc_error ("Actual argument to %qs at %L must have the same "
2294 "declared type", formal
->name
, &actual
->where
);
2299 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2300 is necessary also for F03, so retain error for both.
2301 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2302 compatible, no attempt has been made to channel to this one. */
2303 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2304 && (CLASS_DATA (formal
)->attr
.allocatable
2305 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2308 gfc_error ("Actual argument to %qs at %L must be unlimited "
2309 "polymorphic since the formal argument is a "
2310 "pointer or allocatable unlimited polymorphic "
2311 "entity [F2008: 12.5.2.5]", formal
->name
,
2316 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2319 gfc_error ("Actual argument to %qs at %L must be a coarray",
2320 formal
->name
, &actual
->where
);
2324 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2326 gfc_ref
*last
= NULL
;
2328 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2329 if (ref
->type
== REF_COMPONENT
)
2332 /* F2008, 12.5.2.6. */
2333 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2335 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2338 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2339 formal
->name
, &actual
->where
, formal
->as
->corank
,
2340 last
? last
->u
.c
.component
->as
->corank
2341 : actual
->symtree
->n
.sym
->as
->corank
);
2346 if (formal
->attr
.codimension
)
2348 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2349 /* F2015, 12.5.2.8. */
2350 if (formal
->attr
.dimension
2351 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2352 && gfc_expr_attr (actual
).dimension
2353 && !gfc_is_simply_contiguous (actual
, true, true))
2356 gfc_error ("Actual argument to %qs at %L must be simply "
2357 "contiguous or an element of such an array",
2358 formal
->name
, &actual
->where
);
2362 /* F2008, C1303 and C1304. */
2363 if (formal
->attr
.intent
!= INTENT_INOUT
2364 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2365 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2366 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2367 || formal
->attr
.lock_comp
))
2371 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2372 "which is LOCK_TYPE or has a LOCK_TYPE component",
2373 formal
->name
, &actual
->where
);
2377 /* TS18508, C702/C703. */
2378 if (formal
->attr
.intent
!= INTENT_INOUT
2379 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2380 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2381 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2382 || formal
->attr
.event_comp
))
2386 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2387 "which is EVENT_TYPE or has a EVENT_TYPE component",
2388 formal
->name
, &actual
->where
);
2393 /* F2008, C1239/C1240. */
2394 if (actual
->expr_type
== EXPR_VARIABLE
2395 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2396 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2397 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2398 && actual
->rank
&& formal
->as
2399 && !gfc_is_simply_contiguous (actual
, true, false)
2400 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2401 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2402 || formal
->attr
.contiguous
))
2405 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2406 "assumed-rank array without CONTIGUOUS attribute - as actual"
2407 " argument at %L is not simply contiguous and both are "
2408 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2412 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2413 && gfc_expr_attr (actual
).codimension
)
2415 if (formal
->attr
.intent
== INTENT_OUT
)
2418 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2419 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2423 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2424 gfc_warning (OPT_Wsurprising
,
2425 "Passing coarray at %L to allocatable, noncoarray dummy "
2426 "argument %qs, which is invalid if the allocation status"
2427 " is modified", &actual
->where
, formal
->name
);
2430 /* If the rank is the same or the formal argument has assumed-rank. */
2431 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2434 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2435 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2436 || formal
->as
->type
== AS_DEFERRED
)
2437 && actual
->expr_type
!= EXPR_NULL
;
2439 /* Skip rank checks for NO_ARG_CHECK. */
2440 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2443 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2444 if (rank_check
|| ranks_must_agree
2445 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2446 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2447 || (actual
->rank
== 0
2448 && ((formal
->ts
.type
== BT_CLASS
2449 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2450 || (formal
->ts
.type
!= BT_CLASS
2451 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2452 && actual
->expr_type
!= EXPR_NULL
)
2453 || (actual
->rank
== 0 && formal
->attr
.dimension
2454 && gfc_is_coindexed (actual
)))
2457 argument_rank_mismatch (formal
->name
, &actual
->where
,
2458 symbol_rank (formal
), actual
->rank
);
2461 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2464 /* At this point, we are considering a scalar passed to an array. This
2465 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2466 - if the actual argument is (a substring of) an element of a
2467 non-assumed-shape/non-pointer/non-polymorphic array; or
2468 - (F2003) if the actual argument is of type character of default/c_char
2471 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2472 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2474 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2476 if (ref
->type
== REF_COMPONENT
)
2477 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2478 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2479 && ref
->u
.ar
.dimen
> 0
2481 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2485 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2488 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2489 "at %L", formal
->name
, &actual
->where
);
2493 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2494 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2497 gfc_error ("Element of assumed-shaped or pointer "
2498 "array passed to array dummy argument %qs at %L",
2499 formal
->name
, &actual
->where
);
2503 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2504 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2506 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2509 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2510 "CHARACTER actual argument with array dummy argument "
2511 "%qs at %L", formal
->name
, &actual
->where
);
2515 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2517 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2518 "array dummy argument %qs at %L",
2519 formal
->name
, &actual
->where
);
2522 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2528 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2531 argument_rank_mismatch (formal
->name
, &actual
->where
,
2532 symbol_rank (formal
), actual
->rank
);
2540 /* Returns the storage size of a symbol (formal argument) or
2541 zero if it cannot be determined. */
2543 static unsigned long
2544 get_sym_storage_size (gfc_symbol
*sym
)
2547 unsigned long strlen
, elements
;
2549 if (sym
->ts
.type
== BT_CHARACTER
)
2551 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2552 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2553 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2560 if (symbol_rank (sym
) == 0)
2564 if (sym
->as
->type
!= AS_EXPLICIT
)
2566 for (i
= 0; i
< sym
->as
->rank
; i
++)
2568 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2569 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2572 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2573 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2576 return strlen
*elements
;
2580 /* Returns the storage size of an expression (actual argument) or
2581 zero if it cannot be determined. For an array element, it returns
2582 the remaining size as the element sequence consists of all storage
2583 units of the actual argument up to the end of the array. */
2585 static unsigned long
2586 get_expr_storage_size (gfc_expr
*e
)
2589 long int strlen
, elements
;
2590 long int substrlen
= 0;
2591 bool is_str_storage
= false;
2597 if (e
->ts
.type
== BT_CHARACTER
)
2599 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2600 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2601 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2602 else if (e
->expr_type
== EXPR_CONSTANT
2603 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2604 strlen
= e
->value
.character
.length
;
2609 strlen
= 1; /* Length per element. */
2611 if (e
->rank
== 0 && !e
->ref
)
2619 for (i
= 0; i
< e
->rank
; i
++)
2620 elements
*= mpz_get_si (e
->shape
[i
]);
2621 return elements
*strlen
;
2624 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2626 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2627 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2631 /* The string length is the substring length.
2632 Set now to full string length. */
2633 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2634 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2637 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2639 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2643 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2644 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2646 long int start
, end
, stride
;
2649 if (ref
->u
.ar
.stride
[i
])
2651 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2652 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2657 if (ref
->u
.ar
.start
[i
])
2659 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2660 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2664 else if (ref
->u
.ar
.as
->lower
[i
]
2665 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2666 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2670 if (ref
->u
.ar
.end
[i
])
2672 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2673 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2677 else if (ref
->u
.ar
.as
->upper
[i
]
2678 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2679 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2683 elements
*= (end
- start
)/stride
+ 1L;
2685 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2686 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2688 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2689 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2690 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2691 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2692 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2693 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2694 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2699 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2700 && e
->expr_type
== EXPR_VARIABLE
)
2702 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2703 || e
->symtree
->n
.sym
->attr
.pointer
)
2709 /* Determine the number of remaining elements in the element
2710 sequence for array element designators. */
2711 is_str_storage
= true;
2712 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2714 if (ref
->u
.ar
.start
[i
] == NULL
2715 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2716 || ref
->u
.ar
.as
->upper
[i
] == NULL
2717 || ref
->u
.ar
.as
->lower
[i
] == NULL
2718 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2719 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2724 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2725 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2727 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2728 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2731 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2732 && ref
->u
.c
.component
->attr
.proc_pointer
2733 && ref
->u
.c
.component
->attr
.dimension
)
2735 /* Array-valued procedure-pointer components. */
2736 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2737 for (i
= 0; i
< as
->rank
; i
++)
2739 if (!as
->upper
[i
] || !as
->lower
[i
]
2740 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2741 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2745 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2746 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2752 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2755 return elements
*strlen
;
2759 /* Given an expression, check whether it is an array section
2760 which has a vector subscript. If it has, one is returned,
2764 gfc_has_vector_subscript (gfc_expr
*e
)
2769 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2772 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2773 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2774 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2775 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2783 is_procptr_result (gfc_expr
*expr
)
2785 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2787 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2789 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2790 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2794 /* Given formal and actual argument lists, see if they are compatible.
2795 If they are compatible, the actual argument list is sorted to
2796 correspond with the formal list, and elements for missing optional
2797 arguments are inserted. If WHERE pointer is nonnull, then we issue
2798 errors when things don't match instead of just returning the status
2802 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2803 int ranks_must_agree
, int is_elemental
, locus
*where
)
2805 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2806 gfc_formal_arglist
*f
;
2808 unsigned long actual_size
, formal_size
;
2809 bool full_array
= false;
2813 if (actual
== NULL
&& formal
== NULL
)
2817 for (f
= formal
; f
; f
= f
->next
)
2820 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2822 for (i
= 0; i
< n
; i
++)
2829 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2831 /* Look for keywords but ignore g77 extensions like %VAL. */
2832 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2835 for (f
= formal
; f
; f
= f
->next
, i
++)
2839 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2846 gfc_error ("Keyword argument %qs at %L is not in "
2847 "the procedure", a
->name
, &a
->expr
->where
);
2851 if (new_arg
[i
] != NULL
)
2854 gfc_error ("Keyword argument %qs at %L is already associated "
2855 "with another actual argument", a
->name
,
2864 gfc_error ("More actual than formal arguments in procedure "
2865 "call at %L", where
);
2870 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2876 gfc_error ("Missing alternate return spec in subroutine call "
2881 if (a
->expr
== NULL
)
2884 gfc_error ("Unexpected alternate return spec in subroutine "
2885 "call at %L", where
);
2889 /* Make sure that intrinsic vtables exist for calls to unlimited
2890 polymorphic formal arguments. */
2891 if (UNLIMITED_POLY (f
->sym
)
2892 && a
->expr
->ts
.type
!= BT_DERIVED
2893 && a
->expr
->ts
.type
!= BT_CLASS
)
2894 gfc_find_vtab (&a
->expr
->ts
);
2896 if (a
->expr
->expr_type
== EXPR_NULL
2897 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2898 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2899 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2900 || (f
->sym
->ts
.type
== BT_CLASS
2901 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2902 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2903 || !f
->sym
->attr
.optional
2904 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2907 && (!f
->sym
->attr
.optional
2908 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2909 || (f
->sym
->ts
.type
== BT_CLASS
2910 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2911 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2912 where
, f
->sym
->name
);
2914 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2915 "dummy %qs", where
, f
->sym
->name
);
2920 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2921 is_elemental
, where
))
2924 /* TS 29113, 6.3p2. */
2925 if (f
->sym
->ts
.type
== BT_ASSUMED
2926 && (a
->expr
->ts
.type
== BT_DERIVED
2927 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2929 gfc_namespace
*f2k_derived
;
2931 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2932 ? a
->expr
->ts
.u
.derived
->f2k_derived
2933 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2936 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2938 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2939 "derived type with type-bound or FINAL procedures",
2945 /* Special case for character arguments. For allocatable, pointer
2946 and assumed-shape dummies, the string length needs to match
2948 if (a
->expr
->ts
.type
== BT_CHARACTER
2949 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2950 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2951 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2952 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2953 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2954 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2955 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2956 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2958 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2960 "Character length mismatch (%ld/%ld) between actual "
2961 "argument and pointer or allocatable dummy argument "
2963 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2964 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2965 f
->sym
->name
, &a
->expr
->where
);
2968 "Character length mismatch (%ld/%ld) between actual "
2969 "argument and assumed-shape dummy argument %qs "
2971 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2972 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2973 f
->sym
->name
, &a
->expr
->where
);
2977 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2978 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2979 && a
->expr
->ts
.type
== BT_CHARACTER
)
2982 gfc_error ("Actual argument at %L to allocatable or "
2983 "pointer dummy argument %qs must have a deferred "
2984 "length type parameter if and only if the dummy has one",
2985 &a
->expr
->where
, f
->sym
->name
);
2989 if (f
->sym
->ts
.type
== BT_CLASS
)
2990 goto skip_size_check
;
2992 actual_size
= get_expr_storage_size (a
->expr
);
2993 formal_size
= get_sym_storage_size (f
->sym
);
2994 if (actual_size
!= 0 && actual_size
< formal_size
2995 && a
->expr
->ts
.type
!= BT_PROCEDURE
2996 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2998 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2999 gfc_warning (0, "Character length of actual argument shorter "
3000 "than of dummy argument %qs (%lu/%lu) at %L",
3001 f
->sym
->name
, actual_size
, formal_size
,
3004 gfc_warning (0, "Actual argument contains too few "
3005 "elements for dummy argument %qs (%lu/%lu) at %L",
3006 f
->sym
->name
, actual_size
, formal_size
,
3013 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3014 argument is provided for a procedure pointer formal argument. */
3015 if (f
->sym
->attr
.proc_pointer
3016 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3017 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3018 || gfc_is_proc_ptr_comp (a
->expr
)))
3019 || (a
->expr
->expr_type
== EXPR_FUNCTION
3020 && is_procptr_result (a
->expr
))))
3023 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3024 f
->sym
->name
, &a
->expr
->where
);
3028 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3029 provided for a procedure formal argument. */
3030 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3031 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3032 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3033 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3034 || gfc_is_proc_ptr_comp (a
->expr
)))
3035 || (a
->expr
->expr_type
== EXPR_FUNCTION
3036 && is_procptr_result (a
->expr
))))
3039 gfc_error ("Expected a procedure for argument %qs at %L",
3040 f
->sym
->name
, &a
->expr
->where
);
3044 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3045 && a
->expr
->expr_type
== EXPR_VARIABLE
3046 && a
->expr
->symtree
->n
.sym
->as
3047 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3048 && (a
->expr
->ref
== NULL
3049 || (a
->expr
->ref
->type
== REF_ARRAY
3050 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3053 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3054 " array at %L", f
->sym
->name
, where
);
3058 if (a
->expr
->expr_type
!= EXPR_NULL
3059 && compare_pointer (f
->sym
, a
->expr
) == 0)
3062 gfc_error ("Actual argument for %qs must be a pointer at %L",
3063 f
->sym
->name
, &a
->expr
->where
);
3067 if (a
->expr
->expr_type
!= EXPR_NULL
3068 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3069 && compare_pointer (f
->sym
, a
->expr
) == 2)
3072 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3073 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3078 /* Fortran 2008, C1242. */
3079 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3082 gfc_error ("Coindexed actual argument at %L to pointer "
3084 &a
->expr
->where
, f
->sym
->name
);
3088 /* Fortran 2008, 12.5.2.5 (no constraint). */
3089 if (a
->expr
->expr_type
== EXPR_VARIABLE
3090 && f
->sym
->attr
.intent
!= INTENT_IN
3091 && f
->sym
->attr
.allocatable
3092 && gfc_is_coindexed (a
->expr
))
3095 gfc_error ("Coindexed actual argument at %L to allocatable "
3096 "dummy %qs requires INTENT(IN)",
3097 &a
->expr
->where
, f
->sym
->name
);
3101 /* Fortran 2008, C1237. */
3102 if (a
->expr
->expr_type
== EXPR_VARIABLE
3103 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3104 && gfc_is_coindexed (a
->expr
)
3105 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3106 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3109 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3110 "%L requires that dummy %qs has neither "
3111 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3116 /* Fortran 2008, 12.5.2.4 (no constraint). */
3117 if (a
->expr
->expr_type
== EXPR_VARIABLE
3118 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3119 && gfc_is_coindexed (a
->expr
)
3120 && gfc_has_ultimate_allocatable (a
->expr
))
3123 gfc_error ("Coindexed actual argument at %L with allocatable "
3124 "ultimate component to dummy %qs requires either VALUE "
3125 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3129 if (f
->sym
->ts
.type
== BT_CLASS
3130 && CLASS_DATA (f
->sym
)->attr
.allocatable
3131 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3135 gfc_error ("Actual CLASS array argument for %qs must be a full "
3136 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3141 if (a
->expr
->expr_type
!= EXPR_NULL
3142 && compare_allocatable (f
->sym
, a
->expr
) == 0)
3145 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3146 f
->sym
->name
, &a
->expr
->where
);
3150 /* Check intent = OUT/INOUT for definable actual argument. */
3151 if ((f
->sym
->attr
.intent
== INTENT_OUT
3152 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3154 const char* context
= (where
3155 ? _("actual argument to INTENT = OUT/INOUT")
3158 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3159 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3160 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3161 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3163 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3167 if ((f
->sym
->attr
.intent
== INTENT_OUT
3168 || f
->sym
->attr
.intent
== INTENT_INOUT
3169 || f
->sym
->attr
.volatile_
3170 || f
->sym
->attr
.asynchronous
)
3171 && gfc_has_vector_subscript (a
->expr
))
3174 gfc_error ("Array-section actual argument with vector "
3175 "subscripts at %L is incompatible with INTENT(OUT), "
3176 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3177 "of the dummy argument %qs",
3178 &a
->expr
->where
, f
->sym
->name
);
3182 /* C1232 (R1221) For an actual argument which is an array section or
3183 an assumed-shape array, the dummy argument shall be an assumed-
3184 shape array, if the dummy argument has the VOLATILE attribute. */
3186 if (f
->sym
->attr
.volatile_
3187 && a
->expr
->symtree
->n
.sym
->as
3188 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3189 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3192 gfc_error ("Assumed-shape actual argument at %L is "
3193 "incompatible with the non-assumed-shape "
3194 "dummy argument %qs due to VOLATILE attribute",
3195 &a
->expr
->where
,f
->sym
->name
);
3199 if (f
->sym
->attr
.volatile_
3200 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
3201 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3204 gfc_error ("Array-section actual argument at %L is "
3205 "incompatible with the non-assumed-shape "
3206 "dummy argument %qs due to VOLATILE attribute",
3207 &a
->expr
->where
,f
->sym
->name
);
3211 /* C1233 (R1221) For an actual argument which is a pointer array, the
3212 dummy argument shall be an assumed-shape or pointer array, if the
3213 dummy argument has the VOLATILE attribute. */
3215 if (f
->sym
->attr
.volatile_
3216 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3217 && a
->expr
->symtree
->n
.sym
->as
3219 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3220 || f
->sym
->attr
.pointer
)))
3223 gfc_error ("Pointer-array actual argument at %L requires "
3224 "an assumed-shape or pointer-array dummy "
3225 "argument %qs due to VOLATILE attribute",
3226 &a
->expr
->where
,f
->sym
->name
);
3237 /* Make sure missing actual arguments are optional. */
3239 for (f
= formal
; f
; f
= f
->next
, i
++)
3241 if (new_arg
[i
] != NULL
)
3246 gfc_error ("Missing alternate return spec in subroutine call "
3250 if (!f
->sym
->attr
.optional
)
3253 gfc_error ("Missing actual argument for argument %qs at %L",
3254 f
->sym
->name
, where
);
3259 /* The argument lists are compatible. We now relink a new actual
3260 argument list with null arguments in the right places. The head
3261 of the list remains the head. */
3262 for (i
= 0; i
< n
; i
++)
3263 if (new_arg
[i
] == NULL
)
3264 new_arg
[i
] = gfc_get_actual_arglist ();
3268 std::swap (*new_arg
[0], *actual
);
3269 std::swap (new_arg
[0], new_arg
[na
]);
3272 for (i
= 0; i
< n
- 1; i
++)
3273 new_arg
[i
]->next
= new_arg
[i
+ 1];
3275 new_arg
[i
]->next
= NULL
;
3277 if (*ap
== NULL
&& n
> 0)
3280 /* Note the types of omitted optional arguments. */
3281 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3282 if (a
->expr
== NULL
&& a
->label
== NULL
)
3283 a
->missing_arg_type
= f
->sym
->ts
.type
;
3291 gfc_formal_arglist
*f
;
3292 gfc_actual_arglist
*a
;
3296 /* qsort comparison function for argument pairs, with the following
3298 - p->a->expr == NULL
3299 - p->a->expr->expr_type != EXPR_VARIABLE
3300 - growing p->a->expr->symbol. */
3303 pair_cmp (const void *p1
, const void *p2
)
3305 const gfc_actual_arglist
*a1
, *a2
;
3307 /* *p1 and *p2 are elements of the to-be-sorted array. */
3308 a1
= ((const argpair
*) p1
)->a
;
3309 a2
= ((const argpair
*) p2
)->a
;
3318 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3320 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3324 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3326 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3330 /* Given two expressions from some actual arguments, test whether they
3331 refer to the same expression. The analysis is conservative.
3332 Returning false will produce no warning. */
3335 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3337 const gfc_ref
*r1
, *r2
;
3340 || e1
->expr_type
!= EXPR_VARIABLE
3341 || e2
->expr_type
!= EXPR_VARIABLE
3342 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3345 /* TODO: improve comparison, see expr.c:show_ref(). */
3346 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3348 if (r1
->type
!= r2
->type
)
3353 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3355 /* TODO: At the moment, consider only full arrays;
3356 we could do better. */
3357 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3362 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3370 gfc_internal_error ("compare_actual_expr(): Bad component code");
3379 /* Given formal and actual argument lists that correspond to one
3380 another, check that identical actual arguments aren't not
3381 associated with some incompatible INTENTs. */
3384 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3386 sym_intent f1_intent
, f2_intent
;
3387 gfc_formal_arglist
*f1
;
3388 gfc_actual_arglist
*a1
;
3394 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3396 if (f1
== NULL
&& a1
== NULL
)
3398 if (f1
== NULL
|| a1
== NULL
)
3399 gfc_internal_error ("check_some_aliasing(): List mismatch");
3404 p
= XALLOCAVEC (argpair
, n
);
3406 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3412 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3414 for (i
= 0; i
< n
; i
++)
3417 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3418 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3420 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3421 for (j
= i
+ 1; j
< n
; j
++)
3423 /* Expected order after the sort. */
3424 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3425 gfc_internal_error ("check_some_aliasing(): corrupted data");
3427 /* Are the expression the same? */
3428 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3430 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3431 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3432 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3433 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3435 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3436 "argument %qs and INTENT(%s) argument %qs at %L",
3437 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3438 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3439 &p
[i
].a
->expr
->where
);
3449 /* Given formal and actual argument lists that correspond to one
3450 another, check that they are compatible in the sense that intents
3451 are not mismatched. */
3454 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3456 sym_intent f_intent
;
3458 for (;; f
= f
->next
, a
= a
->next
)
3462 if (f
== NULL
&& a
== NULL
)
3464 if (f
== NULL
|| a
== NULL
)
3465 gfc_internal_error ("check_intents(): List mismatch");
3467 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3468 && a
->expr
->value
.function
.isym
3469 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3470 expr
= a
->expr
->value
.function
.actual
->expr
;
3474 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3477 f_intent
= f
->sym
->attr
.intent
;
3479 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3481 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3482 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3483 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3485 gfc_error ("Procedure argument at %L is local to a PURE "
3486 "procedure and has the POINTER attribute",
3492 /* Fortran 2008, C1283. */
3493 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3495 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3497 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3498 "is passed to an INTENT(%s) argument",
3499 &expr
->where
, gfc_intent_string (f_intent
));
3503 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3504 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3505 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3507 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3508 "is passed to a POINTER dummy argument",
3514 /* F2008, Section 12.5.2.4. */
3515 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3516 && gfc_is_coindexed (expr
))
3518 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3519 "polymorphic dummy argument %qs",
3520 &expr
->where
, f
->sym
->name
);
3529 /* Check how a procedure is used against its interface. If all goes
3530 well, the actual argument list will also end up being properly
3534 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3536 gfc_formal_arglist
*dummy_args
;
3538 /* Warn about calls with an implicit interface. Special case
3539 for calling a ISO_C_BINDING because c_loc and c_funloc
3540 are pseudo-unknown. Additionally, warn about procedures not
3541 explicitly declared at all if requested. */
3542 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3544 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3546 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3550 if (warn_implicit_interface
)
3551 gfc_warning (OPT_Wimplicit_interface
,
3552 "Procedure %qs called with an implicit interface at %L",
3554 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3555 gfc_warning (OPT_Wimplicit_procedure
,
3556 "Procedure %qs called at %L is not explicitly declared",
3560 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3562 gfc_actual_arglist
*a
;
3564 if (sym
->attr
.pointer
)
3566 gfc_error ("The pointer object %qs at %L must have an explicit "
3567 "function interface or be declared as array",
3572 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3574 gfc_error ("The allocatable object %qs at %L must have an explicit "
3575 "function interface or be declared as array",
3580 if (sym
->attr
.allocatable
)
3582 gfc_error ("Allocatable function %qs at %L must have an explicit "
3583 "function interface", sym
->name
, where
);
3587 for (a
= *ap
; a
; a
= a
->next
)
3589 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3590 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3592 gfc_error ("Keyword argument requires explicit interface "
3593 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3597 /* TS 29113, 6.2. */
3598 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3599 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3601 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3602 "interface", a
->expr
->symtree
->n
.sym
->name
,
3607 /* F2008, C1303 and C1304. */
3609 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3610 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3611 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3612 || gfc_expr_attr (a
->expr
).lock_comp
))
3614 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3615 "component at %L requires an explicit interface for "
3616 "procedure %qs", &a
->expr
->where
, sym
->name
);
3621 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3622 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3623 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3624 == ISOFORTRAN_EVENT_TYPE
)
3625 || gfc_expr_attr (a
->expr
).event_comp
))
3627 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3628 "component at %L requires an explicit interface for "
3629 "procedure %qs", &a
->expr
->where
, sym
->name
);
3633 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3634 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3636 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3640 /* TS 29113, C407b. */
3641 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3642 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3644 gfc_error ("Assumed-rank argument requires an explicit interface "
3645 "at %L", &a
->expr
->where
);
3653 dummy_args
= gfc_sym_get_dummy_args (sym
);
3655 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3658 if (!check_intents (dummy_args
, *ap
))
3662 check_some_aliasing (dummy_args
, *ap
);
3668 /* Check how a procedure pointer component is used against its interface.
3669 If all goes well, the actual argument list will also end up being properly
3670 sorted. Completely analogous to gfc_procedure_use. */
3673 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3675 /* Warn about calls with an implicit interface. Special case
3676 for calling a ISO_C_BINDING because c_loc and c_funloc
3677 are pseudo-unknown. */
3678 if (warn_implicit_interface
3679 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3680 && !comp
->attr
.is_iso_c
)
3681 gfc_warning (OPT_Wimplicit_interface
,
3682 "Procedure pointer component %qs called with an implicit "
3683 "interface at %L", comp
->name
, where
);
3685 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3687 gfc_actual_arglist
*a
;
3688 for (a
= *ap
; a
; a
= a
->next
)
3690 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3691 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3693 gfc_error ("Keyword argument requires explicit interface "
3694 "for procedure pointer component %qs at %L",
3695 comp
->name
, &a
->expr
->where
);
3703 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3704 comp
->attr
.elemental
, where
))
3707 check_intents (comp
->ts
.interface
->formal
, *ap
);
3709 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3713 /* Try if an actual argument list matches the formal list of a symbol,
3714 respecting the symbol's attributes like ELEMENTAL. This is used for
3715 GENERIC resolution. */
3718 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3720 gfc_formal_arglist
*dummy_args
;
3723 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3726 dummy_args
= gfc_sym_get_dummy_args (sym
);
3728 r
= !sym
->attr
.elemental
;
3729 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3731 check_intents (dummy_args
, *args
);
3733 check_some_aliasing (dummy_args
, *args
);
3741 /* Given an interface pointer and an actual argument list, search for
3742 a formal argument list that matches the actual. If found, returns
3743 a pointer to the symbol of the correct interface. Returns NULL if
3747 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3748 gfc_actual_arglist
**ap
)
3750 gfc_symbol
*elem_sym
= NULL
;
3751 gfc_symbol
*null_sym
= NULL
;
3752 locus null_expr_loc
;
3753 gfc_actual_arglist
*a
;
3754 bool has_null_arg
= false;
3756 for (a
= *ap
; a
; a
= a
->next
)
3757 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3758 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3760 has_null_arg
= true;
3761 null_expr_loc
= a
->expr
->where
;
3765 for (; intr
; intr
= intr
->next
)
3767 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3769 if (sub_flag
&& intr
->sym
->attr
.function
)
3771 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3774 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3776 if (has_null_arg
&& null_sym
)
3778 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3779 "between specific functions %s and %s",
3780 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3783 else if (has_null_arg
)
3785 null_sym
= intr
->sym
;
3789 /* Satisfy 12.4.4.1 such that an elemental match has lower
3790 weight than a non-elemental match. */
3791 if (intr
->sym
->attr
.elemental
)
3793 elem_sym
= intr
->sym
;
3803 return elem_sym
? elem_sym
: NULL
;
3807 /* Do a brute force recursive search for a symbol. */
3809 static gfc_symtree
*
3810 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3814 if (root
->n
.sym
== sym
)
3819 st
= find_symtree0 (root
->left
, sym
);
3820 if (root
->right
&& ! st
)
3821 st
= find_symtree0 (root
->right
, sym
);
3826 /* Find a symtree for a symbol. */
3829 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3834 /* First try to find it by name. */
3835 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3836 if (st
&& st
->n
.sym
== sym
)
3839 /* If it's been renamed, resort to a brute-force search. */
3840 /* TODO: avoid having to do this search. If the symbol doesn't exist
3841 in the symtree for the current namespace, it should probably be added. */
3842 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3844 st
= find_symtree0 (ns
->sym_root
, sym
);
3848 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3853 /* See if the arglist to an operator-call contains a derived-type argument
3854 with a matching type-bound operator. If so, return the matching specific
3855 procedure defined as operator-target as well as the base-object to use
3856 (which is the found derived-type argument with operator). The generic
3857 name, if any, is transmitted to the final expression via 'gname'. */
3859 static gfc_typebound_proc
*
3860 matching_typebound_op (gfc_expr
** tb_base
,
3861 gfc_actual_arglist
* args
,
3862 gfc_intrinsic_op op
, const char* uop
,
3863 const char ** gname
)
3865 gfc_actual_arglist
* base
;
3867 for (base
= args
; base
; base
= base
->next
)
3868 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3870 gfc_typebound_proc
* tb
;
3871 gfc_symbol
* derived
;
3874 while (base
->expr
->expr_type
== EXPR_OP
3875 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3876 base
->expr
= base
->expr
->value
.op
.op1
;
3878 if (base
->expr
->ts
.type
== BT_CLASS
)
3880 if (CLASS_DATA (base
->expr
) == NULL
3881 || !gfc_expr_attr (base
->expr
).class_ok
)
3883 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3886 derived
= base
->expr
->ts
.u
.derived
;
3888 if (op
== INTRINSIC_USER
)
3890 gfc_symtree
* tb_uop
;
3893 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3902 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3905 /* This means we hit a PRIVATE operator which is use-associated and
3906 should thus not be seen. */
3910 /* Look through the super-type hierarchy for a matching specific
3912 for (; tb
; tb
= tb
->overridden
)
3916 gcc_assert (tb
->is_generic
);
3917 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3920 gfc_actual_arglist
* argcopy
;
3923 gcc_assert (g
->specific
);
3924 if (g
->specific
->error
)
3927 target
= g
->specific
->u
.specific
->n
.sym
;
3929 /* Check if this arglist matches the formal. */
3930 argcopy
= gfc_copy_actual_arglist (args
);
3931 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3932 gfc_free_actual_arglist (argcopy
);
3934 /* Return if we found a match. */
3937 *tb_base
= base
->expr
;
3938 *gname
= g
->specific_st
->name
;
3949 /* For the 'actual arglist' of an operator call and a specific typebound
3950 procedure that has been found the target of a type-bound operator, build the
3951 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3952 type-bound procedures rather than resolving type-bound operators 'directly'
3953 so that we can reuse the existing logic. */
3956 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3957 gfc_expr
* base
, gfc_typebound_proc
* target
,
3960 e
->expr_type
= EXPR_COMPCALL
;
3961 e
->value
.compcall
.tbp
= target
;
3962 e
->value
.compcall
.name
= gname
? gname
: "$op";
3963 e
->value
.compcall
.actual
= actual
;
3964 e
->value
.compcall
.base_object
= base
;
3965 e
->value
.compcall
.ignore_pass
= 1;
3966 e
->value
.compcall
.assign
= 0;
3967 if (e
->ts
.type
== BT_UNKNOWN
3968 && target
->function
)
3970 if (target
->is_generic
)
3971 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3973 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3978 /* This subroutine is called when an expression is being resolved.
3979 The expression node in question is either a user defined operator
3980 or an intrinsic operator with arguments that aren't compatible
3981 with the operator. This subroutine builds an actual argument list
3982 corresponding to the operands, then searches for a compatible
3983 interface. If one is found, the expression node is replaced with
3984 the appropriate function call. We use the 'match' enum to specify
3985 whether a replacement has been made or not, or if an error occurred. */
3988 gfc_extend_expr (gfc_expr
*e
)
3990 gfc_actual_arglist
*actual
;
3996 gfc_typebound_proc
* tbo
;
4001 actual
= gfc_get_actual_arglist ();
4002 actual
->expr
= e
->value
.op
.op1
;
4006 if (e
->value
.op
.op2
!= NULL
)
4008 actual
->next
= gfc_get_actual_arglist ();
4009 actual
->next
->expr
= e
->value
.op
.op2
;
4012 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4014 /* See if we find a matching type-bound operator. */
4015 if (i
== INTRINSIC_USER
)
4016 tbo
= matching_typebound_op (&tb_base
, actual
,
4017 i
, e
->value
.op
.uop
->name
, &gname
);
4021 #define CHECK_OS_COMPARISON(comp) \
4022 case INTRINSIC_##comp: \
4023 case INTRINSIC_##comp##_OS: \
4024 tbo = matching_typebound_op (&tb_base, actual, \
4025 INTRINSIC_##comp, NULL, &gname); \
4027 tbo = matching_typebound_op (&tb_base, actual, \
4028 INTRINSIC_##comp##_OS, NULL, &gname); \
4030 CHECK_OS_COMPARISON(EQ
)
4031 CHECK_OS_COMPARISON(NE
)
4032 CHECK_OS_COMPARISON(GT
)
4033 CHECK_OS_COMPARISON(GE
)
4034 CHECK_OS_COMPARISON(LT
)
4035 CHECK_OS_COMPARISON(LE
)
4036 #undef CHECK_OS_COMPARISON
4039 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4043 /* If there is a matching typebound-operator, replace the expression with
4044 a call to it and succeed. */
4047 gcc_assert (tb_base
);
4048 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4050 if (!gfc_resolve_expr (e
))
4056 if (i
== INTRINSIC_USER
)
4058 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4060 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4064 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4071 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4073 /* Due to the distinction between '==' and '.eq.' and friends, one has
4074 to check if either is defined. */
4077 #define CHECK_OS_COMPARISON(comp) \
4078 case INTRINSIC_##comp: \
4079 case INTRINSIC_##comp##_OS: \
4080 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4082 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4084 CHECK_OS_COMPARISON(EQ
)
4085 CHECK_OS_COMPARISON(NE
)
4086 CHECK_OS_COMPARISON(GT
)
4087 CHECK_OS_COMPARISON(GE
)
4088 CHECK_OS_COMPARISON(LT
)
4089 CHECK_OS_COMPARISON(LE
)
4090 #undef CHECK_OS_COMPARISON
4093 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4101 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4102 found rather than just taking the first one and not checking further. */
4106 /* Don't use gfc_free_actual_arglist(). */
4107 free (actual
->next
);
4112 /* Change the expression node to a function call. */
4113 e
->expr_type
= EXPR_FUNCTION
;
4114 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4115 e
->value
.function
.actual
= actual
;
4116 e
->value
.function
.esym
= NULL
;
4117 e
->value
.function
.isym
= NULL
;
4118 e
->value
.function
.name
= NULL
;
4119 e
->user_operator
= 1;
4121 if (!gfc_resolve_expr (e
))
4128 /* Tries to replace an assignment code node with a subroutine call to the
4129 subroutine associated with the assignment operator. Return true if the node
4130 was replaced. On false, no error is generated. */
4133 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4135 gfc_actual_arglist
*actual
;
4136 gfc_expr
*lhs
, *rhs
, *tb_base
;
4137 gfc_symbol
*sym
= NULL
;
4138 const char *gname
= NULL
;
4139 gfc_typebound_proc
* tbo
;
4144 /* Don't allow an intrinsic assignment to be replaced. */
4145 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4146 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4147 && (lhs
->ts
.type
== rhs
->ts
.type
4148 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4151 actual
= gfc_get_actual_arglist ();
4154 actual
->next
= gfc_get_actual_arglist ();
4155 actual
->next
->expr
= rhs
;
4157 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4159 /* See if we find a matching type-bound assignment. */
4160 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4165 /* Success: Replace the expression with a type-bound call. */
4166 gcc_assert (tb_base
);
4167 c
->expr1
= gfc_get_expr ();
4168 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4169 c
->expr1
->value
.compcall
.assign
= 1;
4170 c
->expr1
->where
= c
->loc
;
4172 c
->op
= EXEC_COMPCALL
;
4176 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4177 for (; ns
; ns
= ns
->parent
)
4179 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4186 /* Success: Replace the assignment with the call. */
4187 c
->op
= EXEC_ASSIGN_CALL
;
4188 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4191 c
->ext
.actual
= actual
;
4195 /* Failure: No assignment procedure found. */
4196 free (actual
->next
);
4202 /* Make sure that the interface just parsed is not already present in
4203 the given interface list. Ambiguity isn't checked yet since module
4204 procedures can be present without interfaces. */
4207 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4211 for (ip
= base
; ip
; ip
= ip
->next
)
4213 if (ip
->sym
== new_sym
)
4215 gfc_error ("Entity %qs at %L is already present in the interface",
4216 new_sym
->name
, &loc
);
4225 /* Add a symbol to the current interface. */
4228 gfc_add_interface (gfc_symbol
*new_sym
)
4230 gfc_interface
**head
, *intr
;
4234 switch (current_interface
.type
)
4236 case INTERFACE_NAMELESS
:
4237 case INTERFACE_ABSTRACT
:
4240 case INTERFACE_INTRINSIC_OP
:
4241 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4242 switch (current_interface
.op
)
4245 case INTRINSIC_EQ_OS
:
4246 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4248 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4249 new_sym
, gfc_current_locus
))
4254 case INTRINSIC_NE_OS
:
4255 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4257 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4258 new_sym
, gfc_current_locus
))
4263 case INTRINSIC_GT_OS
:
4264 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4265 new_sym
, gfc_current_locus
)
4266 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4267 new_sym
, gfc_current_locus
))
4272 case INTRINSIC_GE_OS
:
4273 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4274 new_sym
, gfc_current_locus
)
4275 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4276 new_sym
, gfc_current_locus
))
4281 case INTRINSIC_LT_OS
:
4282 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4283 new_sym
, gfc_current_locus
)
4284 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4285 new_sym
, gfc_current_locus
))
4290 case INTRINSIC_LE_OS
:
4291 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4292 new_sym
, gfc_current_locus
)
4293 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4294 new_sym
, gfc_current_locus
))
4299 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4300 new_sym
, gfc_current_locus
))
4304 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4307 case INTERFACE_GENERIC
:
4308 case INTERFACE_DTIO
:
4309 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4311 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4315 if (!gfc_check_new_interface (sym
->generic
,
4316 new_sym
, gfc_current_locus
))
4320 head
= ¤t_interface
.sym
->generic
;
4323 case INTERFACE_USER_OP
:
4324 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4325 new_sym
, gfc_current_locus
))
4328 head
= ¤t_interface
.uop
->op
;
4332 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4335 intr
= gfc_get_interface ();
4336 intr
->sym
= new_sym
;
4337 intr
->where
= gfc_current_locus
;
4347 gfc_current_interface_head (void)
4349 switch (current_interface
.type
)
4351 case INTERFACE_INTRINSIC_OP
:
4352 return current_interface
.ns
->op
[current_interface
.op
];
4354 case INTERFACE_GENERIC
:
4355 case INTERFACE_DTIO
:
4356 return current_interface
.sym
->generic
;
4358 case INTERFACE_USER_OP
:
4359 return current_interface
.uop
->op
;
4368 gfc_set_current_interface_head (gfc_interface
*i
)
4370 switch (current_interface
.type
)
4372 case INTERFACE_INTRINSIC_OP
:
4373 current_interface
.ns
->op
[current_interface
.op
] = i
;
4376 case INTERFACE_GENERIC
:
4377 case INTERFACE_DTIO
:
4378 current_interface
.sym
->generic
= i
;
4381 case INTERFACE_USER_OP
:
4382 current_interface
.uop
->op
= i
;
4391 /* Gets rid of a formal argument list. We do not free symbols.
4392 Symbols are freed when a namespace is freed. */
4395 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4397 gfc_formal_arglist
*q
;
4407 /* Check that it is ok for the type-bound procedure 'proc' to override the
4408 procedure 'old', cf. F08:4.5.7.3. */
4411 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4414 gfc_symbol
*proc_target
, *old_target
;
4415 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4416 gfc_formal_arglist
*proc_formal
, *old_formal
;
4420 /* This procedure should only be called for non-GENERIC proc. */
4421 gcc_assert (!proc
->n
.tb
->is_generic
);
4423 /* If the overwritten procedure is GENERIC, this is an error. */
4424 if (old
->n
.tb
->is_generic
)
4426 gfc_error ("Can't overwrite GENERIC %qs at %L",
4427 old
->name
, &proc
->n
.tb
->where
);
4431 where
= proc
->n
.tb
->where
;
4432 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4433 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4435 /* Check that overridden binding is not NON_OVERRIDABLE. */
4436 if (old
->n
.tb
->non_overridable
)
4438 gfc_error ("%qs at %L overrides a procedure binding declared"
4439 " NON_OVERRIDABLE", proc
->name
, &where
);
4443 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4444 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4446 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4447 " non-DEFERRED binding", proc
->name
, &where
);
4451 /* If the overridden binding is PURE, the overriding must be, too. */
4452 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4454 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4455 proc
->name
, &where
);
4459 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4460 is not, the overriding must not be either. */
4461 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4463 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4464 " ELEMENTAL", proc
->name
, &where
);
4467 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4469 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4470 " be ELEMENTAL, either", proc
->name
, &where
);
4474 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4476 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4478 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4479 " SUBROUTINE", proc
->name
, &where
);
4483 /* If the overridden binding is a FUNCTION, the overriding must also be a
4484 FUNCTION and have the same characteristics. */
4485 if (old_target
->attr
.function
)
4487 if (!proc_target
->attr
.function
)
4489 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4490 " FUNCTION", proc
->name
, &where
);
4494 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4497 gfc_error ("Result mismatch for the overriding procedure "
4498 "%qs at %L: %s", proc
->name
, &where
, err
);
4503 /* If the overridden binding is PUBLIC, the overriding one must not be
4505 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4506 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4508 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4509 " PRIVATE", proc
->name
, &where
);
4513 /* Compare the formal argument lists of both procedures. This is also abused
4514 to find the position of the passed-object dummy arguments of both
4515 bindings as at least the overridden one might not yet be resolved and we
4516 need those positions in the check below. */
4517 proc_pass_arg
= old_pass_arg
= 0;
4518 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4520 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4523 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4524 old_formal
= gfc_sym_get_dummy_args (old_target
);
4525 for ( ; proc_formal
&& old_formal
;
4526 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4528 if (proc
->n
.tb
->pass_arg
4529 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4530 proc_pass_arg
= argpos
;
4531 if (old
->n
.tb
->pass_arg
4532 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4533 old_pass_arg
= argpos
;
4535 /* Check that the names correspond. */
4536 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4538 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4539 " to match the corresponding argument of the overridden"
4540 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4541 old_formal
->sym
->name
);
4545 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4546 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4547 check_type
, err
, sizeof(err
)))
4549 gfc_error ("Argument mismatch for the overriding procedure "
4550 "%qs at %L: %s", proc
->name
, &where
, err
);
4556 if (proc_formal
|| old_formal
)
4558 gfc_error ("%qs at %L must have the same number of formal arguments as"
4559 " the overridden procedure", proc
->name
, &where
);
4563 /* If the overridden binding is NOPASS, the overriding one must also be
4565 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4567 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4568 " NOPASS", proc
->name
, &where
);
4572 /* If the overridden binding is PASS(x), the overriding one must also be
4573 PASS and the passed-object dummy arguments must correspond. */
4574 if (!old
->n
.tb
->nopass
)
4576 if (proc
->n
.tb
->nopass
)
4578 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4579 " PASS", proc
->name
, &where
);
4583 if (proc_pass_arg
!= old_pass_arg
)
4585 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4586 " the same position as the passed-object dummy argument of"
4587 " the overridden procedure", proc
->name
, &where
);
4596 /* The following three functions check that the formal arguments
4597 of user defined derived type IO procedures are compliant with
4598 the requirements of the standard. */
4601 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4602 int kind
, int rank
, sym_intent intent
)
4604 if (fsym
->ts
.type
!= type
)
4606 gfc_error ("DTIO dummy argument at %L must be of type %s",
4607 &fsym
->declared_at
, gfc_basic_typename (type
));
4611 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4612 && fsym
->ts
.kind
!= kind
)
4613 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4614 &fsym
->declared_at
, kind
);
4618 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4619 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4620 gfc_error ("DTIO dummy argument at %L be a scalar",
4621 &fsym
->declared_at
);
4623 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4624 gfc_error ("DTIO dummy argument at %L must be an "
4625 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4627 if (fsym
->attr
.intent
!= intent
)
4628 gfc_error ("DTIO dummy argument at %L must have intent %s",
4629 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4635 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4636 bool typebound
, bool formatted
, int code
)
4638 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4639 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4640 gfc_interface
*intr
;
4641 gfc_formal_arglist
*formal
;
4644 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4645 || ((dtio_codes
)code
== DTIO_RUF
);
4653 /* Typebound DTIO binding. */
4654 tb_io_proc
= tb_io_st
->n
.tb
;
4655 if (tb_io_proc
== NULL
)
4658 gcc_assert (tb_io_proc
->is_generic
);
4659 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4661 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4662 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4665 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4669 generic_proc
= tb_io_st
->n
.sym
;
4670 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4673 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4675 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4676 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4677 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4679 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4680 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4682 dtio_sub
= intr
->sym
;
4685 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4687 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4688 "procedure", &intr
->sym
->declared_at
);
4693 if (dtio_sub
== NULL
)
4697 gcc_assert (dtio_sub
);
4698 if (!dtio_sub
->attr
.subroutine
)
4699 gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
4700 dtio_sub
->name
, &dtio_sub
->declared_at
);
4703 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4706 if (arg_num
< (formatted
? 6 : 4))
4708 gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
4709 dtio_sub
->name
, &dtio_sub
->declared_at
);
4713 if (arg_num
> (formatted
? 6 : 4))
4715 gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
4716 dtio_sub
->name
, &dtio_sub
->declared_at
);
4721 /* Now go through the formal arglist. */
4723 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4725 if (!formatted
&& arg_num
== 3)
4731 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4732 "procedure", &dtio_sub
->declared_at
);
4739 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4740 BT_DERIVED
: BT_CLASS
;
4742 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4743 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4749 kind
= gfc_default_integer_kind
;
4751 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4754 case(3): /* IOTYPE */
4755 type
= BT_CHARACTER
;
4756 kind
= gfc_default_character_kind
;
4758 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4761 case(4): /* VLIST */
4763 kind
= gfc_default_integer_kind
;
4765 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4768 case(5): /* IOSTAT */
4770 kind
= gfc_default_integer_kind
;
4771 intent
= INTENT_OUT
;
4772 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4775 case(6): /* IOMSG */
4776 type
= BT_CHARACTER
;
4777 kind
= gfc_default_character_kind
;
4778 intent
= INTENT_INOUT
;
4779 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4786 derived
->attr
.has_dtio_procs
= 1;
4791 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4793 gfc_symtree
*tb_io_st
;
4798 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4801 /* Check typebound DTIO bindings. */
4802 for (code
= 0; code
< 4; code
++)
4804 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4805 || ((dtio_codes
)code
== DTIO_WF
);
4807 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4808 gfc_code2string (dtio_procs
, code
),
4809 true, &derived
->declared_at
);
4810 if (tb_io_st
!= NULL
)
4811 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4814 /* Check generic DTIO interfaces. */
4815 for (code
= 0; code
< 4; code
++)
4817 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4818 || ((dtio_codes
)code
== DTIO_WF
);
4820 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4821 gfc_code2string (dtio_procs
, code
));
4822 if (tb_io_st
!= NULL
)
4823 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4829 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4831 gfc_symtree
*tb_io_st
= NULL
;
4832 gfc_symbol
*dtio_sub
= NULL
;
4833 gfc_symbol
*extended
;
4834 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4837 if (!derived
|| derived
->attr
.flavor
!= FL_DERIVED
)
4840 /* Try to find a typebound DTIO binding. */
4841 if (formatted
== true)
4844 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4845 gfc_code2string (dtio_procs
,
4848 &derived
->declared_at
);
4850 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4851 gfc_code2string (dtio_procs
,
4854 &derived
->declared_at
);
4859 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4860 gfc_code2string (dtio_procs
,
4863 &derived
->declared_at
);
4865 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4866 gfc_code2string (dtio_procs
,
4869 &derived
->declared_at
);
4872 if (tb_io_st
!= NULL
)
4874 const char *genname
;
4877 tb_io_proc
= tb_io_st
->n
.tb
;
4878 gcc_assert (tb_io_proc
!= NULL
);
4879 gcc_assert (tb_io_proc
->is_generic
);
4880 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4882 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4883 gcc_assert (!specific_proc
->is_generic
);
4885 /* Go back and make sure that we have the right specific procedure.
4886 Here we most likely have a procedure from the parent type, which
4887 can be overridden in extensions. */
4888 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4889 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4890 true, &tb_io_proc
->where
);
4892 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4894 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4897 if (tb_io_st
!= NULL
)
4900 /* If there is not a typebound binding, look for a generic
4902 for (extended
= derived
; extended
;
4903 extended
= gfc_get_derived_super_type (extended
))
4905 if (extended
== NULL
|| extended
->ns
== NULL
)
4908 if (formatted
== true)
4911 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4912 gfc_code2string (dtio_procs
,
4915 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4916 gfc_code2string (dtio_procs
,
4922 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4923 gfc_code2string (dtio_procs
,
4926 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4927 gfc_code2string (dtio_procs
,
4931 if (tb_io_st
!= NULL
4933 && tb_io_st
->n
.sym
->generic
)
4935 gfc_interface
*intr
;
4936 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4938 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
4939 if (intr
->sym
&& intr
->sym
->formal
4940 && ((fsym
->ts
.type
== BT_CLASS
4941 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
4942 || (fsym
->ts
.type
== BT_DERIVED
4943 && fsym
->ts
.u
.derived
== extended
)))
4945 dtio_sub
= intr
->sym
;
4953 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
4954 gfc_find_derived_vtab (derived
);