1 /* Deal with interfaces.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface
;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface
*intr
)
88 for (; intr
; intr
= next
)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op
)
104 case INTRINSIC_UPLUS
:
107 case INTRINSIC_UMINUS
:
108 op
= INTRINSIC_MINUS
;
118 /* Return the operator depending on the DTIO moded string. Note that
119 these are not operators in the normal sense and so have been placed
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
122 static gfc_intrinsic_op
125 if (strncmp (mode
, "formatted", 9) == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strncmp (mode
, "unformatted", 9) == 0)
128 return INTRINSIC_UNFORMATTED
;
129 return INTRINSIC_NONE
;
133 /* Match a generic specification. Depending on which type of
134 interface is found, the 'name' or 'op' pointers may be set.
135 This subroutine doesn't return MATCH_NO. */
138 gfc_match_generic_spec (interface_type
*type
,
140 gfc_intrinsic_op
*op
)
142 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
146 if (gfc_match (" assignment ( = )") == MATCH_YES
)
148 *type
= INTERFACE_INTRINSIC_OP
;
149 *op
= INTRINSIC_ASSIGN
;
153 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
155 *type
= INTERFACE_INTRINSIC_OP
;
156 *op
= fold_unary_intrinsic (i
);
160 *op
= INTRINSIC_NONE
;
161 if (gfc_match (" operator ( ") == MATCH_YES
)
163 m
= gfc_match_defined_op_name (buffer
, 1);
169 m
= gfc_match_char (')');
175 strcpy (name
, buffer
);
176 *type
= INTERFACE_USER_OP
;
180 if (gfc_match (" read ( %n )", buffer
) == MATCH_YES
)
182 *op
= dtio_op (buffer
);
183 if (*op
== INTRINSIC_FORMATTED
)
185 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RF
));
186 *type
= INTERFACE_DTIO
;
188 if (*op
== INTRINSIC_UNFORMATTED
)
190 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RUF
));
191 *type
= INTERFACE_DTIO
;
193 if (*op
!= INTRINSIC_NONE
)
197 if (gfc_match (" write ( %n )", buffer
) == MATCH_YES
)
199 *op
= dtio_op (buffer
);
200 if (*op
== INTRINSIC_FORMATTED
)
202 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WF
));
203 *type
= INTERFACE_DTIO
;
205 if (*op
== INTRINSIC_UNFORMATTED
)
207 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WUF
));
208 *type
= INTERFACE_DTIO
;
210 if (*op
!= INTRINSIC_NONE
)
214 if (gfc_match_name (buffer
) == MATCH_YES
)
216 strcpy (name
, buffer
);
217 *type
= INTERFACE_GENERIC
;
221 *type
= INTERFACE_NAMELESS
;
225 gfc_error ("Syntax error in generic specification at %C");
230 /* Match one of the five F95 forms of an interface statement. The
231 matcher for the abstract interface follows. */
234 gfc_match_interface (void)
236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
242 m
= gfc_match_space ();
244 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
247 /* If we're not looking at the end of the statement now, or if this
248 is not a nameless interface but we did not see a space, punt. */
249 if (gfc_match_eos () != MATCH_YES
250 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
257 current_interface
.type
= type
;
262 case INTERFACE_GENERIC
:
263 if (gfc_get_symbol (name
, NULL
, &sym
))
266 if (!sym
->attr
.generic
267 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
272 gfc_error ("Dummy procedure %qs at %C cannot have a "
273 "generic interface", sym
->name
);
277 current_interface
.sym
= gfc_new_block
= sym
;
280 case INTERFACE_USER_OP
:
281 current_interface
.uop
= gfc_get_uop (name
);
284 case INTERFACE_INTRINSIC_OP
:
285 current_interface
.op
= op
;
288 case INTERFACE_NAMELESS
:
289 case INTERFACE_ABSTRACT
:
298 /* Match a F2003 abstract interface. */
301 gfc_match_abstract_interface (void)
305 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
308 m
= gfc_match_eos ();
312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
316 current_interface
.type
= INTERFACE_ABSTRACT
;
322 /* Match the different sort of generic-specs that can be present after
323 the END INTERFACE itself. */
326 gfc_match_end_interface (void)
328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
333 m
= gfc_match_space ();
335 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
338 /* If we're not looking at the end of the statement now, or if this
339 is not a nameless interface but we did not see a space, punt. */
340 if (gfc_match_eos () != MATCH_YES
341 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
350 switch (current_interface
.type
)
352 case INTERFACE_NAMELESS
:
353 case INTERFACE_ABSTRACT
:
354 if (type
!= INTERFACE_NAMELESS
)
356 gfc_error ("Expected a nameless interface at %C");
362 case INTERFACE_INTRINSIC_OP
:
363 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
366 if (current_interface
.op
== INTRINSIC_ASSIGN
)
369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
374 s1
= gfc_op2string (current_interface
.op
);
375 s2
= gfc_op2string (op
);
377 /* The following if-statements are used to enforce C1202
379 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
380 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
382 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
383 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
385 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
386 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
388 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
389 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
391 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
392 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
394 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
395 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
399 if (strcmp(s2
, "none") == 0)
400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
404 "but got %qs", s1
, s2
);
411 case INTERFACE_USER_OP
:
412 /* Comparing the symbol node names is OK because only use-associated
413 symbols can be renamed. */
414 if (type
!= current_interface
.type
415 || strcmp (current_interface
.uop
->name
, name
) != 0)
417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
418 current_interface
.uop
->name
);
425 case INTERFACE_GENERIC
:
426 if (type
!= current_interface
.type
427 || strcmp (current_interface
.sym
->name
, name
) != 0)
429 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
430 current_interface
.sym
->name
);
441 /* Return whether the component was defined anonymously. */
444 is_anonymous_component (gfc_component
*cmp
)
446 /* Only UNION and MAP components are anonymous. In the case of a MAP,
447 the derived type symbol is FL_STRUCT and the component name looks like mM*.
448 This is the only case in which the second character of a component name is
450 return cmp
->ts
.type
== BT_UNION
451 || (cmp
->ts
.type
== BT_DERIVED
452 && cmp
->ts
.u
.derived
->attr
.flavor
== FL_STRUCT
453 && cmp
->name
[0] && cmp
->name
[1] && ISUPPER (cmp
->name
[1]));
457 /* Return whether the derived type was defined anonymously. */
460 is_anonymous_dt (gfc_symbol
*derived
)
462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
464 and the type name looks like XX*. This is the only case in which the
465 second character of a type name is uppercase. */
466 return derived
->attr
.flavor
== FL_UNION
467 || (derived
->attr
.flavor
== FL_STRUCT
468 && derived
->name
[0] && derived
->name
[1] && ISUPPER (derived
->name
[1]));
472 /* Compare components according to 4.4.2 of the Fortran standard. */
475 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
476 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
478 /* Compare names, but not for anonymous components such as UNION or MAP. */
479 if (!is_anonymous_component (cmp1
) && !is_anonymous_component (cmp2
)
480 && strcmp (cmp1
->name
, cmp2
->name
) != 0)
483 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
486 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
489 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
492 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
495 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
498 if (cmp1
->ts
.type
== BT_CHARACTER
&& cmp2
->ts
.type
== BT_CHARACTER
)
500 gfc_charlen
*l1
= cmp1
->ts
.u
.cl
;
501 gfc_charlen
*l2
= cmp2
->ts
.u
.cl
;
502 if (l1
&& l2
&& l1
->length
&& l2
->length
503 && l1
->length
->expr_type
== EXPR_CONSTANT
504 && l2
->length
->expr_type
== EXPR_CONSTANT
505 && gfc_dep_compare_expr (l1
->length
, l2
->length
) != 0)
509 /* Make sure that link lists do not put this function into an
510 endless recursive loop! */
511 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
512 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
513 && !gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
))
516 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
517 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
520 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
521 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
528 /* Compare two union types by comparing the components of their maps.
529 Because unions and maps are anonymous their types get special internal
530 names; therefore the usual derived type comparison will fail on them.
532 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
533 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
534 definitions' than 'equivalent structure'. */
537 compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
539 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
540 gfc_symbol
*map1_t
, *map2_t
;
542 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
545 if (un1
->attr
.zero_comp
!= un2
->attr
.zero_comp
)
548 if (un1
->attr
.zero_comp
)
551 map1
= un1
->components
;
552 map2
= un2
->components
;
554 /* In terms of 'equality' here we are worried about types which are
555 declared the same in two places, not types that represent equivalent
556 structures. (This is common because of FORTRAN's weird scoping rules.)
557 Though two unions with their maps in different orders could be equivalent,
558 we will say they are not equal for the purposes of this test; therefore
559 we compare the maps sequentially. */
562 map1_t
= map1
->ts
.u
.derived
;
563 map2_t
= map2
->ts
.u
.derived
;
565 cmp1
= map1_t
->components
;
566 cmp2
= map2_t
->components
;
568 /* Protect against null components. */
569 if (map1_t
->attr
.zero_comp
!= map2_t
->attr
.zero_comp
)
572 if (map1_t
->attr
.zero_comp
)
577 /* No two fields will ever point to the same map type unless they are
578 the same component, because one map field is created with its type
579 declaration. Therefore don't worry about recursion here. */
580 /* TODO: worry about recursion into parent types of the unions? */
581 if (!compare_components (cmp1
, cmp2
, map1_t
, map2_t
))
587 if (cmp1
== NULL
&& cmp2
== NULL
)
589 if (cmp1
== NULL
|| cmp2
== NULL
)
596 if (map1
== NULL
&& map2
== NULL
)
598 if (map1
== NULL
|| map2
== NULL
)
607 /* Compare two derived types using the criteria in 4.4.2 of the standard,
608 recursing through gfc_compare_types for the components. */
611 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
613 gfc_component
*cmp1
, *cmp2
;
615 if (derived1
== derived2
)
618 if (!derived1
|| !derived2
)
619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
621 /* Compare UNION types specially. */
622 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
623 return compare_union_types (derived1
, derived2
);
625 /* Special case for comparing derived types across namespaces. If the
626 true names and module names are the same and the module name is
627 nonnull, then they are equal. */
628 if (strcmp (derived1
->name
, derived2
->name
) == 0
629 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
630 && strcmp (derived1
->module
, derived2
->module
) == 0)
633 /* Compare type via the rules of the standard. Both types must have
634 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
635 because they can be anonymous; therefore two structures with different
636 names may be equal. */
638 /* Compare names, but not for anonymous types such as UNION or MAP. */
639 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
640 && strcmp (derived1
->name
, derived2
->name
) != 0)
643 if (derived1
->component_access
== ACCESS_PRIVATE
644 || derived2
->component_access
== ACCESS_PRIVATE
)
647 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
648 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
)
649 && !(derived1
->attr
.pdt_type
&& derived2
->attr
.pdt_type
))
652 /* Protect against null components. */
653 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
656 if (derived1
->attr
.zero_comp
)
659 cmp1
= derived1
->components
;
660 cmp2
= derived2
->components
;
662 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
663 simple test can speed things up. Otherwise, lots of things have to
667 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
673 if (cmp1
== NULL
&& cmp2
== NULL
)
675 if (cmp1
== NULL
|| cmp2
== NULL
)
683 /* Compare two typespecs, recursively if necessary. */
686 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
688 /* See if one of the typespecs is a BT_VOID, which is what is being used
689 to allow the funcs like c_f_pointer to accept any pointer type.
690 TODO: Possibly should narrow this to just the one typespec coming in
691 that is for the formal arg, but oh well. */
692 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
695 /* The _data component is not always present, therefore check for its
696 presence before assuming, that its derived->attr is available.
697 When the _data component is not present, then nevertheless the
698 unlimited_polymorphic flag may be set in the derived type's attr. */
699 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
700 && ((ts1
->u
.derived
->attr
.is_class
701 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
702 .unlimited_polymorphic
)
703 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
707 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
708 && ts2
->u
.derived
->components
709 && ((ts2
->u
.derived
->attr
.is_class
710 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
711 .unlimited_polymorphic
)
712 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
713 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
716 if (ts1
->type
!= ts2
->type
717 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
718 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
721 if (ts1
->type
== BT_UNION
)
722 return compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
724 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
725 return (ts1
->kind
== ts2
->kind
);
727 /* Compare derived types. */
728 return gfc_type_compatible (ts1
, ts2
);
733 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
735 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
738 /* TYPE and CLASS of the same declared type are type compatible,
739 but have different characteristics. */
740 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
741 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
744 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
749 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
751 gfc_array_spec
*as1
, *as2
;
754 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
757 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
758 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
760 r1
= as1
? as1
->rank
: 0;
761 r2
= as2
? as2
->rank
: 0;
763 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
764 return false; /* Ranks differ. */
770 /* Given two symbols that are formal arguments, compare their ranks
771 and types. Returns true if they have the same rank and type,
775 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
777 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
781 /* Given two symbols that are formal arguments, compare their types
782 and rank and their formal interfaces if they are both dummy
783 procedures. Returns true if the same, false if different. */
786 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
788 if (s1
== NULL
|| s2
== NULL
)
794 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
795 return compare_type_rank (s1
, s2
);
797 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
800 /* At this point, both symbols are procedures. It can happen that
801 external procedures are compared, where one is identified by usage
802 to be a function or subroutine but the other is not. Check TKR
803 nonetheless for these cases. */
804 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
805 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
807 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
808 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
810 /* Now the type of procedure has been identified. */
811 if (s1
->attr
.function
!= s2
->attr
.function
812 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
815 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
818 /* Originally, gfortran recursed here to check the interfaces of passed
819 procedures. This is explicitly not required by the standard. */
824 /* Given a formal argument list and a keyword name, search the list
825 for that keyword. Returns the correct symbol node if found, NULL
829 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
831 for (; f
; f
= f
->next
)
832 if (strcmp (f
->sym
->name
, name
) == 0)
839 /******** Interface checking subroutines **********/
842 /* Given an operator interface and the operator, make sure that all
843 interfaces for that operator are legal. */
846 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
849 gfc_formal_arglist
*formal
;
852 int args
, r1
, r2
, k1
, k2
;
857 t1
= t2
= BT_UNKNOWN
;
858 i1
= i2
= INTENT_UNKNOWN
;
862 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
864 gfc_symbol
*fsym
= formal
->sym
;
867 gfc_error ("Alternate return cannot appear in operator "
868 "interface at %L", &sym
->declared_at
);
874 i1
= fsym
->attr
.intent
;
875 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
881 i2
= fsym
->attr
.intent
;
882 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
888 /* Only +, - and .not. can be unary operators.
889 .not. cannot be a binary operator. */
890 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
891 && op
!= INTRINSIC_MINUS
892 && op
!= INTRINSIC_NOT
)
893 || (args
== 2 && op
== INTRINSIC_NOT
))
895 if (op
== INTRINSIC_ASSIGN
)
896 gfc_error ("Assignment operator interface at %L must have "
897 "two arguments", &sym
->declared_at
);
899 gfc_error ("Operator interface at %L has the wrong number of arguments",
904 /* Check that intrinsics are mapped to functions, except
905 INTRINSIC_ASSIGN which should map to a subroutine. */
906 if (op
== INTRINSIC_ASSIGN
)
908 gfc_formal_arglist
*dummy_args
;
910 if (!sym
->attr
.subroutine
)
912 gfc_error ("Assignment operator interface at %L must be "
913 "a SUBROUTINE", &sym
->declared_at
);
917 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
918 - First argument an array with different rank than second,
919 - First argument is a scalar and second an array,
920 - Types and kinds do not conform, or
921 - First argument is of derived type. */
922 dummy_args
= gfc_sym_get_dummy_args (sym
);
923 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
924 && dummy_args
->sym
->ts
.type
!= BT_CLASS
925 && (r2
== 0 || r1
== r2
)
926 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
927 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
928 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
930 gfc_error ("Assignment operator interface at %L must not redefine "
931 "an INTRINSIC type assignment", &sym
->declared_at
);
937 if (!sym
->attr
.function
)
939 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
945 /* Check intents on operator interfaces. */
946 if (op
== INTRINSIC_ASSIGN
)
948 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
950 gfc_error ("First argument of defined assignment at %L must be "
951 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
957 gfc_error ("Second argument of defined assignment at %L must be "
958 "INTENT(IN)", &sym
->declared_at
);
966 gfc_error ("First argument of operator interface at %L must be "
967 "INTENT(IN)", &sym
->declared_at
);
971 if (args
== 2 && i2
!= INTENT_IN
)
973 gfc_error ("Second argument of operator interface at %L must be "
974 "INTENT(IN)", &sym
->declared_at
);
979 /* From now on, all we have to do is check that the operator definition
980 doesn't conflict with an intrinsic operator. The rules for this
981 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
982 as well as 12.3.2.1.1 of Fortran 2003:
984 "If the operator is an intrinsic-operator (R310), the number of
985 function arguments shall be consistent with the intrinsic uses of
986 that operator, and the types, kind type parameters, or ranks of the
987 dummy arguments shall differ from those required for the intrinsic
988 operation (7.1.2)." */
990 #define IS_NUMERIC_TYPE(t) \
991 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
993 /* Unary ops are easy, do them first. */
994 if (op
== INTRINSIC_NOT
)
996 if (t1
== BT_LOGICAL
)
1002 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1004 if (IS_NUMERIC_TYPE (t1
))
1010 /* Character intrinsic operators have same character kind, thus
1011 operator definitions with operands of different character kinds
1013 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1016 /* Intrinsic operators always perform on arguments of same rank,
1017 so different ranks is also always safe. (rank == 0) is an exception
1018 to that, because all intrinsic operators are elemental. */
1019 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1025 case INTRINSIC_EQ_OS
:
1027 case INTRINSIC_NE_OS
:
1028 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1032 case INTRINSIC_PLUS
:
1033 case INTRINSIC_MINUS
:
1034 case INTRINSIC_TIMES
:
1035 case INTRINSIC_DIVIDE
:
1036 case INTRINSIC_POWER
:
1037 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1042 case INTRINSIC_GT_OS
:
1044 case INTRINSIC_GE_OS
:
1046 case INTRINSIC_LT_OS
:
1048 case INTRINSIC_LE_OS
:
1049 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1051 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1052 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1056 case INTRINSIC_CONCAT
:
1057 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1064 case INTRINSIC_NEQV
:
1065 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1075 #undef IS_NUMERIC_TYPE
1078 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1084 /* Given a pair of formal argument lists, we see if the two lists can
1085 be distinguished by counting the number of nonoptional arguments of
1086 a given type/rank in f1 and seeing if there are less then that
1087 number of those arguments in f2 (including optional arguments).
1088 Since this test is asymmetric, it has to be called twice to make it
1089 symmetric. Returns nonzero if the argument lists are incompatible
1090 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1091 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1094 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1095 const char *p1
, const char *p2
)
1097 int ac1
, ac2
, i
, j
, k
, n1
;
1098 gfc_formal_arglist
*f
;
1111 for (f
= f1
; f
; f
= f
->next
)
1114 /* Build an array of integers that gives the same integer to
1115 arguments of the same type/rank. */
1116 arg
= XCNEWVEC (arginfo
, n1
);
1119 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1122 arg
[i
].sym
= f
->sym
;
1127 for (i
= 0; i
< n1
; i
++)
1129 if (arg
[i
].flag
!= -1)
1132 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1133 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1134 continue; /* Skip OPTIONAL and PASS arguments. */
1138 /* Find other non-optional, non-pass arguments of the same type/rank. */
1139 for (j
= i
+ 1; j
< n1
; j
++)
1140 if ((arg
[j
].sym
== NULL
1141 || !(arg
[j
].sym
->attr
.optional
1142 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1143 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1144 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1150 /* Now loop over each distinct type found in f1. */
1154 for (i
= 0; i
< n1
; i
++)
1156 if (arg
[i
].flag
!= k
)
1160 for (j
= i
+ 1; j
< n1
; j
++)
1161 if (arg
[j
].flag
== k
)
1164 /* Count the number of non-pass arguments in f2 with that type,
1165 including those that are optional. */
1168 for (f
= f2
; f
; f
= f
->next
)
1169 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1170 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1171 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1189 /* Perform the correspondence test in rule (3) of F08:C1215.
1190 Returns zero if no argument is found that satisfies this rule,
1191 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1194 This test is also not symmetric in f1 and f2 and must be called
1195 twice. This test finds problems caused by sorting the actual
1196 argument list with keywords. For example:
1200 INTEGER :: A ; REAL :: B
1204 INTEGER :: A ; REAL :: B
1208 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1211 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1212 const char *p1
, const char *p2
)
1214 gfc_formal_arglist
*f2_save
, *g
;
1221 if (f1
->sym
->attr
.optional
)
1224 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1226 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1229 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1230 || compare_type_rank (f2
->sym
, f1
->sym
))
1231 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1232 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1233 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1236 /* Now search for a disambiguating keyword argument starting at
1237 the current non-match. */
1238 for (g
= f1
; g
; g
= g
->next
)
1240 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1243 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1244 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1245 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1246 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1247 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1263 symbol_rank (gfc_symbol
*sym
)
1266 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1267 return as
? as
->rank
: 0;
1271 /* Check if the characteristics of two dummy arguments match,
1275 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1276 bool type_must_agree
, char *errmsg
,
1279 if (s1
== NULL
|| s2
== NULL
)
1280 return s1
== s2
? true : false;
1282 /* Check type and rank. */
1283 if (type_must_agree
)
1285 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1287 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1288 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1291 if (!compare_rank (s1
, s2
))
1293 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1294 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1300 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1302 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1307 /* Check OPTIONAL attribute. */
1308 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1310 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1315 /* Check ALLOCATABLE attribute. */
1316 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1318 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1323 /* Check POINTER attribute. */
1324 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1326 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1331 /* Check TARGET attribute. */
1332 if (s1
->attr
.target
!= s2
->attr
.target
)
1334 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1339 /* Check ASYNCHRONOUS attribute. */
1340 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1342 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1347 /* Check CONTIGUOUS attribute. */
1348 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1350 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1355 /* Check VALUE attribute. */
1356 if (s1
->attr
.value
!= s2
->attr
.value
)
1358 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1363 /* Check VOLATILE attribute. */
1364 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1366 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1371 /* Check interface of dummy procedures. */
1372 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1375 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1378 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1379 "'%s': %s", s1
->name
, err
);
1384 /* Check string length. */
1385 if (s1
->ts
.type
== BT_CHARACTER
1386 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1387 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1389 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1390 s2
->ts
.u
.cl
->length
);
1396 snprintf (errmsg
, err_len
, "Character length mismatch "
1397 "in argument '%s'", s1
->name
);
1401 /* FIXME: Implement a warning for this case.
1402 gfc_warning (0, "Possible character length mismatch in argument %qs",
1410 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1411 "%i of gfc_dep_compare_expr", compval
);
1416 /* Check array shape. */
1417 if (s1
->as
&& s2
->as
)
1420 gfc_expr
*shape1
, *shape2
;
1422 if (s1
->as
->type
!= s2
->as
->type
)
1424 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1429 if (s1
->as
->corank
!= s2
->as
->corank
)
1431 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1432 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1436 if (s1
->as
->type
== AS_EXPLICIT
)
1437 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1439 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1440 gfc_copy_expr (s1
->as
->lower
[i
]));
1441 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1442 gfc_copy_expr (s2
->as
->lower
[i
]));
1443 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1444 gfc_free_expr (shape1
);
1445 gfc_free_expr (shape2
);
1451 if (i
< s1
->as
->rank
)
1452 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1453 " argument '%s'", i
+ 1, s1
->name
);
1455 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1456 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1460 /* FIXME: Implement a warning for this case.
1461 gfc_warning (0, "Possible shape mismatch in argument %qs",
1469 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1470 "result %i of gfc_dep_compare_expr",
1481 /* Check if the characteristics of two function results match,
1485 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1486 char *errmsg
, int err_len
)
1488 gfc_symbol
*r1
, *r2
;
1490 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1491 r1
= s1
->ts
.interface
->result
;
1493 r1
= s1
->result
? s1
->result
: s1
;
1495 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1496 r2
= s2
->ts
.interface
->result
;
1498 r2
= s2
->result
? s2
->result
: s2
;
1500 if (r1
->ts
.type
== BT_UNKNOWN
)
1503 /* Check type and rank. */
1504 if (!compare_type (r1
, r2
))
1506 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1507 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1510 if (!compare_rank (r1
, r2
))
1512 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1513 symbol_rank (r1
), symbol_rank (r2
));
1517 /* Check ALLOCATABLE attribute. */
1518 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1520 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1525 /* Check POINTER attribute. */
1526 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1528 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1533 /* Check CONTIGUOUS attribute. */
1534 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1536 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1541 /* Check PROCEDURE POINTER attribute. */
1542 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1544 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1549 /* Check string length. */
1550 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1552 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1554 snprintf (errmsg
, err_len
, "Character length mismatch "
1555 "in function result");
1559 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1561 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1562 r2
->ts
.u
.cl
->length
);
1568 snprintf (errmsg
, err_len
, "Character length mismatch "
1569 "in function result");
1573 /* FIXME: Implement a warning for this case.
1574 snprintf (errmsg, err_len, "Possible character length mismatch "
1575 "in function result");*/
1582 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1583 "result %i of gfc_dep_compare_expr", compval
);
1589 /* Check array shape. */
1590 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1593 gfc_expr
*shape1
, *shape2
;
1595 if (r1
->as
->type
!= r2
->as
->type
)
1597 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1601 if (r1
->as
->type
== AS_EXPLICIT
)
1602 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1604 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1605 gfc_copy_expr (r1
->as
->lower
[i
]));
1606 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1607 gfc_copy_expr (r2
->as
->lower
[i
]));
1608 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1609 gfc_free_expr (shape1
);
1610 gfc_free_expr (shape2
);
1616 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1617 "function result", i
+ 1);
1621 /* FIXME: Implement a warning for this case.
1622 gfc_warning (0, "Possible shape mismatch in return value");*/
1629 gfc_internal_error ("check_result_characteristics (2): "
1630 "Unexpected result %i of "
1631 "gfc_dep_compare_expr", compval
);
1641 /* 'Compare' two formal interfaces associated with a pair of symbols.
1642 We return true if there exists an actual argument list that
1643 would be ambiguous between the two interfaces, zero otherwise.
1644 'strict_flag' specifies whether all the characteristics are
1645 required to match, which is not the case for ambiguity checks.
1646 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1649 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1650 int generic_flag
, int strict_flag
,
1651 char *errmsg
, int err_len
,
1652 const char *p1
, const char *p2
)
1654 gfc_formal_arglist
*f1
, *f2
;
1656 gcc_assert (name2
!= NULL
);
1658 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1659 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1660 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1663 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1667 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1670 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1674 /* Do strict checks on all characteristics
1675 (for dummy procedures and procedure pointer assignments). */
1676 if (!generic_flag
&& strict_flag
)
1678 if (s1
->attr
.function
&& s2
->attr
.function
)
1680 /* If both are functions, check result characteristics. */
1681 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1682 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1686 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1688 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1691 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1693 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1698 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1699 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1702 f1
= gfc_sym_get_dummy_args (s1
);
1703 f2
= gfc_sym_get_dummy_args (s2
);
1705 /* Special case: No arguments. */
1706 if (f1
== NULL
&& f2
== NULL
)
1711 if (count_types_test (f1
, f2
, p1
, p2
)
1712 || count_types_test (f2
, f1
, p2
, p1
))
1715 /* Special case: alternate returns. If both f1->sym and f2->sym are
1716 NULL, then the leading formal arguments are alternate returns.
1717 The previous conditional should catch argument lists with
1718 different number of argument. */
1719 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1722 if (generic_correspondence (f1
, f2
, p1
, p2
)
1723 || generic_correspondence (f2
, f1
, p2
, p1
))
1727 /* Perform the abbreviated correspondence test for operators (the
1728 arguments cannot be optional and are always ordered correctly).
1729 This is also done when comparing interfaces for dummy procedures and in
1730 procedure pointer assignments. */
1732 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1734 /* Check existence. */
1735 if (f1
== NULL
|| f2
== NULL
)
1738 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1739 "arguments", name2
);
1745 /* Check all characteristics. */
1746 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1752 /* Only check type and rank. */
1753 if (!compare_type (f2
->sym
, f1
->sym
))
1756 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1757 "(%s/%s)", f1
->sym
->name
,
1758 gfc_typename (&f1
->sym
->ts
),
1759 gfc_typename (&f2
->sym
->ts
));
1762 if (!compare_rank (f2
->sym
, f1
->sym
))
1765 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1766 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1767 symbol_rank (f2
->sym
));
1777 /* Given a pointer to an interface pointer, remove duplicate
1778 interfaces and make sure that all symbols are either functions
1779 or subroutines, and all of the same kind. Returns true if
1780 something goes wrong. */
1783 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1785 gfc_interface
*psave
, *q
, *qlast
;
1788 for (; p
; p
= p
->next
)
1790 /* Make sure all symbols in the interface have been defined as
1791 functions or subroutines. */
1792 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1793 || !p
->sym
->attr
.if_source
)
1794 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1796 if (p
->sym
->attr
.external
)
1797 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1798 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1800 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1801 "subroutine", p
->sym
->name
, interface_name
,
1802 &p
->sym
->declared_at
);
1806 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1807 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1808 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1809 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1811 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1812 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1813 " or all FUNCTIONs", interface_name
,
1814 &p
->sym
->declared_at
);
1815 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1816 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1817 "generic name is also the name of a derived type",
1818 interface_name
, &p
->sym
->declared_at
);
1822 /* F2003, C1207. F2008, C1207. */
1823 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1824 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1825 "%qs in %s at %L", p
->sym
->name
,
1826 interface_name
, &p
->sym
->declared_at
))
1831 /* Remove duplicate interfaces in this interface list. */
1832 for (; p
; p
= p
->next
)
1836 for (q
= p
->next
; q
;)
1838 if (p
->sym
!= q
->sym
)
1845 /* Duplicate interface. */
1846 qlast
->next
= q
->next
;
1857 /* Check lists of interfaces to make sure that no two interfaces are
1858 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1861 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1862 int generic_flag
, const char *interface_name
,
1866 for (; p
; p
= p
->next
)
1867 for (q
= q0
; q
; q
= q
->next
)
1869 if (p
->sym
== q
->sym
)
1870 continue; /* Duplicates OK here. */
1872 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1875 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1876 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1877 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1878 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1881 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1882 "and %qs at %L", interface_name
,
1883 q
->sym
->name
, &q
->sym
->declared_at
,
1884 p
->sym
->name
, &p
->sym
->declared_at
);
1885 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1886 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1887 "and %qs at %L", interface_name
,
1888 q
->sym
->name
, &q
->sym
->declared_at
,
1889 p
->sym
->name
, &p
->sym
->declared_at
);
1891 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1892 "interfaces at %L", interface_name
, &p
->where
);
1900 /* Check the generic and operator interfaces of symbols to make sure
1901 that none of the interfaces conflict. The check has to be done
1902 after all of the symbols are actually loaded. */
1905 check_sym_interfaces (gfc_symbol
*sym
)
1907 char interface_name
[100];
1910 if (sym
->ns
!= gfc_current_ns
)
1913 if (sym
->generic
!= NULL
)
1915 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1916 if (check_interface0 (sym
->generic
, interface_name
))
1919 for (p
= sym
->generic
; p
; p
= p
->next
)
1921 if (p
->sym
->attr
.mod_proc
1922 && !p
->sym
->attr
.module_procedure
1923 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1924 || p
->sym
->attr
.procedure
))
1926 gfc_error ("%qs at %L is not a module procedure",
1927 p
->sym
->name
, &p
->where
);
1932 /* Originally, this test was applied to host interfaces too;
1933 this is incorrect since host associated symbols, from any
1934 source, cannot be ambiguous with local symbols. */
1935 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1936 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1942 check_uop_interfaces (gfc_user_op
*uop
)
1944 char interface_name
[100];
1948 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1949 if (check_interface0 (uop
->op
, interface_name
))
1952 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1954 uop2
= gfc_find_uop (uop
->name
, ns
);
1958 check_interface1 (uop
->op
, uop2
->op
, 0,
1959 interface_name
, true);
1963 /* Given an intrinsic op, return an equivalent op if one exists,
1964 or INTRINSIC_NONE otherwise. */
1967 gfc_equivalent_op (gfc_intrinsic_op op
)
1972 return INTRINSIC_EQ_OS
;
1974 case INTRINSIC_EQ_OS
:
1975 return INTRINSIC_EQ
;
1978 return INTRINSIC_NE_OS
;
1980 case INTRINSIC_NE_OS
:
1981 return INTRINSIC_NE
;
1984 return INTRINSIC_GT_OS
;
1986 case INTRINSIC_GT_OS
:
1987 return INTRINSIC_GT
;
1990 return INTRINSIC_GE_OS
;
1992 case INTRINSIC_GE_OS
:
1993 return INTRINSIC_GE
;
1996 return INTRINSIC_LT_OS
;
1998 case INTRINSIC_LT_OS
:
1999 return INTRINSIC_LT
;
2002 return INTRINSIC_LE_OS
;
2004 case INTRINSIC_LE_OS
:
2005 return INTRINSIC_LE
;
2008 return INTRINSIC_NONE
;
2012 /* For the namespace, check generic, user operator and intrinsic
2013 operator interfaces for consistency and to remove duplicate
2014 interfaces. We traverse the whole namespace, counting on the fact
2015 that most symbols will not have generic or operator interfaces. */
2018 gfc_check_interfaces (gfc_namespace
*ns
)
2020 gfc_namespace
*old_ns
, *ns2
;
2021 char interface_name
[100];
2024 old_ns
= gfc_current_ns
;
2025 gfc_current_ns
= ns
;
2027 gfc_traverse_ns (ns
, check_sym_interfaces
);
2029 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2031 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2033 if (i
== INTRINSIC_USER
)
2036 if (i
== INTRINSIC_ASSIGN
)
2037 strcpy (interface_name
, "intrinsic assignment operator");
2039 sprintf (interface_name
, "intrinsic '%s' operator",
2040 gfc_op2string ((gfc_intrinsic_op
) i
));
2042 if (check_interface0 (ns
->op
[i
], interface_name
))
2046 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2049 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2051 gfc_intrinsic_op other_op
;
2053 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2054 interface_name
, true))
2057 /* i should be gfc_intrinsic_op, but has to be int with this cast
2058 here for stupid C++ compatibility rules. */
2059 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2060 if (other_op
!= INTRINSIC_NONE
2061 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2062 0, interface_name
, true))
2068 gfc_current_ns
= old_ns
;
2072 /* Given a symbol of a formal argument list and an expression, if the
2073 formal argument is allocatable, check that the actual argument is
2074 allocatable. Returns true if compatible, zero if not compatible. */
2077 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2079 if (formal
->attr
.allocatable
2080 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2082 symbol_attribute attr
= gfc_expr_attr (actual
);
2083 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2085 else if (!attr
.allocatable
)
2093 /* Given a symbol of a formal argument list and an expression, if the
2094 formal argument is a pointer, see if the actual argument is a
2095 pointer. Returns nonzero if compatible, zero if not compatible. */
2098 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2100 symbol_attribute attr
;
2102 if (formal
->attr
.pointer
2103 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2104 && CLASS_DATA (formal
)->attr
.class_pointer
))
2106 attr
= gfc_expr_attr (actual
);
2108 /* Fortran 2008 allows non-pointer actual arguments. */
2109 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2120 /* Emit clear error messages for rank mismatch. */
2123 argument_rank_mismatch (const char *name
, locus
*where
,
2124 int rank1
, int rank2
)
2127 /* TS 29113, C407b. */
2129 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2130 " %qs has assumed-rank", where
, name
);
2131 else if (rank1
== 0)
2132 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2133 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2134 else if (rank2
== 0)
2135 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2136 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2138 gfc_error_opt (OPT_Wargument_mismatch
, "Rank mismatch in argument %qs "
2139 "at %L (rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2143 /* Given a symbol of a formal argument list and an expression, see if
2144 the two are compatible as arguments. Returns true if
2145 compatible, false if not compatible. */
2148 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2149 int ranks_must_agree
, int is_elemental
, locus
*where
)
2152 bool rank_check
, is_pointer
;
2156 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2157 procs c_f_pointer or c_f_procpointer, and we need to accept most
2158 pointers the user could give us. This should allow that. */
2159 if (formal
->ts
.type
== BT_VOID
)
2162 if (formal
->ts
.type
== BT_DERIVED
2163 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2164 && actual
->ts
.type
== BT_DERIVED
2165 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2168 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2169 /* Make sure the vtab symbol is present when
2170 the module variables are generated. */
2171 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2173 if (actual
->ts
.type
== BT_PROCEDURE
)
2175 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2177 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2180 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2184 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2185 sizeof(err
), NULL
, NULL
))
2188 gfc_error_opt (OPT_Wargument_mismatch
,
2189 "Interface mismatch in dummy procedure %qs at %L:"
2190 " %s", formal
->name
, &actual
->where
, err
);
2194 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2196 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2197 &act_sym
->declared_at
);
2198 if (act_sym
->ts
.type
== BT_UNKNOWN
2199 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2202 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2203 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2204 &act_sym
->declared_at
);
2209 ppc
= gfc_get_proc_ptr_comp (actual
);
2210 if (ppc
&& ppc
->ts
.interface
)
2212 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2213 err
, sizeof(err
), NULL
, NULL
))
2216 gfc_error_opt (OPT_Wargument_mismatch
,
2217 "Interface mismatch in dummy procedure %qs at %L:"
2218 " %s", formal
->name
, &actual
->where
, err
);
2224 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2225 && !gfc_is_simply_contiguous (actual
, true, false))
2228 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2229 "must be simply contiguous", formal
->name
, &actual
->where
);
2233 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2234 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2237 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2238 && actual
->ts
.type
!= BT_HOLLERITH
2239 && formal
->ts
.type
!= BT_ASSUMED
2240 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2241 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2242 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2243 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2244 CLASS_DATA (actual
)->ts
.u
.derived
)))
2247 gfc_error_opt (OPT_Wargument_mismatch
,
2248 "Type mismatch in argument %qs at %L; passed %s to %s",
2249 formal
->name
, where
, gfc_typename (&actual
->ts
),
2250 gfc_typename (&formal
->ts
));
2254 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2257 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2258 "argument %qs is of assumed type", &actual
->where
,
2263 /* F2008, 12.5.2.5; IR F08/0073. */
2264 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2265 && actual
->expr_type
!= EXPR_NULL
2266 && ((CLASS_DATA (formal
)->attr
.class_pointer
2267 && formal
->attr
.intent
!= INTENT_IN
)
2268 || CLASS_DATA (formal
)->attr
.allocatable
))
2270 if (actual
->ts
.type
!= BT_CLASS
)
2273 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2274 formal
->name
, &actual
->where
);
2278 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2279 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2280 CLASS_DATA (formal
)->ts
.u
.derived
))
2283 gfc_error ("Actual argument to %qs at %L must have the same "
2284 "declared type", formal
->name
, &actual
->where
);
2289 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2290 is necessary also for F03, so retain error for both.
2291 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2292 compatible, no attempt has been made to channel to this one. */
2293 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2294 && (CLASS_DATA (formal
)->attr
.allocatable
2295 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2298 gfc_error ("Actual argument to %qs at %L must be unlimited "
2299 "polymorphic since the formal argument is a "
2300 "pointer or allocatable unlimited polymorphic "
2301 "entity [F2008: 12.5.2.5]", formal
->name
,
2306 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2309 gfc_error ("Actual argument to %qs at %L must be a coarray",
2310 formal
->name
, &actual
->where
);
2314 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2316 gfc_ref
*last
= NULL
;
2318 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2319 if (ref
->type
== REF_COMPONENT
)
2322 /* F2008, 12.5.2.6. */
2323 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2325 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2328 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2329 formal
->name
, &actual
->where
, formal
->as
->corank
,
2330 last
? last
->u
.c
.component
->as
->corank
2331 : actual
->symtree
->n
.sym
->as
->corank
);
2336 if (formal
->attr
.codimension
)
2338 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2339 /* F2015, 12.5.2.8. */
2340 if (formal
->attr
.dimension
2341 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2342 && actual_attr
.dimension
2343 && !gfc_is_simply_contiguous (actual
, true, true))
2346 gfc_error ("Actual argument to %qs at %L must be simply "
2347 "contiguous or an element of such an array",
2348 formal
->name
, &actual
->where
);
2352 /* F2008, C1303 and C1304. */
2353 if (formal
->attr
.intent
!= INTENT_INOUT
2354 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2355 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2356 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2357 || formal
->attr
.lock_comp
))
2361 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2362 "which is LOCK_TYPE or has a LOCK_TYPE component",
2363 formal
->name
, &actual
->where
);
2367 /* TS18508, C702/C703. */
2368 if (formal
->attr
.intent
!= INTENT_INOUT
2369 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2370 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2371 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2372 || formal
->attr
.event_comp
))
2376 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2377 "which is EVENT_TYPE or has a EVENT_TYPE component",
2378 formal
->name
, &actual
->where
);
2383 /* F2008, C1239/C1240. */
2384 if (actual
->expr_type
== EXPR_VARIABLE
2385 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2386 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2387 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2388 && actual
->rank
&& formal
->as
2389 && !gfc_is_simply_contiguous (actual
, true, false)
2390 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2391 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2392 || formal
->attr
.contiguous
))
2395 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2396 "assumed-rank array without CONTIGUOUS attribute - as actual"
2397 " argument at %L is not simply contiguous and both are "
2398 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2402 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2403 && actual_attr
.codimension
)
2405 if (formal
->attr
.intent
== INTENT_OUT
)
2408 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2409 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2413 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2414 gfc_warning (OPT_Wsurprising
,
2415 "Passing coarray at %L to allocatable, noncoarray dummy "
2416 "argument %qs, which is invalid if the allocation status"
2417 " is modified", &actual
->where
, formal
->name
);
2420 /* If the rank is the same or the formal argument has assumed-rank. */
2421 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2424 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2425 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2426 || formal
->as
->type
== AS_DEFERRED
)
2427 && actual
->expr_type
!= EXPR_NULL
;
2429 /* Skip rank checks for NO_ARG_CHECK. */
2430 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2433 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2434 if (rank_check
|| ranks_must_agree
2435 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2436 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2437 || (actual
->rank
== 0
2438 && ((formal
->ts
.type
== BT_CLASS
2439 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2440 || (formal
->ts
.type
!= BT_CLASS
2441 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2442 && actual
->expr_type
!= EXPR_NULL
)
2443 || (actual
->rank
== 0 && formal
->attr
.dimension
2444 && gfc_is_coindexed (actual
)))
2447 argument_rank_mismatch (formal
->name
, &actual
->where
,
2448 symbol_rank (formal
), actual
->rank
);
2451 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2454 /* At this point, we are considering a scalar passed to an array. This
2455 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2456 - if the actual argument is (a substring of) an element of a
2457 non-assumed-shape/non-pointer/non-polymorphic array; or
2458 - (F2003) if the actual argument is of type character of default/c_char
2461 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2462 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2464 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2466 if (ref
->type
== REF_COMPONENT
)
2467 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2468 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2469 && ref
->u
.ar
.dimen
> 0
2471 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2475 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2478 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2479 "at %L", formal
->name
, &actual
->where
);
2483 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2484 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2487 gfc_error ("Element of assumed-shaped or pointer "
2488 "array passed to array dummy argument %qs at %L",
2489 formal
->name
, &actual
->where
);
2493 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2494 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2496 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2499 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2500 "CHARACTER actual argument with array dummy argument "
2501 "%qs at %L", formal
->name
, &actual
->where
);
2505 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2507 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2508 "array dummy argument %qs at %L",
2509 formal
->name
, &actual
->where
);
2513 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2516 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2519 argument_rank_mismatch (formal
->name
, &actual
->where
,
2520 symbol_rank (formal
), actual
->rank
);
2528 /* Returns the storage size of a symbol (formal argument) or
2529 zero if it cannot be determined. */
2531 static unsigned long
2532 get_sym_storage_size (gfc_symbol
*sym
)
2535 unsigned long strlen
, elements
;
2537 if (sym
->ts
.type
== BT_CHARACTER
)
2539 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2540 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2541 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2548 if (symbol_rank (sym
) == 0)
2552 if (sym
->as
->type
!= AS_EXPLICIT
)
2554 for (i
= 0; i
< sym
->as
->rank
; i
++)
2556 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2557 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2560 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2561 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2564 return strlen
*elements
;
2568 /* Returns the storage size of an expression (actual argument) or
2569 zero if it cannot be determined. For an array element, it returns
2570 the remaining size as the element sequence consists of all storage
2571 units of the actual argument up to the end of the array. */
2573 static unsigned long
2574 get_expr_storage_size (gfc_expr
*e
)
2577 long int strlen
, elements
;
2578 long int substrlen
= 0;
2579 bool is_str_storage
= false;
2585 if (e
->ts
.type
== BT_CHARACTER
)
2587 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2588 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2589 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2590 else if (e
->expr_type
== EXPR_CONSTANT
2591 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2592 strlen
= e
->value
.character
.length
;
2597 strlen
= 1; /* Length per element. */
2599 if (e
->rank
== 0 && !e
->ref
)
2607 for (i
= 0; i
< e
->rank
; i
++)
2608 elements
*= mpz_get_si (e
->shape
[i
]);
2609 return elements
*strlen
;
2612 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2614 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2615 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2619 /* The string length is the substring length.
2620 Set now to full string length. */
2621 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2622 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2625 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2627 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2631 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2632 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2634 long int start
, end
, stride
;
2637 if (ref
->u
.ar
.stride
[i
])
2639 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2640 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2645 if (ref
->u
.ar
.start
[i
])
2647 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2648 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2652 else if (ref
->u
.ar
.as
->lower
[i
]
2653 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2654 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2658 if (ref
->u
.ar
.end
[i
])
2660 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2661 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2665 else if (ref
->u
.ar
.as
->upper
[i
]
2666 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2667 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2671 elements
*= (end
- start
)/stride
+ 1L;
2673 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2674 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2676 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2677 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2678 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2679 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2680 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2681 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2682 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2687 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2688 && e
->expr_type
== EXPR_VARIABLE
)
2690 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2691 || e
->symtree
->n
.sym
->attr
.pointer
)
2697 /* Determine the number of remaining elements in the element
2698 sequence for array element designators. */
2699 is_str_storage
= true;
2700 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2702 if (ref
->u
.ar
.start
[i
] == NULL
2703 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2704 || ref
->u
.ar
.as
->upper
[i
] == NULL
2705 || ref
->u
.ar
.as
->lower
[i
] == NULL
2706 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2707 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2712 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2713 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2715 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2716 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2719 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2720 && ref
->u
.c
.component
->attr
.proc_pointer
2721 && ref
->u
.c
.component
->attr
.dimension
)
2723 /* Array-valued procedure-pointer components. */
2724 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2725 for (i
= 0; i
< as
->rank
; i
++)
2727 if (!as
->upper
[i
] || !as
->lower
[i
]
2728 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2729 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2733 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2734 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2740 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2743 return elements
*strlen
;
2747 /* Given an expression, check whether it is an array section
2748 which has a vector subscript. */
2751 gfc_has_vector_subscript (gfc_expr
*e
)
2756 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2759 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2760 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2761 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2762 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2770 is_procptr_result (gfc_expr
*expr
)
2772 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2774 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2776 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2777 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2781 /* Given formal and actual argument lists, see if they are compatible.
2782 If they are compatible, the actual argument list is sorted to
2783 correspond with the formal list, and elements for missing optional
2784 arguments are inserted. If WHERE pointer is nonnull, then we issue
2785 errors when things don't match instead of just returning the status
2789 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2790 int ranks_must_agree
, int is_elemental
, locus
*where
)
2792 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2793 gfc_formal_arglist
*f
;
2795 unsigned long actual_size
, formal_size
;
2796 bool full_array
= false;
2797 gfc_array_ref
*actual_arr_ref
;
2801 if (actual
== NULL
&& formal
== NULL
)
2805 for (f
= formal
; f
; f
= f
->next
)
2808 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2810 for (i
= 0; i
< n
; i
++)
2817 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2819 /* Look for keywords but ignore g77 extensions like %VAL. */
2820 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2823 for (f
= formal
; f
; f
= f
->next
, i
++)
2827 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2834 gfc_error ("Keyword argument %qs at %L is not in "
2835 "the procedure", a
->name
, &a
->expr
->where
);
2839 if (new_arg
[i
] != NULL
)
2842 gfc_error ("Keyword argument %qs at %L is already associated "
2843 "with another actual argument", a
->name
,
2852 gfc_error ("More actual than formal arguments in procedure "
2853 "call at %L", where
);
2858 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2864 gfc_error ("Missing alternate return spec in subroutine call "
2869 if (a
->expr
== NULL
)
2872 gfc_error ("Unexpected alternate return spec in subroutine "
2873 "call at %L", where
);
2877 /* Make sure that intrinsic vtables exist for calls to unlimited
2878 polymorphic formal arguments. */
2879 if (UNLIMITED_POLY (f
->sym
)
2880 && a
->expr
->ts
.type
!= BT_DERIVED
2881 && a
->expr
->ts
.type
!= BT_CLASS
)
2882 gfc_find_vtab (&a
->expr
->ts
);
2884 if (a
->expr
->expr_type
== EXPR_NULL
2885 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2886 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2887 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2888 || (f
->sym
->ts
.type
== BT_CLASS
2889 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2890 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2891 || !f
->sym
->attr
.optional
2892 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2895 && (!f
->sym
->attr
.optional
2896 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2897 || (f
->sym
->ts
.type
== BT_CLASS
2898 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2899 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2900 where
, f
->sym
->name
);
2902 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2903 "dummy %qs", where
, f
->sym
->name
);
2908 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2909 is_elemental
, where
))
2912 /* TS 29113, 6.3p2. */
2913 if (f
->sym
->ts
.type
== BT_ASSUMED
2914 && (a
->expr
->ts
.type
== BT_DERIVED
2915 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2917 gfc_namespace
*f2k_derived
;
2919 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2920 ? a
->expr
->ts
.u
.derived
->f2k_derived
2921 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2924 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2926 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2927 "derived type with type-bound or FINAL procedures",
2933 /* Special case for character arguments. For allocatable, pointer
2934 and assumed-shape dummies, the string length needs to match
2936 if (a
->expr
->ts
.type
== BT_CHARACTER
2937 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2938 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2939 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
2940 && f
->sym
->ts
.u
.cl
->length
2941 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2942 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2943 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2944 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2945 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2947 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2948 gfc_warning (OPT_Wargument_mismatch
,
2949 "Character length mismatch (%ld/%ld) between actual "
2950 "argument and pointer or allocatable dummy argument "
2952 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2953 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2954 f
->sym
->name
, &a
->expr
->where
);
2956 gfc_warning (OPT_Wargument_mismatch
,
2957 "Character length mismatch (%ld/%ld) between actual "
2958 "argument and assumed-shape dummy argument %qs "
2960 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2961 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2962 f
->sym
->name
, &a
->expr
->where
);
2966 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2967 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2968 && a
->expr
->ts
.type
== BT_CHARACTER
)
2971 gfc_error ("Actual argument at %L to allocatable or "
2972 "pointer dummy argument %qs must have a deferred "
2973 "length type parameter if and only if the dummy has one",
2974 &a
->expr
->where
, f
->sym
->name
);
2978 if (f
->sym
->ts
.type
== BT_CLASS
)
2979 goto skip_size_check
;
2981 actual_size
= get_expr_storage_size (a
->expr
);
2982 formal_size
= get_sym_storage_size (f
->sym
);
2983 if (actual_size
!= 0 && actual_size
< formal_size
2984 && a
->expr
->ts
.type
!= BT_PROCEDURE
2985 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2987 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2988 gfc_warning (OPT_Wargument_mismatch
,
2989 "Character length of actual argument shorter "
2990 "than of dummy argument %qs (%lu/%lu) at %L",
2991 f
->sym
->name
, actual_size
, formal_size
,
2995 /* Emit a warning for -std=legacy and an error otherwise. */
2996 if (gfc_option
.warn_std
== 0)
2997 gfc_warning (OPT_Wargument_mismatch
,
2998 "Actual argument contains too few "
2999 "elements for dummy argument %qs (%lu/%lu) "
3000 "at %L", f
->sym
->name
, actual_size
,
3001 formal_size
, &a
->expr
->where
);
3003 gfc_error_now ("Actual argument contains too few "
3004 "elements for dummy argument %qs (%lu/%lu) "
3005 "at %L", f
->sym
->name
, actual_size
,
3006 formal_size
, &a
->expr
->where
);
3013 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3014 argument is provided for a procedure pointer formal argument. */
3015 if (f
->sym
->attr
.proc_pointer
3016 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3017 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3018 || gfc_is_proc_ptr_comp (a
->expr
)))
3019 || (a
->expr
->expr_type
== EXPR_FUNCTION
3020 && is_procptr_result (a
->expr
))))
3023 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3024 f
->sym
->name
, &a
->expr
->where
);
3028 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3029 provided for a procedure formal argument. */
3030 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3031 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3032 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3033 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3034 || gfc_is_proc_ptr_comp (a
->expr
)))
3035 || (a
->expr
->expr_type
== EXPR_FUNCTION
3036 && is_procptr_result (a
->expr
))))
3039 gfc_error ("Expected a procedure for argument %qs at %L",
3040 f
->sym
->name
, &a
->expr
->where
);
3044 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3045 && a
->expr
->expr_type
== EXPR_VARIABLE
3046 && a
->expr
->symtree
->n
.sym
->as
3047 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3048 && (a
->expr
->ref
== NULL
3049 || (a
->expr
->ref
->type
== REF_ARRAY
3050 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3053 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3054 " array at %L", f
->sym
->name
, where
);
3058 if (a
->expr
->expr_type
!= EXPR_NULL
3059 && compare_pointer (f
->sym
, a
->expr
) == 0)
3062 gfc_error ("Actual argument for %qs must be a pointer at %L",
3063 f
->sym
->name
, &a
->expr
->where
);
3067 if (a
->expr
->expr_type
!= EXPR_NULL
3068 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3069 && compare_pointer (f
->sym
, a
->expr
) == 2)
3072 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3073 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3078 /* Fortran 2008, C1242. */
3079 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3082 gfc_error ("Coindexed actual argument at %L to pointer "
3084 &a
->expr
->where
, f
->sym
->name
);
3088 /* Fortran 2008, 12.5.2.5 (no constraint). */
3089 if (a
->expr
->expr_type
== EXPR_VARIABLE
3090 && f
->sym
->attr
.intent
!= INTENT_IN
3091 && f
->sym
->attr
.allocatable
3092 && gfc_is_coindexed (a
->expr
))
3095 gfc_error ("Coindexed actual argument at %L to allocatable "
3096 "dummy %qs requires INTENT(IN)",
3097 &a
->expr
->where
, f
->sym
->name
);
3101 /* Fortran 2008, C1237. */
3102 if (a
->expr
->expr_type
== EXPR_VARIABLE
3103 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3104 && gfc_is_coindexed (a
->expr
)
3105 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3106 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3109 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3110 "%L requires that dummy %qs has neither "
3111 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3116 /* Fortran 2008, 12.5.2.4 (no constraint). */
3117 if (a
->expr
->expr_type
== EXPR_VARIABLE
3118 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3119 && gfc_is_coindexed (a
->expr
)
3120 && gfc_has_ultimate_allocatable (a
->expr
))
3123 gfc_error ("Coindexed actual argument at %L with allocatable "
3124 "ultimate component to dummy %qs requires either VALUE "
3125 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3129 if (f
->sym
->ts
.type
== BT_CLASS
3130 && CLASS_DATA (f
->sym
)->attr
.allocatable
3131 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3135 gfc_error ("Actual CLASS array argument for %qs must be a full "
3136 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3141 if (a
->expr
->expr_type
!= EXPR_NULL
3142 && !compare_allocatable (f
->sym
, a
->expr
))
3145 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3146 f
->sym
->name
, &a
->expr
->where
);
3150 /* Check intent = OUT/INOUT for definable actual argument. */
3151 if ((f
->sym
->attr
.intent
== INTENT_OUT
3152 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3154 const char* context
= (where
3155 ? _("actual argument to INTENT = OUT/INOUT")
3158 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3159 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3160 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3161 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3163 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3167 if ((f
->sym
->attr
.intent
== INTENT_OUT
3168 || f
->sym
->attr
.intent
== INTENT_INOUT
3169 || f
->sym
->attr
.volatile_
3170 || f
->sym
->attr
.asynchronous
)
3171 && gfc_has_vector_subscript (a
->expr
))
3174 gfc_error ("Array-section actual argument with vector "
3175 "subscripts at %L is incompatible with INTENT(OUT), "
3176 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3177 "of the dummy argument %qs",
3178 &a
->expr
->where
, f
->sym
->name
);
3182 /* C1232 (R1221) For an actual argument which is an array section or
3183 an assumed-shape array, the dummy argument shall be an assumed-
3184 shape array, if the dummy argument has the VOLATILE attribute. */
3186 if (f
->sym
->attr
.volatile_
3187 && a
->expr
->expr_type
== EXPR_VARIABLE
3188 && a
->expr
->symtree
->n
.sym
->as
3189 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3190 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3193 gfc_error ("Assumed-shape actual argument at %L is "
3194 "incompatible with the non-assumed-shape "
3195 "dummy argument %qs due to VOLATILE attribute",
3196 &a
->expr
->where
,f
->sym
->name
);
3200 /* Find the last array_ref. */
3201 actual_arr_ref
= NULL
;
3203 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3205 if (f
->sym
->attr
.volatile_
3206 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3207 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3210 gfc_error ("Array-section actual argument at %L is "
3211 "incompatible with the non-assumed-shape "
3212 "dummy argument %qs due to VOLATILE attribute",
3213 &a
->expr
->where
, f
->sym
->name
);
3217 /* C1233 (R1221) For an actual argument which is a pointer array, the
3218 dummy argument shall be an assumed-shape or pointer array, if the
3219 dummy argument has the VOLATILE attribute. */
3221 if (f
->sym
->attr
.volatile_
3222 && a
->expr
->expr_type
== EXPR_VARIABLE
3223 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3224 && a
->expr
->symtree
->n
.sym
->as
3226 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3227 || f
->sym
->attr
.pointer
)))
3230 gfc_error ("Pointer-array actual argument at %L requires "
3231 "an assumed-shape or pointer-array dummy "
3232 "argument %qs due to VOLATILE attribute",
3233 &a
->expr
->where
,f
->sym
->name
);
3244 /* Make sure missing actual arguments are optional. */
3246 for (f
= formal
; f
; f
= f
->next
, i
++)
3248 if (new_arg
[i
] != NULL
)
3253 gfc_error ("Missing alternate return spec in subroutine call "
3257 if (!f
->sym
->attr
.optional
)
3260 gfc_error ("Missing actual argument for argument %qs at %L",
3261 f
->sym
->name
, where
);
3266 /* The argument lists are compatible. We now relink a new actual
3267 argument list with null arguments in the right places. The head
3268 of the list remains the head. */
3269 for (i
= 0; i
< n
; i
++)
3270 if (new_arg
[i
] == NULL
)
3271 new_arg
[i
] = gfc_get_actual_arglist ();
3275 std::swap (*new_arg
[0], *actual
);
3276 std::swap (new_arg
[0], new_arg
[na
]);
3279 for (i
= 0; i
< n
- 1; i
++)
3280 new_arg
[i
]->next
= new_arg
[i
+ 1];
3282 new_arg
[i
]->next
= NULL
;
3284 if (*ap
== NULL
&& n
> 0)
3287 /* Note the types of omitted optional arguments. */
3288 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3289 if (a
->expr
== NULL
&& a
->label
== NULL
)
3290 a
->missing_arg_type
= f
->sym
->ts
.type
;
3298 gfc_formal_arglist
*f
;
3299 gfc_actual_arglist
*a
;
3303 /* qsort comparison function for argument pairs, with the following
3305 - p->a->expr == NULL
3306 - p->a->expr->expr_type != EXPR_VARIABLE
3307 - by gfc_symbol pointer value (larger first). */
3310 pair_cmp (const void *p1
, const void *p2
)
3312 const gfc_actual_arglist
*a1
, *a2
;
3314 /* *p1 and *p2 are elements of the to-be-sorted array. */
3315 a1
= ((const argpair
*) p1
)->a
;
3316 a2
= ((const argpair
*) p2
)->a
;
3325 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3327 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3331 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3333 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3335 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3339 /* Given two expressions from some actual arguments, test whether they
3340 refer to the same expression. The analysis is conservative.
3341 Returning false will produce no warning. */
3344 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3346 const gfc_ref
*r1
, *r2
;
3349 || e1
->expr_type
!= EXPR_VARIABLE
3350 || e2
->expr_type
!= EXPR_VARIABLE
3351 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3354 /* TODO: improve comparison, see expr.c:show_ref(). */
3355 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3357 if (r1
->type
!= r2
->type
)
3362 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3364 /* TODO: At the moment, consider only full arrays;
3365 we could do better. */
3366 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3371 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3379 gfc_internal_error ("compare_actual_expr(): Bad component code");
3388 /* Given formal and actual argument lists that correspond to one
3389 another, check that identical actual arguments aren't not
3390 associated with some incompatible INTENTs. */
3393 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3395 sym_intent f1_intent
, f2_intent
;
3396 gfc_formal_arglist
*f1
;
3397 gfc_actual_arglist
*a1
;
3403 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3405 if (f1
== NULL
&& a1
== NULL
)
3407 if (f1
== NULL
|| a1
== NULL
)
3408 gfc_internal_error ("check_some_aliasing(): List mismatch");
3413 p
= XALLOCAVEC (argpair
, n
);
3415 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3421 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3423 for (i
= 0; i
< n
; i
++)
3426 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3427 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3429 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3430 for (j
= i
+ 1; j
< n
; j
++)
3432 /* Expected order after the sort. */
3433 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3434 gfc_internal_error ("check_some_aliasing(): corrupted data");
3436 /* Are the expression the same? */
3437 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3439 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3440 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3441 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3442 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3444 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3445 "argument %qs and INTENT(%s) argument %qs at %L",
3446 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3447 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3448 &p
[i
].a
->expr
->where
);
3458 /* Given formal and actual argument lists that correspond to one
3459 another, check that they are compatible in the sense that intents
3460 are not mismatched. */
3463 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3465 sym_intent f_intent
;
3467 for (;; f
= f
->next
, a
= a
->next
)
3471 if (f
== NULL
&& a
== NULL
)
3473 if (f
== NULL
|| a
== NULL
)
3474 gfc_internal_error ("check_intents(): List mismatch");
3476 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3477 && a
->expr
->value
.function
.isym
3478 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3479 expr
= a
->expr
->value
.function
.actual
->expr
;
3483 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3486 f_intent
= f
->sym
->attr
.intent
;
3488 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3490 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3491 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3492 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3494 gfc_error ("Procedure argument at %L is local to a PURE "
3495 "procedure and has the POINTER attribute",
3501 /* Fortran 2008, C1283. */
3502 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3504 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3506 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3507 "is passed to an INTENT(%s) argument",
3508 &expr
->where
, gfc_intent_string (f_intent
));
3512 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3513 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3514 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3516 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3517 "is passed to a POINTER dummy argument",
3523 /* F2008, Section 12.5.2.4. */
3524 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3525 && gfc_is_coindexed (expr
))
3527 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3528 "polymorphic dummy argument %qs",
3529 &expr
->where
, f
->sym
->name
);
3538 /* Check how a procedure is used against its interface. If all goes
3539 well, the actual argument list will also end up being properly
3543 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3545 gfc_formal_arglist
*dummy_args
;
3547 /* Warn about calls with an implicit interface. Special case
3548 for calling a ISO_C_BINDING because c_loc and c_funloc
3549 are pseudo-unknown. Additionally, warn about procedures not
3550 explicitly declared at all if requested. */
3551 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3553 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3555 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3559 if (warn_implicit_interface
)
3560 gfc_warning (OPT_Wimplicit_interface
,
3561 "Procedure %qs called with an implicit interface at %L",
3563 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3564 gfc_warning (OPT_Wimplicit_procedure
,
3565 "Procedure %qs called at %L is not explicitly declared",
3569 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3571 gfc_actual_arglist
*a
;
3573 if (sym
->attr
.pointer
)
3575 gfc_error ("The pointer object %qs at %L must have an explicit "
3576 "function interface or be declared as array",
3581 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3583 gfc_error ("The allocatable object %qs at %L must have an explicit "
3584 "function interface or be declared as array",
3589 if (sym
->attr
.allocatable
)
3591 gfc_error ("Allocatable function %qs at %L must have an explicit "
3592 "function interface", sym
->name
, where
);
3596 for (a
= *ap
; a
; a
= a
->next
)
3598 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3599 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3601 gfc_error ("Keyword argument requires explicit interface "
3602 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3606 /* TS 29113, 6.2. */
3607 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3608 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3610 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3611 "interface", a
->expr
->symtree
->n
.sym
->name
,
3616 /* F2008, C1303 and C1304. */
3618 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3619 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3620 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3621 || gfc_expr_attr (a
->expr
).lock_comp
))
3623 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3624 "component at %L requires an explicit interface for "
3625 "procedure %qs", &a
->expr
->where
, sym
->name
);
3630 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3631 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3632 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3633 == ISOFORTRAN_EVENT_TYPE
)
3634 || gfc_expr_attr (a
->expr
).event_comp
))
3636 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3637 "component at %L requires an explicit interface for "
3638 "procedure %qs", &a
->expr
->where
, sym
->name
);
3642 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3643 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3645 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3649 /* TS 29113, C407b. */
3650 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3651 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3653 gfc_error ("Assumed-rank argument requires an explicit interface "
3654 "at %L", &a
->expr
->where
);
3662 dummy_args
= gfc_sym_get_dummy_args (sym
);
3664 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3667 if (!check_intents (dummy_args
, *ap
))
3671 check_some_aliasing (dummy_args
, *ap
);
3677 /* Check how a procedure pointer component is used against its interface.
3678 If all goes well, the actual argument list will also end up being properly
3679 sorted. Completely analogous to gfc_procedure_use. */
3682 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3684 /* Warn about calls with an implicit interface. Special case
3685 for calling a ISO_C_BINDING because c_loc and c_funloc
3686 are pseudo-unknown. */
3687 if (warn_implicit_interface
3688 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3689 && !comp
->attr
.is_iso_c
)
3690 gfc_warning (OPT_Wimplicit_interface
,
3691 "Procedure pointer component %qs called with an implicit "
3692 "interface at %L", comp
->name
, where
);
3694 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3696 gfc_actual_arglist
*a
;
3697 for (a
= *ap
; a
; a
= a
->next
)
3699 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3700 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3702 gfc_error ("Keyword argument requires explicit interface "
3703 "for procedure pointer component %qs at %L",
3704 comp
->name
, &a
->expr
->where
);
3712 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3713 comp
->attr
.elemental
, where
))
3716 check_intents (comp
->ts
.interface
->formal
, *ap
);
3718 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3722 /* Try if an actual argument list matches the formal list of a symbol,
3723 respecting the symbol's attributes like ELEMENTAL. This is used for
3724 GENERIC resolution. */
3727 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3729 gfc_formal_arglist
*dummy_args
;
3732 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3735 dummy_args
= gfc_sym_get_dummy_args (sym
);
3737 r
= !sym
->attr
.elemental
;
3738 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3740 check_intents (dummy_args
, *args
);
3742 check_some_aliasing (dummy_args
, *args
);
3750 /* Given an interface pointer and an actual argument list, search for
3751 a formal argument list that matches the actual. If found, returns
3752 a pointer to the symbol of the correct interface. Returns NULL if
3756 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3757 gfc_actual_arglist
**ap
)
3759 gfc_symbol
*elem_sym
= NULL
;
3760 gfc_symbol
*null_sym
= NULL
;
3761 locus null_expr_loc
;
3762 gfc_actual_arglist
*a
;
3763 bool has_null_arg
= false;
3765 for (a
= *ap
; a
; a
= a
->next
)
3766 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3767 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3769 has_null_arg
= true;
3770 null_expr_loc
= a
->expr
->where
;
3774 for (; intr
; intr
= intr
->next
)
3776 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3778 if (sub_flag
&& intr
->sym
->attr
.function
)
3780 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3783 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3785 if (has_null_arg
&& null_sym
)
3787 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3788 "between specific functions %s and %s",
3789 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3792 else if (has_null_arg
)
3794 null_sym
= intr
->sym
;
3798 /* Satisfy 12.4.4.1 such that an elemental match has lower
3799 weight than a non-elemental match. */
3800 if (intr
->sym
->attr
.elemental
)
3802 elem_sym
= intr
->sym
;
3812 return elem_sym
? elem_sym
: NULL
;
3816 /* Do a brute force recursive search for a symbol. */
3818 static gfc_symtree
*
3819 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3823 if (root
->n
.sym
== sym
)
3828 st
= find_symtree0 (root
->left
, sym
);
3829 if (root
->right
&& ! st
)
3830 st
= find_symtree0 (root
->right
, sym
);
3835 /* Find a symtree for a symbol. */
3838 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3843 /* First try to find it by name. */
3844 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3845 if (st
&& st
->n
.sym
== sym
)
3848 /* If it's been renamed, resort to a brute-force search. */
3849 /* TODO: avoid having to do this search. If the symbol doesn't exist
3850 in the symtree for the current namespace, it should probably be added. */
3851 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3853 st
= find_symtree0 (ns
->sym_root
, sym
);
3857 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3862 /* See if the arglist to an operator-call contains a derived-type argument
3863 with a matching type-bound operator. If so, return the matching specific
3864 procedure defined as operator-target as well as the base-object to use
3865 (which is the found derived-type argument with operator). The generic
3866 name, if any, is transmitted to the final expression via 'gname'. */
3868 static gfc_typebound_proc
*
3869 matching_typebound_op (gfc_expr
** tb_base
,
3870 gfc_actual_arglist
* args
,
3871 gfc_intrinsic_op op
, const char* uop
,
3872 const char ** gname
)
3874 gfc_actual_arglist
* base
;
3876 for (base
= args
; base
; base
= base
->next
)
3877 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3879 gfc_typebound_proc
* tb
;
3880 gfc_symbol
* derived
;
3883 while (base
->expr
->expr_type
== EXPR_OP
3884 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3885 base
->expr
= base
->expr
->value
.op
.op1
;
3887 if (base
->expr
->ts
.type
== BT_CLASS
)
3889 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
3890 || !gfc_expr_attr (base
->expr
).class_ok
)
3892 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3895 derived
= base
->expr
->ts
.u
.derived
;
3897 if (op
== INTRINSIC_USER
)
3899 gfc_symtree
* tb_uop
;
3902 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3911 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3914 /* This means we hit a PRIVATE operator which is use-associated and
3915 should thus not be seen. */
3919 /* Look through the super-type hierarchy for a matching specific
3921 for (; tb
; tb
= tb
->overridden
)
3925 gcc_assert (tb
->is_generic
);
3926 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3929 gfc_actual_arglist
* argcopy
;
3932 gcc_assert (g
->specific
);
3933 if (g
->specific
->error
)
3936 target
= g
->specific
->u
.specific
->n
.sym
;
3938 /* Check if this arglist matches the formal. */
3939 argcopy
= gfc_copy_actual_arglist (args
);
3940 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3941 gfc_free_actual_arglist (argcopy
);
3943 /* Return if we found a match. */
3946 *tb_base
= base
->expr
;
3947 *gname
= g
->specific_st
->name
;
3958 /* For the 'actual arglist' of an operator call and a specific typebound
3959 procedure that has been found the target of a type-bound operator, build the
3960 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3961 type-bound procedures rather than resolving type-bound operators 'directly'
3962 so that we can reuse the existing logic. */
3965 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3966 gfc_expr
* base
, gfc_typebound_proc
* target
,
3969 e
->expr_type
= EXPR_COMPCALL
;
3970 e
->value
.compcall
.tbp
= target
;
3971 e
->value
.compcall
.name
= gname
? gname
: "$op";
3972 e
->value
.compcall
.actual
= actual
;
3973 e
->value
.compcall
.base_object
= base
;
3974 e
->value
.compcall
.ignore_pass
= 1;
3975 e
->value
.compcall
.assign
= 0;
3976 if (e
->ts
.type
== BT_UNKNOWN
3977 && target
->function
)
3979 if (target
->is_generic
)
3980 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3982 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3987 /* This subroutine is called when an expression is being resolved.
3988 The expression node in question is either a user defined operator
3989 or an intrinsic operator with arguments that aren't compatible
3990 with the operator. This subroutine builds an actual argument list
3991 corresponding to the operands, then searches for a compatible
3992 interface. If one is found, the expression node is replaced with
3993 the appropriate function call. We use the 'match' enum to specify
3994 whether a replacement has been made or not, or if an error occurred. */
3997 gfc_extend_expr (gfc_expr
*e
)
3999 gfc_actual_arglist
*actual
;
4005 gfc_typebound_proc
* tbo
;
4010 actual
= gfc_get_actual_arglist ();
4011 actual
->expr
= e
->value
.op
.op1
;
4015 if (e
->value
.op
.op2
!= NULL
)
4017 actual
->next
= gfc_get_actual_arglist ();
4018 actual
->next
->expr
= e
->value
.op
.op2
;
4021 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4023 /* See if we find a matching type-bound operator. */
4024 if (i
== INTRINSIC_USER
)
4025 tbo
= matching_typebound_op (&tb_base
, actual
,
4026 i
, e
->value
.op
.uop
->name
, &gname
);
4030 #define CHECK_OS_COMPARISON(comp) \
4031 case INTRINSIC_##comp: \
4032 case INTRINSIC_##comp##_OS: \
4033 tbo = matching_typebound_op (&tb_base, actual, \
4034 INTRINSIC_##comp, NULL, &gname); \
4036 tbo = matching_typebound_op (&tb_base, actual, \
4037 INTRINSIC_##comp##_OS, NULL, &gname); \
4039 CHECK_OS_COMPARISON(EQ
)
4040 CHECK_OS_COMPARISON(NE
)
4041 CHECK_OS_COMPARISON(GT
)
4042 CHECK_OS_COMPARISON(GE
)
4043 CHECK_OS_COMPARISON(LT
)
4044 CHECK_OS_COMPARISON(LE
)
4045 #undef CHECK_OS_COMPARISON
4048 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4052 /* If there is a matching typebound-operator, replace the expression with
4053 a call to it and succeed. */
4056 gcc_assert (tb_base
);
4057 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4059 if (!gfc_resolve_expr (e
))
4065 if (i
== INTRINSIC_USER
)
4067 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4069 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4073 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4080 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4082 /* Due to the distinction between '==' and '.eq.' and friends, one has
4083 to check if either is defined. */
4086 #define CHECK_OS_COMPARISON(comp) \
4087 case INTRINSIC_##comp: \
4088 case INTRINSIC_##comp##_OS: \
4089 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4091 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4093 CHECK_OS_COMPARISON(EQ
)
4094 CHECK_OS_COMPARISON(NE
)
4095 CHECK_OS_COMPARISON(GT
)
4096 CHECK_OS_COMPARISON(GE
)
4097 CHECK_OS_COMPARISON(LT
)
4098 CHECK_OS_COMPARISON(LE
)
4099 #undef CHECK_OS_COMPARISON
4102 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4110 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4111 found rather than just taking the first one and not checking further. */
4115 /* Don't use gfc_free_actual_arglist(). */
4116 free (actual
->next
);
4121 /* Change the expression node to a function call. */
4122 e
->expr_type
= EXPR_FUNCTION
;
4123 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4124 e
->value
.function
.actual
= actual
;
4125 e
->value
.function
.esym
= NULL
;
4126 e
->value
.function
.isym
= NULL
;
4127 e
->value
.function
.name
= NULL
;
4128 e
->user_operator
= 1;
4130 if (!gfc_resolve_expr (e
))
4137 /* Tries to replace an assignment code node with a subroutine call to the
4138 subroutine associated with the assignment operator. Return true if the node
4139 was replaced. On false, no error is generated. */
4142 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4144 gfc_actual_arglist
*actual
;
4145 gfc_expr
*lhs
, *rhs
, *tb_base
;
4146 gfc_symbol
*sym
= NULL
;
4147 const char *gname
= NULL
;
4148 gfc_typebound_proc
* tbo
;
4153 /* Don't allow an intrinsic assignment to be replaced. */
4154 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4155 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4156 && (lhs
->ts
.type
== rhs
->ts
.type
4157 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4160 actual
= gfc_get_actual_arglist ();
4163 actual
->next
= gfc_get_actual_arglist ();
4164 actual
->next
->expr
= rhs
;
4166 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4168 /* See if we find a matching type-bound assignment. */
4169 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4174 /* Success: Replace the expression with a type-bound call. */
4175 gcc_assert (tb_base
);
4176 c
->expr1
= gfc_get_expr ();
4177 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4178 c
->expr1
->value
.compcall
.assign
= 1;
4179 c
->expr1
->where
= c
->loc
;
4181 c
->op
= EXEC_COMPCALL
;
4185 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4186 for (; ns
; ns
= ns
->parent
)
4188 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4195 /* Success: Replace the assignment with the call. */
4196 c
->op
= EXEC_ASSIGN_CALL
;
4197 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4200 c
->ext
.actual
= actual
;
4204 /* Failure: No assignment procedure found. */
4205 free (actual
->next
);
4211 /* Make sure that the interface just parsed is not already present in
4212 the given interface list. Ambiguity isn't checked yet since module
4213 procedures can be present without interfaces. */
4216 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4220 for (ip
= base
; ip
; ip
= ip
->next
)
4222 if (ip
->sym
== new_sym
)
4224 gfc_error ("Entity %qs at %L is already present in the interface",
4225 new_sym
->name
, &loc
);
4234 /* Add a symbol to the current interface. */
4237 gfc_add_interface (gfc_symbol
*new_sym
)
4239 gfc_interface
**head
, *intr
;
4243 switch (current_interface
.type
)
4245 case INTERFACE_NAMELESS
:
4246 case INTERFACE_ABSTRACT
:
4249 case INTERFACE_INTRINSIC_OP
:
4250 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4251 switch (current_interface
.op
)
4254 case INTRINSIC_EQ_OS
:
4255 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4257 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4258 new_sym
, gfc_current_locus
))
4263 case INTRINSIC_NE_OS
:
4264 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4266 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4267 new_sym
, gfc_current_locus
))
4272 case INTRINSIC_GT_OS
:
4273 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4274 new_sym
, gfc_current_locus
)
4275 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4276 new_sym
, gfc_current_locus
))
4281 case INTRINSIC_GE_OS
:
4282 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4283 new_sym
, gfc_current_locus
)
4284 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4285 new_sym
, gfc_current_locus
))
4290 case INTRINSIC_LT_OS
:
4291 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4292 new_sym
, gfc_current_locus
)
4293 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4294 new_sym
, gfc_current_locus
))
4299 case INTRINSIC_LE_OS
:
4300 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4301 new_sym
, gfc_current_locus
)
4302 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4303 new_sym
, gfc_current_locus
))
4308 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4309 new_sym
, gfc_current_locus
))
4313 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4316 case INTERFACE_GENERIC
:
4317 case INTERFACE_DTIO
:
4318 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4320 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4324 if (!gfc_check_new_interface (sym
->generic
,
4325 new_sym
, gfc_current_locus
))
4329 head
= ¤t_interface
.sym
->generic
;
4332 case INTERFACE_USER_OP
:
4333 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4334 new_sym
, gfc_current_locus
))
4337 head
= ¤t_interface
.uop
->op
;
4341 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4344 intr
= gfc_get_interface ();
4345 intr
->sym
= new_sym
;
4346 intr
->where
= gfc_current_locus
;
4356 gfc_current_interface_head (void)
4358 switch (current_interface
.type
)
4360 case INTERFACE_INTRINSIC_OP
:
4361 return current_interface
.ns
->op
[current_interface
.op
];
4363 case INTERFACE_GENERIC
:
4364 case INTERFACE_DTIO
:
4365 return current_interface
.sym
->generic
;
4367 case INTERFACE_USER_OP
:
4368 return current_interface
.uop
->op
;
4377 gfc_set_current_interface_head (gfc_interface
*i
)
4379 switch (current_interface
.type
)
4381 case INTERFACE_INTRINSIC_OP
:
4382 current_interface
.ns
->op
[current_interface
.op
] = i
;
4385 case INTERFACE_GENERIC
:
4386 case INTERFACE_DTIO
:
4387 current_interface
.sym
->generic
= i
;
4390 case INTERFACE_USER_OP
:
4391 current_interface
.uop
->op
= i
;
4400 /* Gets rid of a formal argument list. We do not free symbols.
4401 Symbols are freed when a namespace is freed. */
4404 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4406 gfc_formal_arglist
*q
;
4416 /* Check that it is ok for the type-bound procedure 'proc' to override the
4417 procedure 'old', cf. F08:4.5.7.3. */
4420 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4423 gfc_symbol
*proc_target
, *old_target
;
4424 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4425 gfc_formal_arglist
*proc_formal
, *old_formal
;
4429 /* This procedure should only be called for non-GENERIC proc. */
4430 gcc_assert (!proc
->n
.tb
->is_generic
);
4432 /* If the overwritten procedure is GENERIC, this is an error. */
4433 if (old
->n
.tb
->is_generic
)
4435 gfc_error ("Can't overwrite GENERIC %qs at %L",
4436 old
->name
, &proc
->n
.tb
->where
);
4440 where
= proc
->n
.tb
->where
;
4441 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4442 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4444 /* Check that overridden binding is not NON_OVERRIDABLE. */
4445 if (old
->n
.tb
->non_overridable
)
4447 gfc_error ("%qs at %L overrides a procedure binding declared"
4448 " NON_OVERRIDABLE", proc
->name
, &where
);
4452 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4453 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4455 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4456 " non-DEFERRED binding", proc
->name
, &where
);
4460 /* If the overridden binding is PURE, the overriding must be, too. */
4461 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4463 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4464 proc
->name
, &where
);
4468 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4469 is not, the overriding must not be either. */
4470 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4472 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4473 " ELEMENTAL", proc
->name
, &where
);
4476 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4478 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4479 " be ELEMENTAL, either", proc
->name
, &where
);
4483 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4485 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4487 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4488 " SUBROUTINE", proc
->name
, &where
);
4492 /* If the overridden binding is a FUNCTION, the overriding must also be a
4493 FUNCTION and have the same characteristics. */
4494 if (old_target
->attr
.function
)
4496 if (!proc_target
->attr
.function
)
4498 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4499 " FUNCTION", proc
->name
, &where
);
4503 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4506 gfc_error ("Result mismatch for the overriding procedure "
4507 "%qs at %L: %s", proc
->name
, &where
, err
);
4512 /* If the overridden binding is PUBLIC, the overriding one must not be
4514 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4515 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4517 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4518 " PRIVATE", proc
->name
, &where
);
4522 /* Compare the formal argument lists of both procedures. This is also abused
4523 to find the position of the passed-object dummy arguments of both
4524 bindings as at least the overridden one might not yet be resolved and we
4525 need those positions in the check below. */
4526 proc_pass_arg
= old_pass_arg
= 0;
4527 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4529 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4532 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4533 old_formal
= gfc_sym_get_dummy_args (old_target
);
4534 for ( ; proc_formal
&& old_formal
;
4535 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4537 if (proc
->n
.tb
->pass_arg
4538 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4539 proc_pass_arg
= argpos
;
4540 if (old
->n
.tb
->pass_arg
4541 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4542 old_pass_arg
= argpos
;
4544 /* Check that the names correspond. */
4545 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4547 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4548 " to match the corresponding argument of the overridden"
4549 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4550 old_formal
->sym
->name
);
4554 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4555 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4556 check_type
, err
, sizeof(err
)))
4558 gfc_error_opt (OPT_Wargument_mismatch
,
4559 "Argument mismatch for the overriding procedure "
4560 "%qs at %L: %s", proc
->name
, &where
, err
);
4566 if (proc_formal
|| old_formal
)
4568 gfc_error ("%qs at %L must have the same number of formal arguments as"
4569 " the overridden procedure", proc
->name
, &where
);
4573 /* If the overridden binding is NOPASS, the overriding one must also be
4575 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4577 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4578 " NOPASS", proc
->name
, &where
);
4582 /* If the overridden binding is PASS(x), the overriding one must also be
4583 PASS and the passed-object dummy arguments must correspond. */
4584 if (!old
->n
.tb
->nopass
)
4586 if (proc
->n
.tb
->nopass
)
4588 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4589 " PASS", proc
->name
, &where
);
4593 if (proc_pass_arg
!= old_pass_arg
)
4595 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4596 " the same position as the passed-object dummy argument of"
4597 " the overridden procedure", proc
->name
, &where
);
4606 /* The following three functions check that the formal arguments
4607 of user defined derived type IO procedures are compliant with
4608 the requirements of the standard. */
4611 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4612 int kind
, int rank
, sym_intent intent
)
4614 if (fsym
->ts
.type
!= type
)
4616 gfc_error ("DTIO dummy argument at %L must be of type %s",
4617 &fsym
->declared_at
, gfc_basic_typename (type
));
4621 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4622 && fsym
->ts
.kind
!= kind
)
4623 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4624 &fsym
->declared_at
, kind
);
4628 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4629 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4630 gfc_error ("DTIO dummy argument at %L must be a scalar",
4631 &fsym
->declared_at
);
4633 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4634 gfc_error ("DTIO dummy argument at %L must be an "
4635 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4637 if (fsym
->attr
.intent
!= intent
)
4638 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4639 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4645 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4646 bool typebound
, bool formatted
, int code
)
4648 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4649 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4650 gfc_interface
*intr
;
4651 gfc_formal_arglist
*formal
;
4654 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4655 || ((dtio_codes
)code
== DTIO_RUF
);
4663 /* Typebound DTIO binding. */
4664 tb_io_proc
= tb_io_st
->n
.tb
;
4665 if (tb_io_proc
== NULL
)
4668 gcc_assert (tb_io_proc
->is_generic
);
4669 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4671 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4672 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4675 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4679 generic_proc
= tb_io_st
->n
.sym
;
4680 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4683 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4685 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4686 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4687 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4689 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4690 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4692 dtio_sub
= intr
->sym
;
4695 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4697 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4698 "procedure", &intr
->sym
->declared_at
);
4703 if (dtio_sub
== NULL
)
4707 gcc_assert (dtio_sub
);
4708 if (!dtio_sub
->attr
.subroutine
)
4709 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
4710 dtio_sub
->name
, &dtio_sub
->declared_at
);
4713 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4716 if (arg_num
< (formatted
? 6 : 4))
4718 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
4719 dtio_sub
->name
, &dtio_sub
->declared_at
);
4723 if (arg_num
> (formatted
? 6 : 4))
4725 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
4726 dtio_sub
->name
, &dtio_sub
->declared_at
);
4731 /* Now go through the formal arglist. */
4733 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4735 if (!formatted
&& arg_num
== 3)
4741 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4742 "procedure", &dtio_sub
->declared_at
);
4749 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4750 BT_DERIVED
: BT_CLASS
;
4752 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4753 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4759 kind
= gfc_default_integer_kind
;
4761 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4764 case(3): /* IOTYPE */
4765 type
= BT_CHARACTER
;
4766 kind
= gfc_default_character_kind
;
4768 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4771 case(4): /* VLIST */
4773 kind
= gfc_default_integer_kind
;
4775 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4778 case(5): /* IOSTAT */
4780 kind
= gfc_default_integer_kind
;
4781 intent
= INTENT_OUT
;
4782 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4785 case(6): /* IOMSG */
4786 type
= BT_CHARACTER
;
4787 kind
= gfc_default_character_kind
;
4788 intent
= INTENT_INOUT
;
4789 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4796 derived
->attr
.has_dtio_procs
= 1;
4801 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4803 gfc_symtree
*tb_io_st
;
4808 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4811 /* Check typebound DTIO bindings. */
4812 for (code
= 0; code
< 4; code
++)
4814 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4815 || ((dtio_codes
)code
== DTIO_WF
);
4817 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4818 gfc_code2string (dtio_procs
, code
),
4819 true, &derived
->declared_at
);
4820 if (tb_io_st
!= NULL
)
4821 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4824 /* Check generic DTIO interfaces. */
4825 for (code
= 0; code
< 4; code
++)
4827 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4828 || ((dtio_codes
)code
== DTIO_WF
);
4830 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4831 gfc_code2string (dtio_procs
, code
));
4832 if (tb_io_st
!= NULL
)
4833 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4839 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4841 gfc_symtree
*tb_io_st
= NULL
;
4844 if (!derived
|| !derived
->resolved
|| derived
->attr
.flavor
!= FL_DERIVED
)
4847 /* Try to find a typebound DTIO binding. */
4848 if (formatted
== true)
4851 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4852 gfc_code2string (dtio_procs
,
4855 &derived
->declared_at
);
4857 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4858 gfc_code2string (dtio_procs
,
4861 &derived
->declared_at
);
4866 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4867 gfc_code2string (dtio_procs
,
4870 &derived
->declared_at
);
4872 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4873 gfc_code2string (dtio_procs
,
4876 &derived
->declared_at
);
4883 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4885 gfc_symtree
*tb_io_st
= NULL
;
4886 gfc_symbol
*dtio_sub
= NULL
;
4887 gfc_symbol
*extended
;
4888 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4890 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
4892 if (tb_io_st
!= NULL
)
4894 const char *genname
;
4897 tb_io_proc
= tb_io_st
->n
.tb
;
4898 gcc_assert (tb_io_proc
!= NULL
);
4899 gcc_assert (tb_io_proc
->is_generic
);
4900 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4902 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4903 gcc_assert (!specific_proc
->is_generic
);
4905 /* Go back and make sure that we have the right specific procedure.
4906 Here we most likely have a procedure from the parent type, which
4907 can be overridden in extensions. */
4908 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4909 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4910 true, &tb_io_proc
->where
);
4912 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4914 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4919 /* If there is not a typebound binding, look for a generic
4921 for (extended
= derived
; extended
;
4922 extended
= gfc_get_derived_super_type (extended
))
4924 if (extended
== NULL
|| extended
->ns
== NULL
4925 || extended
->attr
.flavor
== FL_UNKNOWN
)
4928 if (formatted
== true)
4931 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4932 gfc_code2string (dtio_procs
,
4935 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4936 gfc_code2string (dtio_procs
,
4942 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4943 gfc_code2string (dtio_procs
,
4946 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4947 gfc_code2string (dtio_procs
,
4951 if (tb_io_st
!= NULL
4953 && tb_io_st
->n
.sym
->generic
)
4955 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
4956 intr
&& intr
->sym
; intr
= intr
->next
)
4958 if (intr
->sym
->formal
)
4960 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
4961 if ((fsym
->ts
.type
== BT_CLASS
4962 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
4963 || (fsym
->ts
.type
== BT_DERIVED
4964 && fsym
->ts
.u
.derived
== extended
))
4966 dtio_sub
= intr
->sym
;
4975 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
4976 gfc_find_derived_vtab (derived
);