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 if (!derived1
|| !derived2
)
619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
621 /* Compare UNION types specially. */
622 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
623 return gfc_compare_union_types (derived1
, derived2
);
625 /* Special case for comparing derived types across namespaces. If the
626 true names and module names are the same and the module name is
627 nonnull, then they are equal. */
628 if (strcmp (derived1
->name
, derived2
->name
) == 0
629 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
630 && strcmp (derived1
->module
, derived2
->module
) == 0)
633 /* Compare type via the rules of the standard. Both types must have
634 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
635 because they can be anonymous; therefore two structures with different
636 names may be equal. */
638 /* Compare names, but not for anonymous types such as UNION or MAP. */
639 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
640 && strcmp (derived1
->name
, derived2
->name
) != 0)
643 if (derived1
->component_access
== ACCESS_PRIVATE
644 || derived2
->component_access
== ACCESS_PRIVATE
)
647 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
648 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
651 /* Protect against null components. */
652 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
655 if (derived1
->attr
.zero_comp
)
658 cmp1
= derived1
->components
;
659 cmp2
= derived2
->components
;
661 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
662 simple test can speed things up. Otherwise, lots of things have to
666 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
672 if (cmp1
== NULL
&& cmp2
== NULL
)
674 if (cmp1
== NULL
|| cmp2
== NULL
)
682 /* Compare two typespecs, recursively if necessary. */
685 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
687 /* See if one of the typespecs is a BT_VOID, which is what is being used
688 to allow the funcs like c_f_pointer to accept any pointer type.
689 TODO: Possibly should narrow this to just the one typespec coming in
690 that is for the formal arg, but oh well. */
691 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
694 /* The _data component is not always present, therefore check for its
695 presence before assuming, that its derived->attr is available.
696 When the _data component is not present, then nevertheless the
697 unlimited_polymorphic flag may be set in the derived type's attr. */
698 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
699 && ((ts1
->u
.derived
->attr
.is_class
700 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
701 .unlimited_polymorphic
)
702 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
706 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
707 && ts2
->u
.derived
->components
708 && ((ts2
->u
.derived
->attr
.is_class
709 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
710 .unlimited_polymorphic
)
711 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
712 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
715 if (ts1
->type
!= ts2
->type
716 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
717 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
720 if (ts1
->type
== BT_UNION
)
721 return gfc_compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
723 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
724 return (ts1
->kind
== ts2
->kind
);
726 /* Compare derived types. */
727 return gfc_type_compatible (ts1
, ts2
);
732 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
734 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
737 /* TYPE and CLASS of the same declared type are type compatible,
738 but have different characteristics. */
739 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
740 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
743 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
748 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
750 gfc_array_spec
*as1
, *as2
;
753 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
756 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
757 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
759 r1
= as1
? as1
->rank
: 0;
760 r2
= as2
? as2
->rank
: 0;
762 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
763 return 0; /* Ranks differ. */
769 /* Given two symbols that are formal arguments, compare their ranks
770 and types. Returns nonzero if they have the same rank and type,
774 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
776 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
780 /* Given two symbols that are formal arguments, compare their types
781 and rank and their formal interfaces if they are both dummy
782 procedures. Returns nonzero if the same, zero if different. */
785 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
787 if (s1
== NULL
|| s2
== NULL
)
788 return s1
== s2
? 1 : 0;
793 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
794 return compare_type_rank (s1
, s2
);
796 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
799 /* At this point, both symbols are procedures. It can happen that
800 external procedures are compared, where one is identified by usage
801 to be a function or subroutine but the other is not. Check TKR
802 nonetheless for these cases. */
803 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
804 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
806 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
807 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
809 /* Now the type of procedure has been identified. */
810 if (s1
->attr
.function
!= s2
->attr
.function
811 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
814 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
817 /* Originally, gfortran recursed here to check the interfaces of passed
818 procedures. This is explicitly not required by the standard. */
823 /* Given a formal argument list and a keyword name, search the list
824 for that keyword. Returns the correct symbol node if found, NULL
828 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
830 for (; f
; f
= f
->next
)
831 if (strcmp (f
->sym
->name
, name
) == 0)
838 /******** Interface checking subroutines **********/
841 /* Given an operator interface and the operator, make sure that all
842 interfaces for that operator are legal. */
845 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
848 gfc_formal_arglist
*formal
;
851 int args
, r1
, r2
, k1
, k2
;
856 t1
= t2
= BT_UNKNOWN
;
857 i1
= i2
= INTENT_UNKNOWN
;
861 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
863 gfc_symbol
*fsym
= formal
->sym
;
866 gfc_error ("Alternate return cannot appear in operator "
867 "interface at %L", &sym
->declared_at
);
873 i1
= fsym
->attr
.intent
;
874 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
880 i2
= fsym
->attr
.intent
;
881 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
887 /* Only +, - and .not. can be unary operators.
888 .not. cannot be a binary operator. */
889 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
890 && op
!= INTRINSIC_MINUS
891 && op
!= INTRINSIC_NOT
)
892 || (args
== 2 && op
== INTRINSIC_NOT
))
894 if (op
== INTRINSIC_ASSIGN
)
895 gfc_error ("Assignment operator interface at %L must have "
896 "two arguments", &sym
->declared_at
);
898 gfc_error ("Operator interface at %L has the wrong number of arguments",
903 /* Check that intrinsics are mapped to functions, except
904 INTRINSIC_ASSIGN which should map to a subroutine. */
905 if (op
== INTRINSIC_ASSIGN
)
907 gfc_formal_arglist
*dummy_args
;
909 if (!sym
->attr
.subroutine
)
911 gfc_error ("Assignment operator interface at %L must be "
912 "a SUBROUTINE", &sym
->declared_at
);
916 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
917 - First argument an array with different rank than second,
918 - First argument is a scalar and second an array,
919 - Types and kinds do not conform, or
920 - First argument is of derived type. */
921 dummy_args
= gfc_sym_get_dummy_args (sym
);
922 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
923 && dummy_args
->sym
->ts
.type
!= BT_CLASS
924 && (r2
== 0 || r1
== r2
)
925 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
926 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
927 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
929 gfc_error ("Assignment operator interface at %L must not redefine "
930 "an INTRINSIC type assignment", &sym
->declared_at
);
936 if (!sym
->attr
.function
)
938 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
944 /* Check intents on operator interfaces. */
945 if (op
== INTRINSIC_ASSIGN
)
947 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
949 gfc_error ("First argument of defined assignment at %L must be "
950 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
956 gfc_error ("Second argument of defined assignment at %L must be "
957 "INTENT(IN)", &sym
->declared_at
);
965 gfc_error ("First argument of operator interface at %L must be "
966 "INTENT(IN)", &sym
->declared_at
);
970 if (args
== 2 && i2
!= INTENT_IN
)
972 gfc_error ("Second argument of operator interface at %L must be "
973 "INTENT(IN)", &sym
->declared_at
);
978 /* From now on, all we have to do is check that the operator definition
979 doesn't conflict with an intrinsic operator. The rules for this
980 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
981 as well as 12.3.2.1.1 of Fortran 2003:
983 "If the operator is an intrinsic-operator (R310), the number of
984 function arguments shall be consistent with the intrinsic uses of
985 that operator, and the types, kind type parameters, or ranks of the
986 dummy arguments shall differ from those required for the intrinsic
987 operation (7.1.2)." */
989 #define IS_NUMERIC_TYPE(t) \
990 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
992 /* Unary ops are easy, do them first. */
993 if (op
== INTRINSIC_NOT
)
995 if (t1
== BT_LOGICAL
)
1001 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1003 if (IS_NUMERIC_TYPE (t1
))
1009 /* Character intrinsic operators have same character kind, thus
1010 operator definitions with operands of different character kinds
1012 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1015 /* Intrinsic operators always perform on arguments of same rank,
1016 so different ranks is also always safe. (rank == 0) is an exception
1017 to that, because all intrinsic operators are elemental. */
1018 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1024 case INTRINSIC_EQ_OS
:
1026 case INTRINSIC_NE_OS
:
1027 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1031 case INTRINSIC_PLUS
:
1032 case INTRINSIC_MINUS
:
1033 case INTRINSIC_TIMES
:
1034 case INTRINSIC_DIVIDE
:
1035 case INTRINSIC_POWER
:
1036 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1041 case INTRINSIC_GT_OS
:
1043 case INTRINSIC_GE_OS
:
1045 case INTRINSIC_LT_OS
:
1047 case INTRINSIC_LE_OS
:
1048 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1050 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1051 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1055 case INTRINSIC_CONCAT
:
1056 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1063 case INTRINSIC_NEQV
:
1064 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1074 #undef IS_NUMERIC_TYPE
1077 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1083 /* Given a pair of formal argument lists, we see if the two lists can
1084 be distinguished by counting the number of nonoptional arguments of
1085 a given type/rank in f1 and seeing if there are less then that
1086 number of those arguments in f2 (including optional arguments).
1087 Since this test is asymmetric, it has to be called twice to make it
1088 symmetric. Returns nonzero if the argument lists are incompatible
1089 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1090 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1093 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1094 const char *p1
, const char *p2
)
1096 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
1097 gfc_formal_arglist
*f
;
1110 for (f
= f1
; f
; f
= f
->next
)
1113 /* Build an array of integers that gives the same integer to
1114 arguments of the same type/rank. */
1115 arg
= XCNEWVEC (arginfo
, n1
);
1118 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1121 arg
[i
].sym
= f
->sym
;
1126 for (i
= 0; i
< n1
; i
++)
1128 if (arg
[i
].flag
!= -1)
1131 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1132 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1133 continue; /* Skip OPTIONAL and PASS arguments. */
1137 /* Find other non-optional, non-pass arguments of the same type/rank. */
1138 for (j
= i
+ 1; j
< n1
; j
++)
1139 if ((arg
[j
].sym
== NULL
1140 || !(arg
[j
].sym
->attr
.optional
1141 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1142 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1143 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1149 /* Now loop over each distinct type found in f1. */
1153 for (i
= 0; i
< n1
; i
++)
1155 if (arg
[i
].flag
!= k
)
1159 for (j
= i
+ 1; j
< n1
; j
++)
1160 if (arg
[j
].flag
== k
)
1163 /* Count the number of non-pass arguments in f2 with that type,
1164 including those that are optional. */
1167 for (f
= f2
; f
; f
= f
->next
)
1168 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1169 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1170 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1188 /* Perform the correspondence test in rule (3) of F08:C1215.
1189 Returns zero if no argument is found that satisfies this rule,
1190 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1193 This test is also not symmetric in f1 and f2 and must be called
1194 twice. This test finds problems caused by sorting the actual
1195 argument list with keywords. For example:
1199 INTEGER :: A ; REAL :: B
1203 INTEGER :: A ; REAL :: B
1207 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1210 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1211 const char *p1
, const char *p2
)
1213 gfc_formal_arglist
*f2_save
, *g
;
1220 if (f1
->sym
->attr
.optional
)
1223 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1225 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1228 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1229 || compare_type_rank (f2
->sym
, f1
->sym
))
1230 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1231 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1232 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1235 /* Now search for a disambiguating keyword argument starting at
1236 the current non-match. */
1237 for (g
= f1
; g
; g
= g
->next
)
1239 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1242 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1243 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1244 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1245 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1246 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1262 symbol_rank (gfc_symbol
*sym
)
1265 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1266 return as
? as
->rank
: 0;
1270 /* Check if the characteristics of two dummy arguments match,
1274 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1275 bool type_must_agree
, char *errmsg
,
1278 if (s1
== NULL
|| s2
== NULL
)
1279 return s1
== s2
? true : false;
1281 /* Check type and rank. */
1282 if (type_must_agree
)
1284 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1286 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1287 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1290 if (!compare_rank (s1
, s2
))
1292 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1293 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1299 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1301 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1306 /* Check OPTIONAL attribute. */
1307 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1309 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1314 /* Check ALLOCATABLE attribute. */
1315 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1317 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1322 /* Check POINTER attribute. */
1323 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1325 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1330 /* Check TARGET attribute. */
1331 if (s1
->attr
.target
!= s2
->attr
.target
)
1333 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1338 /* Check ASYNCHRONOUS attribute. */
1339 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1341 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1346 /* Check CONTIGUOUS attribute. */
1347 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1349 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1354 /* Check VALUE attribute. */
1355 if (s1
->attr
.value
!= s2
->attr
.value
)
1357 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1362 /* Check VOLATILE attribute. */
1363 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1365 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1370 /* Check interface of dummy procedures. */
1371 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1374 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1377 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1378 "'%s': %s", s1
->name
, err
);
1383 /* Check string length. */
1384 if (s1
->ts
.type
== BT_CHARACTER
1385 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1386 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1388 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1389 s2
->ts
.u
.cl
->length
);
1395 snprintf (errmsg
, err_len
, "Character length mismatch "
1396 "in argument '%s'", s1
->name
);
1400 /* FIXME: Implement a warning for this case.
1401 gfc_warning (0, "Possible character length mismatch in argument %qs",
1409 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1410 "%i of gfc_dep_compare_expr", compval
);
1415 /* Check array shape. */
1416 if (s1
->as
&& s2
->as
)
1419 gfc_expr
*shape1
, *shape2
;
1421 if (s1
->as
->type
!= s2
->as
->type
)
1423 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1428 if (s1
->as
->corank
!= s2
->as
->corank
)
1430 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1431 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1435 if (s1
->as
->type
== AS_EXPLICIT
)
1436 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1438 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1439 gfc_copy_expr (s1
->as
->lower
[i
]));
1440 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1441 gfc_copy_expr (s2
->as
->lower
[i
]));
1442 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1443 gfc_free_expr (shape1
);
1444 gfc_free_expr (shape2
);
1450 if (i
< s1
->as
->rank
)
1451 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1452 " argument '%s'", i
+ 1, s1
->name
);
1454 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1455 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1459 /* FIXME: Implement a warning for this case.
1460 gfc_warning (0, "Possible shape mismatch in argument %qs",
1468 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1469 "result %i of gfc_dep_compare_expr",
1480 /* Check if the characteristics of two function results match,
1484 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1485 char *errmsg
, int err_len
)
1487 gfc_symbol
*r1
, *r2
;
1489 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1490 r1
= s1
->ts
.interface
->result
;
1492 r1
= s1
->result
? s1
->result
: s1
;
1494 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1495 r2
= s2
->ts
.interface
->result
;
1497 r2
= s2
->result
? s2
->result
: s2
;
1499 if (r1
->ts
.type
== BT_UNKNOWN
)
1502 /* Check type and rank. */
1503 if (!compare_type (r1
, r2
))
1505 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1506 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1509 if (!compare_rank (r1
, r2
))
1511 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1512 symbol_rank (r1
), symbol_rank (r2
));
1516 /* Check ALLOCATABLE attribute. */
1517 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1519 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1524 /* Check POINTER attribute. */
1525 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1527 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1532 /* Check CONTIGUOUS attribute. */
1533 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1535 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1540 /* Check PROCEDURE POINTER attribute. */
1541 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1543 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1548 /* Check string length. */
1549 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1551 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1553 snprintf (errmsg
, err_len
, "Character length mismatch "
1554 "in function result");
1558 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1560 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1561 r2
->ts
.u
.cl
->length
);
1567 snprintf (errmsg
, err_len
, "Character length mismatch "
1568 "in function result");
1572 /* FIXME: Implement a warning for this case.
1573 snprintf (errmsg, err_len, "Possible character length mismatch "
1574 "in function result");*/
1581 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1582 "result %i of gfc_dep_compare_expr", compval
);
1588 /* Check array shape. */
1589 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1592 gfc_expr
*shape1
, *shape2
;
1594 if (r1
->as
->type
!= r2
->as
->type
)
1596 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1600 if (r1
->as
->type
== AS_EXPLICIT
)
1601 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1603 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1604 gfc_copy_expr (r1
->as
->lower
[i
]));
1605 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1606 gfc_copy_expr (r2
->as
->lower
[i
]));
1607 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1608 gfc_free_expr (shape1
);
1609 gfc_free_expr (shape2
);
1615 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1616 "function result", i
+ 1);
1620 /* FIXME: Implement a warning for this case.
1621 gfc_warning (0, "Possible shape mismatch in return value");*/
1628 gfc_internal_error ("check_result_characteristics (2): "
1629 "Unexpected result %i of "
1630 "gfc_dep_compare_expr", compval
);
1640 /* 'Compare' two formal interfaces associated with a pair of symbols.
1641 We return nonzero if there exists an actual argument list that
1642 would be ambiguous between the two interfaces, zero otherwise.
1643 'strict_flag' specifies whether all the characteristics are
1644 required to match, which is not the case for ambiguity checks.
1645 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1648 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1649 int generic_flag
, int strict_flag
,
1650 char *errmsg
, int err_len
,
1651 const char *p1
, const char *p2
)
1653 gfc_formal_arglist
*f1
, *f2
;
1655 gcc_assert (name2
!= NULL
);
1657 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1658 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1659 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1662 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1666 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1669 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1673 /* Do strict checks on all characteristics
1674 (for dummy procedures and procedure pointer assignments). */
1675 if (!generic_flag
&& strict_flag
)
1677 if (s1
->attr
.function
&& s2
->attr
.function
)
1679 /* If both are functions, check result characteristics. */
1680 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1681 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1685 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1687 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1690 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1692 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1697 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1698 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1701 f1
= gfc_sym_get_dummy_args (s1
);
1702 f2
= gfc_sym_get_dummy_args (s2
);
1704 /* Special case: No arguments. */
1705 if (f1
== NULL
&& f2
== NULL
)
1710 if (count_types_test (f1
, f2
, p1
, p2
)
1711 || count_types_test (f2
, f1
, p2
, p1
))
1714 /* Special case: alternate returns. If both f1->sym and f2->sym are
1715 NULL, then the leading formal arguments are alternate returns.
1716 The previous conditional should catch argument lists with
1717 different number of argument. */
1718 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1721 if (generic_correspondence (f1
, f2
, p1
, p2
)
1722 || generic_correspondence (f2
, f1
, p2
, p1
))
1726 /* Perform the abbreviated correspondence test for operators (the
1727 arguments cannot be optional and are always ordered correctly).
1728 This is also done when comparing interfaces for dummy procedures and in
1729 procedure pointer assignments. */
1731 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1733 /* Check existence. */
1734 if (f1
== NULL
|| f2
== NULL
)
1737 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1738 "arguments", name2
);
1744 /* Check all characteristics. */
1745 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1751 /* Only check type and rank. */
1752 if (!compare_type (f2
->sym
, f1
->sym
))
1755 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1756 "(%s/%s)", f1
->sym
->name
,
1757 gfc_typename (&f1
->sym
->ts
),
1758 gfc_typename (&f2
->sym
->ts
));
1761 if (!compare_rank (f2
->sym
, f1
->sym
))
1764 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1765 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1766 symbol_rank (f2
->sym
));
1776 /* Given a pointer to an interface pointer, remove duplicate
1777 interfaces and make sure that all symbols are either functions
1778 or subroutines, and all of the same kind. Returns nonzero if
1779 something goes wrong. */
1782 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1784 gfc_interface
*psave
, *q
, *qlast
;
1787 for (; p
; p
= p
->next
)
1789 /* Make sure all symbols in the interface have been defined as
1790 functions or subroutines. */
1791 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1792 || !p
->sym
->attr
.if_source
)
1793 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1795 if (p
->sym
->attr
.external
)
1796 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1797 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1799 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1800 "subroutine", p
->sym
->name
, interface_name
,
1801 &p
->sym
->declared_at
);
1805 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1806 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1807 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1808 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1810 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1811 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1812 " or all FUNCTIONs", interface_name
,
1813 &p
->sym
->declared_at
);
1814 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1815 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1816 "generic name is also the name of a derived type",
1817 interface_name
, &p
->sym
->declared_at
);
1821 /* F2003, C1207. F2008, C1207. */
1822 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1823 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1824 "%qs in %s at %L", p
->sym
->name
,
1825 interface_name
, &p
->sym
->declared_at
))
1830 /* Remove duplicate interfaces in this interface list. */
1831 for (; p
; p
= p
->next
)
1835 for (q
= p
->next
; q
;)
1837 if (p
->sym
!= q
->sym
)
1844 /* Duplicate interface. */
1845 qlast
->next
= q
->next
;
1856 /* Check lists of interfaces to make sure that no two interfaces are
1857 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1860 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1861 int generic_flag
, const char *interface_name
,
1865 for (; p
; p
= p
->next
)
1866 for (q
= q0
; q
; q
= q
->next
)
1868 if (p
->sym
== q
->sym
)
1869 continue; /* Duplicates OK here. */
1871 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1874 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1875 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1876 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1877 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1880 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1881 "and %qs at %L", interface_name
,
1882 q
->sym
->name
, &q
->sym
->declared_at
,
1883 p
->sym
->name
, &p
->sym
->declared_at
);
1884 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1885 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1886 "and %qs at %L", interface_name
,
1887 q
->sym
->name
, &q
->sym
->declared_at
,
1888 p
->sym
->name
, &p
->sym
->declared_at
);
1890 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1891 "interfaces at %L", interface_name
, &p
->where
);
1899 /* Check the generic and operator interfaces of symbols to make sure
1900 that none of the interfaces conflict. The check has to be done
1901 after all of the symbols are actually loaded. */
1904 check_sym_interfaces (gfc_symbol
*sym
)
1906 char interface_name
[100];
1909 if (sym
->ns
!= gfc_current_ns
)
1912 if (sym
->generic
!= NULL
)
1914 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1915 if (check_interface0 (sym
->generic
, interface_name
))
1918 for (p
= sym
->generic
; p
; p
= p
->next
)
1920 if (p
->sym
->attr
.mod_proc
1921 && !p
->sym
->attr
.module_procedure
1922 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1923 || p
->sym
->attr
.procedure
))
1925 gfc_error ("%qs at %L is not a module procedure",
1926 p
->sym
->name
, &p
->where
);
1931 /* Originally, this test was applied to host interfaces too;
1932 this is incorrect since host associated symbols, from any
1933 source, cannot be ambiguous with local symbols. */
1934 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1935 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1941 check_uop_interfaces (gfc_user_op
*uop
)
1943 char interface_name
[100];
1947 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1948 if (check_interface0 (uop
->op
, interface_name
))
1951 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1953 uop2
= gfc_find_uop (uop
->name
, ns
);
1957 check_interface1 (uop
->op
, uop2
->op
, 0,
1958 interface_name
, true);
1962 /* Given an intrinsic op, return an equivalent op if one exists,
1963 or INTRINSIC_NONE otherwise. */
1966 gfc_equivalent_op (gfc_intrinsic_op op
)
1971 return INTRINSIC_EQ_OS
;
1973 case INTRINSIC_EQ_OS
:
1974 return INTRINSIC_EQ
;
1977 return INTRINSIC_NE_OS
;
1979 case INTRINSIC_NE_OS
:
1980 return INTRINSIC_NE
;
1983 return INTRINSIC_GT_OS
;
1985 case INTRINSIC_GT_OS
:
1986 return INTRINSIC_GT
;
1989 return INTRINSIC_GE_OS
;
1991 case INTRINSIC_GE_OS
:
1992 return INTRINSIC_GE
;
1995 return INTRINSIC_LT_OS
;
1997 case INTRINSIC_LT_OS
:
1998 return INTRINSIC_LT
;
2001 return INTRINSIC_LE_OS
;
2003 case INTRINSIC_LE_OS
:
2004 return INTRINSIC_LE
;
2007 return INTRINSIC_NONE
;
2011 /* For the namespace, check generic, user operator and intrinsic
2012 operator interfaces for consistency and to remove duplicate
2013 interfaces. We traverse the whole namespace, counting on the fact
2014 that most symbols will not have generic or operator interfaces. */
2017 gfc_check_interfaces (gfc_namespace
*ns
)
2019 gfc_namespace
*old_ns
, *ns2
;
2020 char interface_name
[100];
2023 old_ns
= gfc_current_ns
;
2024 gfc_current_ns
= ns
;
2026 gfc_traverse_ns (ns
, check_sym_interfaces
);
2028 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2030 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2032 if (i
== INTRINSIC_USER
)
2035 if (i
== INTRINSIC_ASSIGN
)
2036 strcpy (interface_name
, "intrinsic assignment operator");
2038 sprintf (interface_name
, "intrinsic '%s' operator",
2039 gfc_op2string ((gfc_intrinsic_op
) i
));
2041 if (check_interface0 (ns
->op
[i
], interface_name
))
2045 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2048 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2050 gfc_intrinsic_op other_op
;
2052 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2053 interface_name
, true))
2056 /* i should be gfc_intrinsic_op, but has to be int with this cast
2057 here for stupid C++ compatibility rules. */
2058 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2059 if (other_op
!= INTRINSIC_NONE
2060 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2061 0, interface_name
, true))
2067 gfc_current_ns
= old_ns
;
2071 /* Given a symbol of a formal argument list and an expression, if the
2072 formal argument is allocatable, check that the actual argument is
2073 allocatable. Returns nonzero if compatible, zero if not compatible. */
2076 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2078 if (formal
->attr
.allocatable
2079 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2081 symbol_attribute attr
= gfc_expr_attr (actual
);
2082 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2084 else if (!attr
.allocatable
)
2092 /* Given a symbol of a formal argument list and an expression, if the
2093 formal argument is a pointer, see if the actual argument is a
2094 pointer. Returns nonzero if compatible, zero if not compatible. */
2097 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2099 symbol_attribute attr
;
2101 if (formal
->attr
.pointer
2102 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2103 && CLASS_DATA (formal
)->attr
.class_pointer
))
2105 attr
= gfc_expr_attr (actual
);
2107 /* Fortran 2008 allows non-pointer actual arguments. */
2108 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2119 /* Emit clear error messages for rank mismatch. */
2122 argument_rank_mismatch (const char *name
, locus
*where
,
2123 int rank1
, int rank2
)
2126 /* TS 29113, C407b. */
2129 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2130 " %qs has assumed-rank", where
, name
);
2132 else if (rank1
== 0)
2134 gfc_error (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs at %L "
2135 "(scalar and rank-%d)", name
, where
, rank2
);
2137 else if (rank2
== 0)
2139 gfc_error (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs at %L "
2140 "(rank-%d and scalar)", name
, where
, rank1
);
2144 gfc_error (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs at %L "
2145 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2150 /* Given a symbol of a formal argument list and an expression, see if
2151 the two are compatible as arguments. Returns nonzero if
2152 compatible, zero if not compatible. */
2155 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2156 int ranks_must_agree
, int is_elemental
, locus
*where
)
2159 bool rank_check
, is_pointer
;
2163 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2164 procs c_f_pointer or c_f_procpointer, and we need to accept most
2165 pointers the user could give us. This should allow that. */
2166 if (formal
->ts
.type
== BT_VOID
)
2169 if (formal
->ts
.type
== BT_DERIVED
2170 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2171 && actual
->ts
.type
== BT_DERIVED
2172 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2175 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2176 /* Make sure the vtab symbol is present when
2177 the module variables are generated. */
2178 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2180 if (actual
->ts
.type
== BT_PROCEDURE
)
2182 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2184 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2187 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2191 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2192 sizeof(err
), NULL
, NULL
))
2195 gfc_error (OPT_Wargument_mismatch
,
2196 "Interface mismatch in dummy procedure %qs at %L: %s",
2197 formal
->name
, &actual
->where
, err
);
2201 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2203 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2204 &act_sym
->declared_at
);
2205 if (act_sym
->ts
.type
== BT_UNKNOWN
2206 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2209 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2210 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2211 &act_sym
->declared_at
);
2216 ppc
= gfc_get_proc_ptr_comp (actual
);
2217 if (ppc
&& ppc
->ts
.interface
)
2219 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2220 err
, sizeof(err
), NULL
, NULL
))
2223 gfc_error (OPT_Wargument_mismatch
,
2224 "Interface mismatch in dummy procedure %qs at %L: %s",
2225 formal
->name
, &actual
->where
, err
);
2231 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2232 && !gfc_is_simply_contiguous (actual
, true, false))
2235 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2236 "must be simply contiguous", formal
->name
, &actual
->where
);
2240 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2241 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2244 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2245 && actual
->ts
.type
!= BT_HOLLERITH
2246 && formal
->ts
.type
!= BT_ASSUMED
2247 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2248 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2249 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2250 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2251 CLASS_DATA (actual
)->ts
.u
.derived
)))
2254 gfc_error (OPT_Wargument_mismatch
,
2255 "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 ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2286 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2287 CLASS_DATA (formal
)->ts
.u
.derived
))
2290 gfc_error ("Actual argument to %qs at %L must have the same "
2291 "declared type", formal
->name
, &actual
->where
);
2296 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2297 is necessary also for F03, so retain error for both.
2298 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2299 compatible, no attempt has been made to channel to this one. */
2300 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2301 && (CLASS_DATA (formal
)->attr
.allocatable
2302 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2305 gfc_error ("Actual argument to %qs at %L must be unlimited "
2306 "polymorphic since the formal argument is a "
2307 "pointer or allocatable unlimited polymorphic "
2308 "entity [F2008: 12.5.2.5]", formal
->name
,
2313 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2316 gfc_error ("Actual argument to %qs at %L must be a coarray",
2317 formal
->name
, &actual
->where
);
2321 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2323 gfc_ref
*last
= NULL
;
2325 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2326 if (ref
->type
== REF_COMPONENT
)
2329 /* F2008, 12.5.2.6. */
2330 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2332 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2335 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2336 formal
->name
, &actual
->where
, formal
->as
->corank
,
2337 last
? last
->u
.c
.component
->as
->corank
2338 : actual
->symtree
->n
.sym
->as
->corank
);
2343 if (formal
->attr
.codimension
)
2345 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2346 /* F2015, 12.5.2.8. */
2347 if (formal
->attr
.dimension
2348 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2349 && actual_attr
.dimension
2350 && !gfc_is_simply_contiguous (actual
, true, true))
2353 gfc_error ("Actual argument to %qs at %L must be simply "
2354 "contiguous or an element of such an array",
2355 formal
->name
, &actual
->where
);
2359 /* F2008, C1303 and C1304. */
2360 if (formal
->attr
.intent
!= INTENT_INOUT
2361 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2362 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2363 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2364 || formal
->attr
.lock_comp
))
2368 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2369 "which is LOCK_TYPE or has a LOCK_TYPE component",
2370 formal
->name
, &actual
->where
);
2374 /* TS18508, C702/C703. */
2375 if (formal
->attr
.intent
!= INTENT_INOUT
2376 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2377 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2378 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2379 || formal
->attr
.event_comp
))
2383 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2384 "which is EVENT_TYPE or has a EVENT_TYPE component",
2385 formal
->name
, &actual
->where
);
2390 /* F2008, C1239/C1240. */
2391 if (actual
->expr_type
== EXPR_VARIABLE
2392 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2393 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2394 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2395 && actual
->rank
&& formal
->as
2396 && !gfc_is_simply_contiguous (actual
, true, false)
2397 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2398 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2399 || formal
->attr
.contiguous
))
2402 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2403 "assumed-rank array without CONTIGUOUS attribute - as actual"
2404 " argument at %L is not simply contiguous and both are "
2405 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2409 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2410 && actual_attr
.codimension
)
2412 if (formal
->attr
.intent
== INTENT_OUT
)
2415 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2416 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2420 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2421 gfc_warning (OPT_Wsurprising
,
2422 "Passing coarray at %L to allocatable, noncoarray dummy "
2423 "argument %qs, which is invalid if the allocation status"
2424 " is modified", &actual
->where
, formal
->name
);
2427 /* If the rank is the same or the formal argument has assumed-rank. */
2428 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2431 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2432 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2433 || formal
->as
->type
== AS_DEFERRED
)
2434 && actual
->expr_type
!= EXPR_NULL
;
2436 /* Skip rank checks for NO_ARG_CHECK. */
2437 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2440 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2441 if (rank_check
|| ranks_must_agree
2442 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2443 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2444 || (actual
->rank
== 0
2445 && ((formal
->ts
.type
== BT_CLASS
2446 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2447 || (formal
->ts
.type
!= BT_CLASS
2448 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2449 && actual
->expr_type
!= EXPR_NULL
)
2450 || (actual
->rank
== 0 && formal
->attr
.dimension
2451 && gfc_is_coindexed (actual
)))
2454 argument_rank_mismatch (formal
->name
, &actual
->where
,
2455 symbol_rank (formal
), actual
->rank
);
2458 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2461 /* At this point, we are considering a scalar passed to an array. This
2462 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2463 - if the actual argument is (a substring of) an element of a
2464 non-assumed-shape/non-pointer/non-polymorphic array; or
2465 - (F2003) if the actual argument is of type character of default/c_char
2468 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2469 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2471 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2473 if (ref
->type
== REF_COMPONENT
)
2474 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2475 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2476 && ref
->u
.ar
.dimen
> 0
2478 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2482 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2485 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2486 "at %L", formal
->name
, &actual
->where
);
2490 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2491 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2494 gfc_error ("Element of assumed-shaped or pointer "
2495 "array passed to array dummy argument %qs at %L",
2496 formal
->name
, &actual
->where
);
2500 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2501 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2503 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2506 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2507 "CHARACTER actual argument with array dummy argument "
2508 "%qs at %L", formal
->name
, &actual
->where
);
2512 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2514 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2515 "array dummy argument %qs at %L",
2516 formal
->name
, &actual
->where
);
2519 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2525 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2528 argument_rank_mismatch (formal
->name
, &actual
->where
,
2529 symbol_rank (formal
), actual
->rank
);
2537 /* Returns the storage size of a symbol (formal argument) or
2538 zero if it cannot be determined. */
2540 static unsigned long
2541 get_sym_storage_size (gfc_symbol
*sym
)
2544 unsigned long strlen
, elements
;
2546 if (sym
->ts
.type
== BT_CHARACTER
)
2548 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2549 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2550 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2557 if (symbol_rank (sym
) == 0)
2561 if (sym
->as
->type
!= AS_EXPLICIT
)
2563 for (i
= 0; i
< sym
->as
->rank
; i
++)
2565 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2566 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2569 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2570 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2573 return strlen
*elements
;
2577 /* Returns the storage size of an expression (actual argument) or
2578 zero if it cannot be determined. For an array element, it returns
2579 the remaining size as the element sequence consists of all storage
2580 units of the actual argument up to the end of the array. */
2582 static unsigned long
2583 get_expr_storage_size (gfc_expr
*e
)
2586 long int strlen
, elements
;
2587 long int substrlen
= 0;
2588 bool is_str_storage
= false;
2594 if (e
->ts
.type
== BT_CHARACTER
)
2596 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2597 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2598 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2599 else if (e
->expr_type
== EXPR_CONSTANT
2600 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2601 strlen
= e
->value
.character
.length
;
2606 strlen
= 1; /* Length per element. */
2608 if (e
->rank
== 0 && !e
->ref
)
2616 for (i
= 0; i
< e
->rank
; i
++)
2617 elements
*= mpz_get_si (e
->shape
[i
]);
2618 return elements
*strlen
;
2621 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2623 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2624 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2628 /* The string length is the substring length.
2629 Set now to full string length. */
2630 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2631 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2634 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2636 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2640 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2641 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2643 long int start
, end
, stride
;
2646 if (ref
->u
.ar
.stride
[i
])
2648 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2649 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2654 if (ref
->u
.ar
.start
[i
])
2656 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2657 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2661 else if (ref
->u
.ar
.as
->lower
[i
]
2662 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2663 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2667 if (ref
->u
.ar
.end
[i
])
2669 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2670 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2674 else if (ref
->u
.ar
.as
->upper
[i
]
2675 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2676 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2680 elements
*= (end
- start
)/stride
+ 1L;
2682 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2683 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2685 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2686 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2687 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2688 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2689 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2690 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2691 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2696 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2697 && e
->expr_type
== EXPR_VARIABLE
)
2699 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2700 || e
->symtree
->n
.sym
->attr
.pointer
)
2706 /* Determine the number of remaining elements in the element
2707 sequence for array element designators. */
2708 is_str_storage
= true;
2709 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2711 if (ref
->u
.ar
.start
[i
] == NULL
2712 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2713 || ref
->u
.ar
.as
->upper
[i
] == NULL
2714 || ref
->u
.ar
.as
->lower
[i
] == NULL
2715 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2716 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2721 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2722 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2724 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2725 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2728 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2729 && ref
->u
.c
.component
->attr
.proc_pointer
2730 && ref
->u
.c
.component
->attr
.dimension
)
2732 /* Array-valued procedure-pointer components. */
2733 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2734 for (i
= 0; i
< as
->rank
; i
++)
2736 if (!as
->upper
[i
] || !as
->lower
[i
]
2737 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2738 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2742 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2743 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2749 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2752 return elements
*strlen
;
2756 /* Given an expression, check whether it is an array section
2757 which has a vector subscript. If it has, one is returned,
2761 gfc_has_vector_subscript (gfc_expr
*e
)
2766 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2769 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2770 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2771 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2772 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2780 is_procptr_result (gfc_expr
*expr
)
2782 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2784 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2786 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2787 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2791 /* Given formal and actual argument lists, see if they are compatible.
2792 If they are compatible, the actual argument list is sorted to
2793 correspond with the formal list, and elements for missing optional
2794 arguments are inserted. If WHERE pointer is nonnull, then we issue
2795 errors when things don't match instead of just returning the status
2799 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2800 int ranks_must_agree
, int is_elemental
, locus
*where
)
2802 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2803 gfc_formal_arglist
*f
;
2805 unsigned long actual_size
, formal_size
;
2806 bool full_array
= false;
2807 gfc_array_ref
*actual_arr_ref
;
2811 if (actual
== NULL
&& formal
== NULL
)
2815 for (f
= formal
; f
; f
= f
->next
)
2818 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2820 for (i
= 0; i
< n
; i
++)
2827 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2829 /* Look for keywords but ignore g77 extensions like %VAL. */
2830 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2833 for (f
= formal
; f
; f
= f
->next
, i
++)
2837 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2844 gfc_error ("Keyword argument %qs at %L is not in "
2845 "the procedure", a
->name
, &a
->expr
->where
);
2849 if (new_arg
[i
] != NULL
)
2852 gfc_error ("Keyword argument %qs at %L is already associated "
2853 "with another actual argument", a
->name
,
2862 gfc_error ("More actual than formal arguments in procedure "
2863 "call at %L", where
);
2868 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2874 gfc_error ("Missing alternate return spec in subroutine call "
2879 if (a
->expr
== NULL
)
2882 gfc_error ("Unexpected alternate return spec in subroutine "
2883 "call at %L", where
);
2887 /* Make sure that intrinsic vtables exist for calls to unlimited
2888 polymorphic formal arguments. */
2889 if (UNLIMITED_POLY (f
->sym
)
2890 && a
->expr
->ts
.type
!= BT_DERIVED
2891 && a
->expr
->ts
.type
!= BT_CLASS
)
2892 gfc_find_vtab (&a
->expr
->ts
);
2894 if (a
->expr
->expr_type
== EXPR_NULL
2895 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2896 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2897 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2898 || (f
->sym
->ts
.type
== BT_CLASS
2899 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2900 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2901 || !f
->sym
->attr
.optional
2902 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2905 && (!f
->sym
->attr
.optional
2906 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2907 || (f
->sym
->ts
.type
== BT_CLASS
2908 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2909 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2910 where
, f
->sym
->name
);
2912 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2913 "dummy %qs", where
, f
->sym
->name
);
2918 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2919 is_elemental
, where
))
2922 /* TS 29113, 6.3p2. */
2923 if (f
->sym
->ts
.type
== BT_ASSUMED
2924 && (a
->expr
->ts
.type
== BT_DERIVED
2925 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2927 gfc_namespace
*f2k_derived
;
2929 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2930 ? a
->expr
->ts
.u
.derived
->f2k_derived
2931 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2934 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2936 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2937 "derived type with type-bound or FINAL procedures",
2943 /* Special case for character arguments. For allocatable, pointer
2944 and assumed-shape dummies, the string length needs to match
2946 if (a
->expr
->ts
.type
== BT_CHARACTER
2947 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2948 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2949 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
2950 && f
->sym
->ts
.u
.cl
->length
2951 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2952 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2953 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2954 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2955 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2957 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2958 gfc_warning (OPT_Wargument_mismatch
,
2959 "Character length mismatch (%ld/%ld) between actual "
2960 "argument and pointer or allocatable dummy argument "
2962 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2963 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2964 f
->sym
->name
, &a
->expr
->where
);
2966 gfc_warning (OPT_Wargument_mismatch
,
2967 "Character length mismatch (%ld/%ld) between actual "
2968 "argument and assumed-shape dummy argument %qs "
2970 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2971 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2972 f
->sym
->name
, &a
->expr
->where
);
2976 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2977 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2978 && a
->expr
->ts
.type
== BT_CHARACTER
)
2981 gfc_error ("Actual argument at %L to allocatable or "
2982 "pointer dummy argument %qs must have a deferred "
2983 "length type parameter if and only if the dummy has one",
2984 &a
->expr
->where
, f
->sym
->name
);
2988 if (f
->sym
->ts
.type
== BT_CLASS
)
2989 goto skip_size_check
;
2991 actual_size
= get_expr_storage_size (a
->expr
);
2992 formal_size
= get_sym_storage_size (f
->sym
);
2993 if (actual_size
!= 0 && actual_size
< formal_size
2994 && a
->expr
->ts
.type
!= BT_PROCEDURE
2995 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2997 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2998 gfc_warning (OPT_Wargument_mismatch
,
2999 "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 (OPT_Wargument_mismatch
,
3005 "Actual argument contains too few "
3006 "elements for dummy argument %qs (%lu/%lu) at %L",
3007 f
->sym
->name
, actual_size
, formal_size
,
3014 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3015 argument is provided for a procedure pointer formal argument. */
3016 if (f
->sym
->attr
.proc_pointer
3017 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3018 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3019 || gfc_is_proc_ptr_comp (a
->expr
)))
3020 || (a
->expr
->expr_type
== EXPR_FUNCTION
3021 && is_procptr_result (a
->expr
))))
3024 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3025 f
->sym
->name
, &a
->expr
->where
);
3029 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3030 provided for a procedure formal argument. */
3031 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3032 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3033 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3034 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3035 || gfc_is_proc_ptr_comp (a
->expr
)))
3036 || (a
->expr
->expr_type
== EXPR_FUNCTION
3037 && is_procptr_result (a
->expr
))))
3040 gfc_error ("Expected a procedure for argument %qs at %L",
3041 f
->sym
->name
, &a
->expr
->where
);
3045 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3046 && a
->expr
->expr_type
== EXPR_VARIABLE
3047 && a
->expr
->symtree
->n
.sym
->as
3048 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3049 && (a
->expr
->ref
== NULL
3050 || (a
->expr
->ref
->type
== REF_ARRAY
3051 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3054 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3055 " array at %L", f
->sym
->name
, where
);
3059 if (a
->expr
->expr_type
!= EXPR_NULL
3060 && compare_pointer (f
->sym
, a
->expr
) == 0)
3063 gfc_error ("Actual argument for %qs must be a pointer at %L",
3064 f
->sym
->name
, &a
->expr
->where
);
3068 if (a
->expr
->expr_type
!= EXPR_NULL
3069 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3070 && compare_pointer (f
->sym
, a
->expr
) == 2)
3073 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3074 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3079 /* Fortran 2008, C1242. */
3080 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3083 gfc_error ("Coindexed actual argument at %L to pointer "
3085 &a
->expr
->where
, f
->sym
->name
);
3089 /* Fortran 2008, 12.5.2.5 (no constraint). */
3090 if (a
->expr
->expr_type
== EXPR_VARIABLE
3091 && f
->sym
->attr
.intent
!= INTENT_IN
3092 && f
->sym
->attr
.allocatable
3093 && gfc_is_coindexed (a
->expr
))
3096 gfc_error ("Coindexed actual argument at %L to allocatable "
3097 "dummy %qs requires INTENT(IN)",
3098 &a
->expr
->where
, f
->sym
->name
);
3102 /* Fortran 2008, C1237. */
3103 if (a
->expr
->expr_type
== EXPR_VARIABLE
3104 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3105 && gfc_is_coindexed (a
->expr
)
3106 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3107 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3110 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3111 "%L requires that dummy %qs has neither "
3112 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3117 /* Fortran 2008, 12.5.2.4 (no constraint). */
3118 if (a
->expr
->expr_type
== EXPR_VARIABLE
3119 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3120 && gfc_is_coindexed (a
->expr
)
3121 && gfc_has_ultimate_allocatable (a
->expr
))
3124 gfc_error ("Coindexed actual argument at %L with allocatable "
3125 "ultimate component to dummy %qs requires either VALUE "
3126 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3130 if (f
->sym
->ts
.type
== BT_CLASS
3131 && CLASS_DATA (f
->sym
)->attr
.allocatable
3132 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3136 gfc_error ("Actual CLASS array argument for %qs must be a full "
3137 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3142 if (a
->expr
->expr_type
!= EXPR_NULL
3143 && compare_allocatable (f
->sym
, a
->expr
) == 0)
3146 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3147 f
->sym
->name
, &a
->expr
->where
);
3151 /* Check intent = OUT/INOUT for definable actual argument. */
3152 if ((f
->sym
->attr
.intent
== INTENT_OUT
3153 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3155 const char* context
= (where
3156 ? _("actual argument to INTENT = OUT/INOUT")
3159 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3160 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3161 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3162 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3164 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3168 if ((f
->sym
->attr
.intent
== INTENT_OUT
3169 || f
->sym
->attr
.intent
== INTENT_INOUT
3170 || f
->sym
->attr
.volatile_
3171 || f
->sym
->attr
.asynchronous
)
3172 && gfc_has_vector_subscript (a
->expr
))
3175 gfc_error ("Array-section actual argument with vector "
3176 "subscripts at %L is incompatible with INTENT(OUT), "
3177 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3178 "of the dummy argument %qs",
3179 &a
->expr
->where
, f
->sym
->name
);
3183 /* C1232 (R1221) For an actual argument which is an array section or
3184 an assumed-shape array, the dummy argument shall be an assumed-
3185 shape array, if the dummy argument has the VOLATILE attribute. */
3187 if (f
->sym
->attr
.volatile_
3188 && a
->expr
->expr_type
== EXPR_VARIABLE
3189 && a
->expr
->symtree
->n
.sym
->as
3190 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3191 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3194 gfc_error ("Assumed-shape actual argument at %L is "
3195 "incompatible with the non-assumed-shape "
3196 "dummy argument %qs due to VOLATILE attribute",
3197 &a
->expr
->where
,f
->sym
->name
);
3201 /* Find the last array_ref. */
3202 actual_arr_ref
= NULL
;
3204 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3206 if (f
->sym
->attr
.volatile_
3207 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3208 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3211 gfc_error ("Array-section actual argument at %L is "
3212 "incompatible with the non-assumed-shape "
3213 "dummy argument %qs due to VOLATILE attribute",
3214 &a
->expr
->where
, f
->sym
->name
);
3218 /* C1233 (R1221) For an actual argument which is a pointer array, the
3219 dummy argument shall be an assumed-shape or pointer array, if the
3220 dummy argument has the VOLATILE attribute. */
3222 if (f
->sym
->attr
.volatile_
3223 && a
->expr
->expr_type
== EXPR_VARIABLE
3224 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3225 && a
->expr
->symtree
->n
.sym
->as
3227 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3228 || f
->sym
->attr
.pointer
)))
3231 gfc_error ("Pointer-array actual argument at %L requires "
3232 "an assumed-shape or pointer-array dummy "
3233 "argument %qs due to VOLATILE attribute",
3234 &a
->expr
->where
,f
->sym
->name
);
3245 /* Make sure missing actual arguments are optional. */
3247 for (f
= formal
; f
; f
= f
->next
, i
++)
3249 if (new_arg
[i
] != NULL
)
3254 gfc_error ("Missing alternate return spec in subroutine call "
3258 if (!f
->sym
->attr
.optional
)
3261 gfc_error ("Missing actual argument for argument %qs at %L",
3262 f
->sym
->name
, where
);
3267 /* The argument lists are compatible. We now relink a new actual
3268 argument list with null arguments in the right places. The head
3269 of the list remains the head. */
3270 for (i
= 0; i
< n
; i
++)
3271 if (new_arg
[i
] == NULL
)
3272 new_arg
[i
] = gfc_get_actual_arglist ();
3276 std::swap (*new_arg
[0], *actual
);
3277 std::swap (new_arg
[0], new_arg
[na
]);
3280 for (i
= 0; i
< n
- 1; i
++)
3281 new_arg
[i
]->next
= new_arg
[i
+ 1];
3283 new_arg
[i
]->next
= NULL
;
3285 if (*ap
== NULL
&& n
> 0)
3288 /* Note the types of omitted optional arguments. */
3289 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3290 if (a
->expr
== NULL
&& a
->label
== NULL
)
3291 a
->missing_arg_type
= f
->sym
->ts
.type
;
3299 gfc_formal_arglist
*f
;
3300 gfc_actual_arglist
*a
;
3304 /* qsort comparison function for argument pairs, with the following
3306 - p->a->expr == NULL
3307 - p->a->expr->expr_type != EXPR_VARIABLE
3308 - growing p->a->expr->symbol. */
3311 pair_cmp (const void *p1
, const void *p2
)
3313 const gfc_actual_arglist
*a1
, *a2
;
3315 /* *p1 and *p2 are elements of the to-be-sorted array. */
3316 a1
= ((const argpair
*) p1
)->a
;
3317 a2
= ((const argpair
*) p2
)->a
;
3326 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3328 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3332 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3334 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3338 /* Given two expressions from some actual arguments, test whether they
3339 refer to the same expression. The analysis is conservative.
3340 Returning false will produce no warning. */
3343 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3345 const gfc_ref
*r1
, *r2
;
3348 || e1
->expr_type
!= EXPR_VARIABLE
3349 || e2
->expr_type
!= EXPR_VARIABLE
3350 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3353 /* TODO: improve comparison, see expr.c:show_ref(). */
3354 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3356 if (r1
->type
!= r2
->type
)
3361 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3363 /* TODO: At the moment, consider only full arrays;
3364 we could do better. */
3365 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3370 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3378 gfc_internal_error ("compare_actual_expr(): Bad component code");
3387 /* Given formal and actual argument lists that correspond to one
3388 another, check that identical actual arguments aren't not
3389 associated with some incompatible INTENTs. */
3392 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3394 sym_intent f1_intent
, f2_intent
;
3395 gfc_formal_arglist
*f1
;
3396 gfc_actual_arglist
*a1
;
3402 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3404 if (f1
== NULL
&& a1
== NULL
)
3406 if (f1
== NULL
|| a1
== NULL
)
3407 gfc_internal_error ("check_some_aliasing(): List mismatch");
3412 p
= XALLOCAVEC (argpair
, n
);
3414 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3420 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3422 for (i
= 0; i
< n
; i
++)
3425 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3426 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3428 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3429 for (j
= i
+ 1; j
< n
; j
++)
3431 /* Expected order after the sort. */
3432 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3433 gfc_internal_error ("check_some_aliasing(): corrupted data");
3435 /* Are the expression the same? */
3436 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3438 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3439 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3440 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3441 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3443 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3444 "argument %qs and INTENT(%s) argument %qs at %L",
3445 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3446 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3447 &p
[i
].a
->expr
->where
);
3457 /* Given formal and actual argument lists that correspond to one
3458 another, check that they are compatible in the sense that intents
3459 are not mismatched. */
3462 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3464 sym_intent f_intent
;
3466 for (;; f
= f
->next
, a
= a
->next
)
3470 if (f
== NULL
&& a
== NULL
)
3472 if (f
== NULL
|| a
== NULL
)
3473 gfc_internal_error ("check_intents(): List mismatch");
3475 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3476 && a
->expr
->value
.function
.isym
3477 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3478 expr
= a
->expr
->value
.function
.actual
->expr
;
3482 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3485 f_intent
= f
->sym
->attr
.intent
;
3487 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3489 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3490 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3491 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3493 gfc_error ("Procedure argument at %L is local to a PURE "
3494 "procedure and has the POINTER attribute",
3500 /* Fortran 2008, C1283. */
3501 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3503 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3505 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3506 "is passed to an INTENT(%s) argument",
3507 &expr
->where
, gfc_intent_string (f_intent
));
3511 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3512 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3513 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3515 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3516 "is passed to a POINTER dummy argument",
3522 /* F2008, Section 12.5.2.4. */
3523 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3524 && gfc_is_coindexed (expr
))
3526 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3527 "polymorphic dummy argument %qs",
3528 &expr
->where
, f
->sym
->name
);
3537 /* Check how a procedure is used against its interface. If all goes
3538 well, the actual argument list will also end up being properly
3542 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3544 gfc_formal_arglist
*dummy_args
;
3546 /* Warn about calls with an implicit interface. Special case
3547 for calling a ISO_C_BINDING because c_loc and c_funloc
3548 are pseudo-unknown. Additionally, warn about procedures not
3549 explicitly declared at all if requested. */
3550 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3552 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3554 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3558 if (warn_implicit_interface
)
3559 gfc_warning (OPT_Wimplicit_interface
,
3560 "Procedure %qs called with an implicit interface at %L",
3562 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3563 gfc_warning (OPT_Wimplicit_procedure
,
3564 "Procedure %qs called at %L is not explicitly declared",
3568 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3570 gfc_actual_arglist
*a
;
3572 if (sym
->attr
.pointer
)
3574 gfc_error ("The pointer object %qs at %L must have an explicit "
3575 "function interface or be declared as array",
3580 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3582 gfc_error ("The allocatable object %qs at %L must have an explicit "
3583 "function interface or be declared as array",
3588 if (sym
->attr
.allocatable
)
3590 gfc_error ("Allocatable function %qs at %L must have an explicit "
3591 "function interface", sym
->name
, where
);
3595 for (a
= *ap
; a
; a
= a
->next
)
3597 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3598 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3600 gfc_error ("Keyword argument requires explicit interface "
3601 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3605 /* TS 29113, 6.2. */
3606 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3607 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3609 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3610 "interface", a
->expr
->symtree
->n
.sym
->name
,
3615 /* F2008, C1303 and C1304. */
3617 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3618 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3619 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3620 || gfc_expr_attr (a
->expr
).lock_comp
))
3622 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3623 "component at %L requires an explicit interface for "
3624 "procedure %qs", &a
->expr
->where
, sym
->name
);
3629 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3630 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3631 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3632 == ISOFORTRAN_EVENT_TYPE
)
3633 || gfc_expr_attr (a
->expr
).event_comp
))
3635 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3636 "component at %L requires an explicit interface for "
3637 "procedure %qs", &a
->expr
->where
, sym
->name
);
3641 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3642 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3644 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3648 /* TS 29113, C407b. */
3649 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3650 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3652 gfc_error ("Assumed-rank argument requires an explicit interface "
3653 "at %L", &a
->expr
->where
);
3661 dummy_args
= gfc_sym_get_dummy_args (sym
);
3663 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3666 if (!check_intents (dummy_args
, *ap
))
3670 check_some_aliasing (dummy_args
, *ap
);
3676 /* Check how a procedure pointer component is used against its interface.
3677 If all goes well, the actual argument list will also end up being properly
3678 sorted. Completely analogous to gfc_procedure_use. */
3681 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3683 /* Warn about calls with an implicit interface. Special case
3684 for calling a ISO_C_BINDING because c_loc and c_funloc
3685 are pseudo-unknown. */
3686 if (warn_implicit_interface
3687 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3688 && !comp
->attr
.is_iso_c
)
3689 gfc_warning (OPT_Wimplicit_interface
,
3690 "Procedure pointer component %qs called with an implicit "
3691 "interface at %L", comp
->name
, where
);
3693 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3695 gfc_actual_arglist
*a
;
3696 for (a
= *ap
; a
; a
= a
->next
)
3698 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3699 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3701 gfc_error ("Keyword argument requires explicit interface "
3702 "for procedure pointer component %qs at %L",
3703 comp
->name
, &a
->expr
->where
);
3711 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3712 comp
->attr
.elemental
, where
))
3715 check_intents (comp
->ts
.interface
->formal
, *ap
);
3717 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3721 /* Try if an actual argument list matches the formal list of a symbol,
3722 respecting the symbol's attributes like ELEMENTAL. This is used for
3723 GENERIC resolution. */
3726 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3728 gfc_formal_arglist
*dummy_args
;
3731 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3734 dummy_args
= gfc_sym_get_dummy_args (sym
);
3736 r
= !sym
->attr
.elemental
;
3737 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3739 check_intents (dummy_args
, *args
);
3741 check_some_aliasing (dummy_args
, *args
);
3749 /* Given an interface pointer and an actual argument list, search for
3750 a formal argument list that matches the actual. If found, returns
3751 a pointer to the symbol of the correct interface. Returns NULL if
3755 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3756 gfc_actual_arglist
**ap
)
3758 gfc_symbol
*elem_sym
= NULL
;
3759 gfc_symbol
*null_sym
= NULL
;
3760 locus null_expr_loc
;
3761 gfc_actual_arglist
*a
;
3762 bool has_null_arg
= false;
3764 for (a
= *ap
; a
; a
= a
->next
)
3765 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3766 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3768 has_null_arg
= true;
3769 null_expr_loc
= a
->expr
->where
;
3773 for (; intr
; intr
= intr
->next
)
3775 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3777 if (sub_flag
&& intr
->sym
->attr
.function
)
3779 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3782 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3784 if (has_null_arg
&& null_sym
)
3786 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3787 "between specific functions %s and %s",
3788 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3791 else if (has_null_arg
)
3793 null_sym
= intr
->sym
;
3797 /* Satisfy 12.4.4.1 such that an elemental match has lower
3798 weight than a non-elemental match. */
3799 if (intr
->sym
->attr
.elemental
)
3801 elem_sym
= intr
->sym
;
3811 return elem_sym
? elem_sym
: NULL
;
3815 /* Do a brute force recursive search for a symbol. */
3817 static gfc_symtree
*
3818 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3822 if (root
->n
.sym
== sym
)
3827 st
= find_symtree0 (root
->left
, sym
);
3828 if (root
->right
&& ! st
)
3829 st
= find_symtree0 (root
->right
, sym
);
3834 /* Find a symtree for a symbol. */
3837 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3842 /* First try to find it by name. */
3843 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3844 if (st
&& st
->n
.sym
== sym
)
3847 /* If it's been renamed, resort to a brute-force search. */
3848 /* TODO: avoid having to do this search. If the symbol doesn't exist
3849 in the symtree for the current namespace, it should probably be added. */
3850 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3852 st
= find_symtree0 (ns
->sym_root
, sym
);
3856 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3861 /* See if the arglist to an operator-call contains a derived-type argument
3862 with a matching type-bound operator. If so, return the matching specific
3863 procedure defined as operator-target as well as the base-object to use
3864 (which is the found derived-type argument with operator). The generic
3865 name, if any, is transmitted to the final expression via 'gname'. */
3867 static gfc_typebound_proc
*
3868 matching_typebound_op (gfc_expr
** tb_base
,
3869 gfc_actual_arglist
* args
,
3870 gfc_intrinsic_op op
, const char* uop
,
3871 const char ** gname
)
3873 gfc_actual_arglist
* base
;
3875 for (base
= args
; base
; base
= base
->next
)
3876 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3878 gfc_typebound_proc
* tb
;
3879 gfc_symbol
* derived
;
3882 while (base
->expr
->expr_type
== EXPR_OP
3883 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3884 base
->expr
= base
->expr
->value
.op
.op1
;
3886 if (base
->expr
->ts
.type
== BT_CLASS
)
3888 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
3889 || !gfc_expr_attr (base
->expr
).class_ok
)
3891 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3894 derived
= base
->expr
->ts
.u
.derived
;
3896 if (op
== INTRINSIC_USER
)
3898 gfc_symtree
* tb_uop
;
3901 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3910 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3913 /* This means we hit a PRIVATE operator which is use-associated and
3914 should thus not be seen. */
3918 /* Look through the super-type hierarchy for a matching specific
3920 for (; tb
; tb
= tb
->overridden
)
3924 gcc_assert (tb
->is_generic
);
3925 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3928 gfc_actual_arglist
* argcopy
;
3931 gcc_assert (g
->specific
);
3932 if (g
->specific
->error
)
3935 target
= g
->specific
->u
.specific
->n
.sym
;
3937 /* Check if this arglist matches the formal. */
3938 argcopy
= gfc_copy_actual_arglist (args
);
3939 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3940 gfc_free_actual_arglist (argcopy
);
3942 /* Return if we found a match. */
3945 *tb_base
= base
->expr
;
3946 *gname
= g
->specific_st
->name
;
3957 /* For the 'actual arglist' of an operator call and a specific typebound
3958 procedure that has been found the target of a type-bound operator, build the
3959 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3960 type-bound procedures rather than resolving type-bound operators 'directly'
3961 so that we can reuse the existing logic. */
3964 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3965 gfc_expr
* base
, gfc_typebound_proc
* target
,
3968 e
->expr_type
= EXPR_COMPCALL
;
3969 e
->value
.compcall
.tbp
= target
;
3970 e
->value
.compcall
.name
= gname
? gname
: "$op";
3971 e
->value
.compcall
.actual
= actual
;
3972 e
->value
.compcall
.base_object
= base
;
3973 e
->value
.compcall
.ignore_pass
= 1;
3974 e
->value
.compcall
.assign
= 0;
3975 if (e
->ts
.type
== BT_UNKNOWN
3976 && target
->function
)
3978 if (target
->is_generic
)
3979 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3981 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3986 /* This subroutine is called when an expression is being resolved.
3987 The expression node in question is either a user defined operator
3988 or an intrinsic operator with arguments that aren't compatible
3989 with the operator. This subroutine builds an actual argument list
3990 corresponding to the operands, then searches for a compatible
3991 interface. If one is found, the expression node is replaced with
3992 the appropriate function call. We use the 'match' enum to specify
3993 whether a replacement has been made or not, or if an error occurred. */
3996 gfc_extend_expr (gfc_expr
*e
)
3998 gfc_actual_arglist
*actual
;
4004 gfc_typebound_proc
* tbo
;
4009 actual
= gfc_get_actual_arglist ();
4010 actual
->expr
= e
->value
.op
.op1
;
4014 if (e
->value
.op
.op2
!= NULL
)
4016 actual
->next
= gfc_get_actual_arglist ();
4017 actual
->next
->expr
= e
->value
.op
.op2
;
4020 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4022 /* See if we find a matching type-bound operator. */
4023 if (i
== INTRINSIC_USER
)
4024 tbo
= matching_typebound_op (&tb_base
, actual
,
4025 i
, e
->value
.op
.uop
->name
, &gname
);
4029 #define CHECK_OS_COMPARISON(comp) \
4030 case INTRINSIC_##comp: \
4031 case INTRINSIC_##comp##_OS: \
4032 tbo = matching_typebound_op (&tb_base, actual, \
4033 INTRINSIC_##comp, NULL, &gname); \
4035 tbo = matching_typebound_op (&tb_base, actual, \
4036 INTRINSIC_##comp##_OS, NULL, &gname); \
4038 CHECK_OS_COMPARISON(EQ
)
4039 CHECK_OS_COMPARISON(NE
)
4040 CHECK_OS_COMPARISON(GT
)
4041 CHECK_OS_COMPARISON(GE
)
4042 CHECK_OS_COMPARISON(LT
)
4043 CHECK_OS_COMPARISON(LE
)
4044 #undef CHECK_OS_COMPARISON
4047 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4051 /* If there is a matching typebound-operator, replace the expression with
4052 a call to it and succeed. */
4055 gcc_assert (tb_base
);
4056 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4058 if (!gfc_resolve_expr (e
))
4064 if (i
== INTRINSIC_USER
)
4066 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4068 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4072 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4079 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4081 /* Due to the distinction between '==' and '.eq.' and friends, one has
4082 to check if either is defined. */
4085 #define CHECK_OS_COMPARISON(comp) \
4086 case INTRINSIC_##comp: \
4087 case INTRINSIC_##comp##_OS: \
4088 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4090 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4092 CHECK_OS_COMPARISON(EQ
)
4093 CHECK_OS_COMPARISON(NE
)
4094 CHECK_OS_COMPARISON(GT
)
4095 CHECK_OS_COMPARISON(GE
)
4096 CHECK_OS_COMPARISON(LT
)
4097 CHECK_OS_COMPARISON(LE
)
4098 #undef CHECK_OS_COMPARISON
4101 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4109 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4110 found rather than just taking the first one and not checking further. */
4114 /* Don't use gfc_free_actual_arglist(). */
4115 free (actual
->next
);
4120 /* Change the expression node to a function call. */
4121 e
->expr_type
= EXPR_FUNCTION
;
4122 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4123 e
->value
.function
.actual
= actual
;
4124 e
->value
.function
.esym
= NULL
;
4125 e
->value
.function
.isym
= NULL
;
4126 e
->value
.function
.name
= NULL
;
4127 e
->user_operator
= 1;
4129 if (!gfc_resolve_expr (e
))
4136 /* Tries to replace an assignment code node with a subroutine call to the
4137 subroutine associated with the assignment operator. Return true if the node
4138 was replaced. On false, no error is generated. */
4141 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4143 gfc_actual_arglist
*actual
;
4144 gfc_expr
*lhs
, *rhs
, *tb_base
;
4145 gfc_symbol
*sym
= NULL
;
4146 const char *gname
= NULL
;
4147 gfc_typebound_proc
* tbo
;
4152 /* Don't allow an intrinsic assignment to be replaced. */
4153 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4154 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4155 && (lhs
->ts
.type
== rhs
->ts
.type
4156 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4159 actual
= gfc_get_actual_arglist ();
4162 actual
->next
= gfc_get_actual_arglist ();
4163 actual
->next
->expr
= rhs
;
4165 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4167 /* See if we find a matching type-bound assignment. */
4168 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4173 /* Success: Replace the expression with a type-bound call. */
4174 gcc_assert (tb_base
);
4175 c
->expr1
= gfc_get_expr ();
4176 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4177 c
->expr1
->value
.compcall
.assign
= 1;
4178 c
->expr1
->where
= c
->loc
;
4180 c
->op
= EXEC_COMPCALL
;
4184 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4185 for (; ns
; ns
= ns
->parent
)
4187 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4194 /* Success: Replace the assignment with the call. */
4195 c
->op
= EXEC_ASSIGN_CALL
;
4196 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4199 c
->ext
.actual
= actual
;
4203 /* Failure: No assignment procedure found. */
4204 free (actual
->next
);
4210 /* Make sure that the interface just parsed is not already present in
4211 the given interface list. Ambiguity isn't checked yet since module
4212 procedures can be present without interfaces. */
4215 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4219 for (ip
= base
; ip
; ip
= ip
->next
)
4221 if (ip
->sym
== new_sym
)
4223 gfc_error ("Entity %qs at %L is already present in the interface",
4224 new_sym
->name
, &loc
);
4233 /* Add a symbol to the current interface. */
4236 gfc_add_interface (gfc_symbol
*new_sym
)
4238 gfc_interface
**head
, *intr
;
4242 switch (current_interface
.type
)
4244 case INTERFACE_NAMELESS
:
4245 case INTERFACE_ABSTRACT
:
4248 case INTERFACE_INTRINSIC_OP
:
4249 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4250 switch (current_interface
.op
)
4253 case INTRINSIC_EQ_OS
:
4254 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4256 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4257 new_sym
, gfc_current_locus
))
4262 case INTRINSIC_NE_OS
:
4263 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4265 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4266 new_sym
, gfc_current_locus
))
4271 case INTRINSIC_GT_OS
:
4272 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4273 new_sym
, gfc_current_locus
)
4274 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4275 new_sym
, gfc_current_locus
))
4280 case INTRINSIC_GE_OS
:
4281 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4282 new_sym
, gfc_current_locus
)
4283 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4284 new_sym
, gfc_current_locus
))
4289 case INTRINSIC_LT_OS
:
4290 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4291 new_sym
, gfc_current_locus
)
4292 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4293 new_sym
, gfc_current_locus
))
4298 case INTRINSIC_LE_OS
:
4299 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4300 new_sym
, gfc_current_locus
)
4301 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4302 new_sym
, gfc_current_locus
))
4307 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4308 new_sym
, gfc_current_locus
))
4312 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4315 case INTERFACE_GENERIC
:
4316 case INTERFACE_DTIO
:
4317 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4319 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4323 if (!gfc_check_new_interface (sym
->generic
,
4324 new_sym
, gfc_current_locus
))
4328 head
= ¤t_interface
.sym
->generic
;
4331 case INTERFACE_USER_OP
:
4332 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4333 new_sym
, gfc_current_locus
))
4336 head
= ¤t_interface
.uop
->op
;
4340 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4343 intr
= gfc_get_interface ();
4344 intr
->sym
= new_sym
;
4345 intr
->where
= gfc_current_locus
;
4355 gfc_current_interface_head (void)
4357 switch (current_interface
.type
)
4359 case INTERFACE_INTRINSIC_OP
:
4360 return current_interface
.ns
->op
[current_interface
.op
];
4362 case INTERFACE_GENERIC
:
4363 case INTERFACE_DTIO
:
4364 return current_interface
.sym
->generic
;
4366 case INTERFACE_USER_OP
:
4367 return current_interface
.uop
->op
;
4376 gfc_set_current_interface_head (gfc_interface
*i
)
4378 switch (current_interface
.type
)
4380 case INTERFACE_INTRINSIC_OP
:
4381 current_interface
.ns
->op
[current_interface
.op
] = i
;
4384 case INTERFACE_GENERIC
:
4385 case INTERFACE_DTIO
:
4386 current_interface
.sym
->generic
= i
;
4389 case INTERFACE_USER_OP
:
4390 current_interface
.uop
->op
= i
;
4399 /* Gets rid of a formal argument list. We do not free symbols.
4400 Symbols are freed when a namespace is freed. */
4403 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4405 gfc_formal_arglist
*q
;
4415 /* Check that it is ok for the type-bound procedure 'proc' to override the
4416 procedure 'old', cf. F08:4.5.7.3. */
4419 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4422 gfc_symbol
*proc_target
, *old_target
;
4423 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4424 gfc_formal_arglist
*proc_formal
, *old_formal
;
4428 /* This procedure should only be called for non-GENERIC proc. */
4429 gcc_assert (!proc
->n
.tb
->is_generic
);
4431 /* If the overwritten procedure is GENERIC, this is an error. */
4432 if (old
->n
.tb
->is_generic
)
4434 gfc_error ("Can't overwrite GENERIC %qs at %L",
4435 old
->name
, &proc
->n
.tb
->where
);
4439 where
= proc
->n
.tb
->where
;
4440 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4441 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4443 /* Check that overridden binding is not NON_OVERRIDABLE. */
4444 if (old
->n
.tb
->non_overridable
)
4446 gfc_error ("%qs at %L overrides a procedure binding declared"
4447 " NON_OVERRIDABLE", proc
->name
, &where
);
4451 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4452 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4454 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4455 " non-DEFERRED binding", proc
->name
, &where
);
4459 /* If the overridden binding is PURE, the overriding must be, too. */
4460 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4462 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4463 proc
->name
, &where
);
4467 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4468 is not, the overriding must not be either. */
4469 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4471 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4472 " ELEMENTAL", proc
->name
, &where
);
4475 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4477 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4478 " be ELEMENTAL, either", proc
->name
, &where
);
4482 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4484 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4486 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4487 " SUBROUTINE", proc
->name
, &where
);
4491 /* If the overridden binding is a FUNCTION, the overriding must also be a
4492 FUNCTION and have the same characteristics. */
4493 if (old_target
->attr
.function
)
4495 if (!proc_target
->attr
.function
)
4497 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4498 " FUNCTION", proc
->name
, &where
);
4502 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4505 gfc_error ("Result mismatch for the overriding procedure "
4506 "%qs at %L: %s", proc
->name
, &where
, err
);
4511 /* If the overridden binding is PUBLIC, the overriding one must not be
4513 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4514 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4516 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4517 " PRIVATE", proc
->name
, &where
);
4521 /* Compare the formal argument lists of both procedures. This is also abused
4522 to find the position of the passed-object dummy arguments of both
4523 bindings as at least the overridden one might not yet be resolved and we
4524 need those positions in the check below. */
4525 proc_pass_arg
= old_pass_arg
= 0;
4526 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4528 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4531 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4532 old_formal
= gfc_sym_get_dummy_args (old_target
);
4533 for ( ; proc_formal
&& old_formal
;
4534 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4536 if (proc
->n
.tb
->pass_arg
4537 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4538 proc_pass_arg
= argpos
;
4539 if (old
->n
.tb
->pass_arg
4540 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4541 old_pass_arg
= argpos
;
4543 /* Check that the names correspond. */
4544 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4546 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4547 " to match the corresponding argument of the overridden"
4548 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4549 old_formal
->sym
->name
);
4553 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4554 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4555 check_type
, err
, sizeof(err
)))
4557 gfc_error (OPT_Wargument_mismatch
,
4558 "Argument mismatch for the overriding procedure "
4559 "%qs at %L: %s", proc
->name
, &where
, err
);
4565 if (proc_formal
|| old_formal
)
4567 gfc_error ("%qs at %L must have the same number of formal arguments as"
4568 " the overridden procedure", proc
->name
, &where
);
4572 /* If the overridden binding is NOPASS, the overriding one must also be
4574 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4576 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4577 " NOPASS", proc
->name
, &where
);
4581 /* If the overridden binding is PASS(x), the overriding one must also be
4582 PASS and the passed-object dummy arguments must correspond. */
4583 if (!old
->n
.tb
->nopass
)
4585 if (proc
->n
.tb
->nopass
)
4587 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4588 " PASS", proc
->name
, &where
);
4592 if (proc_pass_arg
!= old_pass_arg
)
4594 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4595 " the same position as the passed-object dummy argument of"
4596 " the overridden procedure", proc
->name
, &where
);
4605 /* The following three functions check that the formal arguments
4606 of user defined derived type IO procedures are compliant with
4607 the requirements of the standard. */
4610 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4611 int kind
, int rank
, sym_intent intent
)
4613 if (fsym
->ts
.type
!= type
)
4615 gfc_error ("DTIO dummy argument at %L must be of type %s",
4616 &fsym
->declared_at
, gfc_basic_typename (type
));
4620 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4621 && fsym
->ts
.kind
!= kind
)
4622 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4623 &fsym
->declared_at
, kind
);
4627 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4628 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4629 gfc_error ("DTIO dummy argument at %L be a scalar",
4630 &fsym
->declared_at
);
4632 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4633 gfc_error ("DTIO dummy argument at %L must be an "
4634 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4636 if (fsym
->attr
.intent
!= intent
)
4637 gfc_error ("DTIO dummy argument at %L must have intent %s",
4638 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4644 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4645 bool typebound
, bool formatted
, int code
)
4647 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4648 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4649 gfc_interface
*intr
;
4650 gfc_formal_arglist
*formal
;
4653 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4654 || ((dtio_codes
)code
== DTIO_RUF
);
4662 /* Typebound DTIO binding. */
4663 tb_io_proc
= tb_io_st
->n
.tb
;
4664 if (tb_io_proc
== NULL
)
4667 gcc_assert (tb_io_proc
->is_generic
);
4668 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4670 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4671 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4674 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4678 generic_proc
= tb_io_st
->n
.sym
;
4679 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4682 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4684 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4685 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4686 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4688 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4689 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4691 dtio_sub
= intr
->sym
;
4694 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4696 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4697 "procedure", &intr
->sym
->declared_at
);
4702 if (dtio_sub
== NULL
)
4706 gcc_assert (dtio_sub
);
4707 if (!dtio_sub
->attr
.subroutine
)
4708 gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
4709 dtio_sub
->name
, &dtio_sub
->declared_at
);
4712 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4715 if (arg_num
< (formatted
? 6 : 4))
4717 gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
4718 dtio_sub
->name
, &dtio_sub
->declared_at
);
4722 if (arg_num
> (formatted
? 6 : 4))
4724 gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
4725 dtio_sub
->name
, &dtio_sub
->declared_at
);
4730 /* Now go through the formal arglist. */
4732 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4734 if (!formatted
&& arg_num
== 3)
4740 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4741 "procedure", &dtio_sub
->declared_at
);
4748 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4749 BT_DERIVED
: BT_CLASS
;
4751 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4752 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4758 kind
= gfc_default_integer_kind
;
4760 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4763 case(3): /* IOTYPE */
4764 type
= BT_CHARACTER
;
4765 kind
= gfc_default_character_kind
;
4767 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4770 case(4): /* VLIST */
4772 kind
= gfc_default_integer_kind
;
4774 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4777 case(5): /* IOSTAT */
4779 kind
= gfc_default_integer_kind
;
4780 intent
= INTENT_OUT
;
4781 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4784 case(6): /* IOMSG */
4785 type
= BT_CHARACTER
;
4786 kind
= gfc_default_character_kind
;
4787 intent
= INTENT_INOUT
;
4788 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4795 derived
->attr
.has_dtio_procs
= 1;
4800 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4802 gfc_symtree
*tb_io_st
;
4807 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4810 /* Check typebound DTIO bindings. */
4811 for (code
= 0; code
< 4; code
++)
4813 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4814 || ((dtio_codes
)code
== DTIO_WF
);
4816 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4817 gfc_code2string (dtio_procs
, code
),
4818 true, &derived
->declared_at
);
4819 if (tb_io_st
!= NULL
)
4820 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4823 /* Check generic DTIO interfaces. */
4824 for (code
= 0; code
< 4; code
++)
4826 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4827 || ((dtio_codes
)code
== DTIO_WF
);
4829 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4830 gfc_code2string (dtio_procs
, code
));
4831 if (tb_io_st
!= NULL
)
4832 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4838 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4840 gfc_symtree
*tb_io_st
= NULL
;
4843 if (!derived
|| derived
->attr
.flavor
!= FL_DERIVED
)
4846 /* Try to find a typebound DTIO binding. */
4847 if (formatted
== true)
4850 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4851 gfc_code2string (dtio_procs
,
4854 &derived
->declared_at
);
4856 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4857 gfc_code2string (dtio_procs
,
4860 &derived
->declared_at
);
4865 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4866 gfc_code2string (dtio_procs
,
4869 &derived
->declared_at
);
4871 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4872 gfc_code2string (dtio_procs
,
4875 &derived
->declared_at
);
4882 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4884 gfc_symtree
*tb_io_st
= NULL
;
4885 gfc_symbol
*dtio_sub
= NULL
;
4886 gfc_symbol
*extended
;
4887 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4889 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
4891 if (tb_io_st
!= NULL
)
4893 const char *genname
;
4896 tb_io_proc
= tb_io_st
->n
.tb
;
4897 gcc_assert (tb_io_proc
!= NULL
);
4898 gcc_assert (tb_io_proc
->is_generic
);
4899 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4901 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4902 gcc_assert (!specific_proc
->is_generic
);
4904 /* Go back and make sure that we have the right specific procedure.
4905 Here we most likely have a procedure from the parent type, which
4906 can be overridden in extensions. */
4907 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4908 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4909 true, &tb_io_proc
->where
);
4911 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4913 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4918 /* If there is not a typebound binding, look for a generic
4920 for (extended
= derived
; extended
;
4921 extended
= gfc_get_derived_super_type (extended
))
4923 if (extended
== NULL
|| extended
->ns
== NULL
4924 || extended
->attr
.flavor
== FL_UNKNOWN
)
4927 if (formatted
== true)
4930 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4931 gfc_code2string (dtio_procs
,
4934 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4935 gfc_code2string (dtio_procs
,
4941 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4942 gfc_code2string (dtio_procs
,
4945 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4946 gfc_code2string (dtio_procs
,
4950 if (tb_io_st
!= NULL
4952 && tb_io_st
->n
.sym
->generic
)
4954 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
4955 intr
&& intr
->sym
&& intr
->sym
->formal
;
4958 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
4959 if ((fsym
->ts
.type
== BT_CLASS
4960 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
4961 || (fsym
->ts
.type
== BT_DERIVED
4962 && fsym
->ts
.u
.derived
== extended
))
4964 dtio_sub
= intr
->sym
;
4972 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
4973 gfc_find_derived_vtab (derived
);