1 /* Deal with interfaces.
2 Copyright (C) 2000-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface
;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface
*intr
)
88 for (; intr
; intr
= next
)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op
)
104 case INTRINSIC_UPLUS
:
107 case INTRINSIC_UMINUS
:
108 op
= INTRINSIC_MINUS
;
118 /* Return the operator depending on the DTIO moded string. Note that
119 these are not operators in the normal sense and so have been placed
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
122 static gfc_intrinsic_op
125 if (strncmp (mode
, "formatted", 9) == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strncmp (mode
, "unformatted", 9) == 0)
128 return INTRINSIC_UNFORMATTED
;
129 return INTRINSIC_NONE
;
133 /* Match a generic specification. Depending on which type of
134 interface is found, the 'name' or 'op' pointers may be set.
135 This subroutine doesn't return MATCH_NO. */
138 gfc_match_generic_spec (interface_type
*type
,
140 gfc_intrinsic_op
*op
)
142 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
146 if (gfc_match (" assignment ( = )") == MATCH_YES
)
148 *type
= INTERFACE_INTRINSIC_OP
;
149 *op
= INTRINSIC_ASSIGN
;
153 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
155 *type
= INTERFACE_INTRINSIC_OP
;
156 *op
= fold_unary_intrinsic (i
);
160 *op
= INTRINSIC_NONE
;
161 if (gfc_match (" operator ( ") == MATCH_YES
)
163 m
= gfc_match_defined_op_name (buffer
, 1);
169 m
= gfc_match_char (')');
175 strcpy (name
, buffer
);
176 *type
= INTERFACE_USER_OP
;
180 if (gfc_match (" read ( %n )", buffer
) == MATCH_YES
)
182 *op
= dtio_op (buffer
);
183 if (*op
== INTRINSIC_FORMATTED
)
185 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RF
));
186 *type
= INTERFACE_DTIO
;
188 if (*op
== INTRINSIC_UNFORMATTED
)
190 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RUF
));
191 *type
= INTERFACE_DTIO
;
193 if (*op
!= INTRINSIC_NONE
)
197 if (gfc_match (" write ( %n )", buffer
) == MATCH_YES
)
199 *op
= dtio_op (buffer
);
200 if (*op
== INTRINSIC_FORMATTED
)
202 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WF
));
203 *type
= INTERFACE_DTIO
;
205 if (*op
== INTRINSIC_UNFORMATTED
)
207 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WUF
));
208 *type
= INTERFACE_DTIO
;
210 if (*op
!= INTRINSIC_NONE
)
214 if (gfc_match_name (buffer
) == MATCH_YES
)
216 strcpy (name
, buffer
);
217 *type
= INTERFACE_GENERIC
;
221 *type
= INTERFACE_NAMELESS
;
225 gfc_error ("Syntax error in generic specification at %C");
230 /* Match one of the five F95 forms of an interface statement. The
231 matcher for the abstract interface follows. */
234 gfc_match_interface (void)
236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
242 m
= gfc_match_space ();
244 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
247 /* If we're not looking at the end of the statement now, or if this
248 is not a nameless interface but we did not see a space, punt. */
249 if (gfc_match_eos () != MATCH_YES
250 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
257 current_interface
.type
= type
;
262 case INTERFACE_GENERIC
:
263 if (gfc_get_symbol (name
, NULL
, &sym
))
266 if (!sym
->attr
.generic
267 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
272 gfc_error ("Dummy procedure %qs at %C cannot have a "
273 "generic interface", sym
->name
);
277 current_interface
.sym
= gfc_new_block
= sym
;
280 case INTERFACE_USER_OP
:
281 current_interface
.uop
= gfc_get_uop (name
);
284 case INTERFACE_INTRINSIC_OP
:
285 current_interface
.op
= op
;
288 case INTERFACE_NAMELESS
:
289 case INTERFACE_ABSTRACT
:
298 /* Match a F2003 abstract interface. */
301 gfc_match_abstract_interface (void)
305 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
308 m
= gfc_match_eos ();
312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
316 current_interface
.type
= INTERFACE_ABSTRACT
;
322 /* Match the different sort of generic-specs that can be present after
323 the END INTERFACE itself. */
326 gfc_match_end_interface (void)
328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
333 m
= gfc_match_space ();
335 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
338 /* If we're not looking at the end of the statement now, or if this
339 is not a nameless interface but we did not see a space, punt. */
340 if (gfc_match_eos () != MATCH_YES
341 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
350 switch (current_interface
.type
)
352 case INTERFACE_NAMELESS
:
353 case INTERFACE_ABSTRACT
:
354 if (type
!= INTERFACE_NAMELESS
)
356 gfc_error ("Expected a nameless interface at %C");
362 case INTERFACE_INTRINSIC_OP
:
363 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
366 if (current_interface
.op
== INTRINSIC_ASSIGN
)
369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
374 s1
= gfc_op2string (current_interface
.op
);
375 s2
= gfc_op2string (op
);
377 /* The following if-statements are used to enforce C1202
379 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
380 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
382 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
383 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
385 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
386 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
388 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
389 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
391 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
392 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
394 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
395 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
399 if (strcmp(s2
, "none") == 0)
400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
404 "but got %s", s1
, s2
);
411 case INTERFACE_USER_OP
:
412 /* Comparing the symbol node names is OK because only use-associated
413 symbols can be renamed. */
414 if (type
!= current_interface
.type
415 || strcmp (current_interface
.uop
->name
, name
) != 0)
417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
418 current_interface
.uop
->name
);
425 case INTERFACE_GENERIC
:
426 if (type
!= current_interface
.type
427 || strcmp (current_interface
.sym
->name
, name
) != 0)
429 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
430 current_interface
.sym
->name
);
441 /* Return whether the component was defined anonymously. */
444 is_anonymous_component (gfc_component
*cmp
)
446 /* Only UNION and MAP components are anonymous. In the case of a MAP,
447 the derived type symbol is FL_STRUCT and the component name looks like mM*.
448 This is the only case in which the second character of a component name is
450 return cmp
->ts
.type
== BT_UNION
451 || (cmp
->ts
.type
== BT_DERIVED
452 && cmp
->ts
.u
.derived
->attr
.flavor
== FL_STRUCT
453 && cmp
->name
[0] && cmp
->name
[1] && ISUPPER (cmp
->name
[1]));
457 /* Return whether the derived type was defined anonymously. */
460 is_anonymous_dt (gfc_symbol
*derived
)
462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
464 and the type name looks like XX*. This is the only case in which the
465 second character of a type name is uppercase. */
466 return derived
->attr
.flavor
== FL_UNION
467 || (derived
->attr
.flavor
== FL_STRUCT
468 && derived
->name
[0] && derived
->name
[1] && ISUPPER (derived
->name
[1]));
472 /* Compare components according to 4.4.2 of the Fortran standard. */
475 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
476 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
478 /* Compare names, but not for anonymous components such as UNION or MAP. */
479 if (!is_anonymous_component (cmp1
) && !is_anonymous_component (cmp2
)
480 && strcmp (cmp1
->name
, cmp2
->name
) != 0)
483 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
486 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
489 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
492 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
495 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
498 /* Make sure that link lists do not put this function into an
499 endless recursive loop! */
500 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
501 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
502 && gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
) == 0)
505 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
506 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
509 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
510 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
517 /* Compare two union types by comparing the components of their maps.
518 Because unions and maps are anonymous their types get special internal
519 names; therefore the usual derived type comparison will fail on them.
521 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
522 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
523 definitions' than 'equivalent structure'. */
526 gfc_compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
528 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
530 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
533 map1
= un1
->components
;
534 map2
= un2
->components
;
536 /* In terms of 'equality' here we are worried about types which are
537 declared the same in two places, not types that represent equivalent
538 structures. (This is common because of FORTRAN's weird scoping rules.)
539 Though two unions with their maps in different orders could be equivalent,
540 we will say they are not equal for the purposes of this test; therefore
541 we compare the maps sequentially. */
544 cmp1
= map1
->ts
.u
.derived
->components
;
545 cmp2
= map2
->ts
.u
.derived
->components
;
548 /* No two fields will ever point to the same map type unless they are
549 the same component, because one map field is created with its type
550 declaration. Therefore don't worry about recursion here. */
551 /* TODO: worry about recursion into parent types of the unions? */
552 if (compare_components (cmp1
, cmp2
,
553 map1
->ts
.u
.derived
, map2
->ts
.u
.derived
) == 0)
559 if (cmp1
== NULL
&& cmp2
== NULL
)
561 if (cmp1
== NULL
|| cmp2
== NULL
)
568 if (map1
== NULL
&& map2
== NULL
)
570 if (map1
== NULL
|| map2
== NULL
)
579 /* Compare two derived types using the criteria in 4.4.2 of the standard,
580 recursing through gfc_compare_types for the components. */
583 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
585 gfc_component
*cmp1
, *cmp2
;
587 if (derived1
== derived2
)
590 gcc_assert (derived1
&& derived2
);
592 /* Special case for comparing derived types across namespaces. If the
593 true names and module names are the same and the module name is
594 nonnull, then they are equal. */
595 if (strcmp (derived1
->name
, derived2
->name
) == 0
596 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
597 && strcmp (derived1
->module
, derived2
->module
) == 0)
600 /* Compare type via the rules of the standard. Both types must have
601 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
602 because they can be anonymous; therefore two structures with different
603 names may be equal. */
605 /* Compare names, but not for anonymous types such as UNION or MAP. */
606 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
607 && strcmp (derived1
->name
, derived2
->name
) != 0)
610 if (derived1
->component_access
== ACCESS_PRIVATE
611 || derived2
->component_access
== ACCESS_PRIVATE
)
614 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
615 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
618 /* Protect against null components. */
619 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
622 if (derived1
->attr
.zero_comp
)
625 cmp1
= derived1
->components
;
626 cmp2
= derived2
->components
;
628 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
629 simple test can speed things up. Otherwise, lots of things have to
633 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
639 if (cmp1
== NULL
&& cmp2
== NULL
)
641 if (cmp1
== NULL
|| cmp2
== NULL
)
649 /* Compare two typespecs, recursively if necessary. */
652 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
654 /* See if one of the typespecs is a BT_VOID, which is what is being used
655 to allow the funcs like c_f_pointer to accept any pointer type.
656 TODO: Possibly should narrow this to just the one typespec coming in
657 that is for the formal arg, but oh well. */
658 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
661 /* The _data component is not always present, therefore check for its
662 presence before assuming, that its derived->attr is available.
663 When the _data component is not present, then nevertheless the
664 unlimited_polymorphic flag may be set in the derived type's attr. */
665 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
666 && ((ts1
->u
.derived
->attr
.is_class
667 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
668 .unlimited_polymorphic
)
669 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
673 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
674 && ts2
->u
.derived
->components
675 && ((ts2
->u
.derived
->attr
.is_class
676 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
677 .unlimited_polymorphic
)
678 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
679 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
682 if (ts1
->type
== BT_UNION
&& ts2
->type
== BT_UNION
)
683 return gfc_compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
685 if (ts1
->type
!= ts2
->type
686 && ((!gfc_bt_struct (ts1
->type
) && ts1
->type
!= BT_CLASS
)
687 || (!gfc_bt_struct (ts2
->type
) && ts2
->type
!= BT_CLASS
)))
689 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
690 return (ts1
->kind
== ts2
->kind
);
692 /* Compare derived types. */
693 return gfc_type_compatible (ts1
, ts2
);
698 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
700 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
703 /* TYPE and CLASS of the same declared type are type compatible,
704 but have different characteristics. */
705 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
706 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
709 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
714 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
716 gfc_array_spec
*as1
, *as2
;
719 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
722 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
723 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
725 r1
= as1
? as1
->rank
: 0;
726 r2
= as2
? as2
->rank
: 0;
728 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
729 return 0; /* Ranks differ. */
735 /* Given two symbols that are formal arguments, compare their ranks
736 and types. Returns nonzero if they have the same rank and type,
740 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
742 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
746 /* Given two symbols that are formal arguments, compare their types
747 and rank and their formal interfaces if they are both dummy
748 procedures. Returns nonzero if the same, zero if different. */
751 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
753 if (s1
== NULL
|| s2
== NULL
)
754 return s1
== s2
? 1 : 0;
759 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
760 return compare_type_rank (s1
, s2
);
762 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
765 /* At this point, both symbols are procedures. It can happen that
766 external procedures are compared, where one is identified by usage
767 to be a function or subroutine but the other is not. Check TKR
768 nonetheless for these cases. */
769 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
770 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
772 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
773 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
775 /* Now the type of procedure has been identified. */
776 if (s1
->attr
.function
!= s2
->attr
.function
777 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
780 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
783 /* Originally, gfortran recursed here to check the interfaces of passed
784 procedures. This is explicitly not required by the standard. */
789 /* Given a formal argument list and a keyword name, search the list
790 for that keyword. Returns the correct symbol node if found, NULL
794 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
796 for (; f
; f
= f
->next
)
797 if (strcmp (f
->sym
->name
, name
) == 0)
804 /******** Interface checking subroutines **********/
807 /* Given an operator interface and the operator, make sure that all
808 interfaces for that operator are legal. */
811 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
814 gfc_formal_arglist
*formal
;
817 int args
, r1
, r2
, k1
, k2
;
822 t1
= t2
= BT_UNKNOWN
;
823 i1
= i2
= INTENT_UNKNOWN
;
827 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
829 gfc_symbol
*fsym
= formal
->sym
;
832 gfc_error ("Alternate return cannot appear in operator "
833 "interface at %L", &sym
->declared_at
);
839 i1
= fsym
->attr
.intent
;
840 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
846 i2
= fsym
->attr
.intent
;
847 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
853 /* Only +, - and .not. can be unary operators.
854 .not. cannot be a binary operator. */
855 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
856 && op
!= INTRINSIC_MINUS
857 && op
!= INTRINSIC_NOT
)
858 || (args
== 2 && op
== INTRINSIC_NOT
))
860 if (op
== INTRINSIC_ASSIGN
)
861 gfc_error ("Assignment operator interface at %L must have "
862 "two arguments", &sym
->declared_at
);
864 gfc_error ("Operator interface at %L has the wrong number of arguments",
869 /* Check that intrinsics are mapped to functions, except
870 INTRINSIC_ASSIGN which should map to a subroutine. */
871 if (op
== INTRINSIC_ASSIGN
)
873 gfc_formal_arglist
*dummy_args
;
875 if (!sym
->attr
.subroutine
)
877 gfc_error ("Assignment operator interface at %L must be "
878 "a SUBROUTINE", &sym
->declared_at
);
882 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
883 - First argument an array with different rank than second,
884 - First argument is a scalar and second an array,
885 - Types and kinds do not conform, or
886 - First argument is of derived type. */
887 dummy_args
= gfc_sym_get_dummy_args (sym
);
888 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
889 && dummy_args
->sym
->ts
.type
!= BT_CLASS
890 && (r2
== 0 || r1
== r2
)
891 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
892 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
893 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
895 gfc_error ("Assignment operator interface at %L must not redefine "
896 "an INTRINSIC type assignment", &sym
->declared_at
);
902 if (!sym
->attr
.function
)
904 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
910 /* Check intents on operator interfaces. */
911 if (op
== INTRINSIC_ASSIGN
)
913 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
915 gfc_error ("First argument of defined assignment at %L must be "
916 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
922 gfc_error ("Second argument of defined assignment at %L must be "
923 "INTENT(IN)", &sym
->declared_at
);
931 gfc_error ("First argument of operator interface at %L must be "
932 "INTENT(IN)", &sym
->declared_at
);
936 if (args
== 2 && i2
!= INTENT_IN
)
938 gfc_error ("Second argument of operator interface at %L must be "
939 "INTENT(IN)", &sym
->declared_at
);
944 /* From now on, all we have to do is check that the operator definition
945 doesn't conflict with an intrinsic operator. The rules for this
946 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
947 as well as 12.3.2.1.1 of Fortran 2003:
949 "If the operator is an intrinsic-operator (R310), the number of
950 function arguments shall be consistent with the intrinsic uses of
951 that operator, and the types, kind type parameters, or ranks of the
952 dummy arguments shall differ from those required for the intrinsic
953 operation (7.1.2)." */
955 #define IS_NUMERIC_TYPE(t) \
956 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
958 /* Unary ops are easy, do them first. */
959 if (op
== INTRINSIC_NOT
)
961 if (t1
== BT_LOGICAL
)
967 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
969 if (IS_NUMERIC_TYPE (t1
))
975 /* Character intrinsic operators have same character kind, thus
976 operator definitions with operands of different character kinds
978 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
981 /* Intrinsic operators always perform on arguments of same rank,
982 so different ranks is also always safe. (rank == 0) is an exception
983 to that, because all intrinsic operators are elemental. */
984 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
990 case INTRINSIC_EQ_OS
:
992 case INTRINSIC_NE_OS
:
993 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
998 case INTRINSIC_MINUS
:
999 case INTRINSIC_TIMES
:
1000 case INTRINSIC_DIVIDE
:
1001 case INTRINSIC_POWER
:
1002 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1007 case INTRINSIC_GT_OS
:
1009 case INTRINSIC_GE_OS
:
1011 case INTRINSIC_LT_OS
:
1013 case INTRINSIC_LE_OS
:
1014 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1016 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1017 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1021 case INTRINSIC_CONCAT
:
1022 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1029 case INTRINSIC_NEQV
:
1030 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1040 #undef IS_NUMERIC_TYPE
1043 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1049 /* Given a pair of formal argument lists, we see if the two lists can
1050 be distinguished by counting the number of nonoptional arguments of
1051 a given type/rank in f1 and seeing if there are less then that
1052 number of those arguments in f2 (including optional arguments).
1053 Since this test is asymmetric, it has to be called twice to make it
1054 symmetric. Returns nonzero if the argument lists are incompatible
1055 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1056 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1059 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1060 const char *p1
, const char *p2
)
1062 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
1063 gfc_formal_arglist
*f
;
1076 for (f
= f1
; f
; f
= f
->next
)
1079 /* Build an array of integers that gives the same integer to
1080 arguments of the same type/rank. */
1081 arg
= XCNEWVEC (arginfo
, n1
);
1084 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1087 arg
[i
].sym
= f
->sym
;
1092 for (i
= 0; i
< n1
; i
++)
1094 if (arg
[i
].flag
!= -1)
1097 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1098 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1099 continue; /* Skip OPTIONAL and PASS arguments. */
1103 /* Find other non-optional, non-pass arguments of the same type/rank. */
1104 for (j
= i
+ 1; j
< n1
; j
++)
1105 if ((arg
[j
].sym
== NULL
1106 || !(arg
[j
].sym
->attr
.optional
1107 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1108 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1109 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1115 /* Now loop over each distinct type found in f1. */
1119 for (i
= 0; i
< n1
; i
++)
1121 if (arg
[i
].flag
!= k
)
1125 for (j
= i
+ 1; j
< n1
; j
++)
1126 if (arg
[j
].flag
== k
)
1129 /* Count the number of non-pass arguments in f2 with that type,
1130 including those that are optional. */
1133 for (f
= f2
; f
; f
= f
->next
)
1134 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1135 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1136 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1154 /* Perform the correspondence test in rule (3) of F08:C1215.
1155 Returns zero if no argument is found that satisfies this rule,
1156 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1159 This test is also not symmetric in f1 and f2 and must be called
1160 twice. This test finds problems caused by sorting the actual
1161 argument list with keywords. For example:
1165 INTEGER :: A ; REAL :: B
1169 INTEGER :: A ; REAL :: B
1173 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1176 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1177 const char *p1
, const char *p2
)
1179 gfc_formal_arglist
*f2_save
, *g
;
1186 if (f1
->sym
->attr
.optional
)
1189 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1191 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1194 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1195 || compare_type_rank (f2
->sym
, f1
->sym
))
1196 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1197 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1198 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1201 /* Now search for a disambiguating keyword argument starting at
1202 the current non-match. */
1203 for (g
= f1
; g
; g
= g
->next
)
1205 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1208 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1209 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1210 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1211 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1212 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1228 symbol_rank (gfc_symbol
*sym
)
1231 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1232 return as
? as
->rank
: 0;
1236 /* Check if the characteristics of two dummy arguments match,
1240 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1241 bool type_must_agree
, char *errmsg
,
1244 if (s1
== NULL
|| s2
== NULL
)
1245 return s1
== s2
? true : false;
1247 /* Check type and rank. */
1248 if (type_must_agree
)
1250 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1252 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1253 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1256 if (!compare_rank (s1
, s2
))
1258 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1259 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1265 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1267 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1272 /* Check OPTIONAL attribute. */
1273 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1275 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1280 /* Check ALLOCATABLE attribute. */
1281 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1283 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1288 /* Check POINTER attribute. */
1289 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1291 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1296 /* Check TARGET attribute. */
1297 if (s1
->attr
.target
!= s2
->attr
.target
)
1299 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1304 /* Check ASYNCHRONOUS attribute. */
1305 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1307 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1312 /* Check CONTIGUOUS attribute. */
1313 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1315 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1320 /* Check VALUE attribute. */
1321 if (s1
->attr
.value
!= s2
->attr
.value
)
1323 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1328 /* Check VOLATILE attribute. */
1329 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1331 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1336 /* Check interface of dummy procedures. */
1337 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1340 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1343 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1344 "'%s': %s", s1
->name
, err
);
1349 /* Check string length. */
1350 if (s1
->ts
.type
== BT_CHARACTER
1351 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1352 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1354 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1355 s2
->ts
.u
.cl
->length
);
1361 snprintf (errmsg
, err_len
, "Character length mismatch "
1362 "in argument '%s'", s1
->name
);
1366 /* FIXME: Implement a warning for this case.
1367 gfc_warning (0, "Possible character length mismatch in argument %qs",
1375 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1376 "%i of gfc_dep_compare_expr", compval
);
1381 /* Check array shape. */
1382 if (s1
->as
&& s2
->as
)
1385 gfc_expr
*shape1
, *shape2
;
1387 if (s1
->as
->type
!= s2
->as
->type
)
1389 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1394 if (s1
->as
->corank
!= s2
->as
->corank
)
1396 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1397 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1401 if (s1
->as
->type
== AS_EXPLICIT
)
1402 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1404 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1405 gfc_copy_expr (s1
->as
->lower
[i
]));
1406 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1407 gfc_copy_expr (s2
->as
->lower
[i
]));
1408 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1409 gfc_free_expr (shape1
);
1410 gfc_free_expr (shape2
);
1416 if (i
< s1
->as
->rank
)
1417 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1418 " argument '%s'", i
+ 1, s1
->name
);
1420 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1421 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1425 /* FIXME: Implement a warning for this case.
1426 gfc_warning (0, "Possible shape mismatch in argument %qs",
1434 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1435 "result %i of gfc_dep_compare_expr",
1446 /* Check if the characteristics of two function results match,
1450 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1451 char *errmsg
, int err_len
)
1453 gfc_symbol
*r1
, *r2
;
1455 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1456 r1
= s1
->ts
.interface
->result
;
1458 r1
= s1
->result
? s1
->result
: s1
;
1460 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1461 r2
= s2
->ts
.interface
->result
;
1463 r2
= s2
->result
? s2
->result
: s2
;
1465 if (r1
->ts
.type
== BT_UNKNOWN
)
1468 /* Check type and rank. */
1469 if (!compare_type (r1
, r2
))
1471 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1472 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1475 if (!compare_rank (r1
, r2
))
1477 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1478 symbol_rank (r1
), symbol_rank (r2
));
1482 /* Check ALLOCATABLE attribute. */
1483 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1485 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1490 /* Check POINTER attribute. */
1491 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1493 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1498 /* Check CONTIGUOUS attribute. */
1499 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1501 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1506 /* Check PROCEDURE POINTER attribute. */
1507 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1509 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1514 /* Check string length. */
1515 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1517 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1519 snprintf (errmsg
, err_len
, "Character length mismatch "
1520 "in function result");
1524 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1526 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1527 r2
->ts
.u
.cl
->length
);
1533 snprintf (errmsg
, err_len
, "Character length mismatch "
1534 "in function result");
1538 /* FIXME: Implement a warning for this case.
1539 snprintf (errmsg, err_len, "Possible character length mismatch "
1540 "in function result");*/
1547 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1548 "result %i of gfc_dep_compare_expr", compval
);
1554 /* Check array shape. */
1555 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1558 gfc_expr
*shape1
, *shape2
;
1560 if (r1
->as
->type
!= r2
->as
->type
)
1562 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1566 if (r1
->as
->type
== AS_EXPLICIT
)
1567 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1569 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1570 gfc_copy_expr (r1
->as
->lower
[i
]));
1571 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1572 gfc_copy_expr (r2
->as
->lower
[i
]));
1573 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1574 gfc_free_expr (shape1
);
1575 gfc_free_expr (shape2
);
1581 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1582 "function result", i
+ 1);
1586 /* FIXME: Implement a warning for this case.
1587 gfc_warning (0, "Possible shape mismatch in return value");*/
1594 gfc_internal_error ("check_result_characteristics (2): "
1595 "Unexpected result %i of "
1596 "gfc_dep_compare_expr", compval
);
1606 /* 'Compare' two formal interfaces associated with a pair of symbols.
1607 We return nonzero if there exists an actual argument list that
1608 would be ambiguous between the two interfaces, zero otherwise.
1609 'strict_flag' specifies whether all the characteristics are
1610 required to match, which is not the case for ambiguity checks.
1611 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1614 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1615 int generic_flag
, int strict_flag
,
1616 char *errmsg
, int err_len
,
1617 const char *p1
, const char *p2
)
1619 gfc_formal_arglist
*f1
, *f2
;
1621 gcc_assert (name2
!= NULL
);
1623 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1624 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1625 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1628 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1632 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1635 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1639 /* Do strict checks on all characteristics
1640 (for dummy procedures and procedure pointer assignments). */
1641 if (!generic_flag
&& strict_flag
)
1643 if (s1
->attr
.function
&& s2
->attr
.function
)
1645 /* If both are functions, check result characteristics. */
1646 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1647 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1651 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1653 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1656 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1658 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1663 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1664 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1667 f1
= gfc_sym_get_dummy_args (s1
);
1668 f2
= gfc_sym_get_dummy_args (s2
);
1670 if (f1
== NULL
&& f2
== NULL
)
1671 return 1; /* Special case: No arguments. */
1675 if (count_types_test (f1
, f2
, p1
, p2
)
1676 || count_types_test (f2
, f1
, p2
, p1
))
1678 if (generic_correspondence (f1
, f2
, p1
, p2
)
1679 || generic_correspondence (f2
, f1
, p2
, p1
))
1683 /* Perform the abbreviated correspondence test for operators (the
1684 arguments cannot be optional and are always ordered correctly).
1685 This is also done when comparing interfaces for dummy procedures and in
1686 procedure pointer assignments. */
1690 /* Check existence. */
1691 if (f1
== NULL
&& f2
== NULL
)
1693 if (f1
== NULL
|| f2
== NULL
)
1696 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1697 "arguments", name2
);
1701 if (UNLIMITED_POLY (f1
->sym
))
1706 /* Check all characteristics. */
1707 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1713 /* Only check type and rank. */
1714 if (!compare_type (f2
->sym
, f1
->sym
))
1717 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1718 "(%s/%s)", f1
->sym
->name
,
1719 gfc_typename (&f1
->sym
->ts
),
1720 gfc_typename (&f2
->sym
->ts
));
1723 if (!compare_rank (f2
->sym
, f1
->sym
))
1726 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1727 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1728 symbol_rank (f2
->sym
));
1741 /* Given a pointer to an interface pointer, remove duplicate
1742 interfaces and make sure that all symbols are either functions
1743 or subroutines, and all of the same kind. Returns nonzero if
1744 something goes wrong. */
1747 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1749 gfc_interface
*psave
, *q
, *qlast
;
1752 for (; p
; p
= p
->next
)
1754 /* Make sure all symbols in the interface have been defined as
1755 functions or subroutines. */
1756 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1757 || !p
->sym
->attr
.if_source
)
1758 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1760 if (p
->sym
->attr
.external
)
1761 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1762 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1764 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1765 "subroutine", p
->sym
->name
, interface_name
,
1766 &p
->sym
->declared_at
);
1770 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1771 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1772 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1773 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1775 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1776 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1777 " or all FUNCTIONs", interface_name
,
1778 &p
->sym
->declared_at
);
1779 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1780 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1781 "generic name is also the name of a derived type",
1782 interface_name
, &p
->sym
->declared_at
);
1786 /* F2003, C1207. F2008, C1207. */
1787 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1788 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1789 "%qs in %s at %L", p
->sym
->name
,
1790 interface_name
, &p
->sym
->declared_at
))
1795 /* Remove duplicate interfaces in this interface list. */
1796 for (; p
; p
= p
->next
)
1800 for (q
= p
->next
; q
;)
1802 if (p
->sym
!= q
->sym
)
1809 /* Duplicate interface. */
1810 qlast
->next
= q
->next
;
1821 /* Check lists of interfaces to make sure that no two interfaces are
1822 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1825 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1826 int generic_flag
, const char *interface_name
,
1830 for (; p
; p
= p
->next
)
1831 for (q
= q0
; q
; q
= q
->next
)
1833 if (p
->sym
== q
->sym
)
1834 continue; /* Duplicates OK here. */
1836 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1839 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1840 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1841 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1842 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1845 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1846 p
->sym
->name
, q
->sym
->name
, interface_name
,
1848 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1849 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
1850 p
->sym
->name
, q
->sym
->name
, interface_name
,
1853 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1854 "interfaces at %L", interface_name
, &p
->where
);
1862 /* Check the generic and operator interfaces of symbols to make sure
1863 that none of the interfaces conflict. The check has to be done
1864 after all of the symbols are actually loaded. */
1867 check_sym_interfaces (gfc_symbol
*sym
)
1869 char interface_name
[100];
1872 if (sym
->ns
!= gfc_current_ns
)
1875 if (sym
->generic
!= NULL
)
1877 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1878 if (check_interface0 (sym
->generic
, interface_name
))
1881 for (p
= sym
->generic
; p
; p
= p
->next
)
1883 if (p
->sym
->attr
.mod_proc
1884 && !p
->sym
->attr
.module_procedure
1885 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1886 || p
->sym
->attr
.procedure
))
1888 gfc_error ("%qs at %L is not a module procedure",
1889 p
->sym
->name
, &p
->where
);
1894 /* Originally, this test was applied to host interfaces too;
1895 this is incorrect since host associated symbols, from any
1896 source, cannot be ambiguous with local symbols. */
1897 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1898 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1904 check_uop_interfaces (gfc_user_op
*uop
)
1906 char interface_name
[100];
1910 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1911 if (check_interface0 (uop
->op
, interface_name
))
1914 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1916 uop2
= gfc_find_uop (uop
->name
, ns
);
1920 check_interface1 (uop
->op
, uop2
->op
, 0,
1921 interface_name
, true);
1925 /* Given an intrinsic op, return an equivalent op if one exists,
1926 or INTRINSIC_NONE otherwise. */
1929 gfc_equivalent_op (gfc_intrinsic_op op
)
1934 return INTRINSIC_EQ_OS
;
1936 case INTRINSIC_EQ_OS
:
1937 return INTRINSIC_EQ
;
1940 return INTRINSIC_NE_OS
;
1942 case INTRINSIC_NE_OS
:
1943 return INTRINSIC_NE
;
1946 return INTRINSIC_GT_OS
;
1948 case INTRINSIC_GT_OS
:
1949 return INTRINSIC_GT
;
1952 return INTRINSIC_GE_OS
;
1954 case INTRINSIC_GE_OS
:
1955 return INTRINSIC_GE
;
1958 return INTRINSIC_LT_OS
;
1960 case INTRINSIC_LT_OS
:
1961 return INTRINSIC_LT
;
1964 return INTRINSIC_LE_OS
;
1966 case INTRINSIC_LE_OS
:
1967 return INTRINSIC_LE
;
1970 return INTRINSIC_NONE
;
1974 /* For the namespace, check generic, user operator and intrinsic
1975 operator interfaces for consistency and to remove duplicate
1976 interfaces. We traverse the whole namespace, counting on the fact
1977 that most symbols will not have generic or operator interfaces. */
1980 gfc_check_interfaces (gfc_namespace
*ns
)
1982 gfc_namespace
*old_ns
, *ns2
;
1983 char interface_name
[100];
1986 old_ns
= gfc_current_ns
;
1987 gfc_current_ns
= ns
;
1989 gfc_traverse_ns (ns
, check_sym_interfaces
);
1991 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1993 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1995 if (i
== INTRINSIC_USER
)
1998 if (i
== INTRINSIC_ASSIGN
)
1999 strcpy (interface_name
, "intrinsic assignment operator");
2001 sprintf (interface_name
, "intrinsic '%s' operator",
2002 gfc_op2string ((gfc_intrinsic_op
) i
));
2004 if (check_interface0 (ns
->op
[i
], interface_name
))
2008 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2011 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2013 gfc_intrinsic_op other_op
;
2015 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2016 interface_name
, true))
2019 /* i should be gfc_intrinsic_op, but has to be int with this cast
2020 here for stupid C++ compatibility rules. */
2021 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2022 if (other_op
!= INTRINSIC_NONE
2023 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2024 0, interface_name
, true))
2030 gfc_current_ns
= old_ns
;
2034 /* Given a symbol of a formal argument list and an expression, if the
2035 formal argument is allocatable, check that the actual argument is
2036 allocatable. Returns nonzero if compatible, zero if not compatible. */
2039 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2041 symbol_attribute attr
;
2043 if (formal
->attr
.allocatable
2044 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2046 attr
= gfc_expr_attr (actual
);
2047 if (!attr
.allocatable
)
2055 /* Given a symbol of a formal argument list and an expression, if the
2056 formal argument is a pointer, see if the actual argument is a
2057 pointer. Returns nonzero if compatible, zero if not compatible. */
2060 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2062 symbol_attribute attr
;
2064 if (formal
->attr
.pointer
2065 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2066 && CLASS_DATA (formal
)->attr
.class_pointer
))
2068 attr
= gfc_expr_attr (actual
);
2070 /* Fortran 2008 allows non-pointer actual arguments. */
2071 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2082 /* Emit clear error messages for rank mismatch. */
2085 argument_rank_mismatch (const char *name
, locus
*where
,
2086 int rank1
, int rank2
)
2089 /* TS 29113, C407b. */
2092 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2093 " %qs has assumed-rank", where
, name
);
2095 else if (rank1
== 0)
2097 gfc_error ("Rank mismatch in argument %qs at %L "
2098 "(scalar and rank-%d)", name
, where
, rank2
);
2100 else if (rank2
== 0)
2102 gfc_error ("Rank mismatch in argument %qs at %L "
2103 "(rank-%d and scalar)", name
, where
, rank1
);
2107 gfc_error ("Rank mismatch in argument %qs at %L "
2108 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2113 /* Given a symbol of a formal argument list and an expression, see if
2114 the two are compatible as arguments. Returns nonzero if
2115 compatible, zero if not compatible. */
2118 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2119 int ranks_must_agree
, int is_elemental
, locus
*where
)
2122 bool rank_check
, is_pointer
;
2126 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2127 procs c_f_pointer or c_f_procpointer, and we need to accept most
2128 pointers the user could give us. This should allow that. */
2129 if (formal
->ts
.type
== BT_VOID
)
2132 if (formal
->ts
.type
== BT_DERIVED
2133 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2134 && actual
->ts
.type
== BT_DERIVED
2135 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2138 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2139 /* Make sure the vtab symbol is present when
2140 the module variables are generated. */
2141 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2143 if (actual
->ts
.type
== BT_PROCEDURE
)
2145 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2147 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2150 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2154 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2155 sizeof(err
), NULL
, NULL
))
2158 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2159 formal
->name
, &actual
->where
, err
);
2163 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2165 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2166 &act_sym
->declared_at
);
2167 if (act_sym
->ts
.type
== BT_UNKNOWN
2168 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2171 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2172 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2173 &act_sym
->declared_at
);
2178 ppc
= gfc_get_proc_ptr_comp (actual
);
2179 if (ppc
&& ppc
->ts
.interface
)
2181 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2182 err
, sizeof(err
), NULL
, NULL
))
2185 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2186 formal
->name
, &actual
->where
, err
);
2192 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2193 && !gfc_is_simply_contiguous (actual
, true, false))
2196 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2197 "must be simply contiguous", formal
->name
, &actual
->where
);
2201 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2202 && actual
->ts
.type
!= BT_HOLLERITH
2203 && formal
->ts
.type
!= BT_ASSUMED
2204 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2205 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2206 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2207 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2208 CLASS_DATA (actual
)->ts
.u
.derived
)))
2211 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2212 formal
->name
, where
, gfc_typename (&actual
->ts
),
2213 gfc_typename (&formal
->ts
));
2217 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2220 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2221 "argument %qs is of assumed type", &actual
->where
,
2226 /* F2008, 12.5.2.5; IR F08/0073. */
2227 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2228 && actual
->expr_type
!= EXPR_NULL
2229 && ((CLASS_DATA (formal
)->attr
.class_pointer
2230 && formal
->attr
.intent
!= INTENT_IN
)
2231 || CLASS_DATA (formal
)->attr
.allocatable
))
2233 if (actual
->ts
.type
!= BT_CLASS
)
2236 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2237 formal
->name
, &actual
->where
);
2241 if (!gfc_expr_attr (actual
).class_ok
)
2244 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2245 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2246 CLASS_DATA (formal
)->ts
.u
.derived
))
2249 gfc_error ("Actual argument to %qs at %L must have the same "
2250 "declared type", formal
->name
, &actual
->where
);
2255 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2256 is necessary also for F03, so retain error for both.
2257 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2258 compatible, no attempt has been made to channel to this one. */
2259 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2260 && (CLASS_DATA (formal
)->attr
.allocatable
2261 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2264 gfc_error ("Actual argument to %qs at %L must be unlimited "
2265 "polymorphic since the formal argument is a "
2266 "pointer or allocatable unlimited polymorphic "
2267 "entity [F2008: 12.5.2.5]", formal
->name
,
2272 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2275 gfc_error ("Actual argument to %qs at %L must be a coarray",
2276 formal
->name
, &actual
->where
);
2280 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2282 gfc_ref
*last
= NULL
;
2284 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2285 if (ref
->type
== REF_COMPONENT
)
2288 /* F2008, 12.5.2.6. */
2289 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2291 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2294 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2295 formal
->name
, &actual
->where
, formal
->as
->corank
,
2296 last
? last
->u
.c
.component
->as
->corank
2297 : actual
->symtree
->n
.sym
->as
->corank
);
2302 if (formal
->attr
.codimension
)
2304 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2305 /* F2015, 12.5.2.8. */
2306 if (formal
->attr
.dimension
2307 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2308 && gfc_expr_attr (actual
).dimension
2309 && !gfc_is_simply_contiguous (actual
, true, true))
2312 gfc_error ("Actual argument to %qs at %L must be simply "
2313 "contiguous or an element of such an array",
2314 formal
->name
, &actual
->where
);
2318 /* F2008, C1303 and C1304. */
2319 if (formal
->attr
.intent
!= INTENT_INOUT
2320 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2321 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2322 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2323 || formal
->attr
.lock_comp
))
2327 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2328 "which is LOCK_TYPE or has a LOCK_TYPE component",
2329 formal
->name
, &actual
->where
);
2333 /* TS18508, C702/C703. */
2334 if (formal
->attr
.intent
!= INTENT_INOUT
2335 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2336 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2337 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2338 || formal
->attr
.event_comp
))
2342 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2343 "which is EVENT_TYPE or has a EVENT_TYPE component",
2344 formal
->name
, &actual
->where
);
2349 /* F2008, C1239/C1240. */
2350 if (actual
->expr_type
== EXPR_VARIABLE
2351 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2352 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2353 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2354 && actual
->rank
&& formal
->as
2355 && !gfc_is_simply_contiguous (actual
, true, false)
2356 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2357 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2358 || formal
->attr
.contiguous
))
2361 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2362 "assumed-rank array without CONTIGUOUS attribute - as actual"
2363 " argument at %L is not simply contiguous and both are "
2364 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2368 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2369 && gfc_expr_attr (actual
).codimension
)
2371 if (formal
->attr
.intent
== INTENT_OUT
)
2374 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2375 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2379 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2380 gfc_warning (OPT_Wsurprising
,
2381 "Passing coarray at %L to allocatable, noncoarray dummy "
2382 "argument %qs, which is invalid if the allocation status"
2383 " is modified", &actual
->where
, formal
->name
);
2386 /* If the rank is the same or the formal argument has assumed-rank. */
2387 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2390 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2391 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2392 || formal
->as
->type
== AS_DEFERRED
)
2393 && actual
->expr_type
!= EXPR_NULL
;
2395 /* Skip rank checks for NO_ARG_CHECK. */
2396 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2399 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2400 if (rank_check
|| ranks_must_agree
2401 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2402 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2403 || (actual
->rank
== 0
2404 && ((formal
->ts
.type
== BT_CLASS
2405 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2406 || (formal
->ts
.type
!= BT_CLASS
2407 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2408 && actual
->expr_type
!= EXPR_NULL
)
2409 || (actual
->rank
== 0 && formal
->attr
.dimension
2410 && gfc_is_coindexed (actual
)))
2413 argument_rank_mismatch (formal
->name
, &actual
->where
,
2414 symbol_rank (formal
), actual
->rank
);
2417 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2420 /* At this point, we are considering a scalar passed to an array. This
2421 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2422 - if the actual argument is (a substring of) an element of a
2423 non-assumed-shape/non-pointer/non-polymorphic array; or
2424 - (F2003) if the actual argument is of type character of default/c_char
2427 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2428 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2430 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2432 if (ref
->type
== REF_COMPONENT
)
2433 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2434 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2435 && ref
->u
.ar
.dimen
> 0
2437 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2441 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2444 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2445 "at %L", formal
->name
, &actual
->where
);
2449 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2450 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2453 gfc_error ("Element of assumed-shaped or pointer "
2454 "array passed to array dummy argument %qs at %L",
2455 formal
->name
, &actual
->where
);
2459 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2460 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2462 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2465 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2466 "CHARACTER actual argument with array dummy argument "
2467 "%qs at %L", formal
->name
, &actual
->where
);
2471 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2473 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2474 "array dummy argument %qs at %L",
2475 formal
->name
, &actual
->where
);
2478 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2484 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2487 argument_rank_mismatch (formal
->name
, &actual
->where
,
2488 symbol_rank (formal
), actual
->rank
);
2496 /* Returns the storage size of a symbol (formal argument) or
2497 zero if it cannot be determined. */
2499 static unsigned long
2500 get_sym_storage_size (gfc_symbol
*sym
)
2503 unsigned long strlen
, elements
;
2505 if (sym
->ts
.type
== BT_CHARACTER
)
2507 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2508 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2509 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2516 if (symbol_rank (sym
) == 0)
2520 if (sym
->as
->type
!= AS_EXPLICIT
)
2522 for (i
= 0; i
< sym
->as
->rank
; i
++)
2524 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2525 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2528 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2529 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2532 return strlen
*elements
;
2536 /* Returns the storage size of an expression (actual argument) or
2537 zero if it cannot be determined. For an array element, it returns
2538 the remaining size as the element sequence consists of all storage
2539 units of the actual argument up to the end of the array. */
2541 static unsigned long
2542 get_expr_storage_size (gfc_expr
*e
)
2545 long int strlen
, elements
;
2546 long int substrlen
= 0;
2547 bool is_str_storage
= false;
2553 if (e
->ts
.type
== BT_CHARACTER
)
2555 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2556 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2557 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2558 else if (e
->expr_type
== EXPR_CONSTANT
2559 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2560 strlen
= e
->value
.character
.length
;
2565 strlen
= 1; /* Length per element. */
2567 if (e
->rank
== 0 && !e
->ref
)
2575 for (i
= 0; i
< e
->rank
; i
++)
2576 elements
*= mpz_get_si (e
->shape
[i
]);
2577 return elements
*strlen
;
2580 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2582 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2583 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2587 /* The string length is the substring length.
2588 Set now to full string length. */
2589 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2590 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2593 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2595 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2599 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2600 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2602 long int start
, end
, stride
;
2605 if (ref
->u
.ar
.stride
[i
])
2607 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2608 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2613 if (ref
->u
.ar
.start
[i
])
2615 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2616 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2620 else if (ref
->u
.ar
.as
->lower
[i
]
2621 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2622 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2626 if (ref
->u
.ar
.end
[i
])
2628 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2629 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2633 else if (ref
->u
.ar
.as
->upper
[i
]
2634 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2635 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2639 elements
*= (end
- start
)/stride
+ 1L;
2641 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2642 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2644 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2645 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2646 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2647 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2648 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2649 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2650 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2655 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2656 && e
->expr_type
== EXPR_VARIABLE
)
2658 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2659 || e
->symtree
->n
.sym
->attr
.pointer
)
2665 /* Determine the number of remaining elements in the element
2666 sequence for array element designators. */
2667 is_str_storage
= true;
2668 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2670 if (ref
->u
.ar
.start
[i
] == NULL
2671 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2672 || ref
->u
.ar
.as
->upper
[i
] == NULL
2673 || ref
->u
.ar
.as
->lower
[i
] == NULL
2674 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2675 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2680 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2681 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2683 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2684 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2687 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2688 && ref
->u
.c
.component
->attr
.proc_pointer
2689 && ref
->u
.c
.component
->attr
.dimension
)
2691 /* Array-valued procedure-pointer components. */
2692 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2693 for (i
= 0; i
< as
->rank
; i
++)
2695 if (!as
->upper
[i
] || !as
->lower
[i
]
2696 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2697 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2701 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2702 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2708 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2711 return elements
*strlen
;
2715 /* Given an expression, check whether it is an array section
2716 which has a vector subscript. If it has, one is returned,
2720 gfc_has_vector_subscript (gfc_expr
*e
)
2725 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2728 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2729 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2730 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2731 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2739 is_procptr_result (gfc_expr
*expr
)
2741 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2743 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2745 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2746 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2750 /* Given formal and actual argument lists, see if they are compatible.
2751 If they are compatible, the actual argument list is sorted to
2752 correspond with the formal list, and elements for missing optional
2753 arguments are inserted. If WHERE pointer is nonnull, then we issue
2754 errors when things don't match instead of just returning the status
2758 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2759 int ranks_must_agree
, int is_elemental
, locus
*where
)
2761 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2762 gfc_formal_arglist
*f
;
2764 unsigned long actual_size
, formal_size
;
2765 bool full_array
= false;
2769 if (actual
== NULL
&& formal
== NULL
)
2773 for (f
= formal
; f
; f
= f
->next
)
2776 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2778 for (i
= 0; i
< n
; i
++)
2785 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2787 /* Look for keywords but ignore g77 extensions like %VAL. */
2788 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2791 for (f
= formal
; f
; f
= f
->next
, i
++)
2795 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2802 gfc_error ("Keyword argument %qs at %L is not in "
2803 "the procedure", a
->name
, &a
->expr
->where
);
2807 if (new_arg
[i
] != NULL
)
2810 gfc_error ("Keyword argument %qs at %L is already associated "
2811 "with another actual argument", a
->name
,
2820 gfc_error ("More actual than formal arguments in procedure "
2821 "call at %L", where
);
2826 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2832 gfc_error ("Missing alternate return spec in subroutine call "
2837 if (a
->expr
== NULL
)
2840 gfc_error ("Unexpected alternate return spec in subroutine "
2841 "call at %L", where
);
2845 /* Make sure that intrinsic vtables exist for calls to unlimited
2846 polymorphic formal arguments. */
2847 if (UNLIMITED_POLY (f
->sym
)
2848 && a
->expr
->ts
.type
!= BT_DERIVED
2849 && a
->expr
->ts
.type
!= BT_CLASS
)
2850 gfc_find_vtab (&a
->expr
->ts
);
2852 if (a
->expr
->expr_type
== EXPR_NULL
2853 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2854 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2855 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2856 || (f
->sym
->ts
.type
== BT_CLASS
2857 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2858 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2859 || !f
->sym
->attr
.optional
2860 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2863 && (!f
->sym
->attr
.optional
2864 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2865 || (f
->sym
->ts
.type
== BT_CLASS
2866 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2867 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2868 where
, f
->sym
->name
);
2870 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2871 "dummy %qs", where
, f
->sym
->name
);
2876 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2877 is_elemental
, where
))
2880 /* TS 29113, 6.3p2. */
2881 if (f
->sym
->ts
.type
== BT_ASSUMED
2882 && (a
->expr
->ts
.type
== BT_DERIVED
2883 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2885 gfc_namespace
*f2k_derived
;
2887 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2888 ? a
->expr
->ts
.u
.derived
->f2k_derived
2889 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2892 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2894 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2895 "derived type with type-bound or FINAL procedures",
2901 /* Special case for character arguments. For allocatable, pointer
2902 and assumed-shape dummies, the string length needs to match
2904 if (a
->expr
->ts
.type
== BT_CHARACTER
2905 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2906 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2907 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2908 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2909 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2910 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2911 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2912 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2914 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2916 "Character length mismatch (%ld/%ld) between actual "
2917 "argument and pointer or allocatable dummy argument "
2919 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2920 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2921 f
->sym
->name
, &a
->expr
->where
);
2924 "Character length mismatch (%ld/%ld) between actual "
2925 "argument and assumed-shape dummy argument %qs "
2927 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2928 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2929 f
->sym
->name
, &a
->expr
->where
);
2933 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2934 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2935 && a
->expr
->ts
.type
== BT_CHARACTER
)
2938 gfc_error ("Actual argument at %L to allocatable or "
2939 "pointer dummy argument %qs must have a deferred "
2940 "length type parameter if and only if the dummy has one",
2941 &a
->expr
->where
, f
->sym
->name
);
2945 if (f
->sym
->ts
.type
== BT_CLASS
)
2946 goto skip_size_check
;
2948 actual_size
= get_expr_storage_size (a
->expr
);
2949 formal_size
= get_sym_storage_size (f
->sym
);
2950 if (actual_size
!= 0 && actual_size
< formal_size
2951 && a
->expr
->ts
.type
!= BT_PROCEDURE
2952 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2954 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2955 gfc_warning (0, "Character length of actual argument shorter "
2956 "than of dummy argument %qs (%lu/%lu) at %L",
2957 f
->sym
->name
, actual_size
, formal_size
,
2960 gfc_warning (0, "Actual argument contains too few "
2961 "elements for dummy argument %qs (%lu/%lu) at %L",
2962 f
->sym
->name
, actual_size
, formal_size
,
2969 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2970 argument is provided for a procedure pointer formal argument. */
2971 if (f
->sym
->attr
.proc_pointer
2972 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2973 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2974 || gfc_is_proc_ptr_comp (a
->expr
)))
2975 || (a
->expr
->expr_type
== EXPR_FUNCTION
2976 && is_procptr_result (a
->expr
))))
2979 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2980 f
->sym
->name
, &a
->expr
->where
);
2984 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2985 provided for a procedure formal argument. */
2986 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2987 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2988 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2989 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2990 || gfc_is_proc_ptr_comp (a
->expr
)))
2991 || (a
->expr
->expr_type
== EXPR_FUNCTION
2992 && is_procptr_result (a
->expr
))))
2995 gfc_error ("Expected a procedure for argument %qs at %L",
2996 f
->sym
->name
, &a
->expr
->where
);
3000 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3001 && a
->expr
->expr_type
== EXPR_VARIABLE
3002 && a
->expr
->symtree
->n
.sym
->as
3003 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3004 && (a
->expr
->ref
== NULL
3005 || (a
->expr
->ref
->type
== REF_ARRAY
3006 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3009 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3010 " array at %L", f
->sym
->name
, where
);
3014 if (a
->expr
->expr_type
!= EXPR_NULL
3015 && compare_pointer (f
->sym
, a
->expr
) == 0)
3018 gfc_error ("Actual argument for %qs must be a pointer at %L",
3019 f
->sym
->name
, &a
->expr
->where
);
3023 if (a
->expr
->expr_type
!= EXPR_NULL
3024 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3025 && compare_pointer (f
->sym
, a
->expr
) == 2)
3028 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3029 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3034 /* Fortran 2008, C1242. */
3035 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3038 gfc_error ("Coindexed actual argument at %L to pointer "
3040 &a
->expr
->where
, f
->sym
->name
);
3044 /* Fortran 2008, 12.5.2.5 (no constraint). */
3045 if (a
->expr
->expr_type
== EXPR_VARIABLE
3046 && f
->sym
->attr
.intent
!= INTENT_IN
3047 && f
->sym
->attr
.allocatable
3048 && gfc_is_coindexed (a
->expr
))
3051 gfc_error ("Coindexed actual argument at %L to allocatable "
3052 "dummy %qs requires INTENT(IN)",
3053 &a
->expr
->where
, f
->sym
->name
);
3057 /* Fortran 2008, C1237. */
3058 if (a
->expr
->expr_type
== EXPR_VARIABLE
3059 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3060 && gfc_is_coindexed (a
->expr
)
3061 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3062 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3065 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3066 "%L requires that dummy %qs has neither "
3067 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3072 /* Fortran 2008, 12.5.2.4 (no constraint). */
3073 if (a
->expr
->expr_type
== EXPR_VARIABLE
3074 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3075 && gfc_is_coindexed (a
->expr
)
3076 && gfc_has_ultimate_allocatable (a
->expr
))
3079 gfc_error ("Coindexed actual argument at %L with allocatable "
3080 "ultimate component to dummy %qs requires either VALUE "
3081 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3085 if (f
->sym
->ts
.type
== BT_CLASS
3086 && CLASS_DATA (f
->sym
)->attr
.allocatable
3087 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3091 gfc_error ("Actual CLASS array argument for %qs must be a full "
3092 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3097 if (a
->expr
->expr_type
!= EXPR_NULL
3098 && compare_allocatable (f
->sym
, a
->expr
) == 0)
3101 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3102 f
->sym
->name
, &a
->expr
->where
);
3106 /* Check intent = OUT/INOUT for definable actual argument. */
3107 if ((f
->sym
->attr
.intent
== INTENT_OUT
3108 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3110 const char* context
= (where
3111 ? _("actual argument to INTENT = OUT/INOUT")
3114 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3115 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3116 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3117 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3119 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3123 if ((f
->sym
->attr
.intent
== INTENT_OUT
3124 || f
->sym
->attr
.intent
== INTENT_INOUT
3125 || f
->sym
->attr
.volatile_
3126 || f
->sym
->attr
.asynchronous
)
3127 && gfc_has_vector_subscript (a
->expr
))
3130 gfc_error ("Array-section actual argument with vector "
3131 "subscripts at %L is incompatible with INTENT(OUT), "
3132 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3133 "of the dummy argument %qs",
3134 &a
->expr
->where
, f
->sym
->name
);
3138 /* C1232 (R1221) For an actual argument which is an array section or
3139 an assumed-shape array, the dummy argument shall be an assumed-
3140 shape array, if the dummy argument has the VOLATILE attribute. */
3142 if (f
->sym
->attr
.volatile_
3143 && a
->expr
->symtree
->n
.sym
->as
3144 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3145 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3148 gfc_error ("Assumed-shape actual argument at %L is "
3149 "incompatible with the non-assumed-shape "
3150 "dummy argument %qs due to VOLATILE attribute",
3151 &a
->expr
->where
,f
->sym
->name
);
3155 if (f
->sym
->attr
.volatile_
3156 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
3157 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3160 gfc_error ("Array-section actual argument at %L is "
3161 "incompatible with the non-assumed-shape "
3162 "dummy argument %qs due to VOLATILE attribute",
3163 &a
->expr
->where
,f
->sym
->name
);
3167 /* C1233 (R1221) For an actual argument which is a pointer array, the
3168 dummy argument shall be an assumed-shape or pointer array, if the
3169 dummy argument has the VOLATILE attribute. */
3171 if (f
->sym
->attr
.volatile_
3172 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3173 && a
->expr
->symtree
->n
.sym
->as
3175 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3176 || f
->sym
->attr
.pointer
)))
3179 gfc_error ("Pointer-array actual argument at %L requires "
3180 "an assumed-shape or pointer-array dummy "
3181 "argument %qs due to VOLATILE attribute",
3182 &a
->expr
->where
,f
->sym
->name
);
3193 /* Make sure missing actual arguments are optional. */
3195 for (f
= formal
; f
; f
= f
->next
, i
++)
3197 if (new_arg
[i
] != NULL
)
3202 gfc_error ("Missing alternate return spec in subroutine call "
3206 if (!f
->sym
->attr
.optional
)
3209 gfc_error ("Missing actual argument for argument %qs at %L",
3210 f
->sym
->name
, where
);
3215 /* The argument lists are compatible. We now relink a new actual
3216 argument list with null arguments in the right places. The head
3217 of the list remains the head. */
3218 for (i
= 0; i
< n
; i
++)
3219 if (new_arg
[i
] == NULL
)
3220 new_arg
[i
] = gfc_get_actual_arglist ();
3224 std::swap (*new_arg
[0], *actual
);
3225 std::swap (new_arg
[0], new_arg
[na
]);
3228 for (i
= 0; i
< n
- 1; i
++)
3229 new_arg
[i
]->next
= new_arg
[i
+ 1];
3231 new_arg
[i
]->next
= NULL
;
3233 if (*ap
== NULL
&& n
> 0)
3236 /* Note the types of omitted optional arguments. */
3237 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3238 if (a
->expr
== NULL
&& a
->label
== NULL
)
3239 a
->missing_arg_type
= f
->sym
->ts
.type
;
3247 gfc_formal_arglist
*f
;
3248 gfc_actual_arglist
*a
;
3252 /* qsort comparison function for argument pairs, with the following
3254 - p->a->expr == NULL
3255 - p->a->expr->expr_type != EXPR_VARIABLE
3256 - growing p->a->expr->symbol. */
3259 pair_cmp (const void *p1
, const void *p2
)
3261 const gfc_actual_arglist
*a1
, *a2
;
3263 /* *p1 and *p2 are elements of the to-be-sorted array. */
3264 a1
= ((const argpair
*) p1
)->a
;
3265 a2
= ((const argpair
*) p2
)->a
;
3274 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3276 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3280 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3282 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3286 /* Given two expressions from some actual arguments, test whether they
3287 refer to the same expression. The analysis is conservative.
3288 Returning false will produce no warning. */
3291 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3293 const gfc_ref
*r1
, *r2
;
3296 || e1
->expr_type
!= EXPR_VARIABLE
3297 || e2
->expr_type
!= EXPR_VARIABLE
3298 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3301 /* TODO: improve comparison, see expr.c:show_ref(). */
3302 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3304 if (r1
->type
!= r2
->type
)
3309 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3311 /* TODO: At the moment, consider only full arrays;
3312 we could do better. */
3313 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3318 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3326 gfc_internal_error ("compare_actual_expr(): Bad component code");
3335 /* Given formal and actual argument lists that correspond to one
3336 another, check that identical actual arguments aren't not
3337 associated with some incompatible INTENTs. */
3340 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3342 sym_intent f1_intent
, f2_intent
;
3343 gfc_formal_arglist
*f1
;
3344 gfc_actual_arglist
*a1
;
3350 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3352 if (f1
== NULL
&& a1
== NULL
)
3354 if (f1
== NULL
|| a1
== NULL
)
3355 gfc_internal_error ("check_some_aliasing(): List mismatch");
3360 p
= XALLOCAVEC (argpair
, n
);
3362 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3368 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3370 for (i
= 0; i
< n
; i
++)
3373 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3374 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3376 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3377 for (j
= i
+ 1; j
< n
; j
++)
3379 /* Expected order after the sort. */
3380 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3381 gfc_internal_error ("check_some_aliasing(): corrupted data");
3383 /* Are the expression the same? */
3384 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3386 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3387 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3388 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3389 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3391 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3392 "argument %qs and INTENT(%s) argument %qs at %L",
3393 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3394 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3395 &p
[i
].a
->expr
->where
);
3405 /* Given formal and actual argument lists that correspond to one
3406 another, check that they are compatible in the sense that intents
3407 are not mismatched. */
3410 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3412 sym_intent f_intent
;
3414 for (;; f
= f
->next
, a
= a
->next
)
3418 if (f
== NULL
&& a
== NULL
)
3420 if (f
== NULL
|| a
== NULL
)
3421 gfc_internal_error ("check_intents(): List mismatch");
3423 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3424 && a
->expr
->value
.function
.isym
3425 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3426 expr
= a
->expr
->value
.function
.actual
->expr
;
3430 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3433 f_intent
= f
->sym
->attr
.intent
;
3435 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3437 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3438 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3439 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3441 gfc_error ("Procedure argument at %L is local to a PURE "
3442 "procedure and has the POINTER attribute",
3448 /* Fortran 2008, C1283. */
3449 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3451 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3453 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3454 "is passed to an INTENT(%s) argument",
3455 &expr
->where
, gfc_intent_string (f_intent
));
3459 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3460 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3461 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3463 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3464 "is passed to a POINTER dummy argument",
3470 /* F2008, Section 12.5.2.4. */
3471 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3472 && gfc_is_coindexed (expr
))
3474 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3475 "polymorphic dummy argument %qs",
3476 &expr
->where
, f
->sym
->name
);
3485 /* Check how a procedure is used against its interface. If all goes
3486 well, the actual argument list will also end up being properly
3490 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3492 gfc_formal_arglist
*dummy_args
;
3494 /* Warn about calls with an implicit interface. Special case
3495 for calling a ISO_C_BINDING because c_loc and c_funloc
3496 are pseudo-unknown. Additionally, warn about procedures not
3497 explicitly declared at all if requested. */
3498 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3500 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3502 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3506 if (warn_implicit_interface
)
3507 gfc_warning (OPT_Wimplicit_interface
,
3508 "Procedure %qs called with an implicit interface at %L",
3510 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3511 gfc_warning (OPT_Wimplicit_procedure
,
3512 "Procedure %qs called at %L is not explicitly declared",
3516 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3518 gfc_actual_arglist
*a
;
3520 if (sym
->attr
.pointer
)
3522 gfc_error ("The pointer object %qs at %L must have an explicit "
3523 "function interface or be declared as array",
3528 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3530 gfc_error ("The allocatable object %qs at %L must have an explicit "
3531 "function interface or be declared as array",
3536 if (sym
->attr
.allocatable
)
3538 gfc_error ("Allocatable function %qs at %L must have an explicit "
3539 "function interface", sym
->name
, where
);
3543 for (a
= *ap
; a
; a
= a
->next
)
3545 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3546 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3548 gfc_error ("Keyword argument requires explicit interface "
3549 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3553 /* TS 29113, 6.2. */
3554 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3555 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3557 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3558 "interface", a
->expr
->symtree
->n
.sym
->name
,
3563 /* F2008, C1303 and C1304. */
3565 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3566 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3567 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3568 || gfc_expr_attr (a
->expr
).lock_comp
))
3570 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3571 "component at %L requires an explicit interface for "
3572 "procedure %qs", &a
->expr
->where
, sym
->name
);
3577 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3578 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3579 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3580 == ISOFORTRAN_EVENT_TYPE
)
3581 || gfc_expr_attr (a
->expr
).event_comp
))
3583 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3584 "component at %L requires an explicit interface for "
3585 "procedure %qs", &a
->expr
->where
, sym
->name
);
3589 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3590 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3592 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3596 /* TS 29113, C407b. */
3597 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3598 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3600 gfc_error ("Assumed-rank argument requires an explicit interface "
3601 "at %L", &a
->expr
->where
);
3609 dummy_args
= gfc_sym_get_dummy_args (sym
);
3611 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3614 if (!check_intents (dummy_args
, *ap
))
3618 check_some_aliasing (dummy_args
, *ap
);
3624 /* Check how a procedure pointer component is used against its interface.
3625 If all goes well, the actual argument list will also end up being properly
3626 sorted. Completely analogous to gfc_procedure_use. */
3629 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3631 /* Warn about calls with an implicit interface. Special case
3632 for calling a ISO_C_BINDING because c_loc and c_funloc
3633 are pseudo-unknown. */
3634 if (warn_implicit_interface
3635 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3636 && !comp
->attr
.is_iso_c
)
3637 gfc_warning (OPT_Wimplicit_interface
,
3638 "Procedure pointer component %qs called with an implicit "
3639 "interface at %L", comp
->name
, where
);
3641 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3643 gfc_actual_arglist
*a
;
3644 for (a
= *ap
; a
; a
= a
->next
)
3646 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3647 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3649 gfc_error ("Keyword argument requires explicit interface "
3650 "for procedure pointer component %qs at %L",
3651 comp
->name
, &a
->expr
->where
);
3659 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3660 comp
->attr
.elemental
, where
))
3663 check_intents (comp
->ts
.interface
->formal
, *ap
);
3665 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3669 /* Try if an actual argument list matches the formal list of a symbol,
3670 respecting the symbol's attributes like ELEMENTAL. This is used for
3671 GENERIC resolution. */
3674 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3676 gfc_formal_arglist
*dummy_args
;
3679 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3682 dummy_args
= gfc_sym_get_dummy_args (sym
);
3684 r
= !sym
->attr
.elemental
;
3685 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3687 check_intents (dummy_args
, *args
);
3689 check_some_aliasing (dummy_args
, *args
);
3697 /* Given an interface pointer and an actual argument list, search for
3698 a formal argument list that matches the actual. If found, returns
3699 a pointer to the symbol of the correct interface. Returns NULL if
3703 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3704 gfc_actual_arglist
**ap
)
3706 gfc_symbol
*elem_sym
= NULL
;
3707 gfc_symbol
*null_sym
= NULL
;
3708 locus null_expr_loc
;
3709 gfc_actual_arglist
*a
;
3710 bool has_null_arg
= false;
3712 for (a
= *ap
; a
; a
= a
->next
)
3713 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3714 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3716 has_null_arg
= true;
3717 null_expr_loc
= a
->expr
->where
;
3721 for (; intr
; intr
= intr
->next
)
3723 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3725 if (sub_flag
&& intr
->sym
->attr
.function
)
3727 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3730 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3732 if (has_null_arg
&& null_sym
)
3734 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3735 "between specific functions %s and %s",
3736 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3739 else if (has_null_arg
)
3741 null_sym
= intr
->sym
;
3745 /* Satisfy 12.4.4.1 such that an elemental match has lower
3746 weight than a non-elemental match. */
3747 if (intr
->sym
->attr
.elemental
)
3749 elem_sym
= intr
->sym
;
3759 return elem_sym
? elem_sym
: NULL
;
3763 /* Do a brute force recursive search for a symbol. */
3765 static gfc_symtree
*
3766 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3770 if (root
->n
.sym
== sym
)
3775 st
= find_symtree0 (root
->left
, sym
);
3776 if (root
->right
&& ! st
)
3777 st
= find_symtree0 (root
->right
, sym
);
3782 /* Find a symtree for a symbol. */
3785 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3790 /* First try to find it by name. */
3791 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3792 if (st
&& st
->n
.sym
== sym
)
3795 /* If it's been renamed, resort to a brute-force search. */
3796 /* TODO: avoid having to do this search. If the symbol doesn't exist
3797 in the symtree for the current namespace, it should probably be added. */
3798 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3800 st
= find_symtree0 (ns
->sym_root
, sym
);
3804 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3809 /* See if the arglist to an operator-call contains a derived-type argument
3810 with a matching type-bound operator. If so, return the matching specific
3811 procedure defined as operator-target as well as the base-object to use
3812 (which is the found derived-type argument with operator). The generic
3813 name, if any, is transmitted to the final expression via 'gname'. */
3815 static gfc_typebound_proc
*
3816 matching_typebound_op (gfc_expr
** tb_base
,
3817 gfc_actual_arglist
* args
,
3818 gfc_intrinsic_op op
, const char* uop
,
3819 const char ** gname
)
3821 gfc_actual_arglist
* base
;
3823 for (base
= args
; base
; base
= base
->next
)
3824 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3826 gfc_typebound_proc
* tb
;
3827 gfc_symbol
* derived
;
3830 while (base
->expr
->expr_type
== EXPR_OP
3831 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3832 base
->expr
= base
->expr
->value
.op
.op1
;
3834 if (base
->expr
->ts
.type
== BT_CLASS
)
3836 if (CLASS_DATA (base
->expr
) == NULL
3837 || !gfc_expr_attr (base
->expr
).class_ok
)
3839 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3842 derived
= base
->expr
->ts
.u
.derived
;
3844 if (op
== INTRINSIC_USER
)
3846 gfc_symtree
* tb_uop
;
3849 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3858 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3861 /* This means we hit a PRIVATE operator which is use-associated and
3862 should thus not be seen. */
3866 /* Look through the super-type hierarchy for a matching specific
3868 for (; tb
; tb
= tb
->overridden
)
3872 gcc_assert (tb
->is_generic
);
3873 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3876 gfc_actual_arglist
* argcopy
;
3879 gcc_assert (g
->specific
);
3880 if (g
->specific
->error
)
3883 target
= g
->specific
->u
.specific
->n
.sym
;
3885 /* Check if this arglist matches the formal. */
3886 argcopy
= gfc_copy_actual_arglist (args
);
3887 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3888 gfc_free_actual_arglist (argcopy
);
3890 /* Return if we found a match. */
3893 *tb_base
= base
->expr
;
3894 *gname
= g
->specific_st
->name
;
3905 /* For the 'actual arglist' of an operator call and a specific typebound
3906 procedure that has been found the target of a type-bound operator, build the
3907 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3908 type-bound procedures rather than resolving type-bound operators 'directly'
3909 so that we can reuse the existing logic. */
3912 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3913 gfc_expr
* base
, gfc_typebound_proc
* target
,
3916 e
->expr_type
= EXPR_COMPCALL
;
3917 e
->value
.compcall
.tbp
= target
;
3918 e
->value
.compcall
.name
= gname
? gname
: "$op";
3919 e
->value
.compcall
.actual
= actual
;
3920 e
->value
.compcall
.base_object
= base
;
3921 e
->value
.compcall
.ignore_pass
= 1;
3922 e
->value
.compcall
.assign
= 0;
3923 if (e
->ts
.type
== BT_UNKNOWN
3924 && target
->function
)
3926 if (target
->is_generic
)
3927 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3929 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3934 /* This subroutine is called when an expression is being resolved.
3935 The expression node in question is either a user defined operator
3936 or an intrinsic operator with arguments that aren't compatible
3937 with the operator. This subroutine builds an actual argument list
3938 corresponding to the operands, then searches for a compatible
3939 interface. If one is found, the expression node is replaced with
3940 the appropriate function call. We use the 'match' enum to specify
3941 whether a replacement has been made or not, or if an error occurred. */
3944 gfc_extend_expr (gfc_expr
*e
)
3946 gfc_actual_arglist
*actual
;
3952 gfc_typebound_proc
* tbo
;
3957 actual
= gfc_get_actual_arglist ();
3958 actual
->expr
= e
->value
.op
.op1
;
3962 if (e
->value
.op
.op2
!= NULL
)
3964 actual
->next
= gfc_get_actual_arglist ();
3965 actual
->next
->expr
= e
->value
.op
.op2
;
3968 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3970 /* See if we find a matching type-bound operator. */
3971 if (i
== INTRINSIC_USER
)
3972 tbo
= matching_typebound_op (&tb_base
, actual
,
3973 i
, e
->value
.op
.uop
->name
, &gname
);
3977 #define CHECK_OS_COMPARISON(comp) \
3978 case INTRINSIC_##comp: \
3979 case INTRINSIC_##comp##_OS: \
3980 tbo = matching_typebound_op (&tb_base, actual, \
3981 INTRINSIC_##comp, NULL, &gname); \
3983 tbo = matching_typebound_op (&tb_base, actual, \
3984 INTRINSIC_##comp##_OS, NULL, &gname); \
3986 CHECK_OS_COMPARISON(EQ
)
3987 CHECK_OS_COMPARISON(NE
)
3988 CHECK_OS_COMPARISON(GT
)
3989 CHECK_OS_COMPARISON(GE
)
3990 CHECK_OS_COMPARISON(LT
)
3991 CHECK_OS_COMPARISON(LE
)
3992 #undef CHECK_OS_COMPARISON
3995 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3999 /* If there is a matching typebound-operator, replace the expression with
4000 a call to it and succeed. */
4003 gcc_assert (tb_base
);
4004 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4006 if (!gfc_resolve_expr (e
))
4012 if (i
== INTRINSIC_USER
)
4014 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4016 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4020 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4027 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4029 /* Due to the distinction between '==' and '.eq.' and friends, one has
4030 to check if either is defined. */
4033 #define CHECK_OS_COMPARISON(comp) \
4034 case INTRINSIC_##comp: \
4035 case INTRINSIC_##comp##_OS: \
4036 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4038 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4040 CHECK_OS_COMPARISON(EQ
)
4041 CHECK_OS_COMPARISON(NE
)
4042 CHECK_OS_COMPARISON(GT
)
4043 CHECK_OS_COMPARISON(GE
)
4044 CHECK_OS_COMPARISON(LT
)
4045 CHECK_OS_COMPARISON(LE
)
4046 #undef CHECK_OS_COMPARISON
4049 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4057 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4058 found rather than just taking the first one and not checking further. */
4062 /* Don't use gfc_free_actual_arglist(). */
4063 free (actual
->next
);
4068 /* Change the expression node to a function call. */
4069 e
->expr_type
= EXPR_FUNCTION
;
4070 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4071 e
->value
.function
.actual
= actual
;
4072 e
->value
.function
.esym
= NULL
;
4073 e
->value
.function
.isym
= NULL
;
4074 e
->value
.function
.name
= NULL
;
4075 e
->user_operator
= 1;
4077 if (!gfc_resolve_expr (e
))
4084 /* Tries to replace an assignment code node with a subroutine call to the
4085 subroutine associated with the assignment operator. Return true if the node
4086 was replaced. On false, no error is generated. */
4089 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4091 gfc_actual_arglist
*actual
;
4092 gfc_expr
*lhs
, *rhs
, *tb_base
;
4093 gfc_symbol
*sym
= NULL
;
4094 const char *gname
= NULL
;
4095 gfc_typebound_proc
* tbo
;
4100 /* Don't allow an intrinsic assignment to be replaced. */
4101 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4102 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4103 && (lhs
->ts
.type
== rhs
->ts
.type
4104 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4107 actual
= gfc_get_actual_arglist ();
4110 actual
->next
= gfc_get_actual_arglist ();
4111 actual
->next
->expr
= rhs
;
4113 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4115 /* See if we find a matching type-bound assignment. */
4116 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4121 /* Success: Replace the expression with a type-bound call. */
4122 gcc_assert (tb_base
);
4123 c
->expr1
= gfc_get_expr ();
4124 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4125 c
->expr1
->value
.compcall
.assign
= 1;
4126 c
->expr1
->where
= c
->loc
;
4128 c
->op
= EXEC_COMPCALL
;
4132 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4133 for (; ns
; ns
= ns
->parent
)
4135 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4142 /* Success: Replace the assignment with the call. */
4143 c
->op
= EXEC_ASSIGN_CALL
;
4144 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4147 c
->ext
.actual
= actual
;
4151 /* Failure: No assignment procedure found. */
4152 free (actual
->next
);
4158 /* Make sure that the interface just parsed is not already present in
4159 the given interface list. Ambiguity isn't checked yet since module
4160 procedures can be present without interfaces. */
4163 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4167 for (ip
= base
; ip
; ip
= ip
->next
)
4169 if (ip
->sym
== new_sym
)
4171 gfc_error ("Entity %qs at %L is already present in the interface",
4172 new_sym
->name
, &loc
);
4181 /* Add a symbol to the current interface. */
4184 gfc_add_interface (gfc_symbol
*new_sym
)
4186 gfc_interface
**head
, *intr
;
4190 switch (current_interface
.type
)
4192 case INTERFACE_NAMELESS
:
4193 case INTERFACE_ABSTRACT
:
4196 case INTERFACE_INTRINSIC_OP
:
4197 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4198 switch (current_interface
.op
)
4201 case INTRINSIC_EQ_OS
:
4202 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4204 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4205 new_sym
, gfc_current_locus
))
4210 case INTRINSIC_NE_OS
:
4211 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4213 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4214 new_sym
, gfc_current_locus
))
4219 case INTRINSIC_GT_OS
:
4220 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4221 new_sym
, gfc_current_locus
)
4222 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4223 new_sym
, gfc_current_locus
))
4228 case INTRINSIC_GE_OS
:
4229 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4230 new_sym
, gfc_current_locus
)
4231 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4232 new_sym
, gfc_current_locus
))
4237 case INTRINSIC_LT_OS
:
4238 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4239 new_sym
, gfc_current_locus
)
4240 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4241 new_sym
, gfc_current_locus
))
4246 case INTRINSIC_LE_OS
:
4247 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4248 new_sym
, gfc_current_locus
)
4249 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4250 new_sym
, gfc_current_locus
))
4255 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4256 new_sym
, gfc_current_locus
))
4260 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4263 case INTERFACE_GENERIC
:
4264 case INTERFACE_DTIO
:
4265 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4267 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4271 if (!gfc_check_new_interface (sym
->generic
,
4272 new_sym
, gfc_current_locus
))
4276 head
= ¤t_interface
.sym
->generic
;
4279 case INTERFACE_USER_OP
:
4280 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4281 new_sym
, gfc_current_locus
))
4284 head
= ¤t_interface
.uop
->op
;
4288 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4291 intr
= gfc_get_interface ();
4292 intr
->sym
= new_sym
;
4293 intr
->where
= gfc_current_locus
;
4303 gfc_current_interface_head (void)
4305 switch (current_interface
.type
)
4307 case INTERFACE_INTRINSIC_OP
:
4308 return current_interface
.ns
->op
[current_interface
.op
];
4311 case INTERFACE_GENERIC
:
4312 case INTERFACE_DTIO
:
4313 return current_interface
.sym
->generic
;
4316 case INTERFACE_USER_OP
:
4317 return current_interface
.uop
->op
;
4327 gfc_set_current_interface_head (gfc_interface
*i
)
4329 switch (current_interface
.type
)
4331 case INTERFACE_INTRINSIC_OP
:
4332 current_interface
.ns
->op
[current_interface
.op
] = i
;
4335 case INTERFACE_GENERIC
:
4336 case INTERFACE_DTIO
:
4337 current_interface
.sym
->generic
= i
;
4340 case INTERFACE_USER_OP
:
4341 current_interface
.uop
->op
= i
;
4350 /* Gets rid of a formal argument list. We do not free symbols.
4351 Symbols are freed when a namespace is freed. */
4354 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4356 gfc_formal_arglist
*q
;
4366 /* Check that it is ok for the type-bound procedure 'proc' to override the
4367 procedure 'old', cf. F08:4.5.7.3. */
4370 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4373 gfc_symbol
*proc_target
, *old_target
;
4374 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4375 gfc_formal_arglist
*proc_formal
, *old_formal
;
4379 /* This procedure should only be called for non-GENERIC proc. */
4380 gcc_assert (!proc
->n
.tb
->is_generic
);
4382 /* If the overwritten procedure is GENERIC, this is an error. */
4383 if (old
->n
.tb
->is_generic
)
4385 gfc_error ("Can't overwrite GENERIC %qs at %L",
4386 old
->name
, &proc
->n
.tb
->where
);
4390 where
= proc
->n
.tb
->where
;
4391 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4392 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4394 /* Check that overridden binding is not NON_OVERRIDABLE. */
4395 if (old
->n
.tb
->non_overridable
)
4397 gfc_error ("%qs at %L overrides a procedure binding declared"
4398 " NON_OVERRIDABLE", proc
->name
, &where
);
4402 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4403 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4405 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4406 " non-DEFERRED binding", proc
->name
, &where
);
4410 /* If the overridden binding is PURE, the overriding must be, too. */
4411 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4413 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4414 proc
->name
, &where
);
4418 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4419 is not, the overriding must not be either. */
4420 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4422 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4423 " ELEMENTAL", proc
->name
, &where
);
4426 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4428 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4429 " be ELEMENTAL, either", proc
->name
, &where
);
4433 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4435 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4437 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4438 " SUBROUTINE", proc
->name
, &where
);
4442 /* If the overridden binding is a FUNCTION, the overriding must also be a
4443 FUNCTION and have the same characteristics. */
4444 if (old_target
->attr
.function
)
4446 if (!proc_target
->attr
.function
)
4448 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4449 " FUNCTION", proc
->name
, &where
);
4453 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4456 gfc_error ("Result mismatch for the overriding procedure "
4457 "%qs at %L: %s", proc
->name
, &where
, err
);
4462 /* If the overridden binding is PUBLIC, the overriding one must not be
4464 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4465 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4467 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4468 " PRIVATE", proc
->name
, &where
);
4472 /* Compare the formal argument lists of both procedures. This is also abused
4473 to find the position of the passed-object dummy arguments of both
4474 bindings as at least the overridden one might not yet be resolved and we
4475 need those positions in the check below. */
4476 proc_pass_arg
= old_pass_arg
= 0;
4477 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4479 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4482 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4483 old_formal
= gfc_sym_get_dummy_args (old_target
);
4484 for ( ; proc_formal
&& old_formal
;
4485 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4487 if (proc
->n
.tb
->pass_arg
4488 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4489 proc_pass_arg
= argpos
;
4490 if (old
->n
.tb
->pass_arg
4491 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4492 old_pass_arg
= argpos
;
4494 /* Check that the names correspond. */
4495 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4497 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4498 " to match the corresponding argument of the overridden"
4499 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4500 old_formal
->sym
->name
);
4504 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4505 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4506 check_type
, err
, sizeof(err
)))
4508 gfc_error ("Argument mismatch for the overriding procedure "
4509 "%qs at %L: %s", proc
->name
, &where
, err
);
4515 if (proc_formal
|| old_formal
)
4517 gfc_error ("%qs at %L must have the same number of formal arguments as"
4518 " the overridden procedure", proc
->name
, &where
);
4522 /* If the overridden binding is NOPASS, the overriding one must also be
4524 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4526 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4527 " NOPASS", proc
->name
, &where
);
4531 /* If the overridden binding is PASS(x), the overriding one must also be
4532 PASS and the passed-object dummy arguments must correspond. */
4533 if (!old
->n
.tb
->nopass
)
4535 if (proc
->n
.tb
->nopass
)
4537 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4538 " PASS", proc
->name
, &where
);
4542 if (proc_pass_arg
!= old_pass_arg
)
4544 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4545 " the same position as the passed-object dummy argument of"
4546 " the overridden procedure", proc
->name
, &where
);
4555 /* The following three functions check that the formal arguments
4556 of user defined derived type IO procedures are compliant with
4557 the requirements of the standard. */
4560 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4561 int kind
, int rank
, sym_intent intent
)
4563 if (fsym
->ts
.type
!= type
)
4565 gfc_error ("DTIO dummy argument at %L must be of type %s",
4566 &fsym
->declared_at
, gfc_basic_typename (type
));
4570 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4571 && fsym
->ts
.kind
!= kind
)
4572 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4573 &fsym
->declared_at
, kind
);
4577 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4578 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4579 gfc_error ("DTIO dummy argument at %L be a scalar",
4580 &fsym
->declared_at
);
4582 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4583 gfc_error ("DTIO dummy argument at %L must be an "
4584 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4586 if (fsym
->attr
.intent
!= intent
)
4587 gfc_error ("DTIO dummy argument at %L must have intent %s",
4588 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4594 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4595 bool typebound
, bool formatted
, int code
)
4597 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4598 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4599 gfc_interface
*intr
;
4600 gfc_formal_arglist
*formal
;
4603 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4604 || ((dtio_codes
)code
== DTIO_RUF
);
4612 /* Typebound DTIO binding. */
4613 tb_io_proc
= tb_io_st
->n
.tb
;
4614 if (tb_io_proc
== NULL
)
4617 gcc_assert (tb_io_proc
->is_generic
);
4618 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4620 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4621 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4624 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4628 generic_proc
= tb_io_st
->n
.sym
;
4629 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4632 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4634 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4635 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4636 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4638 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4639 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4641 dtio_sub
= intr
->sym
;
4644 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4646 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4647 "procedure", &intr
->sym
->declared_at
);
4652 if (dtio_sub
== NULL
)
4656 gcc_assert (dtio_sub
);
4657 if (!dtio_sub
->attr
.subroutine
)
4658 gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
4659 dtio_sub
->name
, &dtio_sub
->declared_at
);
4662 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4665 if (arg_num
< (formatted
? 6 : 4))
4667 gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
4668 dtio_sub
->name
, &dtio_sub
->declared_at
);
4672 if (arg_num
> (formatted
? 6 : 4))
4674 gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
4675 dtio_sub
->name
, &dtio_sub
->declared_at
);
4680 /* Now go through the formal arglist. */
4682 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4684 if (!formatted
&& arg_num
== 3)
4690 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4691 "procedure", &dtio_sub
->declared_at
);
4698 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4699 BT_DERIVED
: BT_CLASS
;
4701 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4702 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4708 kind
= gfc_default_integer_kind
;
4710 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4713 case(3): /* IOTYPE */
4714 type
= BT_CHARACTER
;
4715 kind
= gfc_default_character_kind
;
4717 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4720 case(4): /* VLIST */
4722 kind
= gfc_default_integer_kind
;
4724 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4727 case(5): /* IOSTAT */
4729 kind
= gfc_default_integer_kind
;
4730 intent
= INTENT_OUT
;
4731 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4734 case(6): /* IOMSG */
4735 type
= BT_CHARACTER
;
4736 kind
= gfc_default_character_kind
;
4737 intent
= INTENT_INOUT
;
4738 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4745 derived
->attr
.has_dtio_procs
= 1;
4750 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4752 gfc_symtree
*tb_io_st
;
4757 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4760 /* Check typebound DTIO bindings. */
4761 for (code
= 0; code
< 4; code
++)
4763 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4764 || ((dtio_codes
)code
== DTIO_WF
);
4766 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4767 gfc_code2string (dtio_procs
, code
),
4768 true, &derived
->declared_at
);
4769 if (tb_io_st
!= NULL
)
4770 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4773 /* Check generic DTIO interfaces. */
4774 for (code
= 0; code
< 4; code
++)
4776 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4777 || ((dtio_codes
)code
== DTIO_WF
);
4779 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4780 gfc_code2string (dtio_procs
, code
));
4781 if (tb_io_st
!= NULL
)
4782 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4788 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4790 gfc_symtree
*tb_io_st
= NULL
;
4791 gfc_symbol
*dtio_sub
= NULL
;
4792 gfc_symbol
*extended
;
4793 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4796 /* Try to find a typebound DTIO binding. */
4797 if (formatted
== true)
4800 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4801 gfc_code2string (dtio_procs
,
4804 &derived
->declared_at
);
4806 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4807 gfc_code2string (dtio_procs
,
4810 &derived
->declared_at
);
4815 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4816 gfc_code2string (dtio_procs
,
4819 &derived
->declared_at
);
4821 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4822 gfc_code2string (dtio_procs
,
4825 &derived
->declared_at
);
4828 if (tb_io_st
!= NULL
)
4830 const char *genname
;
4833 tb_io_proc
= tb_io_st
->n
.tb
;
4834 gcc_assert (tb_io_proc
!= NULL
);
4835 gcc_assert (tb_io_proc
->is_generic
);
4836 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4838 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4839 gcc_assert (!specific_proc
->is_generic
);
4841 /* Go back and make sure that we have the right specific procedure.
4842 Here we most likely have a procedure from the parent type, which
4843 can be overridden in extensions. */
4844 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4845 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4846 true, &tb_io_proc
->where
);
4848 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4850 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4853 if (tb_io_st
!= NULL
)
4856 /* If there is not a typebound binding, look for a generic
4858 for (extended
= derived
; extended
;
4859 extended
= gfc_get_derived_super_type (extended
))
4861 if (extended
== NULL
|| extended
->ns
== NULL
)
4864 if (formatted
== true)
4867 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4868 gfc_code2string (dtio_procs
,
4871 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4872 gfc_code2string (dtio_procs
,
4878 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4879 gfc_code2string (dtio_procs
,
4882 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4883 gfc_code2string (dtio_procs
,
4887 if (tb_io_st
!= NULL
4889 && tb_io_st
->n
.sym
->generic
)
4891 gfc_interface
*intr
;
4892 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4894 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
4895 if (intr
->sym
&& intr
->sym
->formal
4896 && ((fsym
->ts
.type
== BT_CLASS
4897 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
4898 || (fsym
->ts
.type
== BT_DERIVED
4899 && fsym
->ts
.u
.derived
== extended
)))
4901 dtio_sub
= intr
->sym
;
4909 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
4910 gfc_find_derived_vtab (derived
);