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
;
529 gfc_symbol
*map1_t
, *map2_t
;
531 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
534 if (un1
->attr
.zero_comp
!= un2
->attr
.zero_comp
)
537 if (un1
->attr
.zero_comp
)
540 map1
= un1
->components
;
541 map2
= un2
->components
;
543 /* In terms of 'equality' here we are worried about types which are
544 declared the same in two places, not types that represent equivalent
545 structures. (This is common because of FORTRAN's weird scoping rules.)
546 Though two unions with their maps in different orders could be equivalent,
547 we will say they are not equal for the purposes of this test; therefore
548 we compare the maps sequentially. */
551 map1_t
= map1
->ts
.u
.derived
;
552 map2_t
= map2
->ts
.u
.derived
;
554 cmp1
= map1_t
->components
;
555 cmp2
= map2_t
->components
;
557 /* Protect against null components. */
558 if (map1_t
->attr
.zero_comp
!= map2_t
->attr
.zero_comp
)
561 if (map1_t
->attr
.zero_comp
)
566 /* No two fields will ever point to the same map type unless they are
567 the same component, because one map field is created with its type
568 declaration. Therefore don't worry about recursion here. */
569 /* TODO: worry about recursion into parent types of the unions? */
570 if (compare_components (cmp1
, cmp2
, map1_t
, map2_t
) == 0)
576 if (cmp1
== NULL
&& cmp2
== NULL
)
578 if (cmp1
== NULL
|| cmp2
== NULL
)
585 if (map1
== NULL
&& map2
== NULL
)
587 if (map1
== NULL
|| map2
== NULL
)
596 /* Compare two derived types using the criteria in 4.4.2 of the standard,
597 recursing through gfc_compare_types for the components. */
600 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
602 gfc_component
*cmp1
, *cmp2
;
604 if (derived1
== derived2
)
607 gcc_assert (derived1
&& derived2
);
609 /* Compare UNION types specially. */
610 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
611 return gfc_compare_union_types (derived1
, derived2
);
613 /* Special case for comparing derived types across namespaces. If the
614 true names and module names are the same and the module name is
615 nonnull, then they are equal. */
616 if (strcmp (derived1
->name
, derived2
->name
) == 0
617 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
618 && strcmp (derived1
->module
, derived2
->module
) == 0)
621 /* Compare type via the rules of the standard. Both types must have
622 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
623 because they can be anonymous; therefore two structures with different
624 names may be equal. */
626 /* Compare names, but not for anonymous types such as UNION or MAP. */
627 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
628 && strcmp (derived1
->name
, derived2
->name
) != 0)
631 if (derived1
->component_access
== ACCESS_PRIVATE
632 || derived2
->component_access
== ACCESS_PRIVATE
)
635 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
636 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
639 /* Protect against null components. */
640 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
643 if (derived1
->attr
.zero_comp
)
646 cmp1
= derived1
->components
;
647 cmp2
= derived2
->components
;
649 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
650 simple test can speed things up. Otherwise, lots of things have to
654 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
660 if (cmp1
== NULL
&& cmp2
== NULL
)
662 if (cmp1
== NULL
|| cmp2
== NULL
)
670 /* Compare two typespecs, recursively if necessary. */
673 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
675 /* See if one of the typespecs is a BT_VOID, which is what is being used
676 to allow the funcs like c_f_pointer to accept any pointer type.
677 TODO: Possibly should narrow this to just the one typespec coming in
678 that is for the formal arg, but oh well. */
679 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
682 /* The _data component is not always present, therefore check for its
683 presence before assuming, that its derived->attr is available.
684 When the _data component is not present, then nevertheless the
685 unlimited_polymorphic flag may be set in the derived type's attr. */
686 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
687 && ((ts1
->u
.derived
->attr
.is_class
688 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
689 .unlimited_polymorphic
)
690 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
694 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
695 && ts2
->u
.derived
->components
696 && ((ts2
->u
.derived
->attr
.is_class
697 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
698 .unlimited_polymorphic
)
699 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
700 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
703 if (ts1
->type
!= ts2
->type
704 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
705 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
708 if (ts1
->type
== BT_UNION
)
709 return gfc_compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
711 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
712 return (ts1
->kind
== ts2
->kind
);
714 /* Compare derived types. */
715 return gfc_type_compatible (ts1
, ts2
);
720 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
722 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
725 /* TYPE and CLASS of the same declared type are type compatible,
726 but have different characteristics. */
727 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
728 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
731 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
736 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
738 gfc_array_spec
*as1
, *as2
;
741 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
744 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
745 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
747 r1
= as1
? as1
->rank
: 0;
748 r2
= as2
? as2
->rank
: 0;
750 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
751 return 0; /* Ranks differ. */
757 /* Given two symbols that are formal arguments, compare their ranks
758 and types. Returns nonzero if they have the same rank and type,
762 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
764 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
768 /* Given two symbols that are formal arguments, compare their types
769 and rank and their formal interfaces if they are both dummy
770 procedures. Returns nonzero if the same, zero if different. */
773 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
775 if (s1
== NULL
|| s2
== NULL
)
776 return s1
== s2
? 1 : 0;
781 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
782 return compare_type_rank (s1
, s2
);
784 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
787 /* At this point, both symbols are procedures. It can happen that
788 external procedures are compared, where one is identified by usage
789 to be a function or subroutine but the other is not. Check TKR
790 nonetheless for these cases. */
791 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
792 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
794 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
795 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
797 /* Now the type of procedure has been identified. */
798 if (s1
->attr
.function
!= s2
->attr
.function
799 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
802 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
805 /* Originally, gfortran recursed here to check the interfaces of passed
806 procedures. This is explicitly not required by the standard. */
811 /* Given a formal argument list and a keyword name, search the list
812 for that keyword. Returns the correct symbol node if found, NULL
816 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
818 for (; f
; f
= f
->next
)
819 if (strcmp (f
->sym
->name
, name
) == 0)
826 /******** Interface checking subroutines **********/
829 /* Given an operator interface and the operator, make sure that all
830 interfaces for that operator are legal. */
833 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
836 gfc_formal_arglist
*formal
;
839 int args
, r1
, r2
, k1
, k2
;
844 t1
= t2
= BT_UNKNOWN
;
845 i1
= i2
= INTENT_UNKNOWN
;
849 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
851 gfc_symbol
*fsym
= formal
->sym
;
854 gfc_error ("Alternate return cannot appear in operator "
855 "interface at %L", &sym
->declared_at
);
861 i1
= fsym
->attr
.intent
;
862 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
868 i2
= fsym
->attr
.intent
;
869 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
875 /* Only +, - and .not. can be unary operators.
876 .not. cannot be a binary operator. */
877 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
878 && op
!= INTRINSIC_MINUS
879 && op
!= INTRINSIC_NOT
)
880 || (args
== 2 && op
== INTRINSIC_NOT
))
882 if (op
== INTRINSIC_ASSIGN
)
883 gfc_error ("Assignment operator interface at %L must have "
884 "two arguments", &sym
->declared_at
);
886 gfc_error ("Operator interface at %L has the wrong number of arguments",
891 /* Check that intrinsics are mapped to functions, except
892 INTRINSIC_ASSIGN which should map to a subroutine. */
893 if (op
== INTRINSIC_ASSIGN
)
895 gfc_formal_arglist
*dummy_args
;
897 if (!sym
->attr
.subroutine
)
899 gfc_error ("Assignment operator interface at %L must be "
900 "a SUBROUTINE", &sym
->declared_at
);
904 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
905 - First argument an array with different rank than second,
906 - First argument is a scalar and second an array,
907 - Types and kinds do not conform, or
908 - First argument is of derived type. */
909 dummy_args
= gfc_sym_get_dummy_args (sym
);
910 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
911 && dummy_args
->sym
->ts
.type
!= BT_CLASS
912 && (r2
== 0 || r1
== r2
)
913 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
914 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
915 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
917 gfc_error ("Assignment operator interface at %L must not redefine "
918 "an INTRINSIC type assignment", &sym
->declared_at
);
924 if (!sym
->attr
.function
)
926 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
932 /* Check intents on operator interfaces. */
933 if (op
== INTRINSIC_ASSIGN
)
935 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
937 gfc_error ("First argument of defined assignment at %L must be "
938 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
944 gfc_error ("Second argument of defined assignment at %L must be "
945 "INTENT(IN)", &sym
->declared_at
);
953 gfc_error ("First argument of operator interface at %L must be "
954 "INTENT(IN)", &sym
->declared_at
);
958 if (args
== 2 && i2
!= INTENT_IN
)
960 gfc_error ("Second argument of operator interface at %L must be "
961 "INTENT(IN)", &sym
->declared_at
);
966 /* From now on, all we have to do is check that the operator definition
967 doesn't conflict with an intrinsic operator. The rules for this
968 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
969 as well as 12.3.2.1.1 of Fortran 2003:
971 "If the operator is an intrinsic-operator (R310), the number of
972 function arguments shall be consistent with the intrinsic uses of
973 that operator, and the types, kind type parameters, or ranks of the
974 dummy arguments shall differ from those required for the intrinsic
975 operation (7.1.2)." */
977 #define IS_NUMERIC_TYPE(t) \
978 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
980 /* Unary ops are easy, do them first. */
981 if (op
== INTRINSIC_NOT
)
983 if (t1
== BT_LOGICAL
)
989 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
991 if (IS_NUMERIC_TYPE (t1
))
997 /* Character intrinsic operators have same character kind, thus
998 operator definitions with operands of different character kinds
1000 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1003 /* Intrinsic operators always perform on arguments of same rank,
1004 so different ranks is also always safe. (rank == 0) is an exception
1005 to that, because all intrinsic operators are elemental. */
1006 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1012 case INTRINSIC_EQ_OS
:
1014 case INTRINSIC_NE_OS
:
1015 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1019 case INTRINSIC_PLUS
:
1020 case INTRINSIC_MINUS
:
1021 case INTRINSIC_TIMES
:
1022 case INTRINSIC_DIVIDE
:
1023 case INTRINSIC_POWER
:
1024 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1029 case INTRINSIC_GT_OS
:
1031 case INTRINSIC_GE_OS
:
1033 case INTRINSIC_LT_OS
:
1035 case INTRINSIC_LE_OS
:
1036 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1038 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1039 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1043 case INTRINSIC_CONCAT
:
1044 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1051 case INTRINSIC_NEQV
:
1052 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1062 #undef IS_NUMERIC_TYPE
1065 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1071 /* Given a pair of formal argument lists, we see if the two lists can
1072 be distinguished by counting the number of nonoptional arguments of
1073 a given type/rank in f1 and seeing if there are less then that
1074 number of those arguments in f2 (including optional arguments).
1075 Since this test is asymmetric, it has to be called twice to make it
1076 symmetric. Returns nonzero if the argument lists are incompatible
1077 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1078 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1081 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1082 const char *p1
, const char *p2
)
1084 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
1085 gfc_formal_arglist
*f
;
1098 for (f
= f1
; f
; f
= f
->next
)
1101 /* Build an array of integers that gives the same integer to
1102 arguments of the same type/rank. */
1103 arg
= XCNEWVEC (arginfo
, n1
);
1106 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1109 arg
[i
].sym
= f
->sym
;
1114 for (i
= 0; i
< n1
; i
++)
1116 if (arg
[i
].flag
!= -1)
1119 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1120 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1121 continue; /* Skip OPTIONAL and PASS arguments. */
1125 /* Find other non-optional, non-pass arguments of the same type/rank. */
1126 for (j
= i
+ 1; j
< n1
; j
++)
1127 if ((arg
[j
].sym
== NULL
1128 || !(arg
[j
].sym
->attr
.optional
1129 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1130 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1131 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1137 /* Now loop over each distinct type found in f1. */
1141 for (i
= 0; i
< n1
; i
++)
1143 if (arg
[i
].flag
!= k
)
1147 for (j
= i
+ 1; j
< n1
; j
++)
1148 if (arg
[j
].flag
== k
)
1151 /* Count the number of non-pass arguments in f2 with that type,
1152 including those that are optional. */
1155 for (f
= f2
; f
; f
= f
->next
)
1156 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1157 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1158 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1176 /* Perform the correspondence test in rule (3) of F08:C1215.
1177 Returns zero if no argument is found that satisfies this rule,
1178 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1181 This test is also not symmetric in f1 and f2 and must be called
1182 twice. This test finds problems caused by sorting the actual
1183 argument list with keywords. For example:
1187 INTEGER :: A ; REAL :: B
1191 INTEGER :: A ; REAL :: B
1195 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1198 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1199 const char *p1
, const char *p2
)
1201 gfc_formal_arglist
*f2_save
, *g
;
1208 if (f1
->sym
->attr
.optional
)
1211 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1213 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1216 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1217 || compare_type_rank (f2
->sym
, f1
->sym
))
1218 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1219 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1220 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1223 /* Now search for a disambiguating keyword argument starting at
1224 the current non-match. */
1225 for (g
= f1
; g
; g
= g
->next
)
1227 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1230 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1231 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1232 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1233 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1234 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1250 symbol_rank (gfc_symbol
*sym
)
1253 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1254 return as
? as
->rank
: 0;
1258 /* Check if the characteristics of two dummy arguments match,
1262 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1263 bool type_must_agree
, char *errmsg
,
1266 if (s1
== NULL
|| s2
== NULL
)
1267 return s1
== s2
? true : false;
1269 /* Check type and rank. */
1270 if (type_must_agree
)
1272 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1274 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1275 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1278 if (!compare_rank (s1
, s2
))
1280 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1281 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1287 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1289 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1294 /* Check OPTIONAL attribute. */
1295 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1297 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1302 /* Check ALLOCATABLE attribute. */
1303 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1305 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1310 /* Check POINTER attribute. */
1311 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1313 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1318 /* Check TARGET attribute. */
1319 if (s1
->attr
.target
!= s2
->attr
.target
)
1321 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1326 /* Check ASYNCHRONOUS attribute. */
1327 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1329 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1334 /* Check CONTIGUOUS attribute. */
1335 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1337 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1342 /* Check VALUE attribute. */
1343 if (s1
->attr
.value
!= s2
->attr
.value
)
1345 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1350 /* Check VOLATILE attribute. */
1351 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1353 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1358 /* Check interface of dummy procedures. */
1359 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1362 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1365 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1366 "'%s': %s", s1
->name
, err
);
1371 /* Check string length. */
1372 if (s1
->ts
.type
== BT_CHARACTER
1373 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1374 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1376 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1377 s2
->ts
.u
.cl
->length
);
1383 snprintf (errmsg
, err_len
, "Character length mismatch "
1384 "in argument '%s'", s1
->name
);
1388 /* FIXME: Implement a warning for this case.
1389 gfc_warning (0, "Possible character length mismatch in argument %qs",
1397 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1398 "%i of gfc_dep_compare_expr", compval
);
1403 /* Check array shape. */
1404 if (s1
->as
&& s2
->as
)
1407 gfc_expr
*shape1
, *shape2
;
1409 if (s1
->as
->type
!= s2
->as
->type
)
1411 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1416 if (s1
->as
->corank
!= s2
->as
->corank
)
1418 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1419 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1423 if (s1
->as
->type
== AS_EXPLICIT
)
1424 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1426 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1427 gfc_copy_expr (s1
->as
->lower
[i
]));
1428 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1429 gfc_copy_expr (s2
->as
->lower
[i
]));
1430 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1431 gfc_free_expr (shape1
);
1432 gfc_free_expr (shape2
);
1438 if (i
< s1
->as
->rank
)
1439 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1440 " argument '%s'", i
+ 1, s1
->name
);
1442 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1443 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1447 /* FIXME: Implement a warning for this case.
1448 gfc_warning (0, "Possible shape mismatch in argument %qs",
1456 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1457 "result %i of gfc_dep_compare_expr",
1468 /* Check if the characteristics of two function results match,
1472 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1473 char *errmsg
, int err_len
)
1475 gfc_symbol
*r1
, *r2
;
1477 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1478 r1
= s1
->ts
.interface
->result
;
1480 r1
= s1
->result
? s1
->result
: s1
;
1482 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1483 r2
= s2
->ts
.interface
->result
;
1485 r2
= s2
->result
? s2
->result
: s2
;
1487 if (r1
->ts
.type
== BT_UNKNOWN
)
1490 /* Check type and rank. */
1491 if (!compare_type (r1
, r2
))
1493 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1494 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1497 if (!compare_rank (r1
, r2
))
1499 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1500 symbol_rank (r1
), symbol_rank (r2
));
1504 /* Check ALLOCATABLE attribute. */
1505 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1507 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1512 /* Check POINTER attribute. */
1513 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1515 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1520 /* Check CONTIGUOUS attribute. */
1521 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1523 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1528 /* Check PROCEDURE POINTER attribute. */
1529 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1531 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1536 /* Check string length. */
1537 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1539 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1541 snprintf (errmsg
, err_len
, "Character length mismatch "
1542 "in function result");
1546 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1548 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1549 r2
->ts
.u
.cl
->length
);
1555 snprintf (errmsg
, err_len
, "Character length mismatch "
1556 "in function result");
1560 /* FIXME: Implement a warning for this case.
1561 snprintf (errmsg, err_len, "Possible character length mismatch "
1562 "in function result");*/
1569 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1570 "result %i of gfc_dep_compare_expr", compval
);
1576 /* Check array shape. */
1577 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1580 gfc_expr
*shape1
, *shape2
;
1582 if (r1
->as
->type
!= r2
->as
->type
)
1584 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1588 if (r1
->as
->type
== AS_EXPLICIT
)
1589 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1591 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1592 gfc_copy_expr (r1
->as
->lower
[i
]));
1593 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1594 gfc_copy_expr (r2
->as
->lower
[i
]));
1595 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1596 gfc_free_expr (shape1
);
1597 gfc_free_expr (shape2
);
1603 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1604 "function result", i
+ 1);
1608 /* FIXME: Implement a warning for this case.
1609 gfc_warning (0, "Possible shape mismatch in return value");*/
1616 gfc_internal_error ("check_result_characteristics (2): "
1617 "Unexpected result %i of "
1618 "gfc_dep_compare_expr", compval
);
1628 /* 'Compare' two formal interfaces associated with a pair of symbols.
1629 We return nonzero if there exists an actual argument list that
1630 would be ambiguous between the two interfaces, zero otherwise.
1631 'strict_flag' specifies whether all the characteristics are
1632 required to match, which is not the case for ambiguity checks.
1633 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1636 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1637 int generic_flag
, int strict_flag
,
1638 char *errmsg
, int err_len
,
1639 const char *p1
, const char *p2
)
1641 gfc_formal_arglist
*f1
, *f2
;
1643 gcc_assert (name2
!= NULL
);
1645 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1646 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1647 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1650 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1654 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1657 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1661 /* Do strict checks on all characteristics
1662 (for dummy procedures and procedure pointer assignments). */
1663 if (!generic_flag
&& strict_flag
)
1665 if (s1
->attr
.function
&& s2
->attr
.function
)
1667 /* If both are functions, check result characteristics. */
1668 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1669 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1673 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1675 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1678 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1680 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1685 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1686 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1689 f1
= gfc_sym_get_dummy_args (s1
);
1690 f2
= gfc_sym_get_dummy_args (s2
);
1692 /* Special case: No arguments. */
1693 if (f1
== NULL
&& f2
== NULL
)
1698 if (count_types_test (f1
, f2
, p1
, p2
)
1699 || count_types_test (f2
, f1
, p2
, p1
))
1702 /* Special case: alternate returns. If both f1->sym and f2->sym are
1703 NULL, then the leading formal arguments are alternate returns.
1704 The previous conditional should catch argument lists with
1705 different number of argument. */
1706 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1709 if (generic_correspondence (f1
, f2
, p1
, p2
)
1710 || generic_correspondence (f2
, f1
, p2
, p1
))
1714 /* Perform the abbreviated correspondence test for operators (the
1715 arguments cannot be optional and are always ordered correctly).
1716 This is also done when comparing interfaces for dummy procedures and in
1717 procedure pointer assignments. */
1721 /* Check existence. */
1722 if (f1
== NULL
&& f2
== NULL
)
1724 if (f1
== NULL
|| f2
== NULL
)
1727 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1728 "arguments", name2
);
1732 if (UNLIMITED_POLY (f1
->sym
))
1737 /* Check all characteristics. */
1738 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1744 /* Only check type and rank. */
1745 if (!compare_type (f2
->sym
, f1
->sym
))
1748 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1749 "(%s/%s)", f1
->sym
->name
,
1750 gfc_typename (&f1
->sym
->ts
),
1751 gfc_typename (&f2
->sym
->ts
));
1754 if (!compare_rank (f2
->sym
, f1
->sym
))
1757 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1758 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1759 symbol_rank (f2
->sym
));
1772 /* Given a pointer to an interface pointer, remove duplicate
1773 interfaces and make sure that all symbols are either functions
1774 or subroutines, and all of the same kind. Returns nonzero if
1775 something goes wrong. */
1778 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1780 gfc_interface
*psave
, *q
, *qlast
;
1783 for (; p
; p
= p
->next
)
1785 /* Make sure all symbols in the interface have been defined as
1786 functions or subroutines. */
1787 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1788 || !p
->sym
->attr
.if_source
)
1789 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1791 if (p
->sym
->attr
.external
)
1792 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1793 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1795 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1796 "subroutine", p
->sym
->name
, interface_name
,
1797 &p
->sym
->declared_at
);
1801 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1802 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1803 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1804 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1806 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1807 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1808 " or all FUNCTIONs", interface_name
,
1809 &p
->sym
->declared_at
);
1810 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1811 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1812 "generic name is also the name of a derived type",
1813 interface_name
, &p
->sym
->declared_at
);
1817 /* F2003, C1207. F2008, C1207. */
1818 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1819 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1820 "%qs in %s at %L", p
->sym
->name
,
1821 interface_name
, &p
->sym
->declared_at
))
1826 /* Remove duplicate interfaces in this interface list. */
1827 for (; p
; p
= p
->next
)
1831 for (q
= p
->next
; q
;)
1833 if (p
->sym
!= q
->sym
)
1840 /* Duplicate interface. */
1841 qlast
->next
= q
->next
;
1852 /* Check lists of interfaces to make sure that no two interfaces are
1853 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1856 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1857 int generic_flag
, const char *interface_name
,
1861 for (; p
; p
= p
->next
)
1862 for (q
= q0
; q
; q
= q
->next
)
1864 if (p
->sym
== q
->sym
)
1865 continue; /* Duplicates OK here. */
1867 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1870 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1871 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1872 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1873 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1876 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1877 "and %qs at %L", interface_name
,
1878 q
->sym
->name
, &q
->sym
->declared_at
,
1879 p
->sym
->name
, &p
->sym
->declared_at
);
1880 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1881 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1882 "and %qs at %L", interface_name
,
1883 q
->sym
->name
, &q
->sym
->declared_at
,
1884 p
->sym
->name
, &p
->sym
->declared_at
);
1886 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1887 "interfaces at %L", interface_name
, &p
->where
);
1895 /* Check the generic and operator interfaces of symbols to make sure
1896 that none of the interfaces conflict. The check has to be done
1897 after all of the symbols are actually loaded. */
1900 check_sym_interfaces (gfc_symbol
*sym
)
1902 char interface_name
[100];
1905 if (sym
->ns
!= gfc_current_ns
)
1908 if (sym
->generic
!= NULL
)
1910 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1911 if (check_interface0 (sym
->generic
, interface_name
))
1914 for (p
= sym
->generic
; p
; p
= p
->next
)
1916 if (p
->sym
->attr
.mod_proc
1917 && !p
->sym
->attr
.module_procedure
1918 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1919 || p
->sym
->attr
.procedure
))
1921 gfc_error ("%qs at %L is not a module procedure",
1922 p
->sym
->name
, &p
->where
);
1927 /* Originally, this test was applied to host interfaces too;
1928 this is incorrect since host associated symbols, from any
1929 source, cannot be ambiguous with local symbols. */
1930 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1931 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1937 check_uop_interfaces (gfc_user_op
*uop
)
1939 char interface_name
[100];
1943 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1944 if (check_interface0 (uop
->op
, interface_name
))
1947 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1949 uop2
= gfc_find_uop (uop
->name
, ns
);
1953 check_interface1 (uop
->op
, uop2
->op
, 0,
1954 interface_name
, true);
1958 /* Given an intrinsic op, return an equivalent op if one exists,
1959 or INTRINSIC_NONE otherwise. */
1962 gfc_equivalent_op (gfc_intrinsic_op op
)
1967 return INTRINSIC_EQ_OS
;
1969 case INTRINSIC_EQ_OS
:
1970 return INTRINSIC_EQ
;
1973 return INTRINSIC_NE_OS
;
1975 case INTRINSIC_NE_OS
:
1976 return INTRINSIC_NE
;
1979 return INTRINSIC_GT_OS
;
1981 case INTRINSIC_GT_OS
:
1982 return INTRINSIC_GT
;
1985 return INTRINSIC_GE_OS
;
1987 case INTRINSIC_GE_OS
:
1988 return INTRINSIC_GE
;
1991 return INTRINSIC_LT_OS
;
1993 case INTRINSIC_LT_OS
:
1994 return INTRINSIC_LT
;
1997 return INTRINSIC_LE_OS
;
1999 case INTRINSIC_LE_OS
:
2000 return INTRINSIC_LE
;
2003 return INTRINSIC_NONE
;
2007 /* For the namespace, check generic, user operator and intrinsic
2008 operator interfaces for consistency and to remove duplicate
2009 interfaces. We traverse the whole namespace, counting on the fact
2010 that most symbols will not have generic or operator interfaces. */
2013 gfc_check_interfaces (gfc_namespace
*ns
)
2015 gfc_namespace
*old_ns
, *ns2
;
2016 char interface_name
[100];
2019 old_ns
= gfc_current_ns
;
2020 gfc_current_ns
= ns
;
2022 gfc_traverse_ns (ns
, check_sym_interfaces
);
2024 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2026 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2028 if (i
== INTRINSIC_USER
)
2031 if (i
== INTRINSIC_ASSIGN
)
2032 strcpy (interface_name
, "intrinsic assignment operator");
2034 sprintf (interface_name
, "intrinsic '%s' operator",
2035 gfc_op2string ((gfc_intrinsic_op
) i
));
2037 if (check_interface0 (ns
->op
[i
], interface_name
))
2041 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2044 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2046 gfc_intrinsic_op other_op
;
2048 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2049 interface_name
, true))
2052 /* i should be gfc_intrinsic_op, but has to be int with this cast
2053 here for stupid C++ compatibility rules. */
2054 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2055 if (other_op
!= INTRINSIC_NONE
2056 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2057 0, interface_name
, true))
2063 gfc_current_ns
= old_ns
;
2067 /* Given a symbol of a formal argument list and an expression, if the
2068 formal argument is allocatable, check that the actual argument is
2069 allocatable. Returns nonzero if compatible, zero if not compatible. */
2072 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2074 symbol_attribute attr
;
2076 if (formal
->attr
.allocatable
2077 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2079 attr
= gfc_expr_attr (actual
);
2080 if (!attr
.allocatable
)
2088 /* Given a symbol of a formal argument list and an expression, if the
2089 formal argument is a pointer, see if the actual argument is a
2090 pointer. Returns nonzero if compatible, zero if not compatible. */
2093 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2095 symbol_attribute attr
;
2097 if (formal
->attr
.pointer
2098 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2099 && CLASS_DATA (formal
)->attr
.class_pointer
))
2101 attr
= gfc_expr_attr (actual
);
2103 /* Fortran 2008 allows non-pointer actual arguments. */
2104 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2115 /* Emit clear error messages for rank mismatch. */
2118 argument_rank_mismatch (const char *name
, locus
*where
,
2119 int rank1
, int rank2
)
2122 /* TS 29113, C407b. */
2125 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2126 " %qs has assumed-rank", where
, name
);
2128 else if (rank1
== 0)
2130 gfc_error ("Rank mismatch in argument %qs at %L "
2131 "(scalar and rank-%d)", name
, where
, rank2
);
2133 else if (rank2
== 0)
2135 gfc_error ("Rank mismatch in argument %qs at %L "
2136 "(rank-%d and scalar)", name
, where
, rank1
);
2140 gfc_error ("Rank mismatch in argument %qs at %L "
2141 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2146 /* Given a symbol of a formal argument list and an expression, see if
2147 the two are compatible as arguments. Returns nonzero if
2148 compatible, zero if not compatible. */
2151 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2152 int ranks_must_agree
, int is_elemental
, locus
*where
)
2155 bool rank_check
, is_pointer
;
2159 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2160 procs c_f_pointer or c_f_procpointer, and we need to accept most
2161 pointers the user could give us. This should allow that. */
2162 if (formal
->ts
.type
== BT_VOID
)
2165 if (formal
->ts
.type
== BT_DERIVED
2166 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2167 && actual
->ts
.type
== BT_DERIVED
2168 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2171 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2172 /* Make sure the vtab symbol is present when
2173 the module variables are generated. */
2174 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2176 if (actual
->ts
.type
== BT_PROCEDURE
)
2178 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2180 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2183 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2187 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2188 sizeof(err
), NULL
, NULL
))
2191 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2192 formal
->name
, &actual
->where
, err
);
2196 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2198 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2199 &act_sym
->declared_at
);
2200 if (act_sym
->ts
.type
== BT_UNKNOWN
2201 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2204 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2205 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2206 &act_sym
->declared_at
);
2211 ppc
= gfc_get_proc_ptr_comp (actual
);
2212 if (ppc
&& ppc
->ts
.interface
)
2214 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2215 err
, sizeof(err
), NULL
, NULL
))
2218 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2219 formal
->name
, &actual
->where
, err
);
2225 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2226 && !gfc_is_simply_contiguous (actual
, true, false))
2229 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2230 "must be simply contiguous", formal
->name
, &actual
->where
);
2234 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2235 && actual
->ts
.type
!= BT_HOLLERITH
2236 && formal
->ts
.type
!= BT_ASSUMED
2237 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2238 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2239 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2240 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2241 CLASS_DATA (actual
)->ts
.u
.derived
)))
2244 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2245 formal
->name
, where
, gfc_typename (&actual
->ts
),
2246 gfc_typename (&formal
->ts
));
2250 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2253 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2254 "argument %qs is of assumed type", &actual
->where
,
2259 /* F2008, 12.5.2.5; IR F08/0073. */
2260 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2261 && actual
->expr_type
!= EXPR_NULL
2262 && ((CLASS_DATA (formal
)->attr
.class_pointer
2263 && formal
->attr
.intent
!= INTENT_IN
)
2264 || CLASS_DATA (formal
)->attr
.allocatable
))
2266 if (actual
->ts
.type
!= BT_CLASS
)
2269 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2270 formal
->name
, &actual
->where
);
2274 if (!gfc_expr_attr (actual
).class_ok
)
2277 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2278 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2279 CLASS_DATA (formal
)->ts
.u
.derived
))
2282 gfc_error ("Actual argument to %qs at %L must have the same "
2283 "declared type", formal
->name
, &actual
->where
);
2288 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2289 is necessary also for F03, so retain error for both.
2290 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2291 compatible, no attempt has been made to channel to this one. */
2292 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2293 && (CLASS_DATA (formal
)->attr
.allocatable
2294 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2297 gfc_error ("Actual argument to %qs at %L must be unlimited "
2298 "polymorphic since the formal argument is a "
2299 "pointer or allocatable unlimited polymorphic "
2300 "entity [F2008: 12.5.2.5]", formal
->name
,
2305 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2308 gfc_error ("Actual argument to %qs at %L must be a coarray",
2309 formal
->name
, &actual
->where
);
2313 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2315 gfc_ref
*last
= NULL
;
2317 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2318 if (ref
->type
== REF_COMPONENT
)
2321 /* F2008, 12.5.2.6. */
2322 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2324 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2327 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2328 formal
->name
, &actual
->where
, formal
->as
->corank
,
2329 last
? last
->u
.c
.component
->as
->corank
2330 : actual
->symtree
->n
.sym
->as
->corank
);
2335 if (formal
->attr
.codimension
)
2337 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2338 /* F2015, 12.5.2.8. */
2339 if (formal
->attr
.dimension
2340 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2341 && gfc_expr_attr (actual
).dimension
2342 && !gfc_is_simply_contiguous (actual
, true, true))
2345 gfc_error ("Actual argument to %qs at %L must be simply "
2346 "contiguous or an element of such an array",
2347 formal
->name
, &actual
->where
);
2351 /* F2008, C1303 and C1304. */
2352 if (formal
->attr
.intent
!= INTENT_INOUT
2353 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2354 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2355 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2356 || formal
->attr
.lock_comp
))
2360 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2361 "which is LOCK_TYPE or has a LOCK_TYPE component",
2362 formal
->name
, &actual
->where
);
2366 /* TS18508, C702/C703. */
2367 if (formal
->attr
.intent
!= INTENT_INOUT
2368 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2369 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2370 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2371 || formal
->attr
.event_comp
))
2375 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2376 "which is EVENT_TYPE or has a EVENT_TYPE component",
2377 formal
->name
, &actual
->where
);
2382 /* F2008, C1239/C1240. */
2383 if (actual
->expr_type
== EXPR_VARIABLE
2384 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2385 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2386 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2387 && actual
->rank
&& formal
->as
2388 && !gfc_is_simply_contiguous (actual
, true, false)
2389 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2390 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2391 || formal
->attr
.contiguous
))
2394 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2395 "assumed-rank array without CONTIGUOUS attribute - as actual"
2396 " argument at %L is not simply contiguous and both are "
2397 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2401 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2402 && gfc_expr_attr (actual
).codimension
)
2404 if (formal
->attr
.intent
== INTENT_OUT
)
2407 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2408 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2412 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2413 gfc_warning (OPT_Wsurprising
,
2414 "Passing coarray at %L to allocatable, noncoarray dummy "
2415 "argument %qs, which is invalid if the allocation status"
2416 " is modified", &actual
->where
, formal
->name
);
2419 /* If the rank is the same or the formal argument has assumed-rank. */
2420 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2423 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2424 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2425 || formal
->as
->type
== AS_DEFERRED
)
2426 && actual
->expr_type
!= EXPR_NULL
;
2428 /* Skip rank checks for NO_ARG_CHECK. */
2429 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2432 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2433 if (rank_check
|| ranks_must_agree
2434 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2435 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2436 || (actual
->rank
== 0
2437 && ((formal
->ts
.type
== BT_CLASS
2438 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2439 || (formal
->ts
.type
!= BT_CLASS
2440 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2441 && actual
->expr_type
!= EXPR_NULL
)
2442 || (actual
->rank
== 0 && formal
->attr
.dimension
2443 && gfc_is_coindexed (actual
)))
2446 argument_rank_mismatch (formal
->name
, &actual
->where
,
2447 symbol_rank (formal
), actual
->rank
);
2450 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2453 /* At this point, we are considering a scalar passed to an array. This
2454 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2455 - if the actual argument is (a substring of) an element of a
2456 non-assumed-shape/non-pointer/non-polymorphic array; or
2457 - (F2003) if the actual argument is of type character of default/c_char
2460 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2461 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2463 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2465 if (ref
->type
== REF_COMPONENT
)
2466 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2467 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2468 && ref
->u
.ar
.dimen
> 0
2470 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2474 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2477 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2478 "at %L", formal
->name
, &actual
->where
);
2482 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2483 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2486 gfc_error ("Element of assumed-shaped or pointer "
2487 "array passed to array dummy argument %qs at %L",
2488 formal
->name
, &actual
->where
);
2492 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2493 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2495 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2498 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2499 "CHARACTER actual argument with array dummy argument "
2500 "%qs at %L", formal
->name
, &actual
->where
);
2504 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2506 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2507 "array dummy argument %qs at %L",
2508 formal
->name
, &actual
->where
);
2511 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2517 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2520 argument_rank_mismatch (formal
->name
, &actual
->where
,
2521 symbol_rank (formal
), actual
->rank
);
2529 /* Returns the storage size of a symbol (formal argument) or
2530 zero if it cannot be determined. */
2532 static unsigned long
2533 get_sym_storage_size (gfc_symbol
*sym
)
2536 unsigned long strlen
, elements
;
2538 if (sym
->ts
.type
== BT_CHARACTER
)
2540 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2541 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2542 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2549 if (symbol_rank (sym
) == 0)
2553 if (sym
->as
->type
!= AS_EXPLICIT
)
2555 for (i
= 0; i
< sym
->as
->rank
; i
++)
2557 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2558 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2561 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2562 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2565 return strlen
*elements
;
2569 /* Returns the storage size of an expression (actual argument) or
2570 zero if it cannot be determined. For an array element, it returns
2571 the remaining size as the element sequence consists of all storage
2572 units of the actual argument up to the end of the array. */
2574 static unsigned long
2575 get_expr_storage_size (gfc_expr
*e
)
2578 long int strlen
, elements
;
2579 long int substrlen
= 0;
2580 bool is_str_storage
= false;
2586 if (e
->ts
.type
== BT_CHARACTER
)
2588 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2589 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2590 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2591 else if (e
->expr_type
== EXPR_CONSTANT
2592 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2593 strlen
= e
->value
.character
.length
;
2598 strlen
= 1; /* Length per element. */
2600 if (e
->rank
== 0 && !e
->ref
)
2608 for (i
= 0; i
< e
->rank
; i
++)
2609 elements
*= mpz_get_si (e
->shape
[i
]);
2610 return elements
*strlen
;
2613 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2615 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2616 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2620 /* The string length is the substring length.
2621 Set now to full string length. */
2622 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2623 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2626 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2628 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2632 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2633 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2635 long int start
, end
, stride
;
2638 if (ref
->u
.ar
.stride
[i
])
2640 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2641 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2646 if (ref
->u
.ar
.start
[i
])
2648 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2649 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2653 else if (ref
->u
.ar
.as
->lower
[i
]
2654 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2655 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2659 if (ref
->u
.ar
.end
[i
])
2661 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2662 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2666 else if (ref
->u
.ar
.as
->upper
[i
]
2667 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2668 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2672 elements
*= (end
- start
)/stride
+ 1L;
2674 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2675 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2677 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2678 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2679 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2680 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2681 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2682 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2683 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2688 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2689 && e
->expr_type
== EXPR_VARIABLE
)
2691 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2692 || e
->symtree
->n
.sym
->attr
.pointer
)
2698 /* Determine the number of remaining elements in the element
2699 sequence for array element designators. */
2700 is_str_storage
= true;
2701 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2703 if (ref
->u
.ar
.start
[i
] == NULL
2704 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2705 || ref
->u
.ar
.as
->upper
[i
] == NULL
2706 || ref
->u
.ar
.as
->lower
[i
] == NULL
2707 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2708 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2713 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2714 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2716 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2717 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2720 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2721 && ref
->u
.c
.component
->attr
.proc_pointer
2722 && ref
->u
.c
.component
->attr
.dimension
)
2724 /* Array-valued procedure-pointer components. */
2725 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2726 for (i
= 0; i
< as
->rank
; i
++)
2728 if (!as
->upper
[i
] || !as
->lower
[i
]
2729 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2730 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2734 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2735 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2741 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2744 return elements
*strlen
;
2748 /* Given an expression, check whether it is an array section
2749 which has a vector subscript. If it has, one is returned,
2753 gfc_has_vector_subscript (gfc_expr
*e
)
2758 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2761 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2762 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2763 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2764 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2772 is_procptr_result (gfc_expr
*expr
)
2774 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2776 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2778 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2779 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2783 /* Given formal and actual argument lists, see if they are compatible.
2784 If they are compatible, the actual argument list is sorted to
2785 correspond with the formal list, and elements for missing optional
2786 arguments are inserted. If WHERE pointer is nonnull, then we issue
2787 errors when things don't match instead of just returning the status
2791 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2792 int ranks_must_agree
, int is_elemental
, locus
*where
)
2794 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2795 gfc_formal_arglist
*f
;
2797 unsigned long actual_size
, formal_size
;
2798 bool full_array
= false;
2802 if (actual
== NULL
&& formal
== NULL
)
2806 for (f
= formal
; f
; f
= f
->next
)
2809 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2811 for (i
= 0; i
< n
; i
++)
2818 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2820 /* Look for keywords but ignore g77 extensions like %VAL. */
2821 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2824 for (f
= formal
; f
; f
= f
->next
, i
++)
2828 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2835 gfc_error ("Keyword argument %qs at %L is not in "
2836 "the procedure", a
->name
, &a
->expr
->where
);
2840 if (new_arg
[i
] != NULL
)
2843 gfc_error ("Keyword argument %qs at %L is already associated "
2844 "with another actual argument", a
->name
,
2853 gfc_error ("More actual than formal arguments in procedure "
2854 "call at %L", where
);
2859 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2865 gfc_error ("Missing alternate return spec in subroutine call "
2870 if (a
->expr
== NULL
)
2873 gfc_error ("Unexpected alternate return spec in subroutine "
2874 "call at %L", where
);
2878 /* Make sure that intrinsic vtables exist for calls to unlimited
2879 polymorphic formal arguments. */
2880 if (UNLIMITED_POLY (f
->sym
)
2881 && a
->expr
->ts
.type
!= BT_DERIVED
2882 && a
->expr
->ts
.type
!= BT_CLASS
)
2883 gfc_find_vtab (&a
->expr
->ts
);
2885 if (a
->expr
->expr_type
== EXPR_NULL
2886 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2887 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2888 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2889 || (f
->sym
->ts
.type
== BT_CLASS
2890 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2891 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2892 || !f
->sym
->attr
.optional
2893 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2896 && (!f
->sym
->attr
.optional
2897 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2898 || (f
->sym
->ts
.type
== BT_CLASS
2899 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2900 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2901 where
, f
->sym
->name
);
2903 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2904 "dummy %qs", where
, f
->sym
->name
);
2909 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2910 is_elemental
, where
))
2913 /* TS 29113, 6.3p2. */
2914 if (f
->sym
->ts
.type
== BT_ASSUMED
2915 && (a
->expr
->ts
.type
== BT_DERIVED
2916 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2918 gfc_namespace
*f2k_derived
;
2920 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2921 ? a
->expr
->ts
.u
.derived
->f2k_derived
2922 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2925 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2927 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2928 "derived type with type-bound or FINAL procedures",
2934 /* Special case for character arguments. For allocatable, pointer
2935 and assumed-shape dummies, the string length needs to match
2937 if (a
->expr
->ts
.type
== BT_CHARACTER
2938 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2939 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2940 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2941 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2942 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2943 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2944 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2945 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2947 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2949 "Character length mismatch (%ld/%ld) between actual "
2950 "argument and pointer or allocatable dummy argument "
2952 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2953 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2954 f
->sym
->name
, &a
->expr
->where
);
2957 "Character length mismatch (%ld/%ld) between actual "
2958 "argument and assumed-shape dummy argument %qs "
2960 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2961 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2962 f
->sym
->name
, &a
->expr
->where
);
2966 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2967 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2968 && a
->expr
->ts
.type
== BT_CHARACTER
)
2971 gfc_error ("Actual argument at %L to allocatable or "
2972 "pointer dummy argument %qs must have a deferred "
2973 "length type parameter if and only if the dummy has one",
2974 &a
->expr
->where
, f
->sym
->name
);
2978 if (f
->sym
->ts
.type
== BT_CLASS
)
2979 goto skip_size_check
;
2981 actual_size
= get_expr_storage_size (a
->expr
);
2982 formal_size
= get_sym_storage_size (f
->sym
);
2983 if (actual_size
!= 0 && actual_size
< formal_size
2984 && a
->expr
->ts
.type
!= BT_PROCEDURE
2985 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2987 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2988 gfc_warning (0, "Character length of actual argument shorter "
2989 "than of dummy argument %qs (%lu/%lu) at %L",
2990 f
->sym
->name
, actual_size
, formal_size
,
2993 gfc_warning (0, "Actual argument contains too few "
2994 "elements for dummy argument %qs (%lu/%lu) at %L",
2995 f
->sym
->name
, actual_size
, formal_size
,
3002 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3003 argument is provided for a procedure pointer formal argument. */
3004 if (f
->sym
->attr
.proc_pointer
3005 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3006 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3007 || gfc_is_proc_ptr_comp (a
->expr
)))
3008 || (a
->expr
->expr_type
== EXPR_FUNCTION
3009 && is_procptr_result (a
->expr
))))
3012 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3013 f
->sym
->name
, &a
->expr
->where
);
3017 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3018 provided for a procedure formal argument. */
3019 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3020 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3021 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3022 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3023 || gfc_is_proc_ptr_comp (a
->expr
)))
3024 || (a
->expr
->expr_type
== EXPR_FUNCTION
3025 && is_procptr_result (a
->expr
))))
3028 gfc_error ("Expected a procedure for argument %qs at %L",
3029 f
->sym
->name
, &a
->expr
->where
);
3033 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3034 && a
->expr
->expr_type
== EXPR_VARIABLE
3035 && a
->expr
->symtree
->n
.sym
->as
3036 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3037 && (a
->expr
->ref
== NULL
3038 || (a
->expr
->ref
->type
== REF_ARRAY
3039 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3042 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3043 " array at %L", f
->sym
->name
, where
);
3047 if (a
->expr
->expr_type
!= EXPR_NULL
3048 && compare_pointer (f
->sym
, a
->expr
) == 0)
3051 gfc_error ("Actual argument for %qs must be a pointer at %L",
3052 f
->sym
->name
, &a
->expr
->where
);
3056 if (a
->expr
->expr_type
!= EXPR_NULL
3057 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3058 && compare_pointer (f
->sym
, a
->expr
) == 2)
3061 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3062 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3067 /* Fortran 2008, C1242. */
3068 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3071 gfc_error ("Coindexed actual argument at %L to pointer "
3073 &a
->expr
->where
, f
->sym
->name
);
3077 /* Fortran 2008, 12.5.2.5 (no constraint). */
3078 if (a
->expr
->expr_type
== EXPR_VARIABLE
3079 && f
->sym
->attr
.intent
!= INTENT_IN
3080 && f
->sym
->attr
.allocatable
3081 && gfc_is_coindexed (a
->expr
))
3084 gfc_error ("Coindexed actual argument at %L to allocatable "
3085 "dummy %qs requires INTENT(IN)",
3086 &a
->expr
->where
, f
->sym
->name
);
3090 /* Fortran 2008, C1237. */
3091 if (a
->expr
->expr_type
== EXPR_VARIABLE
3092 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3093 && gfc_is_coindexed (a
->expr
)
3094 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3095 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3098 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3099 "%L requires that dummy %qs has neither "
3100 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3105 /* Fortran 2008, 12.5.2.4 (no constraint). */
3106 if (a
->expr
->expr_type
== EXPR_VARIABLE
3107 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3108 && gfc_is_coindexed (a
->expr
)
3109 && gfc_has_ultimate_allocatable (a
->expr
))
3112 gfc_error ("Coindexed actual argument at %L with allocatable "
3113 "ultimate component to dummy %qs requires either VALUE "
3114 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3118 if (f
->sym
->ts
.type
== BT_CLASS
3119 && CLASS_DATA (f
->sym
)->attr
.allocatable
3120 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3124 gfc_error ("Actual CLASS array argument for %qs must be a full "
3125 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3130 if (a
->expr
->expr_type
!= EXPR_NULL
3131 && compare_allocatable (f
->sym
, a
->expr
) == 0)
3134 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3135 f
->sym
->name
, &a
->expr
->where
);
3139 /* Check intent = OUT/INOUT for definable actual argument. */
3140 if ((f
->sym
->attr
.intent
== INTENT_OUT
3141 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3143 const char* context
= (where
3144 ? _("actual argument to INTENT = OUT/INOUT")
3147 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3148 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3149 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3150 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3152 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3156 if ((f
->sym
->attr
.intent
== INTENT_OUT
3157 || f
->sym
->attr
.intent
== INTENT_INOUT
3158 || f
->sym
->attr
.volatile_
3159 || f
->sym
->attr
.asynchronous
)
3160 && gfc_has_vector_subscript (a
->expr
))
3163 gfc_error ("Array-section actual argument with vector "
3164 "subscripts at %L is incompatible with INTENT(OUT), "
3165 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3166 "of the dummy argument %qs",
3167 &a
->expr
->where
, f
->sym
->name
);
3171 /* C1232 (R1221) For an actual argument which is an array section or
3172 an assumed-shape array, the dummy argument shall be an assumed-
3173 shape array, if the dummy argument has the VOLATILE attribute. */
3175 if (f
->sym
->attr
.volatile_
3176 && a
->expr
->symtree
->n
.sym
->as
3177 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3178 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3181 gfc_error ("Assumed-shape actual argument at %L is "
3182 "incompatible with the non-assumed-shape "
3183 "dummy argument %qs due to VOLATILE attribute",
3184 &a
->expr
->where
,f
->sym
->name
);
3188 if (f
->sym
->attr
.volatile_
3189 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
3190 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3193 gfc_error ("Array-section actual argument at %L is "
3194 "incompatible with the non-assumed-shape "
3195 "dummy argument %qs due to VOLATILE attribute",
3196 &a
->expr
->where
,f
->sym
->name
);
3200 /* C1233 (R1221) For an actual argument which is a pointer array, the
3201 dummy argument shall be an assumed-shape or pointer array, if the
3202 dummy argument has the VOLATILE attribute. */
3204 if (f
->sym
->attr
.volatile_
3205 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3206 && a
->expr
->symtree
->n
.sym
->as
3208 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3209 || f
->sym
->attr
.pointer
)))
3212 gfc_error ("Pointer-array actual argument at %L requires "
3213 "an assumed-shape or pointer-array dummy "
3214 "argument %qs due to VOLATILE attribute",
3215 &a
->expr
->where
,f
->sym
->name
);
3226 /* Make sure missing actual arguments are optional. */
3228 for (f
= formal
; f
; f
= f
->next
, i
++)
3230 if (new_arg
[i
] != NULL
)
3235 gfc_error ("Missing alternate return spec in subroutine call "
3239 if (!f
->sym
->attr
.optional
)
3242 gfc_error ("Missing actual argument for argument %qs at %L",
3243 f
->sym
->name
, where
);
3248 /* The argument lists are compatible. We now relink a new actual
3249 argument list with null arguments in the right places. The head
3250 of the list remains the head. */
3251 for (i
= 0; i
< n
; i
++)
3252 if (new_arg
[i
] == NULL
)
3253 new_arg
[i
] = gfc_get_actual_arglist ();
3257 std::swap (*new_arg
[0], *actual
);
3258 std::swap (new_arg
[0], new_arg
[na
]);
3261 for (i
= 0; i
< n
- 1; i
++)
3262 new_arg
[i
]->next
= new_arg
[i
+ 1];
3264 new_arg
[i
]->next
= NULL
;
3266 if (*ap
== NULL
&& n
> 0)
3269 /* Note the types of omitted optional arguments. */
3270 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3271 if (a
->expr
== NULL
&& a
->label
== NULL
)
3272 a
->missing_arg_type
= f
->sym
->ts
.type
;
3280 gfc_formal_arglist
*f
;
3281 gfc_actual_arglist
*a
;
3285 /* qsort comparison function for argument pairs, with the following
3287 - p->a->expr == NULL
3288 - p->a->expr->expr_type != EXPR_VARIABLE
3289 - growing p->a->expr->symbol. */
3292 pair_cmp (const void *p1
, const void *p2
)
3294 const gfc_actual_arglist
*a1
, *a2
;
3296 /* *p1 and *p2 are elements of the to-be-sorted array. */
3297 a1
= ((const argpair
*) p1
)->a
;
3298 a2
= ((const argpair
*) p2
)->a
;
3307 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3309 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3313 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3315 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3319 /* Given two expressions from some actual arguments, test whether they
3320 refer to the same expression. The analysis is conservative.
3321 Returning false will produce no warning. */
3324 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3326 const gfc_ref
*r1
, *r2
;
3329 || e1
->expr_type
!= EXPR_VARIABLE
3330 || e2
->expr_type
!= EXPR_VARIABLE
3331 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3334 /* TODO: improve comparison, see expr.c:show_ref(). */
3335 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3337 if (r1
->type
!= r2
->type
)
3342 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3344 /* TODO: At the moment, consider only full arrays;
3345 we could do better. */
3346 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3351 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3359 gfc_internal_error ("compare_actual_expr(): Bad component code");
3368 /* Given formal and actual argument lists that correspond to one
3369 another, check that identical actual arguments aren't not
3370 associated with some incompatible INTENTs. */
3373 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3375 sym_intent f1_intent
, f2_intent
;
3376 gfc_formal_arglist
*f1
;
3377 gfc_actual_arglist
*a1
;
3383 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3385 if (f1
== NULL
&& a1
== NULL
)
3387 if (f1
== NULL
|| a1
== NULL
)
3388 gfc_internal_error ("check_some_aliasing(): List mismatch");
3393 p
= XALLOCAVEC (argpair
, n
);
3395 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3401 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3403 for (i
= 0; i
< n
; i
++)
3406 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3407 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3409 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3410 for (j
= i
+ 1; j
< n
; j
++)
3412 /* Expected order after the sort. */
3413 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3414 gfc_internal_error ("check_some_aliasing(): corrupted data");
3416 /* Are the expression the same? */
3417 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3419 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3420 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3421 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3422 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3424 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3425 "argument %qs and INTENT(%s) argument %qs at %L",
3426 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3427 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3428 &p
[i
].a
->expr
->where
);
3438 /* Given formal and actual argument lists that correspond to one
3439 another, check that they are compatible in the sense that intents
3440 are not mismatched. */
3443 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3445 sym_intent f_intent
;
3447 for (;; f
= f
->next
, a
= a
->next
)
3451 if (f
== NULL
&& a
== NULL
)
3453 if (f
== NULL
|| a
== NULL
)
3454 gfc_internal_error ("check_intents(): List mismatch");
3456 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3457 && a
->expr
->value
.function
.isym
3458 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3459 expr
= a
->expr
->value
.function
.actual
->expr
;
3463 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3466 f_intent
= f
->sym
->attr
.intent
;
3468 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3470 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3471 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3472 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3474 gfc_error ("Procedure argument at %L is local to a PURE "
3475 "procedure and has the POINTER attribute",
3481 /* Fortran 2008, C1283. */
3482 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3484 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3486 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3487 "is passed to an INTENT(%s) argument",
3488 &expr
->where
, gfc_intent_string (f_intent
));
3492 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3493 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3494 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3496 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3497 "is passed to a POINTER dummy argument",
3503 /* F2008, Section 12.5.2.4. */
3504 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3505 && gfc_is_coindexed (expr
))
3507 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3508 "polymorphic dummy argument %qs",
3509 &expr
->where
, f
->sym
->name
);
3518 /* Check how a procedure is used against its interface. If all goes
3519 well, the actual argument list will also end up being properly
3523 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3525 gfc_formal_arglist
*dummy_args
;
3527 /* Warn about calls with an implicit interface. Special case
3528 for calling a ISO_C_BINDING because c_loc and c_funloc
3529 are pseudo-unknown. Additionally, warn about procedures not
3530 explicitly declared at all if requested. */
3531 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3533 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3535 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3539 if (warn_implicit_interface
)
3540 gfc_warning (OPT_Wimplicit_interface
,
3541 "Procedure %qs called with an implicit interface at %L",
3543 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3544 gfc_warning (OPT_Wimplicit_procedure
,
3545 "Procedure %qs called at %L is not explicitly declared",
3549 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3551 gfc_actual_arglist
*a
;
3553 if (sym
->attr
.pointer
)
3555 gfc_error ("The pointer object %qs at %L must have an explicit "
3556 "function interface or be declared as array",
3561 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3563 gfc_error ("The allocatable object %qs at %L must have an explicit "
3564 "function interface or be declared as array",
3569 if (sym
->attr
.allocatable
)
3571 gfc_error ("Allocatable function %qs at %L must have an explicit "
3572 "function interface", sym
->name
, where
);
3576 for (a
= *ap
; a
; a
= a
->next
)
3578 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3579 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3581 gfc_error ("Keyword argument requires explicit interface "
3582 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3586 /* TS 29113, 6.2. */
3587 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3588 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3590 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3591 "interface", a
->expr
->symtree
->n
.sym
->name
,
3596 /* F2008, C1303 and C1304. */
3598 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3599 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3600 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3601 || gfc_expr_attr (a
->expr
).lock_comp
))
3603 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3604 "component at %L requires an explicit interface for "
3605 "procedure %qs", &a
->expr
->where
, sym
->name
);
3610 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3611 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3612 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3613 == ISOFORTRAN_EVENT_TYPE
)
3614 || gfc_expr_attr (a
->expr
).event_comp
))
3616 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3617 "component at %L requires an explicit interface for "
3618 "procedure %qs", &a
->expr
->where
, sym
->name
);
3622 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3623 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3625 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3629 /* TS 29113, C407b. */
3630 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3631 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3633 gfc_error ("Assumed-rank argument requires an explicit interface "
3634 "at %L", &a
->expr
->where
);
3642 dummy_args
= gfc_sym_get_dummy_args (sym
);
3644 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3647 if (!check_intents (dummy_args
, *ap
))
3651 check_some_aliasing (dummy_args
, *ap
);
3657 /* Check how a procedure pointer component is used against its interface.
3658 If all goes well, the actual argument list will also end up being properly
3659 sorted. Completely analogous to gfc_procedure_use. */
3662 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3664 /* Warn about calls with an implicit interface. Special case
3665 for calling a ISO_C_BINDING because c_loc and c_funloc
3666 are pseudo-unknown. */
3667 if (warn_implicit_interface
3668 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3669 && !comp
->attr
.is_iso_c
)
3670 gfc_warning (OPT_Wimplicit_interface
,
3671 "Procedure pointer component %qs called with an implicit "
3672 "interface at %L", comp
->name
, where
);
3674 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3676 gfc_actual_arglist
*a
;
3677 for (a
= *ap
; a
; a
= a
->next
)
3679 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3680 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3682 gfc_error ("Keyword argument requires explicit interface "
3683 "for procedure pointer component %qs at %L",
3684 comp
->name
, &a
->expr
->where
);
3692 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3693 comp
->attr
.elemental
, where
))
3696 check_intents (comp
->ts
.interface
->formal
, *ap
);
3698 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3702 /* Try if an actual argument list matches the formal list of a symbol,
3703 respecting the symbol's attributes like ELEMENTAL. This is used for
3704 GENERIC resolution. */
3707 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3709 gfc_formal_arglist
*dummy_args
;
3712 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3715 dummy_args
= gfc_sym_get_dummy_args (sym
);
3717 r
= !sym
->attr
.elemental
;
3718 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3720 check_intents (dummy_args
, *args
);
3722 check_some_aliasing (dummy_args
, *args
);
3730 /* Given an interface pointer and an actual argument list, search for
3731 a formal argument list that matches the actual. If found, returns
3732 a pointer to the symbol of the correct interface. Returns NULL if
3736 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3737 gfc_actual_arglist
**ap
)
3739 gfc_symbol
*elem_sym
= NULL
;
3740 gfc_symbol
*null_sym
= NULL
;
3741 locus null_expr_loc
;
3742 gfc_actual_arglist
*a
;
3743 bool has_null_arg
= false;
3745 for (a
= *ap
; a
; a
= a
->next
)
3746 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3747 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3749 has_null_arg
= true;
3750 null_expr_loc
= a
->expr
->where
;
3754 for (; intr
; intr
= intr
->next
)
3756 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3758 if (sub_flag
&& intr
->sym
->attr
.function
)
3760 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3763 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3765 if (has_null_arg
&& null_sym
)
3767 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3768 "between specific functions %s and %s",
3769 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3772 else if (has_null_arg
)
3774 null_sym
= intr
->sym
;
3778 /* Satisfy 12.4.4.1 such that an elemental match has lower
3779 weight than a non-elemental match. */
3780 if (intr
->sym
->attr
.elemental
)
3782 elem_sym
= intr
->sym
;
3792 return elem_sym
? elem_sym
: NULL
;
3796 /* Do a brute force recursive search for a symbol. */
3798 static gfc_symtree
*
3799 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3803 if (root
->n
.sym
== sym
)
3808 st
= find_symtree0 (root
->left
, sym
);
3809 if (root
->right
&& ! st
)
3810 st
= find_symtree0 (root
->right
, sym
);
3815 /* Find a symtree for a symbol. */
3818 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3823 /* First try to find it by name. */
3824 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3825 if (st
&& st
->n
.sym
== sym
)
3828 /* If it's been renamed, resort to a brute-force search. */
3829 /* TODO: avoid having to do this search. If the symbol doesn't exist
3830 in the symtree for the current namespace, it should probably be added. */
3831 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3833 st
= find_symtree0 (ns
->sym_root
, sym
);
3837 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3842 /* See if the arglist to an operator-call contains a derived-type argument
3843 with a matching type-bound operator. If so, return the matching specific
3844 procedure defined as operator-target as well as the base-object to use
3845 (which is the found derived-type argument with operator). The generic
3846 name, if any, is transmitted to the final expression via 'gname'. */
3848 static gfc_typebound_proc
*
3849 matching_typebound_op (gfc_expr
** tb_base
,
3850 gfc_actual_arglist
* args
,
3851 gfc_intrinsic_op op
, const char* uop
,
3852 const char ** gname
)
3854 gfc_actual_arglist
* base
;
3856 for (base
= args
; base
; base
= base
->next
)
3857 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3859 gfc_typebound_proc
* tb
;
3860 gfc_symbol
* derived
;
3863 while (base
->expr
->expr_type
== EXPR_OP
3864 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3865 base
->expr
= base
->expr
->value
.op
.op1
;
3867 if (base
->expr
->ts
.type
== BT_CLASS
)
3869 if (CLASS_DATA (base
->expr
) == NULL
3870 || !gfc_expr_attr (base
->expr
).class_ok
)
3872 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3875 derived
= base
->expr
->ts
.u
.derived
;
3877 if (op
== INTRINSIC_USER
)
3879 gfc_symtree
* tb_uop
;
3882 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3891 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3894 /* This means we hit a PRIVATE operator which is use-associated and
3895 should thus not be seen. */
3899 /* Look through the super-type hierarchy for a matching specific
3901 for (; tb
; tb
= tb
->overridden
)
3905 gcc_assert (tb
->is_generic
);
3906 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3909 gfc_actual_arglist
* argcopy
;
3912 gcc_assert (g
->specific
);
3913 if (g
->specific
->error
)
3916 target
= g
->specific
->u
.specific
->n
.sym
;
3918 /* Check if this arglist matches the formal. */
3919 argcopy
= gfc_copy_actual_arglist (args
);
3920 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3921 gfc_free_actual_arglist (argcopy
);
3923 /* Return if we found a match. */
3926 *tb_base
= base
->expr
;
3927 *gname
= g
->specific_st
->name
;
3938 /* For the 'actual arglist' of an operator call and a specific typebound
3939 procedure that has been found the target of a type-bound operator, build the
3940 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3941 type-bound procedures rather than resolving type-bound operators 'directly'
3942 so that we can reuse the existing logic. */
3945 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3946 gfc_expr
* base
, gfc_typebound_proc
* target
,
3949 e
->expr_type
= EXPR_COMPCALL
;
3950 e
->value
.compcall
.tbp
= target
;
3951 e
->value
.compcall
.name
= gname
? gname
: "$op";
3952 e
->value
.compcall
.actual
= actual
;
3953 e
->value
.compcall
.base_object
= base
;
3954 e
->value
.compcall
.ignore_pass
= 1;
3955 e
->value
.compcall
.assign
= 0;
3956 if (e
->ts
.type
== BT_UNKNOWN
3957 && target
->function
)
3959 if (target
->is_generic
)
3960 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3962 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3967 /* This subroutine is called when an expression is being resolved.
3968 The expression node in question is either a user defined operator
3969 or an intrinsic operator with arguments that aren't compatible
3970 with the operator. This subroutine builds an actual argument list
3971 corresponding to the operands, then searches for a compatible
3972 interface. If one is found, the expression node is replaced with
3973 the appropriate function call. We use the 'match' enum to specify
3974 whether a replacement has been made or not, or if an error occurred. */
3977 gfc_extend_expr (gfc_expr
*e
)
3979 gfc_actual_arglist
*actual
;
3985 gfc_typebound_proc
* tbo
;
3990 actual
= gfc_get_actual_arglist ();
3991 actual
->expr
= e
->value
.op
.op1
;
3995 if (e
->value
.op
.op2
!= NULL
)
3997 actual
->next
= gfc_get_actual_arglist ();
3998 actual
->next
->expr
= e
->value
.op
.op2
;
4001 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4003 /* See if we find a matching type-bound operator. */
4004 if (i
== INTRINSIC_USER
)
4005 tbo
= matching_typebound_op (&tb_base
, actual
,
4006 i
, e
->value
.op
.uop
->name
, &gname
);
4010 #define CHECK_OS_COMPARISON(comp) \
4011 case INTRINSIC_##comp: \
4012 case INTRINSIC_##comp##_OS: \
4013 tbo = matching_typebound_op (&tb_base, actual, \
4014 INTRINSIC_##comp, NULL, &gname); \
4016 tbo = matching_typebound_op (&tb_base, actual, \
4017 INTRINSIC_##comp##_OS, NULL, &gname); \
4019 CHECK_OS_COMPARISON(EQ
)
4020 CHECK_OS_COMPARISON(NE
)
4021 CHECK_OS_COMPARISON(GT
)
4022 CHECK_OS_COMPARISON(GE
)
4023 CHECK_OS_COMPARISON(LT
)
4024 CHECK_OS_COMPARISON(LE
)
4025 #undef CHECK_OS_COMPARISON
4028 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4032 /* If there is a matching typebound-operator, replace the expression with
4033 a call to it and succeed. */
4036 gcc_assert (tb_base
);
4037 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4039 if (!gfc_resolve_expr (e
))
4045 if (i
== INTRINSIC_USER
)
4047 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4049 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4053 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4060 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4062 /* Due to the distinction between '==' and '.eq.' and friends, one has
4063 to check if either is defined. */
4066 #define CHECK_OS_COMPARISON(comp) \
4067 case INTRINSIC_##comp: \
4068 case INTRINSIC_##comp##_OS: \
4069 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4071 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4073 CHECK_OS_COMPARISON(EQ
)
4074 CHECK_OS_COMPARISON(NE
)
4075 CHECK_OS_COMPARISON(GT
)
4076 CHECK_OS_COMPARISON(GE
)
4077 CHECK_OS_COMPARISON(LT
)
4078 CHECK_OS_COMPARISON(LE
)
4079 #undef CHECK_OS_COMPARISON
4082 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4090 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4091 found rather than just taking the first one and not checking further. */
4095 /* Don't use gfc_free_actual_arglist(). */
4096 free (actual
->next
);
4101 /* Change the expression node to a function call. */
4102 e
->expr_type
= EXPR_FUNCTION
;
4103 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4104 e
->value
.function
.actual
= actual
;
4105 e
->value
.function
.esym
= NULL
;
4106 e
->value
.function
.isym
= NULL
;
4107 e
->value
.function
.name
= NULL
;
4108 e
->user_operator
= 1;
4110 if (!gfc_resolve_expr (e
))
4117 /* Tries to replace an assignment code node with a subroutine call to the
4118 subroutine associated with the assignment operator. Return true if the node
4119 was replaced. On false, no error is generated. */
4122 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4124 gfc_actual_arglist
*actual
;
4125 gfc_expr
*lhs
, *rhs
, *tb_base
;
4126 gfc_symbol
*sym
= NULL
;
4127 const char *gname
= NULL
;
4128 gfc_typebound_proc
* tbo
;
4133 /* Don't allow an intrinsic assignment to be replaced. */
4134 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4135 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4136 && (lhs
->ts
.type
== rhs
->ts
.type
4137 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4140 actual
= gfc_get_actual_arglist ();
4143 actual
->next
= gfc_get_actual_arglist ();
4144 actual
->next
->expr
= rhs
;
4146 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4148 /* See if we find a matching type-bound assignment. */
4149 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4154 /* Success: Replace the expression with a type-bound call. */
4155 gcc_assert (tb_base
);
4156 c
->expr1
= gfc_get_expr ();
4157 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4158 c
->expr1
->value
.compcall
.assign
= 1;
4159 c
->expr1
->where
= c
->loc
;
4161 c
->op
= EXEC_COMPCALL
;
4165 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4166 for (; ns
; ns
= ns
->parent
)
4168 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4175 /* Success: Replace the assignment with the call. */
4176 c
->op
= EXEC_ASSIGN_CALL
;
4177 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4180 c
->ext
.actual
= actual
;
4184 /* Failure: No assignment procedure found. */
4185 free (actual
->next
);
4191 /* Make sure that the interface just parsed is not already present in
4192 the given interface list. Ambiguity isn't checked yet since module
4193 procedures can be present without interfaces. */
4196 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4200 for (ip
= base
; ip
; ip
= ip
->next
)
4202 if (ip
->sym
== new_sym
)
4204 gfc_error ("Entity %qs at %L is already present in the interface",
4205 new_sym
->name
, &loc
);
4214 /* Add a symbol to the current interface. */
4217 gfc_add_interface (gfc_symbol
*new_sym
)
4219 gfc_interface
**head
, *intr
;
4223 switch (current_interface
.type
)
4225 case INTERFACE_NAMELESS
:
4226 case INTERFACE_ABSTRACT
:
4229 case INTERFACE_INTRINSIC_OP
:
4230 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4231 switch (current_interface
.op
)
4234 case INTRINSIC_EQ_OS
:
4235 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4237 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4238 new_sym
, gfc_current_locus
))
4243 case INTRINSIC_NE_OS
:
4244 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4246 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4247 new_sym
, gfc_current_locus
))
4252 case INTRINSIC_GT_OS
:
4253 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4254 new_sym
, gfc_current_locus
)
4255 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4256 new_sym
, gfc_current_locus
))
4261 case INTRINSIC_GE_OS
:
4262 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4263 new_sym
, gfc_current_locus
)
4264 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4265 new_sym
, gfc_current_locus
))
4270 case INTRINSIC_LT_OS
:
4271 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4272 new_sym
, gfc_current_locus
)
4273 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4274 new_sym
, gfc_current_locus
))
4279 case INTRINSIC_LE_OS
:
4280 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4281 new_sym
, gfc_current_locus
)
4282 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4283 new_sym
, gfc_current_locus
))
4288 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4289 new_sym
, gfc_current_locus
))
4293 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4296 case INTERFACE_GENERIC
:
4297 case INTERFACE_DTIO
:
4298 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4300 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4304 if (!gfc_check_new_interface (sym
->generic
,
4305 new_sym
, gfc_current_locus
))
4309 head
= ¤t_interface
.sym
->generic
;
4312 case INTERFACE_USER_OP
:
4313 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4314 new_sym
, gfc_current_locus
))
4317 head
= ¤t_interface
.uop
->op
;
4321 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4324 intr
= gfc_get_interface ();
4325 intr
->sym
= new_sym
;
4326 intr
->where
= gfc_current_locus
;
4336 gfc_current_interface_head (void)
4338 switch (current_interface
.type
)
4340 case INTERFACE_INTRINSIC_OP
:
4341 return current_interface
.ns
->op
[current_interface
.op
];
4343 case INTERFACE_GENERIC
:
4344 case INTERFACE_DTIO
:
4345 return current_interface
.sym
->generic
;
4347 case INTERFACE_USER_OP
:
4348 return current_interface
.uop
->op
;
4357 gfc_set_current_interface_head (gfc_interface
*i
)
4359 switch (current_interface
.type
)
4361 case INTERFACE_INTRINSIC_OP
:
4362 current_interface
.ns
->op
[current_interface
.op
] = i
;
4365 case INTERFACE_GENERIC
:
4366 case INTERFACE_DTIO
:
4367 current_interface
.sym
->generic
= i
;
4370 case INTERFACE_USER_OP
:
4371 current_interface
.uop
->op
= i
;
4380 /* Gets rid of a formal argument list. We do not free symbols.
4381 Symbols are freed when a namespace is freed. */
4384 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4386 gfc_formal_arglist
*q
;
4396 /* Check that it is ok for the type-bound procedure 'proc' to override the
4397 procedure 'old', cf. F08:4.5.7.3. */
4400 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4403 gfc_symbol
*proc_target
, *old_target
;
4404 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4405 gfc_formal_arglist
*proc_formal
, *old_formal
;
4409 /* This procedure should only be called for non-GENERIC proc. */
4410 gcc_assert (!proc
->n
.tb
->is_generic
);
4412 /* If the overwritten procedure is GENERIC, this is an error. */
4413 if (old
->n
.tb
->is_generic
)
4415 gfc_error ("Can't overwrite GENERIC %qs at %L",
4416 old
->name
, &proc
->n
.tb
->where
);
4420 where
= proc
->n
.tb
->where
;
4421 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4422 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4424 /* Check that overridden binding is not NON_OVERRIDABLE. */
4425 if (old
->n
.tb
->non_overridable
)
4427 gfc_error ("%qs at %L overrides a procedure binding declared"
4428 " NON_OVERRIDABLE", proc
->name
, &where
);
4432 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4433 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4435 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4436 " non-DEFERRED binding", proc
->name
, &where
);
4440 /* If the overridden binding is PURE, the overriding must be, too. */
4441 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4443 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4444 proc
->name
, &where
);
4448 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4449 is not, the overriding must not be either. */
4450 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4452 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4453 " ELEMENTAL", proc
->name
, &where
);
4456 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4458 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4459 " be ELEMENTAL, either", proc
->name
, &where
);
4463 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4465 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4467 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4468 " SUBROUTINE", proc
->name
, &where
);
4472 /* If the overridden binding is a FUNCTION, the overriding must also be a
4473 FUNCTION and have the same characteristics. */
4474 if (old_target
->attr
.function
)
4476 if (!proc_target
->attr
.function
)
4478 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4479 " FUNCTION", proc
->name
, &where
);
4483 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4486 gfc_error ("Result mismatch for the overriding procedure "
4487 "%qs at %L: %s", proc
->name
, &where
, err
);
4492 /* If the overridden binding is PUBLIC, the overriding one must not be
4494 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4495 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4497 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4498 " PRIVATE", proc
->name
, &where
);
4502 /* Compare the formal argument lists of both procedures. This is also abused
4503 to find the position of the passed-object dummy arguments of both
4504 bindings as at least the overridden one might not yet be resolved and we
4505 need those positions in the check below. */
4506 proc_pass_arg
= old_pass_arg
= 0;
4507 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4509 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4512 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4513 old_formal
= gfc_sym_get_dummy_args (old_target
);
4514 for ( ; proc_formal
&& old_formal
;
4515 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4517 if (proc
->n
.tb
->pass_arg
4518 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4519 proc_pass_arg
= argpos
;
4520 if (old
->n
.tb
->pass_arg
4521 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4522 old_pass_arg
= argpos
;
4524 /* Check that the names correspond. */
4525 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4527 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4528 " to match the corresponding argument of the overridden"
4529 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4530 old_formal
->sym
->name
);
4534 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4535 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4536 check_type
, err
, sizeof(err
)))
4538 gfc_error ("Argument mismatch for the overriding procedure "
4539 "%qs at %L: %s", proc
->name
, &where
, err
);
4545 if (proc_formal
|| old_formal
)
4547 gfc_error ("%qs at %L must have the same number of formal arguments as"
4548 " the overridden procedure", proc
->name
, &where
);
4552 /* If the overridden binding is NOPASS, the overriding one must also be
4554 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4556 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4557 " NOPASS", proc
->name
, &where
);
4561 /* If the overridden binding is PASS(x), the overriding one must also be
4562 PASS and the passed-object dummy arguments must correspond. */
4563 if (!old
->n
.tb
->nopass
)
4565 if (proc
->n
.tb
->nopass
)
4567 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4568 " PASS", proc
->name
, &where
);
4572 if (proc_pass_arg
!= old_pass_arg
)
4574 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4575 " the same position as the passed-object dummy argument of"
4576 " the overridden procedure", proc
->name
, &where
);
4585 /* The following three functions check that the formal arguments
4586 of user defined derived type IO procedures are compliant with
4587 the requirements of the standard. */
4590 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4591 int kind
, int rank
, sym_intent intent
)
4593 if (fsym
->ts
.type
!= type
)
4595 gfc_error ("DTIO dummy argument at %L must be of type %s",
4596 &fsym
->declared_at
, gfc_basic_typename (type
));
4600 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4601 && fsym
->ts
.kind
!= kind
)
4602 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4603 &fsym
->declared_at
, kind
);
4607 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4608 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4609 gfc_error ("DTIO dummy argument at %L be a scalar",
4610 &fsym
->declared_at
);
4612 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4613 gfc_error ("DTIO dummy argument at %L must be an "
4614 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4616 if (fsym
->attr
.intent
!= intent
)
4617 gfc_error ("DTIO dummy argument at %L must have intent %s",
4618 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4624 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4625 bool typebound
, bool formatted
, int code
)
4627 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4628 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4629 gfc_interface
*intr
;
4630 gfc_formal_arglist
*formal
;
4633 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4634 || ((dtio_codes
)code
== DTIO_RUF
);
4642 /* Typebound DTIO binding. */
4643 tb_io_proc
= tb_io_st
->n
.tb
;
4644 if (tb_io_proc
== NULL
)
4647 gcc_assert (tb_io_proc
->is_generic
);
4648 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4650 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4651 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4654 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4658 generic_proc
= tb_io_st
->n
.sym
;
4659 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4662 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4664 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
4665 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4666 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4668 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4669 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4671 dtio_sub
= intr
->sym
;
4674 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
4676 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4677 "procedure", &intr
->sym
->declared_at
);
4682 if (dtio_sub
== NULL
)
4686 gcc_assert (dtio_sub
);
4687 if (!dtio_sub
->attr
.subroutine
)
4688 gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
4689 dtio_sub
->name
, &dtio_sub
->declared_at
);
4692 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
4695 if (arg_num
< (formatted
? 6 : 4))
4697 gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
4698 dtio_sub
->name
, &dtio_sub
->declared_at
);
4702 if (arg_num
> (formatted
? 6 : 4))
4704 gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
4705 dtio_sub
->name
, &dtio_sub
->declared_at
);
4710 /* Now go through the formal arglist. */
4712 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4714 if (!formatted
&& arg_num
== 3)
4720 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4721 "procedure", &dtio_sub
->declared_at
);
4728 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4729 BT_DERIVED
: BT_CLASS
;
4731 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4732 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4738 kind
= gfc_default_integer_kind
;
4740 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4743 case(3): /* IOTYPE */
4744 type
= BT_CHARACTER
;
4745 kind
= gfc_default_character_kind
;
4747 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4750 case(4): /* VLIST */
4752 kind
= gfc_default_integer_kind
;
4754 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4757 case(5): /* IOSTAT */
4759 kind
= gfc_default_integer_kind
;
4760 intent
= INTENT_OUT
;
4761 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4764 case(6): /* IOMSG */
4765 type
= BT_CHARACTER
;
4766 kind
= gfc_default_character_kind
;
4767 intent
= INTENT_INOUT
;
4768 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4775 derived
->attr
.has_dtio_procs
= 1;
4780 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4782 gfc_symtree
*tb_io_st
;
4787 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4790 /* Check typebound DTIO bindings. */
4791 for (code
= 0; code
< 4; code
++)
4793 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4794 || ((dtio_codes
)code
== DTIO_WF
);
4796 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4797 gfc_code2string (dtio_procs
, code
),
4798 true, &derived
->declared_at
);
4799 if (tb_io_st
!= NULL
)
4800 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4803 /* Check generic DTIO interfaces. */
4804 for (code
= 0; code
< 4; code
++)
4806 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4807 || ((dtio_codes
)code
== DTIO_WF
);
4809 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4810 gfc_code2string (dtio_procs
, code
));
4811 if (tb_io_st
!= NULL
)
4812 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4818 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4820 gfc_symtree
*tb_io_st
= NULL
;
4821 gfc_symbol
*dtio_sub
= NULL
;
4822 gfc_symbol
*extended
;
4823 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4826 if (!derived
|| derived
->attr
.flavor
!= FL_DERIVED
)
4829 /* Try to find a typebound DTIO binding. */
4830 if (formatted
== true)
4833 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4834 gfc_code2string (dtio_procs
,
4837 &derived
->declared_at
);
4839 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4840 gfc_code2string (dtio_procs
,
4843 &derived
->declared_at
);
4848 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4849 gfc_code2string (dtio_procs
,
4852 &derived
->declared_at
);
4854 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4855 gfc_code2string (dtio_procs
,
4858 &derived
->declared_at
);
4861 if (tb_io_st
!= NULL
)
4863 const char *genname
;
4866 tb_io_proc
= tb_io_st
->n
.tb
;
4867 gcc_assert (tb_io_proc
!= NULL
);
4868 gcc_assert (tb_io_proc
->is_generic
);
4869 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4871 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4872 gcc_assert (!specific_proc
->is_generic
);
4874 /* Go back and make sure that we have the right specific procedure.
4875 Here we most likely have a procedure from the parent type, which
4876 can be overridden in extensions. */
4877 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4878 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4879 true, &tb_io_proc
->where
);
4881 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4883 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4886 if (tb_io_st
!= NULL
)
4889 /* If there is not a typebound binding, look for a generic
4891 for (extended
= derived
; extended
;
4892 extended
= gfc_get_derived_super_type (extended
))
4894 if (extended
== NULL
|| extended
->ns
== NULL
)
4897 if (formatted
== true)
4900 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4901 gfc_code2string (dtio_procs
,
4904 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4905 gfc_code2string (dtio_procs
,
4911 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4912 gfc_code2string (dtio_procs
,
4915 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4916 gfc_code2string (dtio_procs
,
4920 if (tb_io_st
!= NULL
4922 && tb_io_st
->n
.sym
->generic
)
4924 gfc_interface
*intr
;
4925 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4927 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
4928 if (intr
->sym
&& intr
->sym
->formal
4929 && ((fsym
->ts
.type
== BT_CLASS
4930 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
4931 || (fsym
->ts
.type
== BT_DERIVED
4932 && fsym
->ts
.u
.derived
== extended
)))
4934 dtio_sub
= intr
->sym
;
4942 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
4943 gfc_find_derived_vtab (derived
);