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. */
120 static gfc_intrinsic_op
123 if (strncmp (mode
, "formatted", 9) == 0)
124 return INTRINSIC_FORMATTED
;
125 if (strncmp (mode
, "unformatted", 9) == 0)
126 return INTRINSIC_UNFORMATTED
;
127 return INTRINSIC_NONE
;
131 /* Match a generic specification. Depending on which type of
132 interface is found, the 'name' or 'op' pointers may be set.
133 This subroutine doesn't return MATCH_NO. */
136 gfc_match_generic_spec (interface_type
*type
,
138 gfc_intrinsic_op
*op
)
140 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
144 if (gfc_match (" assignment ( = )") == MATCH_YES
)
146 *type
= INTERFACE_INTRINSIC_OP
;
147 *op
= INTRINSIC_ASSIGN
;
151 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
153 *type
= INTERFACE_INTRINSIC_OP
;
154 *op
= fold_unary_intrinsic (i
);
158 *op
= INTRINSIC_NONE
;
159 if (gfc_match (" operator ( ") == MATCH_YES
)
161 m
= gfc_match_defined_op_name (buffer
, 1);
167 m
= gfc_match_char (')');
173 strcpy (name
, buffer
);
174 *type
= INTERFACE_USER_OP
;
178 if (gfc_match (" read ( %n )", buffer
) == MATCH_YES
)
180 *op
= dtio_op (buffer
);
181 if (*op
== INTRINSIC_FORMATTED
)
183 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RF
));
184 *type
= INTERFACE_DTIO
;
186 if (*op
== INTRINSIC_UNFORMATTED
)
188 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_RUF
));
189 *type
= INTERFACE_DTIO
;
191 if (*op
!= INTRINSIC_NONE
)
195 if (gfc_match (" write ( %n )", buffer
) == MATCH_YES
)
197 *op
= dtio_op (buffer
);
198 if (*op
== INTRINSIC_FORMATTED
)
200 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WF
));
201 *type
= INTERFACE_DTIO
;
203 if (*op
== INTRINSIC_UNFORMATTED
)
205 strcpy (name
, gfc_code2string (dtio_procs
, DTIO_WUF
));
206 *type
= INTERFACE_DTIO
;
208 if (*op
!= INTRINSIC_NONE
)
212 if (gfc_match_name (buffer
) == MATCH_YES
)
214 strcpy (name
, buffer
);
215 *type
= INTERFACE_GENERIC
;
219 *type
= INTERFACE_NAMELESS
;
223 gfc_error ("Syntax error in generic specification at %C");
228 /* Match one of the five F95 forms of an interface statement. The
229 matcher for the abstract interface follows. */
232 gfc_match_interface (void)
234 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
240 m
= gfc_match_space ();
242 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
245 /* If we're not looking at the end of the statement now, or if this
246 is not a nameless interface but we did not see a space, punt. */
247 if (gfc_match_eos () != MATCH_YES
248 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
250 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
255 current_interface
.type
= type
;
260 case INTERFACE_GENERIC
:
261 if (gfc_get_symbol (name
, NULL
, &sym
))
264 if (!sym
->attr
.generic
265 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
270 gfc_error ("Dummy procedure %qs at %C cannot have a "
271 "generic interface", sym
->name
);
275 current_interface
.sym
= gfc_new_block
= sym
;
278 case INTERFACE_USER_OP
:
279 current_interface
.uop
= gfc_get_uop (name
);
282 case INTERFACE_INTRINSIC_OP
:
283 current_interface
.op
= op
;
286 case INTERFACE_NAMELESS
:
287 case INTERFACE_ABSTRACT
:
296 /* Match a F2003 abstract interface. */
299 gfc_match_abstract_interface (void)
303 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
306 m
= gfc_match_eos ();
310 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
314 current_interface
.type
= INTERFACE_ABSTRACT
;
320 /* Match the different sort of generic-specs that can be present after
321 the END INTERFACE itself. */
324 gfc_match_end_interface (void)
326 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
331 m
= gfc_match_space ();
333 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
336 /* If we're not looking at the end of the statement now, or if this
337 is not a nameless interface but we did not see a space, punt. */
338 if (gfc_match_eos () != MATCH_YES
339 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
341 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
348 switch (current_interface
.type
)
350 case INTERFACE_NAMELESS
:
351 case INTERFACE_ABSTRACT
:
352 if (type
!= INTERFACE_NAMELESS
)
354 gfc_error ("Expected a nameless interface at %C");
360 case INTERFACE_INTRINSIC_OP
:
361 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
364 if (current_interface
.op
== INTRINSIC_ASSIGN
)
367 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
372 s1
= gfc_op2string (current_interface
.op
);
373 s2
= gfc_op2string (op
);
375 /* The following if-statements are used to enforce C1202
377 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
378 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
380 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
381 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
383 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
384 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
386 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
387 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
389 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
390 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
392 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
393 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
397 if (strcmp(s2
, "none") == 0)
398 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
401 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
402 "but got %s", s1
, s2
);
409 case INTERFACE_USER_OP
:
410 /* Comparing the symbol node names is OK because only use-associated
411 symbols can be renamed. */
412 if (type
!= current_interface
.type
413 || strcmp (current_interface
.uop
->name
, name
) != 0)
415 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
416 current_interface
.uop
->name
);
423 case INTERFACE_GENERIC
:
424 if (type
!= current_interface
.type
425 || strcmp (current_interface
.sym
->name
, name
) != 0)
427 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
428 current_interface
.sym
->name
);
439 /* Return whether the component was defined anonymously. */
442 is_anonymous_component (gfc_component
*cmp
)
444 /* Only UNION and MAP components are anonymous. In the case of a MAP,
445 the derived type symbol is FL_STRUCT and the component name looks like mM*.
446 This is the only case in which the second character of a component name is
448 return cmp
->ts
.type
== BT_UNION
449 || (cmp
->ts
.type
== BT_DERIVED
450 && cmp
->ts
.u
.derived
->attr
.flavor
== FL_STRUCT
451 && cmp
->name
[0] && cmp
->name
[1] && ISUPPER (cmp
->name
[1]));
455 /* Return whether the derived type was defined anonymously. */
458 is_anonymous_dt (gfc_symbol
*derived
)
460 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
461 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
462 and the type name looks like XX*. This is the only case in which the
463 second character of a type name is uppercase. */
464 return derived
->attr
.flavor
== FL_UNION
465 || (derived
->attr
.flavor
== FL_STRUCT
466 && derived
->name
[0] && derived
->name
[1] && ISUPPER (derived
->name
[1]));
470 /* Compare components according to 4.4.2 of the Fortran standard. */
473 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
474 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
476 /* Compare names, but not for anonymous components such as UNION or MAP. */
477 if (!is_anonymous_component (cmp1
) && !is_anonymous_component (cmp2
)
478 && strcmp (cmp1
->name
, cmp2
->name
) != 0)
481 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
484 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
487 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
490 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
493 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
496 /* Make sure that link lists do not put this function into an
497 endless recursive loop! */
498 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
499 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
500 && gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
) == 0)
503 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
504 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
507 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
508 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
515 /* Compare two union types by comparing the components of their maps.
516 Because unions and maps are anonymous their types get special internal
517 names; therefore the usual derived type comparison will fail on them.
519 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
520 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
521 definitions' than 'equivalent structure'. */
524 gfc_compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
526 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
528 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
531 map1
= un1
->components
;
532 map2
= un2
->components
;
534 /* In terms of 'equality' here we are worried about types which are
535 declared the same in two places, not types that represent equivalent
536 structures. (This is common because of FORTRAN's weird scoping rules.)
537 Though two unions with their maps in different orders could be equivalent,
538 we will say they are not equal for the purposes of this test; therefore
539 we compare the maps sequentially. */
542 cmp1
= map1
->ts
.u
.derived
->components
;
543 cmp2
= map2
->ts
.u
.derived
->components
;
546 /* No two fields will ever point to the same map type unless they are
547 the same component, because one map field is created with its type
548 declaration. Therefore don't worry about recursion here. */
549 /* TODO: worry about recursion into parent types of the unions? */
550 if (compare_components (cmp1
, cmp2
,
551 map1
->ts
.u
.derived
, map2
->ts
.u
.derived
) == 0)
557 if (cmp1
== NULL
&& cmp2
== NULL
)
559 if (cmp1
== NULL
|| cmp2
== NULL
)
566 if (map1
== NULL
&& map2
== NULL
)
568 if (map1
== NULL
|| map2
== NULL
)
577 /* Compare two derived types using the criteria in 4.4.2 of the standard,
578 recursing through gfc_compare_types for the components. */
581 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
583 gfc_component
*cmp1
, *cmp2
;
585 if (derived1
== derived2
)
588 gcc_assert (derived1
&& derived2
);
590 /* Special case for comparing derived types across namespaces. If the
591 true names and module names are the same and the module name is
592 nonnull, then they are equal. */
593 if (strcmp (derived1
->name
, derived2
->name
) == 0
594 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
595 && strcmp (derived1
->module
, derived2
->module
) == 0)
598 /* Compare type via the rules of the standard. Both types must have
599 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
600 because they can be anonymous; therefore two structures with different
601 names may be equal. */
603 /* Compare names, but not for anonymous types such as UNION or MAP. */
604 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
605 && strcmp (derived1
->name
, derived2
->name
) != 0)
608 if (derived1
->component_access
== ACCESS_PRIVATE
609 || derived2
->component_access
== ACCESS_PRIVATE
)
612 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
613 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
616 /* Protect against null components. */
617 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
620 if (derived1
->attr
.zero_comp
)
623 cmp1
= derived1
->components
;
624 cmp2
= derived2
->components
;
626 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
627 simple test can speed things up. Otherwise, lots of things have to
631 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
637 if (cmp1
== NULL
&& cmp2
== NULL
)
639 if (cmp1
== NULL
|| cmp2
== NULL
)
647 /* Compare two typespecs, recursively if necessary. */
650 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
652 /* See if one of the typespecs is a BT_VOID, which is what is being used
653 to allow the funcs like c_f_pointer to accept any pointer type.
654 TODO: Possibly should narrow this to just the one typespec coming in
655 that is for the formal arg, but oh well. */
656 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
659 /* The _data component is not always present, therefore check for its
660 presence before assuming, that its derived->attr is available.
661 When the _data component is not present, then nevertheless the
662 unlimited_polymorphic flag may be set in the derived type's attr. */
663 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
664 && ((ts1
->u
.derived
->attr
.is_class
665 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
666 .unlimited_polymorphic
)
667 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
671 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
672 && ts2
->u
.derived
->components
673 && ((ts2
->u
.derived
->attr
.is_class
674 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
675 .unlimited_polymorphic
)
676 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
677 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
680 if (ts1
->type
== BT_UNION
&& ts2
->type
== BT_UNION
)
681 return gfc_compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
683 if (ts1
->type
!= ts2
->type
684 && ((!gfc_bt_struct (ts1
->type
) && ts1
->type
!= BT_CLASS
)
685 || (!gfc_bt_struct (ts2
->type
) && ts2
->type
!= BT_CLASS
)))
687 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
688 return (ts1
->kind
== ts2
->kind
);
690 /* Compare derived types. */
691 return gfc_type_compatible (ts1
, ts2
);
696 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
698 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
701 /* TYPE and CLASS of the same declared type are type compatible,
702 but have different characteristics. */
703 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
704 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
707 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
712 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
714 gfc_array_spec
*as1
, *as2
;
717 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
720 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
721 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
723 r1
= as1
? as1
->rank
: 0;
724 r2
= as2
? as2
->rank
: 0;
726 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
727 return 0; /* Ranks differ. */
733 /* Given two symbols that are formal arguments, compare their ranks
734 and types. Returns nonzero if they have the same rank and type,
738 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
740 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
744 /* Given two symbols that are formal arguments, compare their types
745 and rank and their formal interfaces if they are both dummy
746 procedures. Returns nonzero if the same, zero if different. */
749 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
751 if (s1
== NULL
|| s2
== NULL
)
752 return s1
== s2
? 1 : 0;
757 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
758 return compare_type_rank (s1
, s2
);
760 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
763 /* At this point, both symbols are procedures. It can happen that
764 external procedures are compared, where one is identified by usage
765 to be a function or subroutine but the other is not. Check TKR
766 nonetheless for these cases. */
767 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
768 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
770 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
771 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
773 /* Now the type of procedure has been identified. */
774 if (s1
->attr
.function
!= s2
->attr
.function
775 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
778 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
781 /* Originally, gfortran recursed here to check the interfaces of passed
782 procedures. This is explicitly not required by the standard. */
787 /* Given a formal argument list and a keyword name, search the list
788 for that keyword. Returns the correct symbol node if found, NULL
792 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
794 for (; f
; f
= f
->next
)
795 if (strcmp (f
->sym
->name
, name
) == 0)
802 /******** Interface checking subroutines **********/
805 /* Given an operator interface and the operator, make sure that all
806 interfaces for that operator are legal. */
809 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
812 gfc_formal_arglist
*formal
;
815 int args
, r1
, r2
, k1
, k2
;
820 t1
= t2
= BT_UNKNOWN
;
821 i1
= i2
= INTENT_UNKNOWN
;
825 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
827 gfc_symbol
*fsym
= formal
->sym
;
830 gfc_error ("Alternate return cannot appear in operator "
831 "interface at %L", &sym
->declared_at
);
837 i1
= fsym
->attr
.intent
;
838 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
844 i2
= fsym
->attr
.intent
;
845 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
851 /* Only +, - and .not. can be unary operators.
852 .not. cannot be a binary operator. */
853 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
854 && op
!= INTRINSIC_MINUS
855 && op
!= INTRINSIC_NOT
)
856 || (args
== 2 && op
== INTRINSIC_NOT
))
858 if (op
== INTRINSIC_ASSIGN
)
859 gfc_error ("Assignment operator interface at %L must have "
860 "two arguments", &sym
->declared_at
);
862 gfc_error ("Operator interface at %L has the wrong number of arguments",
867 /* Check that intrinsics are mapped to functions, except
868 INTRINSIC_ASSIGN which should map to a subroutine. */
869 if (op
== INTRINSIC_ASSIGN
)
871 gfc_formal_arglist
*dummy_args
;
873 if (!sym
->attr
.subroutine
)
875 gfc_error ("Assignment operator interface at %L must be "
876 "a SUBROUTINE", &sym
->declared_at
);
880 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
881 - First argument an array with different rank than second,
882 - First argument is a scalar and second an array,
883 - Types and kinds do not conform, or
884 - First argument is of derived type. */
885 dummy_args
= gfc_sym_get_dummy_args (sym
);
886 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
887 && dummy_args
->sym
->ts
.type
!= BT_CLASS
888 && (r2
== 0 || r1
== r2
)
889 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
890 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
891 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
893 gfc_error ("Assignment operator interface at %L must not redefine "
894 "an INTRINSIC type assignment", &sym
->declared_at
);
900 if (!sym
->attr
.function
)
902 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
908 /* Check intents on operator interfaces. */
909 if (op
== INTRINSIC_ASSIGN
)
911 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
913 gfc_error ("First argument of defined assignment at %L must be "
914 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
920 gfc_error ("Second argument of defined assignment at %L must be "
921 "INTENT(IN)", &sym
->declared_at
);
929 gfc_error ("First argument of operator interface at %L must be "
930 "INTENT(IN)", &sym
->declared_at
);
934 if (args
== 2 && i2
!= INTENT_IN
)
936 gfc_error ("Second argument of operator interface at %L must be "
937 "INTENT(IN)", &sym
->declared_at
);
942 /* From now on, all we have to do is check that the operator definition
943 doesn't conflict with an intrinsic operator. The rules for this
944 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
945 as well as 12.3.2.1.1 of Fortran 2003:
947 "If the operator is an intrinsic-operator (R310), the number of
948 function arguments shall be consistent with the intrinsic uses of
949 that operator, and the types, kind type parameters, or ranks of the
950 dummy arguments shall differ from those required for the intrinsic
951 operation (7.1.2)." */
953 #define IS_NUMERIC_TYPE(t) \
954 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
956 /* Unary ops are easy, do them first. */
957 if (op
== INTRINSIC_NOT
)
959 if (t1
== BT_LOGICAL
)
965 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
967 if (IS_NUMERIC_TYPE (t1
))
973 /* Character intrinsic operators have same character kind, thus
974 operator definitions with operands of different character kinds
976 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
979 /* Intrinsic operators always perform on arguments of same rank,
980 so different ranks is also always safe. (rank == 0) is an exception
981 to that, because all intrinsic operators are elemental. */
982 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
988 case INTRINSIC_EQ_OS
:
990 case INTRINSIC_NE_OS
:
991 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
996 case INTRINSIC_MINUS
:
997 case INTRINSIC_TIMES
:
998 case INTRINSIC_DIVIDE
:
999 case INTRINSIC_POWER
:
1000 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1005 case INTRINSIC_GT_OS
:
1007 case INTRINSIC_GE_OS
:
1009 case INTRINSIC_LT_OS
:
1011 case INTRINSIC_LE_OS
:
1012 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1014 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1015 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1019 case INTRINSIC_CONCAT
:
1020 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1027 case INTRINSIC_NEQV
:
1028 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1038 #undef IS_NUMERIC_TYPE
1041 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1047 /* Given a pair of formal argument lists, we see if the two lists can
1048 be distinguished by counting the number of nonoptional arguments of
1049 a given type/rank in f1 and seeing if there are less then that
1050 number of those arguments in f2 (including optional arguments).
1051 Since this test is asymmetric, it has to be called twice to make it
1052 symmetric. Returns nonzero if the argument lists are incompatible
1053 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1054 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1057 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1058 const char *p1
, const char *p2
)
1060 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
1061 gfc_formal_arglist
*f
;
1074 for (f
= f1
; f
; f
= f
->next
)
1077 /* Build an array of integers that gives the same integer to
1078 arguments of the same type/rank. */
1079 arg
= XCNEWVEC (arginfo
, n1
);
1082 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1085 arg
[i
].sym
= f
->sym
;
1090 for (i
= 0; i
< n1
; i
++)
1092 if (arg
[i
].flag
!= -1)
1095 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1096 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1097 continue; /* Skip OPTIONAL and PASS arguments. */
1101 /* Find other non-optional, non-pass arguments of the same type/rank. */
1102 for (j
= i
+ 1; j
< n1
; j
++)
1103 if ((arg
[j
].sym
== NULL
1104 || !(arg
[j
].sym
->attr
.optional
1105 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1106 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1107 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1113 /* Now loop over each distinct type found in f1. */
1117 for (i
= 0; i
< n1
; i
++)
1119 if (arg
[i
].flag
!= k
)
1123 for (j
= i
+ 1; j
< n1
; j
++)
1124 if (arg
[j
].flag
== k
)
1127 /* Count the number of non-pass arguments in f2 with that type,
1128 including those that are optional. */
1131 for (f
= f2
; f
; f
= f
->next
)
1132 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1133 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1134 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1152 /* Perform the correspondence test in rule (3) of F08:C1215.
1153 Returns zero if no argument is found that satisfies this rule,
1154 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1157 This test is also not symmetric in f1 and f2 and must be called
1158 twice. This test finds problems caused by sorting the actual
1159 argument list with keywords. For example:
1163 INTEGER :: A ; REAL :: B
1167 INTEGER :: A ; REAL :: B
1171 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1174 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1175 const char *p1
, const char *p2
)
1177 gfc_formal_arglist
*f2_save
, *g
;
1184 if (f1
->sym
->attr
.optional
)
1187 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1189 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1192 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1193 || compare_type_rank (f2
->sym
, f1
->sym
))
1194 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1195 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1196 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1199 /* Now search for a disambiguating keyword argument starting at
1200 the current non-match. */
1201 for (g
= f1
; g
; g
= g
->next
)
1203 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1206 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1207 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1208 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1209 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1210 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1226 symbol_rank (gfc_symbol
*sym
)
1229 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1230 return as
? as
->rank
: 0;
1234 /* Check if the characteristics of two dummy arguments match,
1238 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1239 bool type_must_agree
, char *errmsg
,
1242 if (s1
== NULL
|| s2
== NULL
)
1243 return s1
== s2
? true : false;
1245 /* Check type and rank. */
1246 if (type_must_agree
)
1248 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1250 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1251 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1254 if (!compare_rank (s1
, s2
))
1256 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1257 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1263 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1265 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1270 /* Check OPTIONAL attribute. */
1271 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1273 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1278 /* Check ALLOCATABLE attribute. */
1279 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1281 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1286 /* Check POINTER attribute. */
1287 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1289 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1294 /* Check TARGET attribute. */
1295 if (s1
->attr
.target
!= s2
->attr
.target
)
1297 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1302 /* Check ASYNCHRONOUS attribute. */
1303 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1305 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1310 /* Check CONTIGUOUS attribute. */
1311 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1313 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1318 /* Check VALUE attribute. */
1319 if (s1
->attr
.value
!= s2
->attr
.value
)
1321 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1326 /* Check VOLATILE attribute. */
1327 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1329 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1334 /* Check interface of dummy procedures. */
1335 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1338 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1341 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1342 "'%s': %s", s1
->name
, err
);
1347 /* Check string length. */
1348 if (s1
->ts
.type
== BT_CHARACTER
1349 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1350 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1352 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1353 s2
->ts
.u
.cl
->length
);
1359 snprintf (errmsg
, err_len
, "Character length mismatch "
1360 "in argument '%s'", s1
->name
);
1364 /* FIXME: Implement a warning for this case.
1365 gfc_warning (0, "Possible character length mismatch in argument %qs",
1373 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1374 "%i of gfc_dep_compare_expr", compval
);
1379 /* Check array shape. */
1380 if (s1
->as
&& s2
->as
)
1383 gfc_expr
*shape1
, *shape2
;
1385 if (s1
->as
->type
!= s2
->as
->type
)
1387 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1392 if (s1
->as
->corank
!= s2
->as
->corank
)
1394 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1395 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1399 if (s1
->as
->type
== AS_EXPLICIT
)
1400 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1402 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1403 gfc_copy_expr (s1
->as
->lower
[i
]));
1404 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1405 gfc_copy_expr (s2
->as
->lower
[i
]));
1406 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1407 gfc_free_expr (shape1
);
1408 gfc_free_expr (shape2
);
1414 if (i
< s1
->as
->rank
)
1415 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1416 " argument '%s'", i
+ 1, s1
->name
);
1418 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1419 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1423 /* FIXME: Implement a warning for this case.
1424 gfc_warning (0, "Possible shape mismatch in argument %qs",
1432 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1433 "result %i of gfc_dep_compare_expr",
1444 /* Check if the characteristics of two function results match,
1448 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1449 char *errmsg
, int err_len
)
1451 gfc_symbol
*r1
, *r2
;
1453 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1454 r1
= s1
->ts
.interface
->result
;
1456 r1
= s1
->result
? s1
->result
: s1
;
1458 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1459 r2
= s2
->ts
.interface
->result
;
1461 r2
= s2
->result
? s2
->result
: s2
;
1463 if (r1
->ts
.type
== BT_UNKNOWN
)
1466 /* Check type and rank. */
1467 if (!compare_type (r1
, r2
))
1469 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1470 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1473 if (!compare_rank (r1
, r2
))
1475 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1476 symbol_rank (r1
), symbol_rank (r2
));
1480 /* Check ALLOCATABLE attribute. */
1481 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1483 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1488 /* Check POINTER attribute. */
1489 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1491 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1496 /* Check CONTIGUOUS attribute. */
1497 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1499 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1504 /* Check PROCEDURE POINTER attribute. */
1505 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1507 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1512 /* Check string length. */
1513 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1515 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1517 snprintf (errmsg
, err_len
, "Character length mismatch "
1518 "in function result");
1522 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1524 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1525 r2
->ts
.u
.cl
->length
);
1531 snprintf (errmsg
, err_len
, "Character length mismatch "
1532 "in function result");
1536 /* FIXME: Implement a warning for this case.
1537 snprintf (errmsg, err_len, "Possible character length mismatch "
1538 "in function result");*/
1545 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1546 "result %i of gfc_dep_compare_expr", compval
);
1552 /* Check array shape. */
1553 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1556 gfc_expr
*shape1
, *shape2
;
1558 if (r1
->as
->type
!= r2
->as
->type
)
1560 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1564 if (r1
->as
->type
== AS_EXPLICIT
)
1565 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1567 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1568 gfc_copy_expr (r1
->as
->lower
[i
]));
1569 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1570 gfc_copy_expr (r2
->as
->lower
[i
]));
1571 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1572 gfc_free_expr (shape1
);
1573 gfc_free_expr (shape2
);
1579 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1580 "function result", i
+ 1);
1584 /* FIXME: Implement a warning for this case.
1585 gfc_warning (0, "Possible shape mismatch in return value");*/
1592 gfc_internal_error ("check_result_characteristics (2): "
1593 "Unexpected result %i of "
1594 "gfc_dep_compare_expr", compval
);
1604 /* 'Compare' two formal interfaces associated with a pair of symbols.
1605 We return nonzero if there exists an actual argument list that
1606 would be ambiguous between the two interfaces, zero otherwise.
1607 'strict_flag' specifies whether all the characteristics are
1608 required to match, which is not the case for ambiguity checks.
1609 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1612 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1613 int generic_flag
, int strict_flag
,
1614 char *errmsg
, int err_len
,
1615 const char *p1
, const char *p2
)
1617 gfc_formal_arglist
*f1
, *f2
;
1619 gcc_assert (name2
!= NULL
);
1621 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1622 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1623 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1626 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1630 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1633 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1637 /* Do strict checks on all characteristics
1638 (for dummy procedures and procedure pointer assignments). */
1639 if (!generic_flag
&& strict_flag
)
1641 if (s1
->attr
.function
&& s2
->attr
.function
)
1643 /* If both are functions, check result characteristics. */
1644 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1645 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1649 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1651 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1654 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1656 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1661 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1662 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1665 f1
= gfc_sym_get_dummy_args (s1
);
1666 f2
= gfc_sym_get_dummy_args (s2
);
1668 if (f1
== NULL
&& f2
== NULL
)
1669 return 1; /* Special case: No arguments. */
1673 if (count_types_test (f1
, f2
, p1
, p2
)
1674 || count_types_test (f2
, f1
, p2
, p1
))
1676 if (generic_correspondence (f1
, f2
, p1
, p2
)
1677 || generic_correspondence (f2
, f1
, p2
, p1
))
1681 /* Perform the abbreviated correspondence test for operators (the
1682 arguments cannot be optional and are always ordered correctly).
1683 This is also done when comparing interfaces for dummy procedures and in
1684 procedure pointer assignments. */
1688 /* Check existence. */
1689 if (f1
== NULL
&& f2
== NULL
)
1691 if (f1
== NULL
|| f2
== NULL
)
1694 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1695 "arguments", name2
);
1699 if (UNLIMITED_POLY (f1
->sym
))
1704 /* Check all characteristics. */
1705 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1711 /* Only check type and rank. */
1712 if (!compare_type (f2
->sym
, f1
->sym
))
1715 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1716 "(%s/%s)", f1
->sym
->name
,
1717 gfc_typename (&f1
->sym
->ts
),
1718 gfc_typename (&f2
->sym
->ts
));
1721 if (!compare_rank (f2
->sym
, f1
->sym
))
1724 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1725 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1726 symbol_rank (f2
->sym
));
1739 /* Given a pointer to an interface pointer, remove duplicate
1740 interfaces and make sure that all symbols are either functions
1741 or subroutines, and all of the same kind. Returns nonzero if
1742 something goes wrong. */
1745 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1747 gfc_interface
*psave
, *q
, *qlast
;
1750 for (; p
; p
= p
->next
)
1752 /* Make sure all symbols in the interface have been defined as
1753 functions or subroutines. */
1754 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1755 || !p
->sym
->attr
.if_source
)
1756 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1758 if (p
->sym
->attr
.external
)
1759 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1760 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1762 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1763 "subroutine", p
->sym
->name
, interface_name
,
1764 &p
->sym
->declared_at
);
1768 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1769 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1770 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1771 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1773 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1774 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1775 " or all FUNCTIONs", interface_name
,
1776 &p
->sym
->declared_at
);
1777 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1778 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1779 "generic name is also the name of a derived type",
1780 interface_name
, &p
->sym
->declared_at
);
1784 /* F2003, C1207. F2008, C1207. */
1785 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1786 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1787 "%qs in %s at %L", p
->sym
->name
,
1788 interface_name
, &p
->sym
->declared_at
))
1793 /* Remove duplicate interfaces in this interface list. */
1794 for (; p
; p
= p
->next
)
1798 for (q
= p
->next
; q
;)
1800 if (p
->sym
!= q
->sym
)
1807 /* Duplicate interface. */
1808 qlast
->next
= q
->next
;
1819 /* Check lists of interfaces to make sure that no two interfaces are
1820 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1823 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1824 int generic_flag
, const char *interface_name
,
1828 for (; p
; p
= p
->next
)
1829 for (q
= q0
; q
; q
= q
->next
)
1831 if (p
->sym
== q
->sym
)
1832 continue; /* Duplicates OK here. */
1834 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1837 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1838 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1839 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1840 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1843 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1844 p
->sym
->name
, q
->sym
->name
, interface_name
,
1846 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1847 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
1848 p
->sym
->name
, q
->sym
->name
, interface_name
,
1851 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1852 "interfaces at %L", interface_name
, &p
->where
);
1860 /* Check the generic and operator interfaces of symbols to make sure
1861 that none of the interfaces conflict. The check has to be done
1862 after all of the symbols are actually loaded. */
1865 check_sym_interfaces (gfc_symbol
*sym
)
1867 char interface_name
[100];
1870 if (sym
->ns
!= gfc_current_ns
)
1873 if (sym
->generic
!= NULL
)
1875 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1876 if (check_interface0 (sym
->generic
, interface_name
))
1879 for (p
= sym
->generic
; p
; p
= p
->next
)
1881 if (p
->sym
->attr
.mod_proc
1882 && !p
->sym
->attr
.module_procedure
1883 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1884 || p
->sym
->attr
.procedure
))
1886 gfc_error ("%qs at %L is not a module procedure",
1887 p
->sym
->name
, &p
->where
);
1892 /* Originally, this test was applied to host interfaces too;
1893 this is incorrect since host associated symbols, from any
1894 source, cannot be ambiguous with local symbols. */
1895 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1896 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1902 check_uop_interfaces (gfc_user_op
*uop
)
1904 char interface_name
[100];
1908 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1909 if (check_interface0 (uop
->op
, interface_name
))
1912 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1914 uop2
= gfc_find_uop (uop
->name
, ns
);
1918 check_interface1 (uop
->op
, uop2
->op
, 0,
1919 interface_name
, true);
1923 /* Given an intrinsic op, return an equivalent op if one exists,
1924 or INTRINSIC_NONE otherwise. */
1927 gfc_equivalent_op (gfc_intrinsic_op op
)
1932 return INTRINSIC_EQ_OS
;
1934 case INTRINSIC_EQ_OS
:
1935 return INTRINSIC_EQ
;
1938 return INTRINSIC_NE_OS
;
1940 case INTRINSIC_NE_OS
:
1941 return INTRINSIC_NE
;
1944 return INTRINSIC_GT_OS
;
1946 case INTRINSIC_GT_OS
:
1947 return INTRINSIC_GT
;
1950 return INTRINSIC_GE_OS
;
1952 case INTRINSIC_GE_OS
:
1953 return INTRINSIC_GE
;
1956 return INTRINSIC_LT_OS
;
1958 case INTRINSIC_LT_OS
:
1959 return INTRINSIC_LT
;
1962 return INTRINSIC_LE_OS
;
1964 case INTRINSIC_LE_OS
:
1965 return INTRINSIC_LE
;
1968 return INTRINSIC_NONE
;
1972 /* For the namespace, check generic, user operator and intrinsic
1973 operator interfaces for consistency and to remove duplicate
1974 interfaces. We traverse the whole namespace, counting on the fact
1975 that most symbols will not have generic or operator interfaces. */
1978 gfc_check_interfaces (gfc_namespace
*ns
)
1980 gfc_namespace
*old_ns
, *ns2
;
1981 char interface_name
[100];
1984 old_ns
= gfc_current_ns
;
1985 gfc_current_ns
= ns
;
1987 gfc_traverse_ns (ns
, check_sym_interfaces
);
1989 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1991 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1993 if (i
== INTRINSIC_USER
)
1996 if (i
== INTRINSIC_ASSIGN
)
1997 strcpy (interface_name
, "intrinsic assignment operator");
1999 sprintf (interface_name
, "intrinsic '%s' operator",
2000 gfc_op2string ((gfc_intrinsic_op
) i
));
2002 if (check_interface0 (ns
->op
[i
], interface_name
))
2006 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2009 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2011 gfc_intrinsic_op other_op
;
2013 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2014 interface_name
, true))
2017 /* i should be gfc_intrinsic_op, but has to be int with this cast
2018 here for stupid C++ compatibility rules. */
2019 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2020 if (other_op
!= INTRINSIC_NONE
2021 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2022 0, interface_name
, true))
2028 gfc_current_ns
= old_ns
;
2032 /* Given a symbol of a formal argument list and an expression, if the
2033 formal argument is allocatable, check that the actual argument is
2034 allocatable. Returns nonzero if compatible, zero if not compatible. */
2037 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2039 symbol_attribute attr
;
2041 if (formal
->attr
.allocatable
2042 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2044 attr
= gfc_expr_attr (actual
);
2045 if (!attr
.allocatable
)
2053 /* Given a symbol of a formal argument list and an expression, if the
2054 formal argument is a pointer, see if the actual argument is a
2055 pointer. Returns nonzero if compatible, zero if not compatible. */
2058 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2060 symbol_attribute attr
;
2062 if (formal
->attr
.pointer
2063 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2064 && CLASS_DATA (formal
)->attr
.class_pointer
))
2066 attr
= gfc_expr_attr (actual
);
2068 /* Fortran 2008 allows non-pointer actual arguments. */
2069 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2080 /* Emit clear error messages for rank mismatch. */
2083 argument_rank_mismatch (const char *name
, locus
*where
,
2084 int rank1
, int rank2
)
2087 /* TS 29113, C407b. */
2090 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2091 " %qs has assumed-rank", where
, name
);
2093 else if (rank1
== 0)
2095 gfc_error ("Rank mismatch in argument %qs at %L "
2096 "(scalar and rank-%d)", name
, where
, rank2
);
2098 else if (rank2
== 0)
2100 gfc_error ("Rank mismatch in argument %qs at %L "
2101 "(rank-%d and scalar)", name
, where
, rank1
);
2105 gfc_error ("Rank mismatch in argument %qs at %L "
2106 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2111 /* Given a symbol of a formal argument list and an expression, see if
2112 the two are compatible as arguments. Returns nonzero if
2113 compatible, zero if not compatible. */
2116 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2117 int ranks_must_agree
, int is_elemental
, locus
*where
)
2120 bool rank_check
, is_pointer
;
2124 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2125 procs c_f_pointer or c_f_procpointer, and we need to accept most
2126 pointers the user could give us. This should allow that. */
2127 if (formal
->ts
.type
== BT_VOID
)
2130 if (formal
->ts
.type
== BT_DERIVED
2131 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2132 && actual
->ts
.type
== BT_DERIVED
2133 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2136 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2137 /* Make sure the vtab symbol is present when
2138 the module variables are generated. */
2139 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2141 if (actual
->ts
.type
== BT_PROCEDURE
)
2143 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2145 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2148 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2152 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2153 sizeof(err
), NULL
, NULL
))
2156 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2157 formal
->name
, &actual
->where
, err
);
2161 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2163 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2164 &act_sym
->declared_at
);
2165 if (act_sym
->ts
.type
== BT_UNKNOWN
2166 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2169 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2170 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2171 &act_sym
->declared_at
);
2176 ppc
= gfc_get_proc_ptr_comp (actual
);
2177 if (ppc
&& ppc
->ts
.interface
)
2179 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2180 err
, sizeof(err
), NULL
, NULL
))
2183 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2184 formal
->name
, &actual
->where
, err
);
2190 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2191 && !gfc_is_simply_contiguous (actual
, true, false))
2194 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2195 "must be simply contiguous", formal
->name
, &actual
->where
);
2199 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2200 && actual
->ts
.type
!= BT_HOLLERITH
2201 && formal
->ts
.type
!= BT_ASSUMED
2202 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2203 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2204 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2205 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2206 CLASS_DATA (actual
)->ts
.u
.derived
)))
2209 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2210 formal
->name
, where
, gfc_typename (&actual
->ts
),
2211 gfc_typename (&formal
->ts
));
2215 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2218 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2219 "argument %qs is of assumed type", &actual
->where
,
2224 /* F2008, 12.5.2.5; IR F08/0073. */
2225 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2226 && actual
->expr_type
!= EXPR_NULL
2227 && ((CLASS_DATA (formal
)->attr
.class_pointer
2228 && formal
->attr
.intent
!= INTENT_IN
)
2229 || CLASS_DATA (formal
)->attr
.allocatable
))
2231 if (actual
->ts
.type
!= BT_CLASS
)
2234 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2235 formal
->name
, &actual
->where
);
2239 if (!gfc_expr_attr (actual
).class_ok
)
2242 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2243 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2244 CLASS_DATA (formal
)->ts
.u
.derived
))
2247 gfc_error ("Actual argument to %qs at %L must have the same "
2248 "declared type", formal
->name
, &actual
->where
);
2253 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2254 is necessary also for F03, so retain error for both.
2255 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2256 compatible, no attempt has been made to channel to this one. */
2257 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2258 && (CLASS_DATA (formal
)->attr
.allocatable
2259 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2262 gfc_error ("Actual argument to %qs at %L must be unlimited "
2263 "polymorphic since the formal argument is a "
2264 "pointer or allocatable unlimited polymorphic "
2265 "entity [F2008: 12.5.2.5]", formal
->name
,
2270 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2273 gfc_error ("Actual argument to %qs at %L must be a coarray",
2274 formal
->name
, &actual
->where
);
2278 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2280 gfc_ref
*last
= NULL
;
2282 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2283 if (ref
->type
== REF_COMPONENT
)
2286 /* F2008, 12.5.2.6. */
2287 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2289 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2292 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2293 formal
->name
, &actual
->where
, formal
->as
->corank
,
2294 last
? last
->u
.c
.component
->as
->corank
2295 : actual
->symtree
->n
.sym
->as
->corank
);
2300 if (formal
->attr
.codimension
)
2302 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2303 /* F2015, 12.5.2.8. */
2304 if (formal
->attr
.dimension
2305 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2306 && gfc_expr_attr (actual
).dimension
2307 && !gfc_is_simply_contiguous (actual
, true, true))
2310 gfc_error ("Actual argument to %qs at %L must be simply "
2311 "contiguous or an element of such an array",
2312 formal
->name
, &actual
->where
);
2316 /* F2008, C1303 and C1304. */
2317 if (formal
->attr
.intent
!= INTENT_INOUT
2318 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2319 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2320 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2321 || formal
->attr
.lock_comp
))
2325 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2326 "which is LOCK_TYPE or has a LOCK_TYPE component",
2327 formal
->name
, &actual
->where
);
2331 /* TS18508, C702/C703. */
2332 if (formal
->attr
.intent
!= INTENT_INOUT
2333 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2334 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2335 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2336 || formal
->attr
.event_comp
))
2340 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2341 "which is EVENT_TYPE or has a EVENT_TYPE component",
2342 formal
->name
, &actual
->where
);
2347 /* F2008, C1239/C1240. */
2348 if (actual
->expr_type
== EXPR_VARIABLE
2349 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2350 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2351 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2352 && actual
->rank
&& formal
->as
2353 && !gfc_is_simply_contiguous (actual
, true, false)
2354 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2355 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2356 || formal
->attr
.contiguous
))
2359 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2360 "assumed-rank array without CONTIGUOUS attribute - as actual"
2361 " argument at %L is not simply contiguous and both are "
2362 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2366 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2367 && gfc_expr_attr (actual
).codimension
)
2369 if (formal
->attr
.intent
== INTENT_OUT
)
2372 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2373 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2377 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2378 gfc_warning (OPT_Wsurprising
,
2379 "Passing coarray at %L to allocatable, noncoarray dummy "
2380 "argument %qs, which is invalid if the allocation status"
2381 " is modified", &actual
->where
, formal
->name
);
2384 /* If the rank is the same or the formal argument has assumed-rank. */
2385 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2388 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2389 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2390 || formal
->as
->type
== AS_DEFERRED
)
2391 && actual
->expr_type
!= EXPR_NULL
;
2393 /* Skip rank checks for NO_ARG_CHECK. */
2394 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2397 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2398 if (rank_check
|| ranks_must_agree
2399 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2400 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2401 || (actual
->rank
== 0
2402 && ((formal
->ts
.type
== BT_CLASS
2403 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2404 || (formal
->ts
.type
!= BT_CLASS
2405 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2406 && actual
->expr_type
!= EXPR_NULL
)
2407 || (actual
->rank
== 0 && formal
->attr
.dimension
2408 && gfc_is_coindexed (actual
)))
2411 argument_rank_mismatch (formal
->name
, &actual
->where
,
2412 symbol_rank (formal
), actual
->rank
);
2415 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2418 /* At this point, we are considering a scalar passed to an array. This
2419 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2420 - if the actual argument is (a substring of) an element of a
2421 non-assumed-shape/non-pointer/non-polymorphic array; or
2422 - (F2003) if the actual argument is of type character of default/c_char
2425 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2426 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2428 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2430 if (ref
->type
== REF_COMPONENT
)
2431 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2432 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2433 && ref
->u
.ar
.dimen
> 0
2435 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2439 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2442 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2443 "at %L", formal
->name
, &actual
->where
);
2447 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2448 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2451 gfc_error ("Element of assumed-shaped or pointer "
2452 "array passed to array dummy argument %qs at %L",
2453 formal
->name
, &actual
->where
);
2457 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2458 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2460 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2463 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2464 "CHARACTER actual argument with array dummy argument "
2465 "%qs at %L", formal
->name
, &actual
->where
);
2469 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2471 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2472 "array dummy argument %qs at %L",
2473 formal
->name
, &actual
->where
);
2476 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2482 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2485 argument_rank_mismatch (formal
->name
, &actual
->where
,
2486 symbol_rank (formal
), actual
->rank
);
2494 /* Returns the storage size of a symbol (formal argument) or
2495 zero if it cannot be determined. */
2497 static unsigned long
2498 get_sym_storage_size (gfc_symbol
*sym
)
2501 unsigned long strlen
, elements
;
2503 if (sym
->ts
.type
== BT_CHARACTER
)
2505 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2506 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2507 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2514 if (symbol_rank (sym
) == 0)
2518 if (sym
->as
->type
!= AS_EXPLICIT
)
2520 for (i
= 0; i
< sym
->as
->rank
; i
++)
2522 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2523 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2526 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2527 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2530 return strlen
*elements
;
2534 /* Returns the storage size of an expression (actual argument) or
2535 zero if it cannot be determined. For an array element, it returns
2536 the remaining size as the element sequence consists of all storage
2537 units of the actual argument up to the end of the array. */
2539 static unsigned long
2540 get_expr_storage_size (gfc_expr
*e
)
2543 long int strlen
, elements
;
2544 long int substrlen
= 0;
2545 bool is_str_storage
= false;
2551 if (e
->ts
.type
== BT_CHARACTER
)
2553 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2554 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2555 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2556 else if (e
->expr_type
== EXPR_CONSTANT
2557 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2558 strlen
= e
->value
.character
.length
;
2563 strlen
= 1; /* Length per element. */
2565 if (e
->rank
== 0 && !e
->ref
)
2573 for (i
= 0; i
< e
->rank
; i
++)
2574 elements
*= mpz_get_si (e
->shape
[i
]);
2575 return elements
*strlen
;
2578 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2580 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2581 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2585 /* The string length is the substring length.
2586 Set now to full string length. */
2587 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2588 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2591 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2593 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2597 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2598 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2600 long int start
, end
, stride
;
2603 if (ref
->u
.ar
.stride
[i
])
2605 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2606 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2611 if (ref
->u
.ar
.start
[i
])
2613 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2614 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2618 else if (ref
->u
.ar
.as
->lower
[i
]
2619 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2620 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2624 if (ref
->u
.ar
.end
[i
])
2626 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2627 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2631 else if (ref
->u
.ar
.as
->upper
[i
]
2632 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2633 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2637 elements
*= (end
- start
)/stride
+ 1L;
2639 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2640 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2642 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2643 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2644 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2645 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2646 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2647 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2648 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2653 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2654 && e
->expr_type
== EXPR_VARIABLE
)
2656 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2657 || e
->symtree
->n
.sym
->attr
.pointer
)
2663 /* Determine the number of remaining elements in the element
2664 sequence for array element designators. */
2665 is_str_storage
= true;
2666 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2668 if (ref
->u
.ar
.start
[i
] == NULL
2669 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2670 || ref
->u
.ar
.as
->upper
[i
] == NULL
2671 || ref
->u
.ar
.as
->lower
[i
] == NULL
2672 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2673 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2678 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2679 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2681 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2682 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2685 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2686 && ref
->u
.c
.component
->attr
.proc_pointer
2687 && ref
->u
.c
.component
->attr
.dimension
)
2689 /* Array-valued procedure-pointer components. */
2690 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2691 for (i
= 0; i
< as
->rank
; i
++)
2693 if (!as
->upper
[i
] || !as
->lower
[i
]
2694 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2695 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2699 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2700 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2706 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2709 return elements
*strlen
;
2713 /* Given an expression, check whether it is an array section
2714 which has a vector subscript. If it has, one is returned,
2718 gfc_has_vector_subscript (gfc_expr
*e
)
2723 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2726 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2727 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2728 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2729 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2737 is_procptr_result (gfc_expr
*expr
)
2739 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2741 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2743 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2744 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2748 /* Given formal and actual argument lists, see if they are compatible.
2749 If they are compatible, the actual argument list is sorted to
2750 correspond with the formal list, and elements for missing optional
2751 arguments are inserted. If WHERE pointer is nonnull, then we issue
2752 errors when things don't match instead of just returning the status
2756 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2757 int ranks_must_agree
, int is_elemental
, locus
*where
)
2759 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2760 gfc_formal_arglist
*f
;
2762 unsigned long actual_size
, formal_size
;
2763 bool full_array
= false;
2767 if (actual
== NULL
&& formal
== NULL
)
2771 for (f
= formal
; f
; f
= f
->next
)
2774 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2776 for (i
= 0; i
< n
; i
++)
2783 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2785 /* Look for keywords but ignore g77 extensions like %VAL. */
2786 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2789 for (f
= formal
; f
; f
= f
->next
, i
++)
2793 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2800 gfc_error ("Keyword argument %qs at %L is not in "
2801 "the procedure", a
->name
, &a
->expr
->where
);
2805 if (new_arg
[i
] != NULL
)
2808 gfc_error ("Keyword argument %qs at %L is already associated "
2809 "with another actual argument", a
->name
,
2818 gfc_error ("More actual than formal arguments in procedure "
2819 "call at %L", where
);
2824 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2830 gfc_error ("Missing alternate return spec in subroutine call "
2835 if (a
->expr
== NULL
)
2838 gfc_error ("Unexpected alternate return spec in subroutine "
2839 "call at %L", where
);
2843 /* Make sure that intrinsic vtables exist for calls to unlimited
2844 polymorphic formal arguments. */
2845 if (UNLIMITED_POLY (f
->sym
)
2846 && a
->expr
->ts
.type
!= BT_DERIVED
2847 && a
->expr
->ts
.type
!= BT_CLASS
)
2848 gfc_find_vtab (&a
->expr
->ts
);
2850 if (a
->expr
->expr_type
== EXPR_NULL
2851 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2852 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2853 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2854 || (f
->sym
->ts
.type
== BT_CLASS
2855 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2856 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2857 || !f
->sym
->attr
.optional
2858 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2861 && (!f
->sym
->attr
.optional
2862 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2863 || (f
->sym
->ts
.type
== BT_CLASS
2864 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2865 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2866 where
, f
->sym
->name
);
2868 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2869 "dummy %qs", where
, f
->sym
->name
);
2874 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2875 is_elemental
, where
))
2878 /* TS 29113, 6.3p2. */
2879 if (f
->sym
->ts
.type
== BT_ASSUMED
2880 && (a
->expr
->ts
.type
== BT_DERIVED
2881 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2883 gfc_namespace
*f2k_derived
;
2885 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2886 ? a
->expr
->ts
.u
.derived
->f2k_derived
2887 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2890 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2892 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2893 "derived type with type-bound or FINAL procedures",
2899 /* Special case for character arguments. For allocatable, pointer
2900 and assumed-shape dummies, the string length needs to match
2902 if (a
->expr
->ts
.type
== BT_CHARACTER
2903 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2904 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2905 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2906 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2907 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2908 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2909 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2910 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2912 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2914 "Character length mismatch (%ld/%ld) between actual "
2915 "argument and pointer or allocatable dummy argument "
2917 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2918 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2919 f
->sym
->name
, &a
->expr
->where
);
2922 "Character length mismatch (%ld/%ld) between actual "
2923 "argument and assumed-shape dummy argument %qs "
2925 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2926 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2927 f
->sym
->name
, &a
->expr
->where
);
2931 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2932 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2933 && a
->expr
->ts
.type
== BT_CHARACTER
)
2936 gfc_error ("Actual argument at %L to allocatable or "
2937 "pointer dummy argument %qs must have a deferred "
2938 "length type parameter if and only if the dummy has one",
2939 &a
->expr
->where
, f
->sym
->name
);
2943 if (f
->sym
->ts
.type
== BT_CLASS
)
2944 goto skip_size_check
;
2946 actual_size
= get_expr_storage_size (a
->expr
);
2947 formal_size
= get_sym_storage_size (f
->sym
);
2948 if (actual_size
!= 0 && actual_size
< formal_size
2949 && a
->expr
->ts
.type
!= BT_PROCEDURE
2950 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2952 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2953 gfc_warning (0, "Character length of actual argument shorter "
2954 "than of dummy argument %qs (%lu/%lu) at %L",
2955 f
->sym
->name
, actual_size
, formal_size
,
2958 gfc_warning (0, "Actual argument contains too few "
2959 "elements for dummy argument %qs (%lu/%lu) at %L",
2960 f
->sym
->name
, actual_size
, formal_size
,
2967 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2968 argument is provided for a procedure pointer formal argument. */
2969 if (f
->sym
->attr
.proc_pointer
2970 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2971 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2972 || gfc_is_proc_ptr_comp (a
->expr
)))
2973 || (a
->expr
->expr_type
== EXPR_FUNCTION
2974 && is_procptr_result (a
->expr
))))
2977 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2978 f
->sym
->name
, &a
->expr
->where
);
2982 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2983 provided for a procedure formal argument. */
2984 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2985 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2986 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2987 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2988 || gfc_is_proc_ptr_comp (a
->expr
)))
2989 || (a
->expr
->expr_type
== EXPR_FUNCTION
2990 && is_procptr_result (a
->expr
))))
2993 gfc_error ("Expected a procedure for argument %qs at %L",
2994 f
->sym
->name
, &a
->expr
->where
);
2998 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2999 && a
->expr
->expr_type
== EXPR_VARIABLE
3000 && a
->expr
->symtree
->n
.sym
->as
3001 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3002 && (a
->expr
->ref
== NULL
3003 || (a
->expr
->ref
->type
== REF_ARRAY
3004 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3007 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3008 " array at %L", f
->sym
->name
, where
);
3012 if (a
->expr
->expr_type
!= EXPR_NULL
3013 && compare_pointer (f
->sym
, a
->expr
) == 0)
3016 gfc_error ("Actual argument for %qs must be a pointer at %L",
3017 f
->sym
->name
, &a
->expr
->where
);
3021 if (a
->expr
->expr_type
!= EXPR_NULL
3022 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3023 && compare_pointer (f
->sym
, a
->expr
) == 2)
3026 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3027 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3032 /* Fortran 2008, C1242. */
3033 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3036 gfc_error ("Coindexed actual argument at %L to pointer "
3038 &a
->expr
->where
, f
->sym
->name
);
3042 /* Fortran 2008, 12.5.2.5 (no constraint). */
3043 if (a
->expr
->expr_type
== EXPR_VARIABLE
3044 && f
->sym
->attr
.intent
!= INTENT_IN
3045 && f
->sym
->attr
.allocatable
3046 && gfc_is_coindexed (a
->expr
))
3049 gfc_error ("Coindexed actual argument at %L to allocatable "
3050 "dummy %qs requires INTENT(IN)",
3051 &a
->expr
->where
, f
->sym
->name
);
3055 /* Fortran 2008, C1237. */
3056 if (a
->expr
->expr_type
== EXPR_VARIABLE
3057 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3058 && gfc_is_coindexed (a
->expr
)
3059 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3060 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3063 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3064 "%L requires that dummy %qs has neither "
3065 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3070 /* Fortran 2008, 12.5.2.4 (no constraint). */
3071 if (a
->expr
->expr_type
== EXPR_VARIABLE
3072 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3073 && gfc_is_coindexed (a
->expr
)
3074 && gfc_has_ultimate_allocatable (a
->expr
))
3077 gfc_error ("Coindexed actual argument at %L with allocatable "
3078 "ultimate component to dummy %qs requires either VALUE "
3079 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3083 if (f
->sym
->ts
.type
== BT_CLASS
3084 && CLASS_DATA (f
->sym
)->attr
.allocatable
3085 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3089 gfc_error ("Actual CLASS array argument for %qs must be a full "
3090 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3095 if (a
->expr
->expr_type
!= EXPR_NULL
3096 && compare_allocatable (f
->sym
, a
->expr
) == 0)
3099 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3100 f
->sym
->name
, &a
->expr
->where
);
3104 /* Check intent = OUT/INOUT for definable actual argument. */
3105 if ((f
->sym
->attr
.intent
== INTENT_OUT
3106 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3108 const char* context
= (where
3109 ? _("actual argument to INTENT = OUT/INOUT")
3112 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3113 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3114 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3115 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3117 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3121 if ((f
->sym
->attr
.intent
== INTENT_OUT
3122 || f
->sym
->attr
.intent
== INTENT_INOUT
3123 || f
->sym
->attr
.volatile_
3124 || f
->sym
->attr
.asynchronous
)
3125 && gfc_has_vector_subscript (a
->expr
))
3128 gfc_error ("Array-section actual argument with vector "
3129 "subscripts at %L is incompatible with INTENT(OUT), "
3130 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3131 "of the dummy argument %qs",
3132 &a
->expr
->where
, f
->sym
->name
);
3136 /* C1232 (R1221) For an actual argument which is an array section or
3137 an assumed-shape array, the dummy argument shall be an assumed-
3138 shape array, if the dummy argument has the VOLATILE attribute. */
3140 if (f
->sym
->attr
.volatile_
3141 && a
->expr
->symtree
->n
.sym
->as
3142 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3143 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3146 gfc_error ("Assumed-shape actual argument at %L is "
3147 "incompatible with the non-assumed-shape "
3148 "dummy argument %qs due to VOLATILE attribute",
3149 &a
->expr
->where
,f
->sym
->name
);
3153 if (f
->sym
->attr
.volatile_
3154 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
3155 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3158 gfc_error ("Array-section actual argument at %L is "
3159 "incompatible with the non-assumed-shape "
3160 "dummy argument %qs due to VOLATILE attribute",
3161 &a
->expr
->where
,f
->sym
->name
);
3165 /* C1233 (R1221) For an actual argument which is a pointer array, the
3166 dummy argument shall be an assumed-shape or pointer array, if the
3167 dummy argument has the VOLATILE attribute. */
3169 if (f
->sym
->attr
.volatile_
3170 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3171 && a
->expr
->symtree
->n
.sym
->as
3173 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3174 || f
->sym
->attr
.pointer
)))
3177 gfc_error ("Pointer-array actual argument at %L requires "
3178 "an assumed-shape or pointer-array dummy "
3179 "argument %qs due to VOLATILE attribute",
3180 &a
->expr
->where
,f
->sym
->name
);
3191 /* Make sure missing actual arguments are optional. */
3193 for (f
= formal
; f
; f
= f
->next
, i
++)
3195 if (new_arg
[i
] != NULL
)
3200 gfc_error ("Missing alternate return spec in subroutine call "
3204 if (!f
->sym
->attr
.optional
)
3207 gfc_error ("Missing actual argument for argument %qs at %L",
3208 f
->sym
->name
, where
);
3213 /* The argument lists are compatible. We now relink a new actual
3214 argument list with null arguments in the right places. The head
3215 of the list remains the head. */
3216 for (i
= 0; i
< n
; i
++)
3217 if (new_arg
[i
] == NULL
)
3218 new_arg
[i
] = gfc_get_actual_arglist ();
3222 std::swap (*new_arg
[0], *actual
);
3223 std::swap (new_arg
[0], new_arg
[na
]);
3226 for (i
= 0; i
< n
- 1; i
++)
3227 new_arg
[i
]->next
= new_arg
[i
+ 1];
3229 new_arg
[i
]->next
= NULL
;
3231 if (*ap
== NULL
&& n
> 0)
3234 /* Note the types of omitted optional arguments. */
3235 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3236 if (a
->expr
== NULL
&& a
->label
== NULL
)
3237 a
->missing_arg_type
= f
->sym
->ts
.type
;
3245 gfc_formal_arglist
*f
;
3246 gfc_actual_arglist
*a
;
3250 /* qsort comparison function for argument pairs, with the following
3252 - p->a->expr == NULL
3253 - p->a->expr->expr_type != EXPR_VARIABLE
3254 - growing p->a->expr->symbol. */
3257 pair_cmp (const void *p1
, const void *p2
)
3259 const gfc_actual_arglist
*a1
, *a2
;
3261 /* *p1 and *p2 are elements of the to-be-sorted array. */
3262 a1
= ((const argpair
*) p1
)->a
;
3263 a2
= ((const argpair
*) p2
)->a
;
3272 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3274 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3278 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3280 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3284 /* Given two expressions from some actual arguments, test whether they
3285 refer to the same expression. The analysis is conservative.
3286 Returning false will produce no warning. */
3289 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3291 const gfc_ref
*r1
, *r2
;
3294 || e1
->expr_type
!= EXPR_VARIABLE
3295 || e2
->expr_type
!= EXPR_VARIABLE
3296 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3299 /* TODO: improve comparison, see expr.c:show_ref(). */
3300 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3302 if (r1
->type
!= r2
->type
)
3307 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3309 /* TODO: At the moment, consider only full arrays;
3310 we could do better. */
3311 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3316 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3324 gfc_internal_error ("compare_actual_expr(): Bad component code");
3333 /* Given formal and actual argument lists that correspond to one
3334 another, check that identical actual arguments aren't not
3335 associated with some incompatible INTENTs. */
3338 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3340 sym_intent f1_intent
, f2_intent
;
3341 gfc_formal_arglist
*f1
;
3342 gfc_actual_arglist
*a1
;
3348 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3350 if (f1
== NULL
&& a1
== NULL
)
3352 if (f1
== NULL
|| a1
== NULL
)
3353 gfc_internal_error ("check_some_aliasing(): List mismatch");
3358 p
= XALLOCAVEC (argpair
, n
);
3360 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3366 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3368 for (i
= 0; i
< n
; i
++)
3371 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3372 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3374 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3375 for (j
= i
+ 1; j
< n
; j
++)
3377 /* Expected order after the sort. */
3378 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3379 gfc_internal_error ("check_some_aliasing(): corrupted data");
3381 /* Are the expression the same? */
3382 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3384 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3385 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3386 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3387 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3389 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3390 "argument %qs and INTENT(%s) argument %qs at %L",
3391 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3392 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3393 &p
[i
].a
->expr
->where
);
3403 /* Given formal and actual argument lists that correspond to one
3404 another, check that they are compatible in the sense that intents
3405 are not mismatched. */
3408 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3410 sym_intent f_intent
;
3412 for (;; f
= f
->next
, a
= a
->next
)
3416 if (f
== NULL
&& a
== NULL
)
3418 if (f
== NULL
|| a
== NULL
)
3419 gfc_internal_error ("check_intents(): List mismatch");
3421 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3422 && a
->expr
->value
.function
.isym
3423 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3424 expr
= a
->expr
->value
.function
.actual
->expr
;
3428 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3431 f_intent
= f
->sym
->attr
.intent
;
3433 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3435 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3436 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3437 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3439 gfc_error ("Procedure argument at %L is local to a PURE "
3440 "procedure and has the POINTER attribute",
3446 /* Fortran 2008, C1283. */
3447 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3449 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3451 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3452 "is passed to an INTENT(%s) argument",
3453 &expr
->where
, gfc_intent_string (f_intent
));
3457 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3458 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3459 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3461 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3462 "is passed to a POINTER dummy argument",
3468 /* F2008, Section 12.5.2.4. */
3469 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3470 && gfc_is_coindexed (expr
))
3472 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3473 "polymorphic dummy argument %qs",
3474 &expr
->where
, f
->sym
->name
);
3483 /* Check how a procedure is used against its interface. If all goes
3484 well, the actual argument list will also end up being properly
3488 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3490 gfc_formal_arglist
*dummy_args
;
3492 /* Warn about calls with an implicit interface. Special case
3493 for calling a ISO_C_BINDING because c_loc and c_funloc
3494 are pseudo-unknown. Additionally, warn about procedures not
3495 explicitly declared at all if requested. */
3496 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3498 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3500 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3504 if (warn_implicit_interface
)
3505 gfc_warning (OPT_Wimplicit_interface
,
3506 "Procedure %qs called with an implicit interface at %L",
3508 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3509 gfc_warning (OPT_Wimplicit_procedure
,
3510 "Procedure %qs called at %L is not explicitly declared",
3514 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3516 gfc_actual_arglist
*a
;
3518 if (sym
->attr
.pointer
)
3520 gfc_error ("The pointer object %qs at %L must have an explicit "
3521 "function interface or be declared as array",
3526 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3528 gfc_error ("The allocatable object %qs at %L must have an explicit "
3529 "function interface or be declared as array",
3534 if (sym
->attr
.allocatable
)
3536 gfc_error ("Allocatable function %qs at %L must have an explicit "
3537 "function interface", sym
->name
, where
);
3541 for (a
= *ap
; a
; a
= a
->next
)
3543 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3544 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3546 gfc_error ("Keyword argument requires explicit interface "
3547 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3551 /* TS 29113, 6.2. */
3552 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3553 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3555 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3556 "interface", a
->expr
->symtree
->n
.sym
->name
,
3561 /* F2008, C1303 and C1304. */
3563 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3564 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3565 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3566 || gfc_expr_attr (a
->expr
).lock_comp
))
3568 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3569 "component at %L requires an explicit interface for "
3570 "procedure %qs", &a
->expr
->where
, sym
->name
);
3575 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3576 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3577 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3578 == ISOFORTRAN_EVENT_TYPE
)
3579 || gfc_expr_attr (a
->expr
).event_comp
))
3581 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3582 "component at %L requires an explicit interface for "
3583 "procedure %qs", &a
->expr
->where
, sym
->name
);
3587 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3588 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3590 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3594 /* TS 29113, C407b. */
3595 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3596 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3598 gfc_error ("Assumed-rank argument requires an explicit interface "
3599 "at %L", &a
->expr
->where
);
3607 dummy_args
= gfc_sym_get_dummy_args (sym
);
3609 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3612 if (!check_intents (dummy_args
, *ap
))
3616 check_some_aliasing (dummy_args
, *ap
);
3622 /* Check how a procedure pointer component is used against its interface.
3623 If all goes well, the actual argument list will also end up being properly
3624 sorted. Completely analogous to gfc_procedure_use. */
3627 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3629 /* Warn about calls with an implicit interface. Special case
3630 for calling a ISO_C_BINDING because c_loc and c_funloc
3631 are pseudo-unknown. */
3632 if (warn_implicit_interface
3633 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3634 && !comp
->attr
.is_iso_c
)
3635 gfc_warning (OPT_Wimplicit_interface
,
3636 "Procedure pointer component %qs called with an implicit "
3637 "interface at %L", comp
->name
, where
);
3639 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3641 gfc_actual_arglist
*a
;
3642 for (a
= *ap
; a
; a
= a
->next
)
3644 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3645 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3647 gfc_error ("Keyword argument requires explicit interface "
3648 "for procedure pointer component %qs at %L",
3649 comp
->name
, &a
->expr
->where
);
3657 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3658 comp
->attr
.elemental
, where
))
3661 check_intents (comp
->ts
.interface
->formal
, *ap
);
3663 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3667 /* Try if an actual argument list matches the formal list of a symbol,
3668 respecting the symbol's attributes like ELEMENTAL. This is used for
3669 GENERIC resolution. */
3672 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3674 gfc_formal_arglist
*dummy_args
;
3677 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3680 dummy_args
= gfc_sym_get_dummy_args (sym
);
3682 r
= !sym
->attr
.elemental
;
3683 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3685 check_intents (dummy_args
, *args
);
3687 check_some_aliasing (dummy_args
, *args
);
3695 /* Given an interface pointer and an actual argument list, search for
3696 a formal argument list that matches the actual. If found, returns
3697 a pointer to the symbol of the correct interface. Returns NULL if
3701 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3702 gfc_actual_arglist
**ap
)
3704 gfc_symbol
*elem_sym
= NULL
;
3705 gfc_symbol
*null_sym
= NULL
;
3706 locus null_expr_loc
;
3707 gfc_actual_arglist
*a
;
3708 bool has_null_arg
= false;
3710 for (a
= *ap
; a
; a
= a
->next
)
3711 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3712 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3714 has_null_arg
= true;
3715 null_expr_loc
= a
->expr
->where
;
3719 for (; intr
; intr
= intr
->next
)
3721 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3723 if (sub_flag
&& intr
->sym
->attr
.function
)
3725 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3728 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3730 if (has_null_arg
&& null_sym
)
3732 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3733 "between specific functions %s and %s",
3734 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3737 else if (has_null_arg
)
3739 null_sym
= intr
->sym
;
3743 /* Satisfy 12.4.4.1 such that an elemental match has lower
3744 weight than a non-elemental match. */
3745 if (intr
->sym
->attr
.elemental
)
3747 elem_sym
= intr
->sym
;
3757 return elem_sym
? elem_sym
: NULL
;
3761 /* Do a brute force recursive search for a symbol. */
3763 static gfc_symtree
*
3764 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3768 if (root
->n
.sym
== sym
)
3773 st
= find_symtree0 (root
->left
, sym
);
3774 if (root
->right
&& ! st
)
3775 st
= find_symtree0 (root
->right
, sym
);
3780 /* Find a symtree for a symbol. */
3783 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3788 /* First try to find it by name. */
3789 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3790 if (st
&& st
->n
.sym
== sym
)
3793 /* If it's been renamed, resort to a brute-force search. */
3794 /* TODO: avoid having to do this search. If the symbol doesn't exist
3795 in the symtree for the current namespace, it should probably be added. */
3796 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3798 st
= find_symtree0 (ns
->sym_root
, sym
);
3802 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3807 /* See if the arglist to an operator-call contains a derived-type argument
3808 with a matching type-bound operator. If so, return the matching specific
3809 procedure defined as operator-target as well as the base-object to use
3810 (which is the found derived-type argument with operator). The generic
3811 name, if any, is transmitted to the final expression via 'gname'. */
3813 static gfc_typebound_proc
*
3814 matching_typebound_op (gfc_expr
** tb_base
,
3815 gfc_actual_arglist
* args
,
3816 gfc_intrinsic_op op
, const char* uop
,
3817 const char ** gname
)
3819 gfc_actual_arglist
* base
;
3821 for (base
= args
; base
; base
= base
->next
)
3822 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3824 gfc_typebound_proc
* tb
;
3825 gfc_symbol
* derived
;
3828 while (base
->expr
->expr_type
== EXPR_OP
3829 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3830 base
->expr
= base
->expr
->value
.op
.op1
;
3832 if (base
->expr
->ts
.type
== BT_CLASS
)
3834 if (CLASS_DATA (base
->expr
) == NULL
3835 || !gfc_expr_attr (base
->expr
).class_ok
)
3837 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3840 derived
= base
->expr
->ts
.u
.derived
;
3842 if (op
== INTRINSIC_USER
)
3844 gfc_symtree
* tb_uop
;
3847 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3856 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3859 /* This means we hit a PRIVATE operator which is use-associated and
3860 should thus not be seen. */
3864 /* Look through the super-type hierarchy for a matching specific
3866 for (; tb
; tb
= tb
->overridden
)
3870 gcc_assert (tb
->is_generic
);
3871 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3874 gfc_actual_arglist
* argcopy
;
3877 gcc_assert (g
->specific
);
3878 if (g
->specific
->error
)
3881 target
= g
->specific
->u
.specific
->n
.sym
;
3883 /* Check if this arglist matches the formal. */
3884 argcopy
= gfc_copy_actual_arglist (args
);
3885 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3886 gfc_free_actual_arglist (argcopy
);
3888 /* Return if we found a match. */
3891 *tb_base
= base
->expr
;
3892 *gname
= g
->specific_st
->name
;
3903 /* For the 'actual arglist' of an operator call and a specific typebound
3904 procedure that has been found the target of a type-bound operator, build the
3905 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3906 type-bound procedures rather than resolving type-bound operators 'directly'
3907 so that we can reuse the existing logic. */
3910 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3911 gfc_expr
* base
, gfc_typebound_proc
* target
,
3914 e
->expr_type
= EXPR_COMPCALL
;
3915 e
->value
.compcall
.tbp
= target
;
3916 e
->value
.compcall
.name
= gname
? gname
: "$op";
3917 e
->value
.compcall
.actual
= actual
;
3918 e
->value
.compcall
.base_object
= base
;
3919 e
->value
.compcall
.ignore_pass
= 1;
3920 e
->value
.compcall
.assign
= 0;
3921 if (e
->ts
.type
== BT_UNKNOWN
3922 && target
->function
)
3924 if (target
->is_generic
)
3925 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3927 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3932 /* This subroutine is called when an expression is being resolved.
3933 The expression node in question is either a user defined operator
3934 or an intrinsic operator with arguments that aren't compatible
3935 with the operator. This subroutine builds an actual argument list
3936 corresponding to the operands, then searches for a compatible
3937 interface. If one is found, the expression node is replaced with
3938 the appropriate function call. We use the 'match' enum to specify
3939 whether a replacement has been made or not, or if an error occurred. */
3942 gfc_extend_expr (gfc_expr
*e
)
3944 gfc_actual_arglist
*actual
;
3950 gfc_typebound_proc
* tbo
;
3955 actual
= gfc_get_actual_arglist ();
3956 actual
->expr
= e
->value
.op
.op1
;
3960 if (e
->value
.op
.op2
!= NULL
)
3962 actual
->next
= gfc_get_actual_arglist ();
3963 actual
->next
->expr
= e
->value
.op
.op2
;
3966 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3968 /* See if we find a matching type-bound operator. */
3969 if (i
== INTRINSIC_USER
)
3970 tbo
= matching_typebound_op (&tb_base
, actual
,
3971 i
, e
->value
.op
.uop
->name
, &gname
);
3975 #define CHECK_OS_COMPARISON(comp) \
3976 case INTRINSIC_##comp: \
3977 case INTRINSIC_##comp##_OS: \
3978 tbo = matching_typebound_op (&tb_base, actual, \
3979 INTRINSIC_##comp, NULL, &gname); \
3981 tbo = matching_typebound_op (&tb_base, actual, \
3982 INTRINSIC_##comp##_OS, NULL, &gname); \
3984 CHECK_OS_COMPARISON(EQ
)
3985 CHECK_OS_COMPARISON(NE
)
3986 CHECK_OS_COMPARISON(GT
)
3987 CHECK_OS_COMPARISON(GE
)
3988 CHECK_OS_COMPARISON(LT
)
3989 CHECK_OS_COMPARISON(LE
)
3990 #undef CHECK_OS_COMPARISON
3993 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3997 /* If there is a matching typebound-operator, replace the expression with
3998 a call to it and succeed. */
4001 gcc_assert (tb_base
);
4002 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4004 if (!gfc_resolve_expr (e
))
4010 if (i
== INTRINSIC_USER
)
4012 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4014 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4018 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4025 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4027 /* Due to the distinction between '==' and '.eq.' and friends, one has
4028 to check if either is defined. */
4031 #define CHECK_OS_COMPARISON(comp) \
4032 case INTRINSIC_##comp: \
4033 case INTRINSIC_##comp##_OS: \
4034 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4036 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4038 CHECK_OS_COMPARISON(EQ
)
4039 CHECK_OS_COMPARISON(NE
)
4040 CHECK_OS_COMPARISON(GT
)
4041 CHECK_OS_COMPARISON(GE
)
4042 CHECK_OS_COMPARISON(LT
)
4043 CHECK_OS_COMPARISON(LE
)
4044 #undef CHECK_OS_COMPARISON
4047 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4055 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4056 found rather than just taking the first one and not checking further. */
4060 /* Don't use gfc_free_actual_arglist(). */
4061 free (actual
->next
);
4066 /* Change the expression node to a function call. */
4067 e
->expr_type
= EXPR_FUNCTION
;
4068 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4069 e
->value
.function
.actual
= actual
;
4070 e
->value
.function
.esym
= NULL
;
4071 e
->value
.function
.isym
= NULL
;
4072 e
->value
.function
.name
= NULL
;
4073 e
->user_operator
= 1;
4075 if (!gfc_resolve_expr (e
))
4082 /* Tries to replace an assignment code node with a subroutine call to the
4083 subroutine associated with the assignment operator. Return true if the node
4084 was replaced. On false, no error is generated. */
4087 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4089 gfc_actual_arglist
*actual
;
4090 gfc_expr
*lhs
, *rhs
, *tb_base
;
4091 gfc_symbol
*sym
= NULL
;
4092 const char *gname
= NULL
;
4093 gfc_typebound_proc
* tbo
;
4098 /* Don't allow an intrinsic assignment to be replaced. */
4099 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4100 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4101 && (lhs
->ts
.type
== rhs
->ts
.type
4102 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4105 actual
= gfc_get_actual_arglist ();
4108 actual
->next
= gfc_get_actual_arglist ();
4109 actual
->next
->expr
= rhs
;
4111 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4113 /* See if we find a matching type-bound assignment. */
4114 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4119 /* Success: Replace the expression with a type-bound call. */
4120 gcc_assert (tb_base
);
4121 c
->expr1
= gfc_get_expr ();
4122 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4123 c
->expr1
->value
.compcall
.assign
= 1;
4124 c
->expr1
->where
= c
->loc
;
4126 c
->op
= EXEC_COMPCALL
;
4130 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4131 for (; ns
; ns
= ns
->parent
)
4133 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4140 /* Success: Replace the assignment with the call. */
4141 c
->op
= EXEC_ASSIGN_CALL
;
4142 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4145 c
->ext
.actual
= actual
;
4149 /* Failure: No assignment procedure found. */
4150 free (actual
->next
);
4156 /* Make sure that the interface just parsed is not already present in
4157 the given interface list. Ambiguity isn't checked yet since module
4158 procedures can be present without interfaces. */
4161 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4165 for (ip
= base
; ip
; ip
= ip
->next
)
4167 if (ip
->sym
== new_sym
)
4169 gfc_error ("Entity %qs at %L is already present in the interface",
4170 new_sym
->name
, &loc
);
4179 /* Add a symbol to the current interface. */
4182 gfc_add_interface (gfc_symbol
*new_sym
)
4184 gfc_interface
**head
, *intr
;
4188 switch (current_interface
.type
)
4190 case INTERFACE_NAMELESS
:
4191 case INTERFACE_ABSTRACT
:
4194 case INTERFACE_INTRINSIC_OP
:
4195 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4196 switch (current_interface
.op
)
4199 case INTRINSIC_EQ_OS
:
4200 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4202 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4203 new_sym
, gfc_current_locus
))
4208 case INTRINSIC_NE_OS
:
4209 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4211 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4212 new_sym
, gfc_current_locus
))
4217 case INTRINSIC_GT_OS
:
4218 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4219 new_sym
, gfc_current_locus
)
4220 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4221 new_sym
, gfc_current_locus
))
4226 case INTRINSIC_GE_OS
:
4227 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4228 new_sym
, gfc_current_locus
)
4229 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4230 new_sym
, gfc_current_locus
))
4235 case INTRINSIC_LT_OS
:
4236 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4237 new_sym
, gfc_current_locus
)
4238 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4239 new_sym
, gfc_current_locus
))
4244 case INTRINSIC_LE_OS
:
4245 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4246 new_sym
, gfc_current_locus
)
4247 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4248 new_sym
, gfc_current_locus
))
4253 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4254 new_sym
, gfc_current_locus
))
4258 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4261 case INTERFACE_GENERIC
:
4262 case INTERFACE_DTIO
:
4263 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4265 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4269 if (!gfc_check_new_interface (sym
->generic
,
4270 new_sym
, gfc_current_locus
))
4274 head
= ¤t_interface
.sym
->generic
;
4277 case INTERFACE_USER_OP
:
4278 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4279 new_sym
, gfc_current_locus
))
4282 head
= ¤t_interface
.uop
->op
;
4286 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4289 intr
= gfc_get_interface ();
4290 intr
->sym
= new_sym
;
4291 intr
->where
= gfc_current_locus
;
4301 gfc_current_interface_head (void)
4303 switch (current_interface
.type
)
4305 case INTERFACE_INTRINSIC_OP
:
4306 return current_interface
.ns
->op
[current_interface
.op
];
4309 case INTERFACE_GENERIC
:
4310 case INTERFACE_DTIO
:
4311 return current_interface
.sym
->generic
;
4314 case INTERFACE_USER_OP
:
4315 return current_interface
.uop
->op
;
4325 gfc_set_current_interface_head (gfc_interface
*i
)
4327 switch (current_interface
.type
)
4329 case INTERFACE_INTRINSIC_OP
:
4330 current_interface
.ns
->op
[current_interface
.op
] = i
;
4333 case INTERFACE_GENERIC
:
4334 case INTERFACE_DTIO
:
4335 current_interface
.sym
->generic
= i
;
4338 case INTERFACE_USER_OP
:
4339 current_interface
.uop
->op
= i
;
4348 /* Gets rid of a formal argument list. We do not free symbols.
4349 Symbols are freed when a namespace is freed. */
4352 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4354 gfc_formal_arglist
*q
;
4364 /* Check that it is ok for the type-bound procedure 'proc' to override the
4365 procedure 'old', cf. F08:4.5.7.3. */
4368 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4371 gfc_symbol
*proc_target
, *old_target
;
4372 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4373 gfc_formal_arglist
*proc_formal
, *old_formal
;
4377 /* This procedure should only be called for non-GENERIC proc. */
4378 gcc_assert (!proc
->n
.tb
->is_generic
);
4380 /* If the overwritten procedure is GENERIC, this is an error. */
4381 if (old
->n
.tb
->is_generic
)
4383 gfc_error ("Can't overwrite GENERIC %qs at %L",
4384 old
->name
, &proc
->n
.tb
->where
);
4388 where
= proc
->n
.tb
->where
;
4389 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4390 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4392 /* Check that overridden binding is not NON_OVERRIDABLE. */
4393 if (old
->n
.tb
->non_overridable
)
4395 gfc_error ("%qs at %L overrides a procedure binding declared"
4396 " NON_OVERRIDABLE", proc
->name
, &where
);
4400 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4401 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4403 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4404 " non-DEFERRED binding", proc
->name
, &where
);
4408 /* If the overridden binding is PURE, the overriding must be, too. */
4409 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4411 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4412 proc
->name
, &where
);
4416 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4417 is not, the overriding must not be either. */
4418 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4420 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4421 " ELEMENTAL", proc
->name
, &where
);
4424 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4426 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4427 " be ELEMENTAL, either", proc
->name
, &where
);
4431 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4433 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4435 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4436 " SUBROUTINE", proc
->name
, &where
);
4440 /* If the overridden binding is a FUNCTION, the overriding must also be a
4441 FUNCTION and have the same characteristics. */
4442 if (old_target
->attr
.function
)
4444 if (!proc_target
->attr
.function
)
4446 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4447 " FUNCTION", proc
->name
, &where
);
4451 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4454 gfc_error ("Result mismatch for the overriding procedure "
4455 "%qs at %L: %s", proc
->name
, &where
, err
);
4460 /* If the overridden binding is PUBLIC, the overriding one must not be
4462 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4463 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4465 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4466 " PRIVATE", proc
->name
, &where
);
4470 /* Compare the formal argument lists of both procedures. This is also abused
4471 to find the position of the passed-object dummy arguments of both
4472 bindings as at least the overridden one might not yet be resolved and we
4473 need those positions in the check below. */
4474 proc_pass_arg
= old_pass_arg
= 0;
4475 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4477 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4480 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4481 old_formal
= gfc_sym_get_dummy_args (old_target
);
4482 for ( ; proc_formal
&& old_formal
;
4483 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4485 if (proc
->n
.tb
->pass_arg
4486 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4487 proc_pass_arg
= argpos
;
4488 if (old
->n
.tb
->pass_arg
4489 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4490 old_pass_arg
= argpos
;
4492 /* Check that the names correspond. */
4493 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4495 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4496 " to match the corresponding argument of the overridden"
4497 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4498 old_formal
->sym
->name
);
4502 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4503 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4504 check_type
, err
, sizeof(err
)))
4506 gfc_error ("Argument mismatch for the overriding procedure "
4507 "%qs at %L: %s", proc
->name
, &where
, err
);
4513 if (proc_formal
|| old_formal
)
4515 gfc_error ("%qs at %L must have the same number of formal arguments as"
4516 " the overridden procedure", proc
->name
, &where
);
4520 /* If the overridden binding is NOPASS, the overriding one must also be
4522 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4524 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4525 " NOPASS", proc
->name
, &where
);
4529 /* If the overridden binding is PASS(x), the overriding one must also be
4530 PASS and the passed-object dummy arguments must correspond. */
4531 if (!old
->n
.tb
->nopass
)
4533 if (proc
->n
.tb
->nopass
)
4535 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4536 " PASS", proc
->name
, &where
);
4540 if (proc_pass_arg
!= old_pass_arg
)
4542 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4543 " the same position as the passed-object dummy argument of"
4544 " the overridden procedure", proc
->name
, &where
);
4553 /* The following three functions check that the formal arguments
4554 of user defined derived type IO procedures are compliant with
4555 the requirements of the standard. */
4558 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4559 int kind
, int rank
, sym_intent intent
)
4561 if (fsym
->ts
.type
!= type
)
4563 gfc_error ("DTIO dummy argument at %L must be of type %s",
4564 &fsym
->declared_at
, gfc_basic_typename (type
));
4568 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4569 && fsym
->ts
.kind
!= kind
)
4570 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4571 &fsym
->declared_at
, kind
);
4575 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4576 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4577 gfc_error ("DTIO dummy argument at %L be a scalar",
4578 &fsym
->declared_at
);
4580 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4581 gfc_error ("DTIO dummy argument at %L must be an "
4582 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4584 if (fsym
->attr
.intent
!= intent
)
4585 gfc_error ("DTIO dummy argument at %L must have intent %s",
4586 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4592 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4593 bool typebound
, bool formatted
, int code
)
4595 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4596 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4597 gfc_interface
*intr
;
4598 gfc_formal_arglist
*formal
;
4601 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4602 || ((dtio_codes
)code
== DTIO_RUF
);
4610 /* Typebound DTIO binding. */
4611 tb_io_proc
= tb_io_st
->n
.tb
;
4612 if (tb_io_proc
== NULL
)
4615 gcc_assert (tb_io_proc
->is_generic
);
4616 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4618 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4619 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
4622 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4626 generic_proc
= tb_io_st
->n
.sym
;
4627 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
4630 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4632 if (intr
->sym
&& intr
->sym
->formal
4633 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
4634 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
4636 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
4637 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
4639 dtio_sub
= intr
->sym
;
4644 if (dtio_sub
== NULL
)
4648 gcc_assert (dtio_sub
);
4649 if (!dtio_sub
->attr
.subroutine
)
4650 gfc_error ("DTIO procedure %s at %L must be a subroutine",
4651 dtio_sub
->name
, &dtio_sub
->declared_at
);
4653 /* Now go through the formal arglist. */
4655 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
4657 if (!formatted
&& arg_num
== 3)
4663 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
4664 BT_DERIVED
: BT_CLASS
;
4666 intent
= read
? INTENT_INOUT
: INTENT_IN
;
4667 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4673 kind
= gfc_default_integer_kind
;
4675 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4678 case(3): /* IOTYPE */
4679 type
= BT_CHARACTER
;
4680 kind
= gfc_default_character_kind
;
4682 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4685 case(4): /* VLIST */
4687 kind
= gfc_default_integer_kind
;
4689 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4692 case(5): /* IOSTAT */
4694 kind
= gfc_default_integer_kind
;
4695 intent
= INTENT_OUT
;
4696 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4699 case(6): /* IOMSG */
4700 type
= BT_CHARACTER
;
4701 kind
= gfc_default_character_kind
;
4702 intent
= INTENT_INOUT
;
4703 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
4710 derived
->attr
.has_dtio_procs
= 1;
4715 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
4717 gfc_symtree
*tb_io_st
;
4722 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
4725 /* Check typebound DTIO bindings. */
4726 for (code
= 0; code
< 4; code
++)
4728 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4729 || ((dtio_codes
)code
== DTIO_WF
);
4731 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4732 gfc_code2string (dtio_procs
, code
),
4733 true, &derived
->declared_at
);
4734 if (tb_io_st
!= NULL
)
4735 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
4738 /* Check generic DTIO interfaces. */
4739 for (code
= 0; code
< 4; code
++)
4741 formatted
= ((dtio_codes
)code
== DTIO_RF
)
4742 || ((dtio_codes
)code
== DTIO_WF
);
4744 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
4745 gfc_code2string (dtio_procs
, code
));
4746 if (tb_io_st
!= NULL
)
4747 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
4753 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
4755 gfc_symtree
*tb_io_st
= NULL
;
4756 gfc_symbol
*dtio_sub
= NULL
;
4757 gfc_symbol
*extended
;
4758 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4761 /* Try to find a typebound DTIO binding. */
4762 if (formatted
== true)
4765 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4766 gfc_code2string (dtio_procs
,
4769 &derived
->declared_at
);
4771 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4772 gfc_code2string (dtio_procs
,
4775 &derived
->declared_at
);
4780 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4781 gfc_code2string (dtio_procs
,
4784 &derived
->declared_at
);
4786 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
4787 gfc_code2string (dtio_procs
,
4790 &derived
->declared_at
);
4793 if (tb_io_st
!= NULL
)
4795 const char *genname
;
4798 tb_io_proc
= tb_io_st
->n
.tb
;
4799 gcc_assert (tb_io_proc
!= NULL
);
4800 gcc_assert (tb_io_proc
->is_generic
);
4801 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
4803 specific_proc
= tb_io_proc
->u
.generic
->specific
;
4804 gcc_assert (!specific_proc
->is_generic
);
4806 /* Go back and make sure that we have the right specific procedure.
4807 Here we most likely have a procedure from the parent type, which
4808 can be overridden in extensions. */
4809 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
4810 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
4811 true, &tb_io_proc
->where
);
4813 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
4815 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
4818 if (tb_io_st
!= NULL
)
4821 /* If there is not a typebound binding, look for a generic
4823 for (extended
= derived
; extended
;
4824 extended
= gfc_get_derived_super_type (extended
))
4826 if (formatted
== true)
4829 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4830 gfc_code2string (dtio_procs
,
4833 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4834 gfc_code2string (dtio_procs
,
4840 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4841 gfc_code2string (dtio_procs
,
4844 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
4845 gfc_code2string (dtio_procs
,
4849 if (tb_io_st
!= NULL
4851 && tb_io_st
->n
.sym
->generic
)
4853 gfc_interface
*intr
;
4854 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
4856 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
4857 if (intr
->sym
&& intr
->sym
->formal
4858 && ((fsym
->ts
.type
== BT_CLASS
4859 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
4860 || (fsym
->ts
.type
== BT_DERIVED
4861 && fsym
->ts
.u
.derived
== extended
)))
4863 dtio_sub
= intr
->sym
;
4871 if (dtio_sub
&& derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
4872 gfc_find_derived_vtab (derived
);