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 /* Match a generic specification. Depending on which type of
119 interface is found, the 'name' or 'op' pointers may be set.
120 This subroutine doesn't return MATCH_NO. */
123 gfc_match_generic_spec (interface_type
*type
,
125 gfc_intrinsic_op
*op
)
127 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
131 if (gfc_match (" assignment ( = )") == MATCH_YES
)
133 *type
= INTERFACE_INTRINSIC_OP
;
134 *op
= INTRINSIC_ASSIGN
;
138 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
140 *type
= INTERFACE_INTRINSIC_OP
;
141 *op
= fold_unary_intrinsic (i
);
145 *op
= INTRINSIC_NONE
;
146 if (gfc_match (" operator ( ") == MATCH_YES
)
148 m
= gfc_match_defined_op_name (buffer
, 1);
154 m
= gfc_match_char (')');
160 strcpy (name
, buffer
);
161 *type
= INTERFACE_USER_OP
;
165 if (gfc_match_name (buffer
) == MATCH_YES
)
167 strcpy (name
, buffer
);
168 *type
= INTERFACE_GENERIC
;
172 *type
= INTERFACE_NAMELESS
;
176 gfc_error ("Syntax error in generic specification at %C");
181 /* Match one of the five F95 forms of an interface statement. The
182 matcher for the abstract interface follows. */
185 gfc_match_interface (void)
187 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
193 m
= gfc_match_space ();
195 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
198 /* If we're not looking at the end of the statement now, or if this
199 is not a nameless interface but we did not see a space, punt. */
200 if (gfc_match_eos () != MATCH_YES
201 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
203 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
208 current_interface
.type
= type
;
212 case INTERFACE_GENERIC
:
213 if (gfc_get_symbol (name
, NULL
, &sym
))
216 if (!sym
->attr
.generic
217 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
222 gfc_error ("Dummy procedure %qs at %C cannot have a "
223 "generic interface", sym
->name
);
227 current_interface
.sym
= gfc_new_block
= sym
;
230 case INTERFACE_USER_OP
:
231 current_interface
.uop
= gfc_get_uop (name
);
234 case INTERFACE_INTRINSIC_OP
:
235 current_interface
.op
= op
;
238 case INTERFACE_NAMELESS
:
239 case INTERFACE_ABSTRACT
:
248 /* Match a F2003 abstract interface. */
251 gfc_match_abstract_interface (void)
255 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
258 m
= gfc_match_eos ();
262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
266 current_interface
.type
= INTERFACE_ABSTRACT
;
272 /* Match the different sort of generic-specs that can be present after
273 the END INTERFACE itself. */
276 gfc_match_end_interface (void)
278 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
283 m
= gfc_match_space ();
285 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
288 /* If we're not looking at the end of the statement now, or if this
289 is not a nameless interface but we did not see a space, punt. */
290 if (gfc_match_eos () != MATCH_YES
291 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
300 switch (current_interface
.type
)
302 case INTERFACE_NAMELESS
:
303 case INTERFACE_ABSTRACT
:
304 if (type
!= INTERFACE_NAMELESS
)
306 gfc_error ("Expected a nameless interface at %C");
312 case INTERFACE_INTRINSIC_OP
:
313 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
316 if (current_interface
.op
== INTRINSIC_ASSIGN
)
319 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
324 s1
= gfc_op2string (current_interface
.op
);
325 s2
= gfc_op2string (op
);
327 /* The following if-statements are used to enforce C1202
329 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
330 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
332 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
333 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
335 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
336 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
338 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
339 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
341 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
342 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
344 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
345 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
349 if (strcmp(s2
, "none") == 0)
350 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
353 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
354 "but got %s", s1
, s2
);
361 case INTERFACE_USER_OP
:
362 /* Comparing the symbol node names is OK because only use-associated
363 symbols can be renamed. */
364 if (type
!= current_interface
.type
365 || strcmp (current_interface
.uop
->name
, name
) != 0)
367 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
368 current_interface
.uop
->name
);
374 case INTERFACE_GENERIC
:
375 if (type
!= current_interface
.type
376 || strcmp (current_interface
.sym
->name
, name
) != 0)
378 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
379 current_interface
.sym
->name
);
390 /* Compare components according to 4.4.2 of the Fortran standard. */
393 compare_components (gfc_component
*cmp1
, gfc_component
*cmp2
,
394 gfc_symbol
*derived1
, gfc_symbol
*derived2
)
397 bool anonymous
= false;
399 /* Unions, maps, and anonymous structures all have names like "[xX]X$\d+"
400 which should not be compared. */
401 d1
= cmp1
->ts
.u
.derived
;
402 d2
= cmp2
->ts
.u
.derived
;
403 if ( (d1
&& (d1
->attr
.flavor
== FL_STRUCT
|| d1
->attr
.flavor
== FL_UNION
)
404 && ISUPPER (cmp1
->name
[1]))
405 || (d2
&& (d2
->attr
.flavor
== FL_STRUCT
|| d2
->attr
.flavor
== FL_UNION
)
406 && ISUPPER (cmp1
->name
[1])))
409 if (!anonymous
&& strcmp (cmp1
->name
, cmp2
->name
) != 0)
412 if (cmp1
->attr
.access
!= cmp2
->attr
.access
)
415 if (cmp1
->attr
.pointer
!= cmp2
->attr
.pointer
)
418 if (cmp1
->attr
.dimension
!= cmp2
->attr
.dimension
)
421 if (cmp1
->attr
.allocatable
!= cmp2
->attr
.allocatable
)
424 if (cmp1
->attr
.dimension
&& gfc_compare_array_spec (cmp1
->as
, cmp2
->as
) == 0)
427 /* Make sure that link lists do not put this function into an
428 endless recursive loop! */
429 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
430 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
431 && gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
) == 0)
434 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
435 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
438 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
439 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
446 /* Compare two union types by comparing the components of their maps.
447 Because unions and maps are anonymous their types get special internal
448 names; therefore the usual derived type comparison will fail on them.
450 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
451 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
452 definitions' than 'equivalent structure'. */
455 gfc_compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
457 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
459 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
462 map1
= un1
->components
;
463 map2
= un2
->components
;
465 /* In terms of 'equality' here we are worried about types which are
466 declared the same in two places, not types that represent equivalent
467 structures. (This is common because of FORTRAN's weird scoping rules.)
468 Though two unions with their maps in different orders could be equivalent,
469 we will say they are not equal for the purposes of this test; therefore
470 we compare the maps sequentially. */
473 cmp1
= map1
->ts
.u
.derived
->components
;
474 cmp2
= map2
->ts
.u
.derived
->components
;
477 /* No two fields will ever point to the same map type unless they are
478 the same component, because one map field is created with its type
479 declaration. Therefore don't worry about recursion here. */
480 /* TODO: worry about recursion into parent types of the unions? */
481 if (compare_components (cmp1
, cmp2
,
482 map1
->ts
.u
.derived
, map2
->ts
.u
.derived
) == 0)
488 if (cmp1
== NULL
&& cmp2
== NULL
)
490 if (cmp1
== NULL
|| cmp2
== NULL
)
497 if (map1
== NULL
&& map2
== NULL
)
499 if (map1
== NULL
|| map2
== NULL
)
508 /* Compare two derived types using the criteria in 4.4.2 of the standard,
509 recursing through gfc_compare_types for the components. */
512 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
514 gfc_component
*cmp1
, *cmp2
;
515 bool anonymous
= false;
517 if (derived1
== derived2
)
520 gcc_assert (derived1
&& derived2
);
522 /* MAP and anonymous STRUCTURE types have internal names of the form
523 mM* and sS* (we can get away this this because source names are converted
524 to lowerase). Compare anonymous type names specially because each
525 gets a unique name when it is declared. */
526 anonymous
= (derived1
->name
[0] == derived2
->name
[0]
527 && derived1
->name
[1] && derived2
->name
[1] && derived2
->name
[2]
528 && derived1
->name
[1] == (char) TOUPPER (derived1
->name
[0])
529 && derived2
->name
[2] == (char) TOUPPER (derived2
->name
[0]));
531 /* Special case for comparing derived types across namespaces. If the
532 true names and module names are the same and the module name is
533 nonnull, then they are equal. */
534 if (strcmp (derived1
->name
, derived2
->name
) == 0
535 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
536 && strcmp (derived1
->module
, derived2
->module
) == 0)
539 /* Compare type via the rules of the standard. Both types must have
540 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
541 because they can be anonymous; therefore two structures with different
542 names may be equal. */
544 if (strcmp (derived1
->name
, derived2
->name
) != 0 && !anonymous
)
547 if (derived1
->component_access
== ACCESS_PRIVATE
548 || derived2
->component_access
== ACCESS_PRIVATE
)
551 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
552 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
555 /* Protect against null components. */
556 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
559 if (derived1
->attr
.zero_comp
)
562 cmp1
= derived1
->components
;
563 cmp2
= derived2
->components
;
565 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
566 simple test can speed things up. Otherwise, lots of things have to
570 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
576 if (cmp1
== NULL
&& cmp2
== NULL
)
578 if (cmp1
== NULL
|| cmp2
== NULL
)
586 /* Compare two typespecs, recursively if necessary. */
589 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
591 /* See if one of the typespecs is a BT_VOID, which is what is being used
592 to allow the funcs like c_f_pointer to accept any pointer type.
593 TODO: Possibly should narrow this to just the one typespec coming in
594 that is for the formal arg, but oh well. */
595 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
598 /* The _data component is not always present, therefore check for its
599 presence before assuming, that its derived->attr is available.
600 When the _data component is not present, then nevertheless the
601 unlimited_polymorphic flag may be set in the derived type's attr. */
602 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
603 && ((ts1
->u
.derived
->attr
.is_class
604 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
605 .unlimited_polymorphic
)
606 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
610 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
611 && ts2
->u
.derived
->components
612 && ((ts2
->u
.derived
->attr
.is_class
613 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
614 .unlimited_polymorphic
)
615 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
616 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
619 if (ts1
->type
== BT_UNION
&& ts2
->type
== BT_UNION
)
620 return gfc_compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
622 if (ts1
->type
!= ts2
->type
623 && ((!gfc_bt_struct (ts1
->type
) && ts1
->type
!= BT_CLASS
)
624 || (!gfc_bt_struct (ts2
->type
) && ts2
->type
!= BT_CLASS
)))
626 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
627 return (ts1
->kind
== ts2
->kind
);
629 /* Compare derived types. */
630 return gfc_type_compatible (ts1
, ts2
);
635 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
637 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
640 /* TYPE and CLASS of the same declared type are type compatible,
641 but have different characteristics. */
642 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
643 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
646 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
651 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
653 gfc_array_spec
*as1
, *as2
;
656 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
659 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
660 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
662 r1
= as1
? as1
->rank
: 0;
663 r2
= as2
? as2
->rank
: 0;
665 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
666 return 0; /* Ranks differ. */
672 /* Given two symbols that are formal arguments, compare their ranks
673 and types. Returns nonzero if they have the same rank and type,
677 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
679 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
683 /* Given two symbols that are formal arguments, compare their types
684 and rank and their formal interfaces if they are both dummy
685 procedures. Returns nonzero if the same, zero if different. */
688 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
690 if (s1
== NULL
|| s2
== NULL
)
691 return s1
== s2
? 1 : 0;
696 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
697 return compare_type_rank (s1
, s2
);
699 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
702 /* At this point, both symbols are procedures. It can happen that
703 external procedures are compared, where one is identified by usage
704 to be a function or subroutine but the other is not. Check TKR
705 nonetheless for these cases. */
706 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
707 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
709 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
710 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
712 /* Now the type of procedure has been identified. */
713 if (s1
->attr
.function
!= s2
->attr
.function
714 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
717 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
720 /* Originally, gfortran recursed here to check the interfaces of passed
721 procedures. This is explicitly not required by the standard. */
726 /* Given a formal argument list and a keyword name, search the list
727 for that keyword. Returns the correct symbol node if found, NULL
731 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
733 for (; f
; f
= f
->next
)
734 if (strcmp (f
->sym
->name
, name
) == 0)
741 /******** Interface checking subroutines **********/
744 /* Given an operator interface and the operator, make sure that all
745 interfaces for that operator are legal. */
748 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
751 gfc_formal_arglist
*formal
;
754 int args
, r1
, r2
, k1
, k2
;
759 t1
= t2
= BT_UNKNOWN
;
760 i1
= i2
= INTENT_UNKNOWN
;
764 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
766 gfc_symbol
*fsym
= formal
->sym
;
769 gfc_error ("Alternate return cannot appear in operator "
770 "interface at %L", &sym
->declared_at
);
776 i1
= fsym
->attr
.intent
;
777 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
783 i2
= fsym
->attr
.intent
;
784 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
790 /* Only +, - and .not. can be unary operators.
791 .not. cannot be a binary operator. */
792 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
793 && op
!= INTRINSIC_MINUS
794 && op
!= INTRINSIC_NOT
)
795 || (args
== 2 && op
== INTRINSIC_NOT
))
797 if (op
== INTRINSIC_ASSIGN
)
798 gfc_error ("Assignment operator interface at %L must have "
799 "two arguments", &sym
->declared_at
);
801 gfc_error ("Operator interface at %L has the wrong number of arguments",
806 /* Check that intrinsics are mapped to functions, except
807 INTRINSIC_ASSIGN which should map to a subroutine. */
808 if (op
== INTRINSIC_ASSIGN
)
810 gfc_formal_arglist
*dummy_args
;
812 if (!sym
->attr
.subroutine
)
814 gfc_error ("Assignment operator interface at %L must be "
815 "a SUBROUTINE", &sym
->declared_at
);
819 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
820 - First argument an array with different rank than second,
821 - First argument is a scalar and second an array,
822 - Types and kinds do not conform, or
823 - First argument is of derived type. */
824 dummy_args
= gfc_sym_get_dummy_args (sym
);
825 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
826 && dummy_args
->sym
->ts
.type
!= BT_CLASS
827 && (r2
== 0 || r1
== r2
)
828 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
829 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
830 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
832 gfc_error ("Assignment operator interface at %L must not redefine "
833 "an INTRINSIC type assignment", &sym
->declared_at
);
839 if (!sym
->attr
.function
)
841 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
847 /* Check intents on operator interfaces. */
848 if (op
== INTRINSIC_ASSIGN
)
850 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
852 gfc_error ("First argument of defined assignment at %L must be "
853 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
859 gfc_error ("Second argument of defined assignment at %L must be "
860 "INTENT(IN)", &sym
->declared_at
);
868 gfc_error ("First argument of operator interface at %L must be "
869 "INTENT(IN)", &sym
->declared_at
);
873 if (args
== 2 && i2
!= INTENT_IN
)
875 gfc_error ("Second argument of operator interface at %L must be "
876 "INTENT(IN)", &sym
->declared_at
);
881 /* From now on, all we have to do is check that the operator definition
882 doesn't conflict with an intrinsic operator. The rules for this
883 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
884 as well as 12.3.2.1.1 of Fortran 2003:
886 "If the operator is an intrinsic-operator (R310), the number of
887 function arguments shall be consistent with the intrinsic uses of
888 that operator, and the types, kind type parameters, or ranks of the
889 dummy arguments shall differ from those required for the intrinsic
890 operation (7.1.2)." */
892 #define IS_NUMERIC_TYPE(t) \
893 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
895 /* Unary ops are easy, do them first. */
896 if (op
== INTRINSIC_NOT
)
898 if (t1
== BT_LOGICAL
)
904 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
906 if (IS_NUMERIC_TYPE (t1
))
912 /* Character intrinsic operators have same character kind, thus
913 operator definitions with operands of different character kinds
915 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
918 /* Intrinsic operators always perform on arguments of same rank,
919 so different ranks is also always safe. (rank == 0) is an exception
920 to that, because all intrinsic operators are elemental. */
921 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
927 case INTRINSIC_EQ_OS
:
929 case INTRINSIC_NE_OS
:
930 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
935 case INTRINSIC_MINUS
:
936 case INTRINSIC_TIMES
:
937 case INTRINSIC_DIVIDE
:
938 case INTRINSIC_POWER
:
939 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
944 case INTRINSIC_GT_OS
:
946 case INTRINSIC_GE_OS
:
948 case INTRINSIC_LT_OS
:
950 case INTRINSIC_LE_OS
:
951 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
953 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
954 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
958 case INTRINSIC_CONCAT
:
959 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
967 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
977 #undef IS_NUMERIC_TYPE
980 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
986 /* Given a pair of formal argument lists, we see if the two lists can
987 be distinguished by counting the number of nonoptional arguments of
988 a given type/rank in f1 and seeing if there are less then that
989 number of those arguments in f2 (including optional arguments).
990 Since this test is asymmetric, it has to be called twice to make it
991 symmetric. Returns nonzero if the argument lists are incompatible
992 by this test. This subroutine implements rule 1 of section F03:16.2.3.
993 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
996 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
997 const char *p1
, const char *p2
)
999 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
1000 gfc_formal_arglist
*f
;
1013 for (f
= f1
; f
; f
= f
->next
)
1016 /* Build an array of integers that gives the same integer to
1017 arguments of the same type/rank. */
1018 arg
= XCNEWVEC (arginfo
, n1
);
1021 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1024 arg
[i
].sym
= f
->sym
;
1029 for (i
= 0; i
< n1
; i
++)
1031 if (arg
[i
].flag
!= -1)
1034 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1035 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1036 continue; /* Skip OPTIONAL and PASS arguments. */
1040 /* Find other non-optional, non-pass arguments of the same type/rank. */
1041 for (j
= i
+ 1; j
< n1
; j
++)
1042 if ((arg
[j
].sym
== NULL
1043 || !(arg
[j
].sym
->attr
.optional
1044 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1045 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1046 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1052 /* Now loop over each distinct type found in f1. */
1056 for (i
= 0; i
< n1
; i
++)
1058 if (arg
[i
].flag
!= k
)
1062 for (j
= i
+ 1; j
< n1
; j
++)
1063 if (arg
[j
].flag
== k
)
1066 /* Count the number of non-pass arguments in f2 with that type,
1067 including those that are optional. */
1070 for (f
= f2
; f
; f
= f
->next
)
1071 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1072 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1073 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1091 /* Perform the correspondence test in rule (3) of F08:C1215.
1092 Returns zero if no argument is found that satisfies this rule,
1093 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1096 This test is also not symmetric in f1 and f2 and must be called
1097 twice. This test finds problems caused by sorting the actual
1098 argument list with keywords. For example:
1102 INTEGER :: A ; REAL :: B
1106 INTEGER :: A ; REAL :: B
1110 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1113 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1114 const char *p1
, const char *p2
)
1116 gfc_formal_arglist
*f2_save
, *g
;
1123 if (f1
->sym
->attr
.optional
)
1126 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1128 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1131 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1132 || compare_type_rank (f2
->sym
, f1
->sym
))
1133 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1134 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1135 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1138 /* Now search for a disambiguating keyword argument starting at
1139 the current non-match. */
1140 for (g
= f1
; g
; g
= g
->next
)
1142 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1145 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1146 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1147 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1148 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1149 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1165 symbol_rank (gfc_symbol
*sym
)
1168 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1169 return as
? as
->rank
: 0;
1173 /* Check if the characteristics of two dummy arguments match,
1177 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1178 bool type_must_agree
, char *errmsg
,
1181 if (s1
== NULL
|| s2
== NULL
)
1182 return s1
== s2
? true : false;
1184 /* Check type and rank. */
1185 if (type_must_agree
)
1187 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1189 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1190 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1193 if (!compare_rank (s1
, s2
))
1195 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1196 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1202 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1204 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1209 /* Check OPTIONAL attribute. */
1210 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1212 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1217 /* Check ALLOCATABLE attribute. */
1218 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1220 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1225 /* Check POINTER attribute. */
1226 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1228 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1233 /* Check TARGET attribute. */
1234 if (s1
->attr
.target
!= s2
->attr
.target
)
1236 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1241 /* Check ASYNCHRONOUS attribute. */
1242 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1244 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1249 /* Check CONTIGUOUS attribute. */
1250 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1252 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1257 /* Check VALUE attribute. */
1258 if (s1
->attr
.value
!= s2
->attr
.value
)
1260 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1265 /* Check VOLATILE attribute. */
1266 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1268 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1273 /* Check interface of dummy procedures. */
1274 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1277 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1280 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1281 "'%s': %s", s1
->name
, err
);
1286 /* Check string length. */
1287 if (s1
->ts
.type
== BT_CHARACTER
1288 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1289 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1291 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1292 s2
->ts
.u
.cl
->length
);
1298 snprintf (errmsg
, err_len
, "Character length mismatch "
1299 "in argument '%s'", s1
->name
);
1303 /* FIXME: Implement a warning for this case.
1304 gfc_warning (0, "Possible character length mismatch in argument %qs",
1312 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1313 "%i of gfc_dep_compare_expr", compval
);
1318 /* Check array shape. */
1319 if (s1
->as
&& s2
->as
)
1322 gfc_expr
*shape1
, *shape2
;
1324 if (s1
->as
->type
!= s2
->as
->type
)
1326 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1331 if (s1
->as
->corank
!= s2
->as
->corank
)
1333 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1334 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1338 if (s1
->as
->type
== AS_EXPLICIT
)
1339 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1341 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1342 gfc_copy_expr (s1
->as
->lower
[i
]));
1343 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1344 gfc_copy_expr (s2
->as
->lower
[i
]));
1345 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1346 gfc_free_expr (shape1
);
1347 gfc_free_expr (shape2
);
1353 if (i
< s1
->as
->rank
)
1354 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1355 " argument '%s'", i
+ 1, s1
->name
);
1357 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1358 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1362 /* FIXME: Implement a warning for this case.
1363 gfc_warning (0, "Possible shape mismatch in argument %qs",
1371 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1372 "result %i of gfc_dep_compare_expr",
1383 /* Check if the characteristics of two function results match,
1387 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1388 char *errmsg
, int err_len
)
1390 gfc_symbol
*r1
, *r2
;
1392 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1393 r1
= s1
->ts
.interface
->result
;
1395 r1
= s1
->result
? s1
->result
: s1
;
1397 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1398 r2
= s2
->ts
.interface
->result
;
1400 r2
= s2
->result
? s2
->result
: s2
;
1402 if (r1
->ts
.type
== BT_UNKNOWN
)
1405 /* Check type and rank. */
1406 if (!compare_type (r1
, r2
))
1408 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1409 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1412 if (!compare_rank (r1
, r2
))
1414 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1415 symbol_rank (r1
), symbol_rank (r2
));
1419 /* Check ALLOCATABLE attribute. */
1420 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1422 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1427 /* Check POINTER attribute. */
1428 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1430 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1435 /* Check CONTIGUOUS attribute. */
1436 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1438 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1443 /* Check PROCEDURE POINTER attribute. */
1444 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1446 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1451 /* Check string length. */
1452 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1454 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1456 snprintf (errmsg
, err_len
, "Character length mismatch "
1457 "in function result");
1461 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1463 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1464 r2
->ts
.u
.cl
->length
);
1470 snprintf (errmsg
, err_len
, "Character length mismatch "
1471 "in function result");
1475 /* FIXME: Implement a warning for this case.
1476 snprintf (errmsg, err_len, "Possible character length mismatch "
1477 "in function result");*/
1484 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1485 "result %i of gfc_dep_compare_expr", compval
);
1491 /* Check array shape. */
1492 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1495 gfc_expr
*shape1
, *shape2
;
1497 if (r1
->as
->type
!= r2
->as
->type
)
1499 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1503 if (r1
->as
->type
== AS_EXPLICIT
)
1504 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1506 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1507 gfc_copy_expr (r1
->as
->lower
[i
]));
1508 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1509 gfc_copy_expr (r2
->as
->lower
[i
]));
1510 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1511 gfc_free_expr (shape1
);
1512 gfc_free_expr (shape2
);
1518 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1519 "function result", i
+ 1);
1523 /* FIXME: Implement a warning for this case.
1524 gfc_warning (0, "Possible shape mismatch in return value");*/
1531 gfc_internal_error ("check_result_characteristics (2): "
1532 "Unexpected result %i of "
1533 "gfc_dep_compare_expr", compval
);
1543 /* 'Compare' two formal interfaces associated with a pair of symbols.
1544 We return nonzero if there exists an actual argument list that
1545 would be ambiguous between the two interfaces, zero otherwise.
1546 'strict_flag' specifies whether all the characteristics are
1547 required to match, which is not the case for ambiguity checks.
1548 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1551 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1552 int generic_flag
, int strict_flag
,
1553 char *errmsg
, int err_len
,
1554 const char *p1
, const char *p2
)
1556 gfc_formal_arglist
*f1
, *f2
;
1558 gcc_assert (name2
!= NULL
);
1560 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1561 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1562 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1565 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1569 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1572 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1576 /* Do strict checks on all characteristics
1577 (for dummy procedures and procedure pointer assignments). */
1578 if (!generic_flag
&& strict_flag
)
1580 if (s1
->attr
.function
&& s2
->attr
.function
)
1582 /* If both are functions, check result characteristics. */
1583 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1584 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1588 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1590 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1593 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1595 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1600 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1601 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1604 f1
= gfc_sym_get_dummy_args (s1
);
1605 f2
= gfc_sym_get_dummy_args (s2
);
1607 if (f1
== NULL
&& f2
== NULL
)
1608 return 1; /* Special case: No arguments. */
1612 if (count_types_test (f1
, f2
, p1
, p2
)
1613 || count_types_test (f2
, f1
, p2
, p1
))
1615 if (generic_correspondence (f1
, f2
, p1
, p2
)
1616 || generic_correspondence (f2
, f1
, p2
, p1
))
1620 /* Perform the abbreviated correspondence test for operators (the
1621 arguments cannot be optional and are always ordered correctly).
1622 This is also done when comparing interfaces for dummy procedures and in
1623 procedure pointer assignments. */
1627 /* Check existence. */
1628 if (f1
== NULL
&& f2
== NULL
)
1630 if (f1
== NULL
|| f2
== NULL
)
1633 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1634 "arguments", name2
);
1638 if (UNLIMITED_POLY (f1
->sym
))
1643 /* Check all characteristics. */
1644 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1650 /* Only check type and rank. */
1651 if (!compare_type (f2
->sym
, f1
->sym
))
1654 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1655 "(%s/%s)", f1
->sym
->name
,
1656 gfc_typename (&f1
->sym
->ts
),
1657 gfc_typename (&f2
->sym
->ts
));
1660 if (!compare_rank (f2
->sym
, f1
->sym
))
1663 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1664 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1665 symbol_rank (f2
->sym
));
1678 /* Given a pointer to an interface pointer, remove duplicate
1679 interfaces and make sure that all symbols are either functions
1680 or subroutines, and all of the same kind. Returns nonzero if
1681 something goes wrong. */
1684 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1686 gfc_interface
*psave
, *q
, *qlast
;
1689 for (; p
; p
= p
->next
)
1691 /* Make sure all symbols in the interface have been defined as
1692 functions or subroutines. */
1693 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1694 || !p
->sym
->attr
.if_source
)
1695 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1697 if (p
->sym
->attr
.external
)
1698 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1699 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1701 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1702 "subroutine", p
->sym
->name
, interface_name
,
1703 &p
->sym
->declared_at
);
1707 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1708 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1709 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1710 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1712 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1713 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1714 " or all FUNCTIONs", interface_name
,
1715 &p
->sym
->declared_at
);
1716 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1717 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1718 "generic name is also the name of a derived type",
1719 interface_name
, &p
->sym
->declared_at
);
1723 /* F2003, C1207. F2008, C1207. */
1724 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1725 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1726 "%qs in %s at %L", p
->sym
->name
,
1727 interface_name
, &p
->sym
->declared_at
))
1732 /* Remove duplicate interfaces in this interface list. */
1733 for (; p
; p
= p
->next
)
1737 for (q
= p
->next
; q
;)
1739 if (p
->sym
!= q
->sym
)
1746 /* Duplicate interface. */
1747 qlast
->next
= q
->next
;
1758 /* Check lists of interfaces to make sure that no two interfaces are
1759 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1762 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1763 int generic_flag
, const char *interface_name
,
1767 for (; p
; p
= p
->next
)
1768 for (q
= q0
; q
; q
= q
->next
)
1770 if (p
->sym
== q
->sym
)
1771 continue; /* Duplicates OK here. */
1773 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1776 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1777 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1778 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1779 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1782 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1783 p
->sym
->name
, q
->sym
->name
, interface_name
,
1785 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1786 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
1787 p
->sym
->name
, q
->sym
->name
, interface_name
,
1790 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1791 "interfaces at %L", interface_name
, &p
->where
);
1799 /* Check the generic and operator interfaces of symbols to make sure
1800 that none of the interfaces conflict. The check has to be done
1801 after all of the symbols are actually loaded. */
1804 check_sym_interfaces (gfc_symbol
*sym
)
1806 char interface_name
[100];
1809 if (sym
->ns
!= gfc_current_ns
)
1812 if (sym
->generic
!= NULL
)
1814 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1815 if (check_interface0 (sym
->generic
, interface_name
))
1818 for (p
= sym
->generic
; p
; p
= p
->next
)
1820 if (p
->sym
->attr
.mod_proc
1821 && !p
->sym
->attr
.module_procedure
1822 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1823 || p
->sym
->attr
.procedure
))
1825 gfc_error ("%qs at %L is not a module procedure",
1826 p
->sym
->name
, &p
->where
);
1831 /* Originally, this test was applied to host interfaces too;
1832 this is incorrect since host associated symbols, from any
1833 source, cannot be ambiguous with local symbols. */
1834 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1835 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1841 check_uop_interfaces (gfc_user_op
*uop
)
1843 char interface_name
[100];
1847 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1848 if (check_interface0 (uop
->op
, interface_name
))
1851 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1853 uop2
= gfc_find_uop (uop
->name
, ns
);
1857 check_interface1 (uop
->op
, uop2
->op
, 0,
1858 interface_name
, true);
1862 /* Given an intrinsic op, return an equivalent op if one exists,
1863 or INTRINSIC_NONE otherwise. */
1866 gfc_equivalent_op (gfc_intrinsic_op op
)
1871 return INTRINSIC_EQ_OS
;
1873 case INTRINSIC_EQ_OS
:
1874 return INTRINSIC_EQ
;
1877 return INTRINSIC_NE_OS
;
1879 case INTRINSIC_NE_OS
:
1880 return INTRINSIC_NE
;
1883 return INTRINSIC_GT_OS
;
1885 case INTRINSIC_GT_OS
:
1886 return INTRINSIC_GT
;
1889 return INTRINSIC_GE_OS
;
1891 case INTRINSIC_GE_OS
:
1892 return INTRINSIC_GE
;
1895 return INTRINSIC_LT_OS
;
1897 case INTRINSIC_LT_OS
:
1898 return INTRINSIC_LT
;
1901 return INTRINSIC_LE_OS
;
1903 case INTRINSIC_LE_OS
:
1904 return INTRINSIC_LE
;
1907 return INTRINSIC_NONE
;
1911 /* For the namespace, check generic, user operator and intrinsic
1912 operator interfaces for consistency and to remove duplicate
1913 interfaces. We traverse the whole namespace, counting on the fact
1914 that most symbols will not have generic or operator interfaces. */
1917 gfc_check_interfaces (gfc_namespace
*ns
)
1919 gfc_namespace
*old_ns
, *ns2
;
1920 char interface_name
[100];
1923 old_ns
= gfc_current_ns
;
1924 gfc_current_ns
= ns
;
1926 gfc_traverse_ns (ns
, check_sym_interfaces
);
1928 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1930 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1932 if (i
== INTRINSIC_USER
)
1935 if (i
== INTRINSIC_ASSIGN
)
1936 strcpy (interface_name
, "intrinsic assignment operator");
1938 sprintf (interface_name
, "intrinsic '%s' operator",
1939 gfc_op2string ((gfc_intrinsic_op
) i
));
1941 if (check_interface0 (ns
->op
[i
], interface_name
))
1945 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1948 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1950 gfc_intrinsic_op other_op
;
1952 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1953 interface_name
, true))
1956 /* i should be gfc_intrinsic_op, but has to be int with this cast
1957 here for stupid C++ compatibility rules. */
1958 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1959 if (other_op
!= INTRINSIC_NONE
1960 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1961 0, interface_name
, true))
1967 gfc_current_ns
= old_ns
;
1971 /* Given a symbol of a formal argument list and an expression, if the
1972 formal argument is allocatable, check that the actual argument is
1973 allocatable. Returns nonzero if compatible, zero if not compatible. */
1976 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1978 symbol_attribute attr
;
1980 if (formal
->attr
.allocatable
1981 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1983 attr
= gfc_expr_attr (actual
);
1984 if (!attr
.allocatable
)
1992 /* Given a symbol of a formal argument list and an expression, if the
1993 formal argument is a pointer, see if the actual argument is a
1994 pointer. Returns nonzero if compatible, zero if not compatible. */
1997 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1999 symbol_attribute attr
;
2001 if (formal
->attr
.pointer
2002 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2003 && CLASS_DATA (formal
)->attr
.class_pointer
))
2005 attr
= gfc_expr_attr (actual
);
2007 /* Fortran 2008 allows non-pointer actual arguments. */
2008 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2019 /* Emit clear error messages for rank mismatch. */
2022 argument_rank_mismatch (const char *name
, locus
*where
,
2023 int rank1
, int rank2
)
2026 /* TS 29113, C407b. */
2029 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2030 " %qs has assumed-rank", where
, name
);
2032 else if (rank1
== 0)
2034 gfc_error ("Rank mismatch in argument %qs at %L "
2035 "(scalar and rank-%d)", name
, where
, rank2
);
2037 else if (rank2
== 0)
2039 gfc_error ("Rank mismatch in argument %qs at %L "
2040 "(rank-%d and scalar)", name
, where
, rank1
);
2044 gfc_error ("Rank mismatch in argument %qs at %L "
2045 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
2050 /* Given a symbol of a formal argument list and an expression, see if
2051 the two are compatible as arguments. Returns nonzero if
2052 compatible, zero if not compatible. */
2055 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2056 int ranks_must_agree
, int is_elemental
, locus
*where
)
2059 bool rank_check
, is_pointer
;
2063 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2064 procs c_f_pointer or c_f_procpointer, and we need to accept most
2065 pointers the user could give us. This should allow that. */
2066 if (formal
->ts
.type
== BT_VOID
)
2069 if (formal
->ts
.type
== BT_DERIVED
2070 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2071 && actual
->ts
.type
== BT_DERIVED
2072 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2075 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2076 /* Make sure the vtab symbol is present when
2077 the module variables are generated. */
2078 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2080 if (actual
->ts
.type
== BT_PROCEDURE
)
2082 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2084 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2087 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2091 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2092 sizeof(err
), NULL
, NULL
))
2095 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2096 formal
->name
, &actual
->where
, err
);
2100 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2102 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2103 &act_sym
->declared_at
);
2104 if (act_sym
->ts
.type
== BT_UNKNOWN
2105 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2108 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2109 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2110 &act_sym
->declared_at
);
2115 ppc
= gfc_get_proc_ptr_comp (actual
);
2116 if (ppc
&& ppc
->ts
.interface
)
2118 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2119 err
, sizeof(err
), NULL
, NULL
))
2122 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2123 formal
->name
, &actual
->where
, err
);
2129 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2130 && !gfc_is_simply_contiguous (actual
, true, false))
2133 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2134 "must be simply contiguous", formal
->name
, &actual
->where
);
2138 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2139 && actual
->ts
.type
!= BT_HOLLERITH
2140 && formal
->ts
.type
!= BT_ASSUMED
2141 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2142 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2143 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2144 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2145 CLASS_DATA (actual
)->ts
.u
.derived
)))
2148 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2149 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
2150 gfc_typename (&formal
->ts
));
2154 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2157 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2158 "argument %qs is of assumed type", &actual
->where
,
2163 /* F2008, 12.5.2.5; IR F08/0073. */
2164 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2165 && actual
->expr_type
!= EXPR_NULL
2166 && ((CLASS_DATA (formal
)->attr
.class_pointer
2167 && formal
->attr
.intent
!= INTENT_IN
)
2168 || CLASS_DATA (formal
)->attr
.allocatable
))
2170 if (actual
->ts
.type
!= BT_CLASS
)
2173 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2174 formal
->name
, &actual
->where
);
2178 if (!gfc_expr_attr (actual
).class_ok
)
2181 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2182 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2183 CLASS_DATA (formal
)->ts
.u
.derived
))
2186 gfc_error ("Actual argument to %qs at %L must have the same "
2187 "declared type", formal
->name
, &actual
->where
);
2192 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2193 is necessary also for F03, so retain error for both.
2194 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2195 compatible, no attempt has been made to channel to this one. */
2196 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2197 && (CLASS_DATA (formal
)->attr
.allocatable
2198 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2201 gfc_error ("Actual argument to %qs at %L must be unlimited "
2202 "polymorphic since the formal argument is a "
2203 "pointer or allocatable unlimited polymorphic "
2204 "entity [F2008: 12.5.2.5]", formal
->name
,
2209 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2212 gfc_error ("Actual argument to %qs at %L must be a coarray",
2213 formal
->name
, &actual
->where
);
2217 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2219 gfc_ref
*last
= NULL
;
2221 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2222 if (ref
->type
== REF_COMPONENT
)
2225 /* F2008, 12.5.2.6. */
2226 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2228 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2231 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2232 formal
->name
, &actual
->where
, formal
->as
->corank
,
2233 last
? last
->u
.c
.component
->as
->corank
2234 : actual
->symtree
->n
.sym
->as
->corank
);
2239 if (formal
->attr
.codimension
)
2241 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2242 /* F2015, 12.5.2.8. */
2243 if (formal
->attr
.dimension
2244 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2245 && gfc_expr_attr (actual
).dimension
2246 && !gfc_is_simply_contiguous (actual
, true, true))
2249 gfc_error ("Actual argument to %qs at %L must be simply "
2250 "contiguous or an element of such an array",
2251 formal
->name
, &actual
->where
);
2255 /* F2008, C1303 and C1304. */
2256 if (formal
->attr
.intent
!= INTENT_INOUT
2257 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2258 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2259 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2260 || formal
->attr
.lock_comp
))
2264 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2265 "which is LOCK_TYPE or has a LOCK_TYPE component",
2266 formal
->name
, &actual
->where
);
2270 /* TS18508, C702/C703. */
2271 if (formal
->attr
.intent
!= INTENT_INOUT
2272 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2273 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2274 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2275 || formal
->attr
.event_comp
))
2279 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2280 "which is EVENT_TYPE or has a EVENT_TYPE component",
2281 formal
->name
, &actual
->where
);
2286 /* F2008, C1239/C1240. */
2287 if (actual
->expr_type
== EXPR_VARIABLE
2288 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2289 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2290 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2291 && actual
->rank
&& formal
->as
2292 && !gfc_is_simply_contiguous (actual
, true, false)
2293 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2294 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2295 || formal
->attr
.contiguous
))
2298 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2299 "assumed-rank array without CONTIGUOUS attribute - as actual"
2300 " argument at %L is not simply contiguous and both are "
2301 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2305 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2306 && gfc_expr_attr (actual
).codimension
)
2308 if (formal
->attr
.intent
== INTENT_OUT
)
2311 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2312 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2316 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2317 gfc_warning (OPT_Wsurprising
,
2318 "Passing coarray at %L to allocatable, noncoarray dummy "
2319 "argument %qs, which is invalid if the allocation status"
2320 " is modified", &actual
->where
, formal
->name
);
2323 /* If the rank is the same or the formal argument has assumed-rank. */
2324 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2327 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2328 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2329 || formal
->as
->type
== AS_DEFERRED
)
2330 && actual
->expr_type
!= EXPR_NULL
;
2332 /* Skip rank checks for NO_ARG_CHECK. */
2333 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2336 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2337 if (rank_check
|| ranks_must_agree
2338 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2339 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2340 || (actual
->rank
== 0
2341 && ((formal
->ts
.type
== BT_CLASS
2342 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2343 || (formal
->ts
.type
!= BT_CLASS
2344 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2345 && actual
->expr_type
!= EXPR_NULL
)
2346 || (actual
->rank
== 0 && formal
->attr
.dimension
2347 && gfc_is_coindexed (actual
)))
2350 argument_rank_mismatch (formal
->name
, &actual
->where
,
2351 symbol_rank (formal
), actual
->rank
);
2354 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2357 /* At this point, we are considering a scalar passed to an array. This
2358 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2359 - if the actual argument is (a substring of) an element of a
2360 non-assumed-shape/non-pointer/non-polymorphic array; or
2361 - (F2003) if the actual argument is of type character of default/c_char
2364 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2365 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2367 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2369 if (ref
->type
== REF_COMPONENT
)
2370 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2371 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2372 && ref
->u
.ar
.dimen
> 0
2374 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2378 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2381 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2382 "at %L", formal
->name
, &actual
->where
);
2386 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2387 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2390 gfc_error ("Element of assumed-shaped or pointer "
2391 "array passed to array dummy argument %qs at %L",
2392 formal
->name
, &actual
->where
);
2396 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2397 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2399 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2402 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2403 "CHARACTER actual argument with array dummy argument "
2404 "%qs at %L", formal
->name
, &actual
->where
);
2408 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2410 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2411 "array dummy argument %qs at %L",
2412 formal
->name
, &actual
->where
);
2415 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2421 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2424 argument_rank_mismatch (formal
->name
, &actual
->where
,
2425 symbol_rank (formal
), actual
->rank
);
2433 /* Returns the storage size of a symbol (formal argument) or
2434 zero if it cannot be determined. */
2436 static unsigned long
2437 get_sym_storage_size (gfc_symbol
*sym
)
2440 unsigned long strlen
, elements
;
2442 if (sym
->ts
.type
== BT_CHARACTER
)
2444 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2445 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2446 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2453 if (symbol_rank (sym
) == 0)
2457 if (sym
->as
->type
!= AS_EXPLICIT
)
2459 for (i
= 0; i
< sym
->as
->rank
; i
++)
2461 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2462 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2465 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2466 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2469 return strlen
*elements
;
2473 /* Returns the storage size of an expression (actual argument) or
2474 zero if it cannot be determined. For an array element, it returns
2475 the remaining size as the element sequence consists of all storage
2476 units of the actual argument up to the end of the array. */
2478 static unsigned long
2479 get_expr_storage_size (gfc_expr
*e
)
2482 long int strlen
, elements
;
2483 long int substrlen
= 0;
2484 bool is_str_storage
= false;
2490 if (e
->ts
.type
== BT_CHARACTER
)
2492 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2493 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2494 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2495 else if (e
->expr_type
== EXPR_CONSTANT
2496 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2497 strlen
= e
->value
.character
.length
;
2502 strlen
= 1; /* Length per element. */
2504 if (e
->rank
== 0 && !e
->ref
)
2512 for (i
= 0; i
< e
->rank
; i
++)
2513 elements
*= mpz_get_si (e
->shape
[i
]);
2514 return elements
*strlen
;
2517 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2519 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2520 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2524 /* The string length is the substring length.
2525 Set now to full string length. */
2526 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2527 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2530 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2532 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2536 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2537 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2539 long int start
, end
, stride
;
2542 if (ref
->u
.ar
.stride
[i
])
2544 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2545 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2550 if (ref
->u
.ar
.start
[i
])
2552 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2553 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2557 else if (ref
->u
.ar
.as
->lower
[i
]
2558 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2559 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2563 if (ref
->u
.ar
.end
[i
])
2565 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2566 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2570 else if (ref
->u
.ar
.as
->upper
[i
]
2571 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2572 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2576 elements
*= (end
- start
)/stride
+ 1L;
2578 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2579 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2581 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2582 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2583 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2584 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2585 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2586 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2587 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2592 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2593 && e
->expr_type
== EXPR_VARIABLE
)
2595 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2596 || e
->symtree
->n
.sym
->attr
.pointer
)
2602 /* Determine the number of remaining elements in the element
2603 sequence for array element designators. */
2604 is_str_storage
= true;
2605 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2607 if (ref
->u
.ar
.start
[i
] == NULL
2608 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2609 || ref
->u
.ar
.as
->upper
[i
] == NULL
2610 || ref
->u
.ar
.as
->lower
[i
] == NULL
2611 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2612 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2617 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2618 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2620 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2621 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2624 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2625 && ref
->u
.c
.component
->attr
.proc_pointer
2626 && ref
->u
.c
.component
->attr
.dimension
)
2628 /* Array-valued procedure-pointer components. */
2629 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2630 for (i
= 0; i
< as
->rank
; i
++)
2632 if (!as
->upper
[i
] || !as
->lower
[i
]
2633 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2634 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2638 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2639 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2645 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2648 return elements
*strlen
;
2652 /* Given an expression, check whether it is an array section
2653 which has a vector subscript. If it has, one is returned,
2657 gfc_has_vector_subscript (gfc_expr
*e
)
2662 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2665 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2666 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2667 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2668 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2676 is_procptr_result (gfc_expr
*expr
)
2678 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2680 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2682 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2683 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2687 /* Given formal and actual argument lists, see if they are compatible.
2688 If they are compatible, the actual argument list is sorted to
2689 correspond with the formal list, and elements for missing optional
2690 arguments are inserted. If WHERE pointer is nonnull, then we issue
2691 errors when things don't match instead of just returning the status
2695 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2696 int ranks_must_agree
, int is_elemental
, locus
*where
)
2698 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2699 gfc_formal_arglist
*f
;
2701 unsigned long actual_size
, formal_size
;
2702 bool full_array
= false;
2706 if (actual
== NULL
&& formal
== NULL
)
2710 for (f
= formal
; f
; f
= f
->next
)
2713 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2715 for (i
= 0; i
< n
; i
++)
2722 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2724 /* Look for keywords but ignore g77 extensions like %VAL. */
2725 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2728 for (f
= formal
; f
; f
= f
->next
, i
++)
2732 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2739 gfc_error ("Keyword argument %qs at %L is not in "
2740 "the procedure", a
->name
, &a
->expr
->where
);
2744 if (new_arg
[i
] != NULL
)
2747 gfc_error ("Keyword argument %qs at %L is already associated "
2748 "with another actual argument", a
->name
,
2757 gfc_error ("More actual than formal arguments in procedure "
2758 "call at %L", where
);
2763 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2769 gfc_error ("Missing alternate return spec in subroutine call "
2774 if (a
->expr
== NULL
)
2777 gfc_error ("Unexpected alternate return spec in subroutine "
2778 "call at %L", where
);
2782 /* Make sure that intrinsic vtables exist for calls to unlimited
2783 polymorphic formal arguments. */
2784 if (UNLIMITED_POLY (f
->sym
)
2785 && a
->expr
->ts
.type
!= BT_DERIVED
2786 && a
->expr
->ts
.type
!= BT_CLASS
)
2787 gfc_find_vtab (&a
->expr
->ts
);
2789 if (a
->expr
->expr_type
== EXPR_NULL
2790 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2791 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2792 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2793 || (f
->sym
->ts
.type
== BT_CLASS
2794 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2795 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2796 || !f
->sym
->attr
.optional
2797 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2800 && (!f
->sym
->attr
.optional
2801 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2802 || (f
->sym
->ts
.type
== BT_CLASS
2803 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2804 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2805 where
, f
->sym
->name
);
2807 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2808 "dummy %qs", where
, f
->sym
->name
);
2813 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2814 is_elemental
, where
))
2817 /* TS 29113, 6.3p2. */
2818 if (f
->sym
->ts
.type
== BT_ASSUMED
2819 && (a
->expr
->ts
.type
== BT_DERIVED
2820 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2822 gfc_namespace
*f2k_derived
;
2824 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2825 ? a
->expr
->ts
.u
.derived
->f2k_derived
2826 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2829 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2831 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2832 "derived type with type-bound or FINAL procedures",
2838 /* Special case for character arguments. For allocatable, pointer
2839 and assumed-shape dummies, the string length needs to match
2841 if (a
->expr
->ts
.type
== BT_CHARACTER
2842 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2843 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2844 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2845 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2846 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2847 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2848 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2849 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2851 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2853 "Character length mismatch (%ld/%ld) between actual "
2854 "argument and pointer or allocatable dummy argument "
2856 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2857 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2858 f
->sym
->name
, &a
->expr
->where
);
2861 "Character length mismatch (%ld/%ld) between actual "
2862 "argument and assumed-shape dummy argument %qs "
2864 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2865 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2866 f
->sym
->name
, &a
->expr
->where
);
2870 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2871 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2872 && a
->expr
->ts
.type
== BT_CHARACTER
)
2875 gfc_error ("Actual argument at %L to allocatable or "
2876 "pointer dummy argument %qs must have a deferred "
2877 "length type parameter if and only if the dummy has one",
2878 &a
->expr
->where
, f
->sym
->name
);
2882 if (f
->sym
->ts
.type
== BT_CLASS
)
2883 goto skip_size_check
;
2885 actual_size
= get_expr_storage_size (a
->expr
);
2886 formal_size
= get_sym_storage_size (f
->sym
);
2887 if (actual_size
!= 0 && actual_size
< formal_size
2888 && a
->expr
->ts
.type
!= BT_PROCEDURE
2889 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2891 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2892 gfc_warning (0, "Character length of actual argument shorter "
2893 "than of dummy argument %qs (%lu/%lu) at %L",
2894 f
->sym
->name
, actual_size
, formal_size
,
2897 gfc_warning (0, "Actual argument contains too few "
2898 "elements for dummy argument %qs (%lu/%lu) at %L",
2899 f
->sym
->name
, actual_size
, formal_size
,
2906 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2907 argument is provided for a procedure pointer formal argument. */
2908 if (f
->sym
->attr
.proc_pointer
2909 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2910 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2911 || gfc_is_proc_ptr_comp (a
->expr
)))
2912 || (a
->expr
->expr_type
== EXPR_FUNCTION
2913 && is_procptr_result (a
->expr
))))
2916 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2917 f
->sym
->name
, &a
->expr
->where
);
2921 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2922 provided for a procedure formal argument. */
2923 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2924 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2925 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2926 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2927 || gfc_is_proc_ptr_comp (a
->expr
)))
2928 || (a
->expr
->expr_type
== EXPR_FUNCTION
2929 && is_procptr_result (a
->expr
))))
2932 gfc_error ("Expected a procedure for argument %qs at %L",
2933 f
->sym
->name
, &a
->expr
->where
);
2937 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2938 && a
->expr
->expr_type
== EXPR_VARIABLE
2939 && a
->expr
->symtree
->n
.sym
->as
2940 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2941 && (a
->expr
->ref
== NULL
2942 || (a
->expr
->ref
->type
== REF_ARRAY
2943 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2946 gfc_error ("Actual argument for %qs cannot be an assumed-size"
2947 " array at %L", f
->sym
->name
, where
);
2951 if (a
->expr
->expr_type
!= EXPR_NULL
2952 && compare_pointer (f
->sym
, a
->expr
) == 0)
2955 gfc_error ("Actual argument for %qs must be a pointer at %L",
2956 f
->sym
->name
, &a
->expr
->where
);
2960 if (a
->expr
->expr_type
!= EXPR_NULL
2961 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2962 && compare_pointer (f
->sym
, a
->expr
) == 2)
2965 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2966 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
2971 /* Fortran 2008, C1242. */
2972 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2975 gfc_error ("Coindexed actual argument at %L to pointer "
2977 &a
->expr
->where
, f
->sym
->name
);
2981 /* Fortran 2008, 12.5.2.5 (no constraint). */
2982 if (a
->expr
->expr_type
== EXPR_VARIABLE
2983 && f
->sym
->attr
.intent
!= INTENT_IN
2984 && f
->sym
->attr
.allocatable
2985 && gfc_is_coindexed (a
->expr
))
2988 gfc_error ("Coindexed actual argument at %L to allocatable "
2989 "dummy %qs requires INTENT(IN)",
2990 &a
->expr
->where
, f
->sym
->name
);
2994 /* Fortran 2008, C1237. */
2995 if (a
->expr
->expr_type
== EXPR_VARIABLE
2996 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2997 && gfc_is_coindexed (a
->expr
)
2998 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2999 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3002 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3003 "%L requires that dummy %qs has neither "
3004 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3009 /* Fortran 2008, 12.5.2.4 (no constraint). */
3010 if (a
->expr
->expr_type
== EXPR_VARIABLE
3011 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3012 && gfc_is_coindexed (a
->expr
)
3013 && gfc_has_ultimate_allocatable (a
->expr
))
3016 gfc_error ("Coindexed actual argument at %L with allocatable "
3017 "ultimate component to dummy %qs requires either VALUE "
3018 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3022 if (f
->sym
->ts
.type
== BT_CLASS
3023 && CLASS_DATA (f
->sym
)->attr
.allocatable
3024 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3028 gfc_error ("Actual CLASS array argument for %qs must be a full "
3029 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3034 if (a
->expr
->expr_type
!= EXPR_NULL
3035 && compare_allocatable (f
->sym
, a
->expr
) == 0)
3038 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3039 f
->sym
->name
, &a
->expr
->where
);
3043 /* Check intent = OUT/INOUT for definable actual argument. */
3044 if ((f
->sym
->attr
.intent
== INTENT_OUT
3045 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3047 const char* context
= (where
3048 ? _("actual argument to INTENT = OUT/INOUT")
3051 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3052 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3053 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3054 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3056 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3060 if ((f
->sym
->attr
.intent
== INTENT_OUT
3061 || f
->sym
->attr
.intent
== INTENT_INOUT
3062 || f
->sym
->attr
.volatile_
3063 || f
->sym
->attr
.asynchronous
)
3064 && gfc_has_vector_subscript (a
->expr
))
3067 gfc_error ("Array-section actual argument with vector "
3068 "subscripts at %L is incompatible with INTENT(OUT), "
3069 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3070 "of the dummy argument %qs",
3071 &a
->expr
->where
, f
->sym
->name
);
3075 /* C1232 (R1221) For an actual argument which is an array section or
3076 an assumed-shape array, the dummy argument shall be an assumed-
3077 shape array, if the dummy argument has the VOLATILE attribute. */
3079 if (f
->sym
->attr
.volatile_
3080 && a
->expr
->symtree
->n
.sym
->as
3081 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3082 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3085 gfc_error ("Assumed-shape actual argument at %L is "
3086 "incompatible with the non-assumed-shape "
3087 "dummy argument %qs due to VOLATILE attribute",
3088 &a
->expr
->where
,f
->sym
->name
);
3092 if (f
->sym
->attr
.volatile_
3093 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
3094 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3097 gfc_error ("Array-section actual argument at %L is "
3098 "incompatible with the non-assumed-shape "
3099 "dummy argument %qs due to VOLATILE attribute",
3100 &a
->expr
->where
,f
->sym
->name
);
3104 /* C1233 (R1221) For an actual argument which is a pointer array, the
3105 dummy argument shall be an assumed-shape or pointer array, if the
3106 dummy argument has the VOLATILE attribute. */
3108 if (f
->sym
->attr
.volatile_
3109 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3110 && a
->expr
->symtree
->n
.sym
->as
3112 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3113 || f
->sym
->attr
.pointer
)))
3116 gfc_error ("Pointer-array actual argument at %L requires "
3117 "an assumed-shape or pointer-array dummy "
3118 "argument %qs due to VOLATILE attribute",
3119 &a
->expr
->where
,f
->sym
->name
);
3130 /* Make sure missing actual arguments are optional. */
3132 for (f
= formal
; f
; f
= f
->next
, i
++)
3134 if (new_arg
[i
] != NULL
)
3139 gfc_error ("Missing alternate return spec in subroutine call "
3143 if (!f
->sym
->attr
.optional
)
3146 gfc_error ("Missing actual argument for argument %qs at %L",
3147 f
->sym
->name
, where
);
3152 /* The argument lists are compatible. We now relink a new actual
3153 argument list with null arguments in the right places. The head
3154 of the list remains the head. */
3155 for (i
= 0; i
< n
; i
++)
3156 if (new_arg
[i
] == NULL
)
3157 new_arg
[i
] = gfc_get_actual_arglist ();
3161 std::swap (*new_arg
[0], *actual
);
3162 std::swap (new_arg
[0], new_arg
[na
]);
3165 for (i
= 0; i
< n
- 1; i
++)
3166 new_arg
[i
]->next
= new_arg
[i
+ 1];
3168 new_arg
[i
]->next
= NULL
;
3170 if (*ap
== NULL
&& n
> 0)
3173 /* Note the types of omitted optional arguments. */
3174 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3175 if (a
->expr
== NULL
&& a
->label
== NULL
)
3176 a
->missing_arg_type
= f
->sym
->ts
.type
;
3184 gfc_formal_arglist
*f
;
3185 gfc_actual_arglist
*a
;
3189 /* qsort comparison function for argument pairs, with the following
3191 - p->a->expr == NULL
3192 - p->a->expr->expr_type != EXPR_VARIABLE
3193 - growing p->a->expr->symbol. */
3196 pair_cmp (const void *p1
, const void *p2
)
3198 const gfc_actual_arglist
*a1
, *a2
;
3200 /* *p1 and *p2 are elements of the to-be-sorted array. */
3201 a1
= ((const argpair
*) p1
)->a
;
3202 a2
= ((const argpair
*) p2
)->a
;
3211 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3213 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3217 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3219 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3223 /* Given two expressions from some actual arguments, test whether they
3224 refer to the same expression. The analysis is conservative.
3225 Returning false will produce no warning. */
3228 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3230 const gfc_ref
*r1
, *r2
;
3233 || e1
->expr_type
!= EXPR_VARIABLE
3234 || e2
->expr_type
!= EXPR_VARIABLE
3235 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3238 /* TODO: improve comparison, see expr.c:show_ref(). */
3239 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3241 if (r1
->type
!= r2
->type
)
3246 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3248 /* TODO: At the moment, consider only full arrays;
3249 we could do better. */
3250 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3255 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3263 gfc_internal_error ("compare_actual_expr(): Bad component code");
3272 /* Given formal and actual argument lists that correspond to one
3273 another, check that identical actual arguments aren't not
3274 associated with some incompatible INTENTs. */
3277 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3279 sym_intent f1_intent
, f2_intent
;
3280 gfc_formal_arglist
*f1
;
3281 gfc_actual_arglist
*a1
;
3287 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3289 if (f1
== NULL
&& a1
== NULL
)
3291 if (f1
== NULL
|| a1
== NULL
)
3292 gfc_internal_error ("check_some_aliasing(): List mismatch");
3297 p
= XALLOCAVEC (argpair
, n
);
3299 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3305 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3307 for (i
= 0; i
< n
; i
++)
3310 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3311 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3313 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3314 for (j
= i
+ 1; j
< n
; j
++)
3316 /* Expected order after the sort. */
3317 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3318 gfc_internal_error ("check_some_aliasing(): corrupted data");
3320 /* Are the expression the same? */
3321 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3323 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3324 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3325 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3326 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3328 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3329 "argument %qs and INTENT(%s) argument %qs at %L",
3330 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3331 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3332 &p
[i
].a
->expr
->where
);
3342 /* Given formal and actual argument lists that correspond to one
3343 another, check that they are compatible in the sense that intents
3344 are not mismatched. */
3347 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3349 sym_intent f_intent
;
3351 for (;; f
= f
->next
, a
= a
->next
)
3355 if (f
== NULL
&& a
== NULL
)
3357 if (f
== NULL
|| a
== NULL
)
3358 gfc_internal_error ("check_intents(): List mismatch");
3360 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3361 && a
->expr
->value
.function
.isym
3362 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3363 expr
= a
->expr
->value
.function
.actual
->expr
;
3367 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3370 f_intent
= f
->sym
->attr
.intent
;
3372 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3374 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3375 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3376 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3378 gfc_error ("Procedure argument at %L is local to a PURE "
3379 "procedure and has the POINTER attribute",
3385 /* Fortran 2008, C1283. */
3386 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3388 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3390 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3391 "is passed to an INTENT(%s) argument",
3392 &expr
->where
, gfc_intent_string (f_intent
));
3396 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3397 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3398 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3400 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3401 "is passed to a POINTER dummy argument",
3407 /* F2008, Section 12.5.2.4. */
3408 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3409 && gfc_is_coindexed (expr
))
3411 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3412 "polymorphic dummy argument %qs",
3413 &expr
->where
, f
->sym
->name
);
3422 /* Check how a procedure is used against its interface. If all goes
3423 well, the actual argument list will also end up being properly
3427 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3429 gfc_formal_arglist
*dummy_args
;
3431 /* Warn about calls with an implicit interface. Special case
3432 for calling a ISO_C_BINDING because c_loc and c_funloc
3433 are pseudo-unknown. Additionally, warn about procedures not
3434 explicitly declared at all if requested. */
3435 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3437 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3439 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3443 if (warn_implicit_interface
)
3444 gfc_warning (OPT_Wimplicit_interface
,
3445 "Procedure %qs called with an implicit interface at %L",
3447 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3448 gfc_warning (OPT_Wimplicit_procedure
,
3449 "Procedure %qs called at %L is not explicitly declared",
3453 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3455 gfc_actual_arglist
*a
;
3457 if (sym
->attr
.pointer
)
3459 gfc_error ("The pointer object %qs at %L must have an explicit "
3460 "function interface or be declared as array",
3465 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3467 gfc_error ("The allocatable object %qs at %L must have an explicit "
3468 "function interface or be declared as array",
3473 if (sym
->attr
.allocatable
)
3475 gfc_error ("Allocatable function %qs at %L must have an explicit "
3476 "function interface", sym
->name
, where
);
3480 for (a
= *ap
; a
; a
= a
->next
)
3482 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3483 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3485 gfc_error ("Keyword argument requires explicit interface "
3486 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3490 /* TS 29113, 6.2. */
3491 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3492 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3494 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3495 "interface", a
->expr
->symtree
->n
.sym
->name
,
3500 /* F2008, C1303 and C1304. */
3502 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3503 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3504 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3505 || gfc_expr_attr (a
->expr
).lock_comp
))
3507 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3508 "component at %L requires an explicit interface for "
3509 "procedure %qs", &a
->expr
->where
, sym
->name
);
3514 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3515 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3516 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3517 == ISOFORTRAN_EVENT_TYPE
)
3518 || gfc_expr_attr (a
->expr
).event_comp
))
3520 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3521 "component at %L requires an explicit interface for "
3522 "procedure %qs", &a
->expr
->where
, sym
->name
);
3526 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3527 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3529 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3533 /* TS 29113, C407b. */
3534 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3535 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3537 gfc_error ("Assumed-rank argument requires an explicit interface "
3538 "at %L", &a
->expr
->where
);
3546 dummy_args
= gfc_sym_get_dummy_args (sym
);
3548 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3551 if (!check_intents (dummy_args
, *ap
))
3555 check_some_aliasing (dummy_args
, *ap
);
3561 /* Check how a procedure pointer component is used against its interface.
3562 If all goes well, the actual argument list will also end up being properly
3563 sorted. Completely analogous to gfc_procedure_use. */
3566 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3568 /* Warn about calls with an implicit interface. Special case
3569 for calling a ISO_C_BINDING because c_loc and c_funloc
3570 are pseudo-unknown. */
3571 if (warn_implicit_interface
3572 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3573 && !comp
->attr
.is_iso_c
)
3574 gfc_warning (OPT_Wimplicit_interface
,
3575 "Procedure pointer component %qs called with an implicit "
3576 "interface at %L", comp
->name
, where
);
3578 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3580 gfc_actual_arglist
*a
;
3581 for (a
= *ap
; a
; a
= a
->next
)
3583 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3584 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3586 gfc_error ("Keyword argument requires explicit interface "
3587 "for procedure pointer component %qs at %L",
3588 comp
->name
, &a
->expr
->where
);
3596 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3597 comp
->attr
.elemental
, where
))
3600 check_intents (comp
->ts
.interface
->formal
, *ap
);
3602 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3606 /* Try if an actual argument list matches the formal list of a symbol,
3607 respecting the symbol's attributes like ELEMENTAL. This is used for
3608 GENERIC resolution. */
3611 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3613 gfc_formal_arglist
*dummy_args
;
3616 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
3619 dummy_args
= gfc_sym_get_dummy_args (sym
);
3621 r
= !sym
->attr
.elemental
;
3622 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3624 check_intents (dummy_args
, *args
);
3626 check_some_aliasing (dummy_args
, *args
);
3634 /* Given an interface pointer and an actual argument list, search for
3635 a formal argument list that matches the actual. If found, returns
3636 a pointer to the symbol of the correct interface. Returns NULL if
3640 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3641 gfc_actual_arglist
**ap
)
3643 gfc_symbol
*elem_sym
= NULL
;
3644 gfc_symbol
*null_sym
= NULL
;
3645 locus null_expr_loc
;
3646 gfc_actual_arglist
*a
;
3647 bool has_null_arg
= false;
3649 for (a
= *ap
; a
; a
= a
->next
)
3650 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3651 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3653 has_null_arg
= true;
3654 null_expr_loc
= a
->expr
->where
;
3658 for (; intr
; intr
= intr
->next
)
3660 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
3662 if (sub_flag
&& intr
->sym
->attr
.function
)
3664 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3667 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3669 if (has_null_arg
&& null_sym
)
3671 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3672 "between specific functions %s and %s",
3673 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3676 else if (has_null_arg
)
3678 null_sym
= intr
->sym
;
3682 /* Satisfy 12.4.4.1 such that an elemental match has lower
3683 weight than a non-elemental match. */
3684 if (intr
->sym
->attr
.elemental
)
3686 elem_sym
= intr
->sym
;
3696 return elem_sym
? elem_sym
: NULL
;
3700 /* Do a brute force recursive search for a symbol. */
3702 static gfc_symtree
*
3703 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3707 if (root
->n
.sym
== sym
)
3712 st
= find_symtree0 (root
->left
, sym
);
3713 if (root
->right
&& ! st
)
3714 st
= find_symtree0 (root
->right
, sym
);
3719 /* Find a symtree for a symbol. */
3722 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3727 /* First try to find it by name. */
3728 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3729 if (st
&& st
->n
.sym
== sym
)
3732 /* If it's been renamed, resort to a brute-force search. */
3733 /* TODO: avoid having to do this search. If the symbol doesn't exist
3734 in the symtree for the current namespace, it should probably be added. */
3735 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3737 st
= find_symtree0 (ns
->sym_root
, sym
);
3741 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3746 /* See if the arglist to an operator-call contains a derived-type argument
3747 with a matching type-bound operator. If so, return the matching specific
3748 procedure defined as operator-target as well as the base-object to use
3749 (which is the found derived-type argument with operator). The generic
3750 name, if any, is transmitted to the final expression via 'gname'. */
3752 static gfc_typebound_proc
*
3753 matching_typebound_op (gfc_expr
** tb_base
,
3754 gfc_actual_arglist
* args
,
3755 gfc_intrinsic_op op
, const char* uop
,
3756 const char ** gname
)
3758 gfc_actual_arglist
* base
;
3760 for (base
= args
; base
; base
= base
->next
)
3761 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3763 gfc_typebound_proc
* tb
;
3764 gfc_symbol
* derived
;
3767 while (base
->expr
->expr_type
== EXPR_OP
3768 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3769 base
->expr
= base
->expr
->value
.op
.op1
;
3771 if (base
->expr
->ts
.type
== BT_CLASS
)
3773 if (CLASS_DATA (base
->expr
) == NULL
3774 || !gfc_expr_attr (base
->expr
).class_ok
)
3776 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3779 derived
= base
->expr
->ts
.u
.derived
;
3781 if (op
== INTRINSIC_USER
)
3783 gfc_symtree
* tb_uop
;
3786 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3795 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3798 /* This means we hit a PRIVATE operator which is use-associated and
3799 should thus not be seen. */
3803 /* Look through the super-type hierarchy for a matching specific
3805 for (; tb
; tb
= tb
->overridden
)
3809 gcc_assert (tb
->is_generic
);
3810 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3813 gfc_actual_arglist
* argcopy
;
3816 gcc_assert (g
->specific
);
3817 if (g
->specific
->error
)
3820 target
= g
->specific
->u
.specific
->n
.sym
;
3822 /* Check if this arglist matches the formal. */
3823 argcopy
= gfc_copy_actual_arglist (args
);
3824 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3825 gfc_free_actual_arglist (argcopy
);
3827 /* Return if we found a match. */
3830 *tb_base
= base
->expr
;
3831 *gname
= g
->specific_st
->name
;
3842 /* For the 'actual arglist' of an operator call and a specific typebound
3843 procedure that has been found the target of a type-bound operator, build the
3844 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3845 type-bound procedures rather than resolving type-bound operators 'directly'
3846 so that we can reuse the existing logic. */
3849 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3850 gfc_expr
* base
, gfc_typebound_proc
* target
,
3853 e
->expr_type
= EXPR_COMPCALL
;
3854 e
->value
.compcall
.tbp
= target
;
3855 e
->value
.compcall
.name
= gname
? gname
: "$op";
3856 e
->value
.compcall
.actual
= actual
;
3857 e
->value
.compcall
.base_object
= base
;
3858 e
->value
.compcall
.ignore_pass
= 1;
3859 e
->value
.compcall
.assign
= 0;
3860 if (e
->ts
.type
== BT_UNKNOWN
3861 && target
->function
)
3863 if (target
->is_generic
)
3864 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3866 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3871 /* This subroutine is called when an expression is being resolved.
3872 The expression node in question is either a user defined operator
3873 or an intrinsic operator with arguments that aren't compatible
3874 with the operator. This subroutine builds an actual argument list
3875 corresponding to the operands, then searches for a compatible
3876 interface. If one is found, the expression node is replaced with
3877 the appropriate function call. We use the 'match' enum to specify
3878 whether a replacement has been made or not, or if an error occurred. */
3881 gfc_extend_expr (gfc_expr
*e
)
3883 gfc_actual_arglist
*actual
;
3889 gfc_typebound_proc
* tbo
;
3894 actual
= gfc_get_actual_arglist ();
3895 actual
->expr
= e
->value
.op
.op1
;
3899 if (e
->value
.op
.op2
!= NULL
)
3901 actual
->next
= gfc_get_actual_arglist ();
3902 actual
->next
->expr
= e
->value
.op
.op2
;
3905 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3907 /* See if we find a matching type-bound operator. */
3908 if (i
== INTRINSIC_USER
)
3909 tbo
= matching_typebound_op (&tb_base
, actual
,
3910 i
, e
->value
.op
.uop
->name
, &gname
);
3914 #define CHECK_OS_COMPARISON(comp) \
3915 case INTRINSIC_##comp: \
3916 case INTRINSIC_##comp##_OS: \
3917 tbo = matching_typebound_op (&tb_base, actual, \
3918 INTRINSIC_##comp, NULL, &gname); \
3920 tbo = matching_typebound_op (&tb_base, actual, \
3921 INTRINSIC_##comp##_OS, NULL, &gname); \
3923 CHECK_OS_COMPARISON(EQ
)
3924 CHECK_OS_COMPARISON(NE
)
3925 CHECK_OS_COMPARISON(GT
)
3926 CHECK_OS_COMPARISON(GE
)
3927 CHECK_OS_COMPARISON(LT
)
3928 CHECK_OS_COMPARISON(LE
)
3929 #undef CHECK_OS_COMPARISON
3932 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3936 /* If there is a matching typebound-operator, replace the expression with
3937 a call to it and succeed. */
3940 gcc_assert (tb_base
);
3941 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3943 if (!gfc_resolve_expr (e
))
3949 if (i
== INTRINSIC_USER
)
3951 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3953 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3957 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3964 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3966 /* Due to the distinction between '==' and '.eq.' and friends, one has
3967 to check if either is defined. */
3970 #define CHECK_OS_COMPARISON(comp) \
3971 case INTRINSIC_##comp: \
3972 case INTRINSIC_##comp##_OS: \
3973 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3975 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3977 CHECK_OS_COMPARISON(EQ
)
3978 CHECK_OS_COMPARISON(NE
)
3979 CHECK_OS_COMPARISON(GT
)
3980 CHECK_OS_COMPARISON(GE
)
3981 CHECK_OS_COMPARISON(LT
)
3982 CHECK_OS_COMPARISON(LE
)
3983 #undef CHECK_OS_COMPARISON
3986 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3994 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3995 found rather than just taking the first one and not checking further. */
3999 /* Don't use gfc_free_actual_arglist(). */
4000 free (actual
->next
);
4005 /* Change the expression node to a function call. */
4006 e
->expr_type
= EXPR_FUNCTION
;
4007 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4008 e
->value
.function
.actual
= actual
;
4009 e
->value
.function
.esym
= NULL
;
4010 e
->value
.function
.isym
= NULL
;
4011 e
->value
.function
.name
= NULL
;
4012 e
->user_operator
= 1;
4014 if (!gfc_resolve_expr (e
))
4021 /* Tries to replace an assignment code node with a subroutine call to the
4022 subroutine associated with the assignment operator. Return true if the node
4023 was replaced. On false, no error is generated. */
4026 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4028 gfc_actual_arglist
*actual
;
4029 gfc_expr
*lhs
, *rhs
, *tb_base
;
4030 gfc_symbol
*sym
= NULL
;
4031 const char *gname
= NULL
;
4032 gfc_typebound_proc
* tbo
;
4037 /* Don't allow an intrinsic assignment to be replaced. */
4038 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4039 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4040 && (lhs
->ts
.type
== rhs
->ts
.type
4041 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4044 actual
= gfc_get_actual_arglist ();
4047 actual
->next
= gfc_get_actual_arglist ();
4048 actual
->next
->expr
= rhs
;
4050 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4052 /* See if we find a matching type-bound assignment. */
4053 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4058 /* Success: Replace the expression with a type-bound call. */
4059 gcc_assert (tb_base
);
4060 c
->expr1
= gfc_get_expr ();
4061 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4062 c
->expr1
->value
.compcall
.assign
= 1;
4063 c
->expr1
->where
= c
->loc
;
4065 c
->op
= EXEC_COMPCALL
;
4069 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4070 for (; ns
; ns
= ns
->parent
)
4072 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4079 /* Success: Replace the assignment with the call. */
4080 c
->op
= EXEC_ASSIGN_CALL
;
4081 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4084 c
->ext
.actual
= actual
;
4088 /* Failure: No assignment procedure found. */
4089 free (actual
->next
);
4095 /* Make sure that the interface just parsed is not already present in
4096 the given interface list. Ambiguity isn't checked yet since module
4097 procedures can be present without interfaces. */
4100 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4104 for (ip
= base
; ip
; ip
= ip
->next
)
4106 if (ip
->sym
== new_sym
)
4108 gfc_error ("Entity %qs at %L is already present in the interface",
4109 new_sym
->name
, &loc
);
4118 /* Add a symbol to the current interface. */
4121 gfc_add_interface (gfc_symbol
*new_sym
)
4123 gfc_interface
**head
, *intr
;
4127 switch (current_interface
.type
)
4129 case INTERFACE_NAMELESS
:
4130 case INTERFACE_ABSTRACT
:
4133 case INTERFACE_INTRINSIC_OP
:
4134 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4135 switch (current_interface
.op
)
4138 case INTRINSIC_EQ_OS
:
4139 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4141 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4142 new_sym
, gfc_current_locus
))
4147 case INTRINSIC_NE_OS
:
4148 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4150 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4151 new_sym
, gfc_current_locus
))
4156 case INTRINSIC_GT_OS
:
4157 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4158 new_sym
, gfc_current_locus
)
4159 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4160 new_sym
, gfc_current_locus
))
4165 case INTRINSIC_GE_OS
:
4166 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4167 new_sym
, gfc_current_locus
)
4168 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4169 new_sym
, gfc_current_locus
))
4174 case INTRINSIC_LT_OS
:
4175 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4176 new_sym
, gfc_current_locus
)
4177 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4178 new_sym
, gfc_current_locus
))
4183 case INTRINSIC_LE_OS
:
4184 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4185 new_sym
, gfc_current_locus
)
4186 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4187 new_sym
, gfc_current_locus
))
4192 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4193 new_sym
, gfc_current_locus
))
4197 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4200 case INTERFACE_GENERIC
:
4201 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4203 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4207 if (!gfc_check_new_interface (sym
->generic
,
4208 new_sym
, gfc_current_locus
))
4212 head
= ¤t_interface
.sym
->generic
;
4215 case INTERFACE_USER_OP
:
4216 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4217 new_sym
, gfc_current_locus
))
4220 head
= ¤t_interface
.uop
->op
;
4224 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4227 intr
= gfc_get_interface ();
4228 intr
->sym
= new_sym
;
4229 intr
->where
= gfc_current_locus
;
4239 gfc_current_interface_head (void)
4241 switch (current_interface
.type
)
4243 case INTERFACE_INTRINSIC_OP
:
4244 return current_interface
.ns
->op
[current_interface
.op
];
4247 case INTERFACE_GENERIC
:
4248 return current_interface
.sym
->generic
;
4251 case INTERFACE_USER_OP
:
4252 return current_interface
.uop
->op
;
4262 gfc_set_current_interface_head (gfc_interface
*i
)
4264 switch (current_interface
.type
)
4266 case INTERFACE_INTRINSIC_OP
:
4267 current_interface
.ns
->op
[current_interface
.op
] = i
;
4270 case INTERFACE_GENERIC
:
4271 current_interface
.sym
->generic
= i
;
4274 case INTERFACE_USER_OP
:
4275 current_interface
.uop
->op
= i
;
4284 /* Gets rid of a formal argument list. We do not free symbols.
4285 Symbols are freed when a namespace is freed. */
4288 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4290 gfc_formal_arglist
*q
;
4300 /* Check that it is ok for the type-bound procedure 'proc' to override the
4301 procedure 'old', cf. F08:4.5.7.3. */
4304 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4307 gfc_symbol
*proc_target
, *old_target
;
4308 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4309 gfc_formal_arglist
*proc_formal
, *old_formal
;
4313 /* This procedure should only be called for non-GENERIC proc. */
4314 gcc_assert (!proc
->n
.tb
->is_generic
);
4316 /* If the overwritten procedure is GENERIC, this is an error. */
4317 if (old
->n
.tb
->is_generic
)
4319 gfc_error ("Can't overwrite GENERIC %qs at %L",
4320 old
->name
, &proc
->n
.tb
->where
);
4324 where
= proc
->n
.tb
->where
;
4325 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4326 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4328 /* Check that overridden binding is not NON_OVERRIDABLE. */
4329 if (old
->n
.tb
->non_overridable
)
4331 gfc_error ("%qs at %L overrides a procedure binding declared"
4332 " NON_OVERRIDABLE", proc
->name
, &where
);
4336 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4337 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4339 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4340 " non-DEFERRED binding", proc
->name
, &where
);
4344 /* If the overridden binding is PURE, the overriding must be, too. */
4345 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4347 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4348 proc
->name
, &where
);
4352 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4353 is not, the overriding must not be either. */
4354 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4356 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4357 " ELEMENTAL", proc
->name
, &where
);
4360 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4362 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4363 " be ELEMENTAL, either", proc
->name
, &where
);
4367 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4369 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4371 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4372 " SUBROUTINE", proc
->name
, &where
);
4376 /* If the overridden binding is a FUNCTION, the overriding must also be a
4377 FUNCTION and have the same characteristics. */
4378 if (old_target
->attr
.function
)
4380 if (!proc_target
->attr
.function
)
4382 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4383 " FUNCTION", proc
->name
, &where
);
4387 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4390 gfc_error ("Result mismatch for the overriding procedure "
4391 "%qs at %L: %s", proc
->name
, &where
, err
);
4396 /* If the overridden binding is PUBLIC, the overriding one must not be
4398 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4399 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4401 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4402 " PRIVATE", proc
->name
, &where
);
4406 /* Compare the formal argument lists of both procedures. This is also abused
4407 to find the position of the passed-object dummy arguments of both
4408 bindings as at least the overridden one might not yet be resolved and we
4409 need those positions in the check below. */
4410 proc_pass_arg
= old_pass_arg
= 0;
4411 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4413 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4416 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4417 old_formal
= gfc_sym_get_dummy_args (old_target
);
4418 for ( ; proc_formal
&& old_formal
;
4419 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4421 if (proc
->n
.tb
->pass_arg
4422 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4423 proc_pass_arg
= argpos
;
4424 if (old
->n
.tb
->pass_arg
4425 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4426 old_pass_arg
= argpos
;
4428 /* Check that the names correspond. */
4429 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4431 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4432 " to match the corresponding argument of the overridden"
4433 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4434 old_formal
->sym
->name
);
4438 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4439 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4440 check_type
, err
, sizeof(err
)))
4442 gfc_error ("Argument mismatch for the overriding procedure "
4443 "%qs at %L: %s", proc
->name
, &where
, err
);
4449 if (proc_formal
|| old_formal
)
4451 gfc_error ("%qs at %L must have the same number of formal arguments as"
4452 " the overridden procedure", proc
->name
, &where
);
4456 /* If the overridden binding is NOPASS, the overriding one must also be
4458 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4460 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4461 " NOPASS", proc
->name
, &where
);
4465 /* If the overridden binding is PASS(x), the overriding one must also be
4466 PASS and the passed-object dummy arguments must correspond. */
4467 if (!old
->n
.tb
->nopass
)
4469 if (proc
->n
.tb
->nopass
)
4471 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4472 " PASS", proc
->name
, &where
);
4476 if (proc_pass_arg
!= old_pass_arg
)
4478 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4479 " the same position as the passed-object dummy argument of"
4480 " the overridden procedure", proc
->name
, &where
);