1 /* Deal with interfaces.
2 Copyright (C) 2000-2015 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 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
350 "but got %s", s1
, s2
);
357 case INTERFACE_USER_OP
:
358 /* Comparing the symbol node names is OK because only use-associated
359 symbols can be renamed. */
360 if (type
!= current_interface
.type
361 || strcmp (current_interface
.uop
->name
, name
) != 0)
363 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
364 current_interface
.uop
->name
);
370 case INTERFACE_GENERIC
:
371 if (type
!= current_interface
.type
372 || strcmp (current_interface
.sym
->name
, name
) != 0)
374 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
375 current_interface
.sym
->name
);
386 /* Compare two derived types using the criteria in 4.4.2 of the standard,
387 recursing through gfc_compare_types for the components. */
390 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
392 gfc_component
*dt1
, *dt2
;
394 if (derived1
== derived2
)
397 gcc_assert (derived1
&& derived2
);
399 /* Special case for comparing derived types across namespaces. If the
400 true names and module names are the same and the module name is
401 nonnull, then they are equal. */
402 if (strcmp (derived1
->name
, derived2
->name
) == 0
403 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
404 && strcmp (derived1
->module
, derived2
->module
) == 0)
407 /* Compare type via the rules of the standard. Both types must have
408 the SEQUENCE or BIND(C) attribute to be equal. */
410 if (strcmp (derived1
->name
, derived2
->name
))
413 if (derived1
->component_access
== ACCESS_PRIVATE
414 || derived2
->component_access
== ACCESS_PRIVATE
)
417 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
418 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
421 dt1
= derived1
->components
;
422 dt2
= derived2
->components
;
424 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
425 simple test can speed things up. Otherwise, lots of things have to
429 if (strcmp (dt1
->name
, dt2
->name
) != 0)
432 if (dt1
->attr
.access
!= dt2
->attr
.access
)
435 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
438 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
441 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
444 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
447 /* Make sure that link lists do not put this function into an
448 endless recursive loop! */
449 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
450 && !(dt2
->ts
.type
== BT_DERIVED
&& derived2
== dt2
->ts
.u
.derived
)
451 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
454 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
455 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
458 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
459 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
465 if (dt1
== NULL
&& dt2
== NULL
)
467 if (dt1
== NULL
|| dt2
== NULL
)
475 /* Compare two typespecs, recursively if necessary. */
478 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
480 /* See if one of the typespecs is a BT_VOID, which is what is being used
481 to allow the funcs like c_f_pointer to accept any pointer type.
482 TODO: Possibly should narrow this to just the one typespec coming in
483 that is for the formal arg, but oh well. */
484 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
487 if (ts1
->type
== BT_CLASS
488 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
492 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
493 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
494 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
497 if (ts1
->type
!= ts2
->type
498 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
499 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
501 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
502 return (ts1
->kind
== ts2
->kind
);
504 /* Compare derived types. */
505 if (gfc_type_compatible (ts1
, ts2
))
508 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
513 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
515 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
518 /* TYPE and CLASS of the same declared type are type compatible,
519 but have different characteristics. */
520 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
521 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
524 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
529 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
531 gfc_array_spec
*as1
, *as2
;
534 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
537 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
538 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
540 r1
= as1
? as1
->rank
: 0;
541 r2
= as2
? as2
->rank
: 0;
543 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
544 return 0; /* Ranks differ. */
550 /* Given two symbols that are formal arguments, compare their ranks
551 and types. Returns nonzero if they have the same rank and type,
555 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
557 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
561 /* Given two symbols that are formal arguments, compare their types
562 and rank and their formal interfaces if they are both dummy
563 procedures. Returns nonzero if the same, zero if different. */
566 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
568 if (s1
== NULL
|| s2
== NULL
)
569 return s1
== s2
? 1 : 0;
574 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
575 return compare_type_rank (s1
, s2
);
577 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
580 /* At this point, both symbols are procedures. It can happen that
581 external procedures are compared, where one is identified by usage
582 to be a function or subroutine but the other is not. Check TKR
583 nonetheless for these cases. */
584 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
585 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
587 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
588 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
590 /* Now the type of procedure has been identified. */
591 if (s1
->attr
.function
!= s2
->attr
.function
592 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
595 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
598 /* Originally, gfortran recursed here to check the interfaces of passed
599 procedures. This is explicitly not required by the standard. */
604 /* Given a formal argument list and a keyword name, search the list
605 for that keyword. Returns the correct symbol node if found, NULL
609 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
611 for (; f
; f
= f
->next
)
612 if (strcmp (f
->sym
->name
, name
) == 0)
619 /******** Interface checking subroutines **********/
622 /* Given an operator interface and the operator, make sure that all
623 interfaces for that operator are legal. */
626 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
629 gfc_formal_arglist
*formal
;
632 int args
, r1
, r2
, k1
, k2
;
637 t1
= t2
= BT_UNKNOWN
;
638 i1
= i2
= INTENT_UNKNOWN
;
642 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
644 gfc_symbol
*fsym
= formal
->sym
;
647 gfc_error ("Alternate return cannot appear in operator "
648 "interface at %L", &sym
->declared_at
);
654 i1
= fsym
->attr
.intent
;
655 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
661 i2
= fsym
->attr
.intent
;
662 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
668 /* Only +, - and .not. can be unary operators.
669 .not. cannot be a binary operator. */
670 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
671 && op
!= INTRINSIC_MINUS
672 && op
!= INTRINSIC_NOT
)
673 || (args
== 2 && op
== INTRINSIC_NOT
))
675 if (op
== INTRINSIC_ASSIGN
)
676 gfc_error ("Assignment operator interface at %L must have "
677 "two arguments", &sym
->declared_at
);
679 gfc_error ("Operator interface at %L has the wrong number of arguments",
684 /* Check that intrinsics are mapped to functions, except
685 INTRINSIC_ASSIGN which should map to a subroutine. */
686 if (op
== INTRINSIC_ASSIGN
)
688 gfc_formal_arglist
*dummy_args
;
690 if (!sym
->attr
.subroutine
)
692 gfc_error ("Assignment operator interface at %L must be "
693 "a SUBROUTINE", &sym
->declared_at
);
697 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
698 - First argument an array with different rank than second,
699 - First argument is a scalar and second an array,
700 - Types and kinds do not conform, or
701 - First argument is of derived type. */
702 dummy_args
= gfc_sym_get_dummy_args (sym
);
703 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
704 && dummy_args
->sym
->ts
.type
!= BT_CLASS
705 && (r2
== 0 || r1
== r2
)
706 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
707 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
708 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
710 gfc_error ("Assignment operator interface at %L must not redefine "
711 "an INTRINSIC type assignment", &sym
->declared_at
);
717 if (!sym
->attr
.function
)
719 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
725 /* Check intents on operator interfaces. */
726 if (op
== INTRINSIC_ASSIGN
)
728 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
730 gfc_error ("First argument of defined assignment at %L must be "
731 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
737 gfc_error ("Second argument of defined assignment at %L must be "
738 "INTENT(IN)", &sym
->declared_at
);
746 gfc_error ("First argument of operator interface at %L must be "
747 "INTENT(IN)", &sym
->declared_at
);
751 if (args
== 2 && i2
!= INTENT_IN
)
753 gfc_error ("Second argument of operator interface at %L must be "
754 "INTENT(IN)", &sym
->declared_at
);
759 /* From now on, all we have to do is check that the operator definition
760 doesn't conflict with an intrinsic operator. The rules for this
761 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
762 as well as 12.3.2.1.1 of Fortran 2003:
764 "If the operator is an intrinsic-operator (R310), the number of
765 function arguments shall be consistent with the intrinsic uses of
766 that operator, and the types, kind type parameters, or ranks of the
767 dummy arguments shall differ from those required for the intrinsic
768 operation (7.1.2)." */
770 #define IS_NUMERIC_TYPE(t) \
771 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
773 /* Unary ops are easy, do them first. */
774 if (op
== INTRINSIC_NOT
)
776 if (t1
== BT_LOGICAL
)
782 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
784 if (IS_NUMERIC_TYPE (t1
))
790 /* Character intrinsic operators have same character kind, thus
791 operator definitions with operands of different character kinds
793 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
796 /* Intrinsic operators always perform on arguments of same rank,
797 so different ranks is also always safe. (rank == 0) is an exception
798 to that, because all intrinsic operators are elemental. */
799 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
805 case INTRINSIC_EQ_OS
:
807 case INTRINSIC_NE_OS
:
808 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
813 case INTRINSIC_MINUS
:
814 case INTRINSIC_TIMES
:
815 case INTRINSIC_DIVIDE
:
816 case INTRINSIC_POWER
:
817 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
822 case INTRINSIC_GT_OS
:
824 case INTRINSIC_GE_OS
:
826 case INTRINSIC_LT_OS
:
828 case INTRINSIC_LE_OS
:
829 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
831 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
832 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
836 case INTRINSIC_CONCAT
:
837 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
845 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
855 #undef IS_NUMERIC_TYPE
858 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
864 /* Given a pair of formal argument lists, we see if the two lists can
865 be distinguished by counting the number of nonoptional arguments of
866 a given type/rank in f1 and seeing if there are less then that
867 number of those arguments in f2 (including optional arguments).
868 Since this test is asymmetric, it has to be called twice to make it
869 symmetric. Returns nonzero if the argument lists are incompatible
870 by this test. This subroutine implements rule 1 of section F03:16.2.3.
871 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
874 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
875 const char *p1
, const char *p2
)
877 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
878 gfc_formal_arglist
*f
;
891 for (f
= f1
; f
; f
= f
->next
)
894 /* Build an array of integers that gives the same integer to
895 arguments of the same type/rank. */
896 arg
= XCNEWVEC (arginfo
, n1
);
899 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
907 for (i
= 0; i
< n1
; i
++)
909 if (arg
[i
].flag
!= -1)
912 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
913 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
914 continue; /* Skip OPTIONAL and PASS arguments. */
918 /* Find other non-optional, non-pass arguments of the same type/rank. */
919 for (j
= i
+ 1; j
< n1
; j
++)
920 if ((arg
[j
].sym
== NULL
921 || !(arg
[j
].sym
->attr
.optional
922 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
923 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
924 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
930 /* Now loop over each distinct type found in f1. */
934 for (i
= 0; i
< n1
; i
++)
936 if (arg
[i
].flag
!= k
)
940 for (j
= i
+ 1; j
< n1
; j
++)
941 if (arg
[j
].flag
== k
)
944 /* Count the number of non-pass arguments in f2 with that type,
945 including those that are optional. */
948 for (f
= f2
; f
; f
= f
->next
)
949 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
950 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
951 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
969 /* Perform the correspondence test in rule (3) of F08:C1215.
970 Returns zero if no argument is found that satisfies this rule,
971 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
974 This test is also not symmetric in f1 and f2 and must be called
975 twice. This test finds problems caused by sorting the actual
976 argument list with keywords. For example:
980 INTEGER :: A ; REAL :: B
984 INTEGER :: A ; REAL :: B
988 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
991 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
992 const char *p1
, const char *p2
)
994 gfc_formal_arglist
*f2_save
, *g
;
1001 if (f1
->sym
->attr
.optional
)
1004 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1006 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1009 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1010 || compare_type_rank (f2
->sym
, f1
->sym
))
1011 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1012 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1013 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1016 /* Now search for a disambiguating keyword argument starting at
1017 the current non-match. */
1018 for (g
= f1
; g
; g
= g
->next
)
1020 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1023 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1024 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1025 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1026 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1027 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1043 symbol_rank (gfc_symbol
*sym
)
1046 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1047 return as
? as
->rank
: 0;
1051 /* Check if the characteristics of two dummy arguments match,
1055 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1056 bool type_must_agree
, char *errmsg
, int err_len
)
1058 if (s1
== NULL
|| s2
== NULL
)
1059 return s1
== s2
? true : false;
1061 /* Check type and rank. */
1062 if (type_must_agree
)
1064 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1066 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1067 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1070 if (!compare_rank (s1
, s2
))
1072 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1073 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1079 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1081 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1086 /* Check OPTIONAL attribute. */
1087 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1089 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1094 /* Check ALLOCATABLE attribute. */
1095 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1097 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1102 /* Check POINTER attribute. */
1103 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1105 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1110 /* Check TARGET attribute. */
1111 if (s1
->attr
.target
!= s2
->attr
.target
)
1113 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1118 /* Check ASYNCHRONOUS attribute. */
1119 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1121 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1126 /* Check CONTIGUOUS attribute. */
1127 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1129 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1134 /* Check VALUE attribute. */
1135 if (s1
->attr
.value
!= s2
->attr
.value
)
1137 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1142 /* Check VOLATILE attribute. */
1143 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1145 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1150 /* Check interface of dummy procedures. */
1151 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1154 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1157 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1158 "'%s': %s", s1
->name
, err
);
1163 /* Check string length. */
1164 if (s1
->ts
.type
== BT_CHARACTER
1165 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1166 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1168 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1169 s2
->ts
.u
.cl
->length
);
1175 snprintf (errmsg
, err_len
, "Character length mismatch "
1176 "in argument '%s'", s1
->name
);
1180 /* FIXME: Implement a warning for this case.
1181 gfc_warning ("Possible character length mismatch in argument %qs",
1189 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1190 "%i of gfc_dep_compare_expr", compval
);
1195 /* Check array shape. */
1196 if (s1
->as
&& s2
->as
)
1199 gfc_expr
*shape1
, *shape2
;
1201 if (s1
->as
->type
!= s2
->as
->type
)
1203 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1208 if (s1
->as
->type
== AS_EXPLICIT
)
1209 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1211 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1212 gfc_copy_expr (s1
->as
->lower
[i
]));
1213 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1214 gfc_copy_expr (s2
->as
->lower
[i
]));
1215 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1216 gfc_free_expr (shape1
);
1217 gfc_free_expr (shape2
);
1223 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1224 "argument '%s'", i
+ 1, s1
->name
);
1228 /* FIXME: Implement a warning for this case.
1229 gfc_warning ("Possible shape mismatch in argument %qs",
1237 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1238 "result %i of gfc_dep_compare_expr",
1249 /* Check if the characteristics of two function results match,
1253 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1254 char *errmsg
, int err_len
)
1256 gfc_symbol
*r1
, *r2
;
1258 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1259 r1
= s1
->ts
.interface
->result
;
1261 r1
= s1
->result
? s1
->result
: s1
;
1263 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1264 r2
= s2
->ts
.interface
->result
;
1266 r2
= s2
->result
? s2
->result
: s2
;
1268 if (r1
->ts
.type
== BT_UNKNOWN
)
1271 /* Check type and rank. */
1272 if (!compare_type (r1
, r2
))
1274 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1275 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1278 if (!compare_rank (r1
, r2
))
1280 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1281 symbol_rank (r1
), symbol_rank (r2
));
1285 /* Check ALLOCATABLE attribute. */
1286 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1288 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1293 /* Check POINTER attribute. */
1294 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1296 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1301 /* Check CONTIGUOUS attribute. */
1302 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1304 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1309 /* Check PROCEDURE POINTER attribute. */
1310 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1312 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1317 /* Check string length. */
1318 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1320 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1322 snprintf (errmsg
, err_len
, "Character length mismatch "
1323 "in function result");
1327 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1329 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1330 r2
->ts
.u
.cl
->length
);
1336 snprintf (errmsg
, err_len
, "Character length mismatch "
1337 "in function result");
1341 /* FIXME: Implement a warning for this case.
1342 snprintf (errmsg, err_len, "Possible character length mismatch "
1343 "in function result");*/
1350 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1351 "result %i of gfc_dep_compare_expr", compval
);
1357 /* Check array shape. */
1358 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1361 gfc_expr
*shape1
, *shape2
;
1363 if (r1
->as
->type
!= r2
->as
->type
)
1365 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1369 if (r1
->as
->type
== AS_EXPLICIT
)
1370 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1372 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1373 gfc_copy_expr (r1
->as
->lower
[i
]));
1374 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1375 gfc_copy_expr (r2
->as
->lower
[i
]));
1376 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1377 gfc_free_expr (shape1
);
1378 gfc_free_expr (shape2
);
1384 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1385 "function result", i
+ 1);
1389 /* FIXME: Implement a warning for this case.
1390 gfc_warning ("Possible shape mismatch in return value");*/
1397 gfc_internal_error ("check_result_characteristics (2): "
1398 "Unexpected result %i of "
1399 "gfc_dep_compare_expr", compval
);
1409 /* 'Compare' two formal interfaces associated with a pair of symbols.
1410 We return nonzero if there exists an actual argument list that
1411 would be ambiguous between the two interfaces, zero otherwise.
1412 'strict_flag' specifies whether all the characteristics are
1413 required to match, which is not the case for ambiguity checks.
1414 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1417 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1418 int generic_flag
, int strict_flag
,
1419 char *errmsg
, int err_len
,
1420 const char *p1
, const char *p2
)
1422 gfc_formal_arglist
*f1
, *f2
;
1424 gcc_assert (name2
!= NULL
);
1426 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1427 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1428 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1431 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1435 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1438 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1442 /* Do strict checks on all characteristics
1443 (for dummy procedures and procedure pointer assignments). */
1444 if (!generic_flag
&& strict_flag
)
1446 if (s1
->attr
.function
&& s2
->attr
.function
)
1448 /* If both are functions, check result characteristics. */
1449 if (!check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1450 || !check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1454 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1456 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1459 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1461 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1466 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1467 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1470 f1
= gfc_sym_get_dummy_args (s1
);
1471 f2
= gfc_sym_get_dummy_args (s2
);
1473 if (f1
== NULL
&& f2
== NULL
)
1474 return 1; /* Special case: No arguments. */
1478 if (count_types_test (f1
, f2
, p1
, p2
)
1479 || count_types_test (f2
, f1
, p2
, p1
))
1481 if (generic_correspondence (f1
, f2
, p1
, p2
)
1482 || generic_correspondence (f2
, f1
, p2
, p1
))
1486 /* Perform the abbreviated correspondence test for operators (the
1487 arguments cannot be optional and are always ordered correctly).
1488 This is also done when comparing interfaces for dummy procedures and in
1489 procedure pointer assignments. */
1493 /* Check existence. */
1494 if (f1
== NULL
&& f2
== NULL
)
1496 if (f1
== NULL
|| f2
== NULL
)
1499 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1500 "arguments", name2
);
1504 if (UNLIMITED_POLY (f1
->sym
))
1509 /* Check all characteristics. */
1510 if (!check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1516 /* Only check type and rank. */
1517 if (!compare_type (f2
->sym
, f1
->sym
))
1520 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1521 "(%s/%s)", f1
->sym
->name
,
1522 gfc_typename (&f1
->sym
->ts
),
1523 gfc_typename (&f2
->sym
->ts
));
1526 if (!compare_rank (f2
->sym
, f1
->sym
))
1529 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1530 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1531 symbol_rank (f2
->sym
));
1544 /* Given a pointer to an interface pointer, remove duplicate
1545 interfaces and make sure that all symbols are either functions
1546 or subroutines, and all of the same kind. Returns nonzero if
1547 something goes wrong. */
1550 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1552 gfc_interface
*psave
, *q
, *qlast
;
1555 for (; p
; p
= p
->next
)
1557 /* Make sure all symbols in the interface have been defined as
1558 functions or subroutines. */
1559 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1560 || !p
->sym
->attr
.if_source
)
1561 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1563 if (p
->sym
->attr
.external
)
1564 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1565 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1567 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1568 "subroutine", p
->sym
->name
, interface_name
,
1569 &p
->sym
->declared_at
);
1573 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1574 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1575 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1576 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1578 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1579 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1580 " or all FUNCTIONs", interface_name
,
1581 &p
->sym
->declared_at
);
1583 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1584 "generic name is also the name of a derived type",
1585 interface_name
, &p
->sym
->declared_at
);
1589 /* F2003, C1207. F2008, C1207. */
1590 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1591 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1592 "%qs in %s at %L", p
->sym
->name
,
1593 interface_name
, &p
->sym
->declared_at
))
1598 /* Remove duplicate interfaces in this interface list. */
1599 for (; p
; p
= p
->next
)
1603 for (q
= p
->next
; q
;)
1605 if (p
->sym
!= q
->sym
)
1612 /* Duplicate interface. */
1613 qlast
->next
= q
->next
;
1624 /* Check lists of interfaces to make sure that no two interfaces are
1625 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1628 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1629 int generic_flag
, const char *interface_name
,
1633 for (; p
; p
= p
->next
)
1634 for (q
= q0
; q
; q
= q
->next
)
1636 if (p
->sym
== q
->sym
)
1637 continue; /* Duplicates OK here. */
1639 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1642 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1643 && q
->sym
->attr
.flavor
!= FL_DERIVED
1644 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1645 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1648 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1649 p
->sym
->name
, q
->sym
->name
, interface_name
,
1651 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1652 gfc_warning ("Ambiguous interfaces %qs and %qs in %s at %L",
1653 p
->sym
->name
, q
->sym
->name
, interface_name
,
1656 gfc_warning ("Although not referenced, %qs has ambiguous "
1657 "interfaces at %L", interface_name
, &p
->where
);
1665 /* Check the generic and operator interfaces of symbols to make sure
1666 that none of the interfaces conflict. The check has to be done
1667 after all of the symbols are actually loaded. */
1670 check_sym_interfaces (gfc_symbol
*sym
)
1672 char interface_name
[100];
1675 if (sym
->ns
!= gfc_current_ns
)
1678 if (sym
->generic
!= NULL
)
1680 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1681 if (check_interface0 (sym
->generic
, interface_name
))
1684 for (p
= sym
->generic
; p
; p
= p
->next
)
1686 if (p
->sym
->attr
.mod_proc
1687 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1688 || p
->sym
->attr
.procedure
))
1690 gfc_error ("%qs at %L is not a module procedure",
1691 p
->sym
->name
, &p
->where
);
1696 /* Originally, this test was applied to host interfaces too;
1697 this is incorrect since host associated symbols, from any
1698 source, cannot be ambiguous with local symbols. */
1699 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1700 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1706 check_uop_interfaces (gfc_user_op
*uop
)
1708 char interface_name
[100];
1712 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1713 if (check_interface0 (uop
->op
, interface_name
))
1716 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1718 uop2
= gfc_find_uop (uop
->name
, ns
);
1722 check_interface1 (uop
->op
, uop2
->op
, 0,
1723 interface_name
, true);
1727 /* Given an intrinsic op, return an equivalent op if one exists,
1728 or INTRINSIC_NONE otherwise. */
1731 gfc_equivalent_op (gfc_intrinsic_op op
)
1736 return INTRINSIC_EQ_OS
;
1738 case INTRINSIC_EQ_OS
:
1739 return INTRINSIC_EQ
;
1742 return INTRINSIC_NE_OS
;
1744 case INTRINSIC_NE_OS
:
1745 return INTRINSIC_NE
;
1748 return INTRINSIC_GT_OS
;
1750 case INTRINSIC_GT_OS
:
1751 return INTRINSIC_GT
;
1754 return INTRINSIC_GE_OS
;
1756 case INTRINSIC_GE_OS
:
1757 return INTRINSIC_GE
;
1760 return INTRINSIC_LT_OS
;
1762 case INTRINSIC_LT_OS
:
1763 return INTRINSIC_LT
;
1766 return INTRINSIC_LE_OS
;
1768 case INTRINSIC_LE_OS
:
1769 return INTRINSIC_LE
;
1772 return INTRINSIC_NONE
;
1776 /* For the namespace, check generic, user operator and intrinsic
1777 operator interfaces for consistency and to remove duplicate
1778 interfaces. We traverse the whole namespace, counting on the fact
1779 that most symbols will not have generic or operator interfaces. */
1782 gfc_check_interfaces (gfc_namespace
*ns
)
1784 gfc_namespace
*old_ns
, *ns2
;
1785 char interface_name
[100];
1788 old_ns
= gfc_current_ns
;
1789 gfc_current_ns
= ns
;
1791 gfc_traverse_ns (ns
, check_sym_interfaces
);
1793 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1795 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1797 if (i
== INTRINSIC_USER
)
1800 if (i
== INTRINSIC_ASSIGN
)
1801 strcpy (interface_name
, "intrinsic assignment operator");
1803 sprintf (interface_name
, "intrinsic '%s' operator",
1804 gfc_op2string ((gfc_intrinsic_op
) i
));
1806 if (check_interface0 (ns
->op
[i
], interface_name
))
1810 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1813 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1815 gfc_intrinsic_op other_op
;
1817 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1818 interface_name
, true))
1821 /* i should be gfc_intrinsic_op, but has to be int with this cast
1822 here for stupid C++ compatibility rules. */
1823 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1824 if (other_op
!= INTRINSIC_NONE
1825 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1826 0, interface_name
, true))
1832 gfc_current_ns
= old_ns
;
1836 /* Given a symbol of a formal argument list and an expression, if the
1837 formal argument is allocatable, check that the actual argument is
1838 allocatable. Returns nonzero if compatible, zero if not compatible. */
1841 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1843 symbol_attribute attr
;
1845 if (formal
->attr
.allocatable
1846 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1848 attr
= gfc_expr_attr (actual
);
1849 if (!attr
.allocatable
)
1857 /* Given a symbol of a formal argument list and an expression, if the
1858 formal argument is a pointer, see if the actual argument is a
1859 pointer. Returns nonzero if compatible, zero if not compatible. */
1862 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1864 symbol_attribute attr
;
1866 if (formal
->attr
.pointer
1867 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1868 && CLASS_DATA (formal
)->attr
.class_pointer
))
1870 attr
= gfc_expr_attr (actual
);
1872 /* Fortran 2008 allows non-pointer actual arguments. */
1873 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1884 /* Emit clear error messages for rank mismatch. */
1887 argument_rank_mismatch (const char *name
, locus
*where
,
1888 int rank1
, int rank2
)
1891 /* TS 29113, C407b. */
1894 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1895 " %qs has assumed-rank", where
, name
);
1897 else if (rank1
== 0)
1899 gfc_error ("Rank mismatch in argument %qs at %L "
1900 "(scalar and rank-%d)", name
, where
, rank2
);
1902 else if (rank2
== 0)
1904 gfc_error ("Rank mismatch in argument %qs at %L "
1905 "(rank-%d and scalar)", name
, where
, rank1
);
1909 gfc_error ("Rank mismatch in argument %qs at %L "
1910 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1915 /* Given a symbol of a formal argument list and an expression, see if
1916 the two are compatible as arguments. Returns nonzero if
1917 compatible, zero if not compatible. */
1920 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1921 int ranks_must_agree
, int is_elemental
, locus
*where
)
1924 bool rank_check
, is_pointer
;
1928 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1929 procs c_f_pointer or c_f_procpointer, and we need to accept most
1930 pointers the user could give us. This should allow that. */
1931 if (formal
->ts
.type
== BT_VOID
)
1934 if (formal
->ts
.type
== BT_DERIVED
1935 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1936 && actual
->ts
.type
== BT_DERIVED
1937 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1940 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1941 /* Make sure the vtab symbol is present when
1942 the module variables are generated. */
1943 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1945 if (actual
->ts
.type
== BT_PROCEDURE
)
1947 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1949 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1952 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1956 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1957 sizeof(err
), NULL
, NULL
))
1960 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
1961 formal
->name
, &actual
->where
, err
);
1965 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1967 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1968 &act_sym
->declared_at
);
1969 if (act_sym
->ts
.type
== BT_UNKNOWN
1970 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
1973 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1974 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1975 &act_sym
->declared_at
);
1980 ppc
= gfc_get_proc_ptr_comp (actual
);
1983 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
1984 err
, sizeof(err
), NULL
, NULL
))
1987 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
1988 formal
->name
, &actual
->where
, err
);
1994 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1995 && !gfc_is_simply_contiguous (actual
, true))
1998 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
1999 "must be simply contiguous", formal
->name
, &actual
->where
);
2003 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2004 && actual
->ts
.type
!= BT_HOLLERITH
2005 && formal
->ts
.type
!= BT_ASSUMED
2006 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2007 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2008 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2009 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2010 CLASS_DATA (actual
)->ts
.u
.derived
)))
2013 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2014 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
2015 gfc_typename (&formal
->ts
));
2019 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2022 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2023 "argument %qs is of assumed type", &actual
->where
,
2028 /* F2008, 12.5.2.5; IR F08/0073. */
2029 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2030 && actual
->expr_type
!= EXPR_NULL
2031 && ((CLASS_DATA (formal
)->attr
.class_pointer
2032 && formal
->attr
.intent
!= INTENT_IN
)
2033 || CLASS_DATA (formal
)->attr
.allocatable
))
2035 if (actual
->ts
.type
!= BT_CLASS
)
2038 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2039 formal
->name
, &actual
->where
);
2043 if (!gfc_expr_attr (actual
).class_ok
)
2046 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2047 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2048 CLASS_DATA (formal
)->ts
.u
.derived
))
2051 gfc_error ("Actual argument to %qs at %L must have the same "
2052 "declared type", formal
->name
, &actual
->where
);
2057 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2058 is necessary also for F03, so retain error for both.
2059 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2060 compatible, no attempt has been made to channel to this one. */
2061 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2062 && (CLASS_DATA (formal
)->attr
.allocatable
2063 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2066 gfc_error ("Actual argument to %qs at %L must be unlimited "
2067 "polymorphic since the formal argument is a "
2068 "pointer or allocatable unlimited polymorphic "
2069 "entity [F2008: 12.5.2.5]", formal
->name
,
2074 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2077 gfc_error ("Actual argument to %qs at %L must be a coarray",
2078 formal
->name
, &actual
->where
);
2082 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2084 gfc_ref
*last
= NULL
;
2086 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2087 if (ref
->type
== REF_COMPONENT
)
2090 /* F2008, 12.5.2.6. */
2091 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2093 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2096 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2097 formal
->name
, &actual
->where
, formal
->as
->corank
,
2098 last
? last
->u
.c
.component
->as
->corank
2099 : actual
->symtree
->n
.sym
->as
->corank
);
2104 if (formal
->attr
.codimension
)
2106 /* F2008, 12.5.2.8. */
2107 if (formal
->attr
.dimension
2108 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2109 && gfc_expr_attr (actual
).dimension
2110 && !gfc_is_simply_contiguous (actual
, true))
2113 gfc_error ("Actual argument to %qs at %L must be simply "
2114 "contiguous", formal
->name
, &actual
->where
);
2118 /* F2008, C1303 and C1304. */
2119 if (formal
->attr
.intent
!= INTENT_INOUT
2120 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2121 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2122 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2123 || formal
->attr
.lock_comp
))
2127 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2128 "which is LOCK_TYPE or has a LOCK_TYPE component",
2129 formal
->name
, &actual
->where
);
2134 /* F2008, C1239/C1240. */
2135 if (actual
->expr_type
== EXPR_VARIABLE
2136 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2137 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2138 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2139 && actual
->rank
&& formal
->as
&& !gfc_is_simply_contiguous (actual
, true)
2140 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2141 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2142 || formal
->attr
.contiguous
))
2145 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2146 "assumed-rank array without CONTIGUOUS attribute - as actual"
2147 " argument at %L is not simply contiguous and both are "
2148 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2152 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2153 && gfc_expr_attr (actual
).codimension
)
2155 if (formal
->attr
.intent
== INTENT_OUT
)
2158 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2159 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2163 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2164 gfc_warning (OPT_Wsurprising
,
2165 "Passing coarray at %L to allocatable, noncoarray dummy "
2166 "argument %qs, which is invalid if the allocation status"
2167 " is modified", &actual
->where
, formal
->name
);
2170 /* If the rank is the same or the formal argument has assumed-rank. */
2171 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2174 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2175 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2176 || formal
->as
->type
== AS_DEFERRED
)
2177 && actual
->expr_type
!= EXPR_NULL
;
2179 /* Skip rank checks for NO_ARG_CHECK. */
2180 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2183 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2184 if (rank_check
|| ranks_must_agree
2185 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2186 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2187 || (actual
->rank
== 0
2188 && ((formal
->ts
.type
== BT_CLASS
2189 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2190 || (formal
->ts
.type
!= BT_CLASS
2191 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2192 && actual
->expr_type
!= EXPR_NULL
)
2193 || (actual
->rank
== 0 && formal
->attr
.dimension
2194 && gfc_is_coindexed (actual
)))
2197 argument_rank_mismatch (formal
->name
, &actual
->where
,
2198 symbol_rank (formal
), actual
->rank
);
2201 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2204 /* At this point, we are considering a scalar passed to an array. This
2205 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2206 - if the actual argument is (a substring of) an element of a
2207 non-assumed-shape/non-pointer/non-polymorphic array; or
2208 - (F2003) if the actual argument is of type character of default/c_char
2211 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2212 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2214 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2216 if (ref
->type
== REF_COMPONENT
)
2217 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2218 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2219 && ref
->u
.ar
.dimen
> 0
2221 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2225 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2228 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2229 "at %L", formal
->name
, &actual
->where
);
2233 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2234 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2237 gfc_error ("Element of assumed-shaped or pointer "
2238 "array passed to array dummy argument %qs at %L",
2239 formal
->name
, &actual
->where
);
2243 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2244 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2246 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2249 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2250 "CHARACTER actual argument with array dummy argument "
2251 "%qs at %L", formal
->name
, &actual
->where
);
2255 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2257 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2258 "array dummy argument %qs at %L",
2259 formal
->name
, &actual
->where
);
2262 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2268 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2271 argument_rank_mismatch (formal
->name
, &actual
->where
,
2272 symbol_rank (formal
), actual
->rank
);
2280 /* Returns the storage size of a symbol (formal argument) or
2281 zero if it cannot be determined. */
2283 static unsigned long
2284 get_sym_storage_size (gfc_symbol
*sym
)
2287 unsigned long strlen
, elements
;
2289 if (sym
->ts
.type
== BT_CHARACTER
)
2291 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2292 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2293 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2300 if (symbol_rank (sym
) == 0)
2304 if (sym
->as
->type
!= AS_EXPLICIT
)
2306 for (i
= 0; i
< sym
->as
->rank
; i
++)
2308 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2309 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2312 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2313 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2316 return strlen
*elements
;
2320 /* Returns the storage size of an expression (actual argument) or
2321 zero if it cannot be determined. For an array element, it returns
2322 the remaining size as the element sequence consists of all storage
2323 units of the actual argument up to the end of the array. */
2325 static unsigned long
2326 get_expr_storage_size (gfc_expr
*e
)
2329 long int strlen
, elements
;
2330 long int substrlen
= 0;
2331 bool is_str_storage
= false;
2337 if (e
->ts
.type
== BT_CHARACTER
)
2339 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2340 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2341 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2342 else if (e
->expr_type
== EXPR_CONSTANT
2343 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2344 strlen
= e
->value
.character
.length
;
2349 strlen
= 1; /* Length per element. */
2351 if (e
->rank
== 0 && !e
->ref
)
2359 for (i
= 0; i
< e
->rank
; i
++)
2360 elements
*= mpz_get_si (e
->shape
[i
]);
2361 return elements
*strlen
;
2364 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2366 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2367 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2371 /* The string length is the substring length.
2372 Set now to full string length. */
2373 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2374 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2377 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2379 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2383 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2384 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2386 long int start
, end
, stride
;
2389 if (ref
->u
.ar
.stride
[i
])
2391 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2392 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2397 if (ref
->u
.ar
.start
[i
])
2399 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2400 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2404 else if (ref
->u
.ar
.as
->lower
[i
]
2405 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2406 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2410 if (ref
->u
.ar
.end
[i
])
2412 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2413 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2417 else if (ref
->u
.ar
.as
->upper
[i
]
2418 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2419 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2423 elements
*= (end
- start
)/stride
+ 1L;
2425 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2426 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2428 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2429 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2430 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2431 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2432 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2437 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2438 && e
->expr_type
== EXPR_VARIABLE
)
2440 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2441 || e
->symtree
->n
.sym
->attr
.pointer
)
2447 /* Determine the number of remaining elements in the element
2448 sequence for array element designators. */
2449 is_str_storage
= true;
2450 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2452 if (ref
->u
.ar
.start
[i
] == NULL
2453 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2454 || ref
->u
.ar
.as
->upper
[i
] == NULL
2455 || ref
->u
.ar
.as
->lower
[i
] == NULL
2456 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2457 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2462 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2463 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2465 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2466 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2469 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2470 && ref
->u
.c
.component
->attr
.proc_pointer
2471 && ref
->u
.c
.component
->attr
.dimension
)
2473 /* Array-valued procedure-pointer components. */
2474 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2475 for (i
= 0; i
< as
->rank
; i
++)
2477 if (!as
->upper
[i
] || !as
->lower
[i
]
2478 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2479 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2483 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2484 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2490 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2493 return elements
*strlen
;
2497 /* Given an expression, check whether it is an array section
2498 which has a vector subscript. If it has, one is returned,
2502 gfc_has_vector_subscript (gfc_expr
*e
)
2507 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2510 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2511 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2512 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2513 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2521 is_procptr_result (gfc_expr
*expr
)
2523 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2525 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2527 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2528 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2532 /* Given formal and actual argument lists, see if they are compatible.
2533 If they are compatible, the actual argument list is sorted to
2534 correspond with the formal list, and elements for missing optional
2535 arguments are inserted. If WHERE pointer is nonnull, then we issue
2536 errors when things don't match instead of just returning the status
2540 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2541 int ranks_must_agree
, int is_elemental
, locus
*where
)
2543 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2544 gfc_formal_arglist
*f
;
2546 unsigned long actual_size
, formal_size
;
2547 bool full_array
= false;
2551 if (actual
== NULL
&& formal
== NULL
)
2555 for (f
= formal
; f
; f
= f
->next
)
2558 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2560 for (i
= 0; i
< n
; i
++)
2567 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2569 /* Look for keywords but ignore g77 extensions like %VAL. */
2570 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2573 for (f
= formal
; f
; f
= f
->next
, i
++)
2577 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2584 gfc_error ("Keyword argument %qs at %L is not in "
2585 "the procedure", a
->name
, &a
->expr
->where
);
2589 if (new_arg
[i
] != NULL
)
2592 gfc_error ("Keyword argument %qs at %L is already associated "
2593 "with another actual argument", a
->name
,
2602 gfc_error ("More actual than formal arguments in procedure "
2603 "call at %L", where
);
2608 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2614 gfc_error ("Missing alternate return spec in subroutine call "
2619 if (a
->expr
== NULL
)
2622 gfc_error ("Unexpected alternate return spec in subroutine "
2623 "call at %L", where
);
2627 /* Make sure that intrinsic vtables exist for calls to unlimited
2628 polymorphic formal arguments. */
2629 if (UNLIMITED_POLY (f
->sym
)
2630 && a
->expr
->ts
.type
!= BT_DERIVED
2631 && a
->expr
->ts
.type
!= BT_CLASS
)
2632 gfc_find_vtab (&a
->expr
->ts
);
2634 if (a
->expr
->expr_type
== EXPR_NULL
2635 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2636 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2637 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2638 || (f
->sym
->ts
.type
== BT_CLASS
2639 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2640 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2641 || !f
->sym
->attr
.optional
2642 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2645 && (!f
->sym
->attr
.optional
2646 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2647 || (f
->sym
->ts
.type
== BT_CLASS
2648 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2649 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2650 where
, f
->sym
->name
);
2652 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2653 "dummy %qs", where
, f
->sym
->name
);
2658 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2659 is_elemental
, where
))
2662 /* TS 29113, 6.3p2. */
2663 if (f
->sym
->ts
.type
== BT_ASSUMED
2664 && (a
->expr
->ts
.type
== BT_DERIVED
2665 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2667 gfc_namespace
*f2k_derived
;
2669 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2670 ? a
->expr
->ts
.u
.derived
->f2k_derived
2671 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2674 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2676 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2677 "derived type with type-bound or FINAL procedures",
2683 /* Special case for character arguments. For allocatable, pointer
2684 and assumed-shape dummies, the string length needs to match
2686 if (a
->expr
->ts
.type
== BT_CHARACTER
2687 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2688 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2689 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2690 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2691 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2692 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2693 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2694 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2696 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2697 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2698 "argument and pointer or allocatable dummy argument "
2700 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2701 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2702 f
->sym
->name
, &a
->expr
->where
);
2704 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2705 "argument and assumed-shape dummy argument %qs "
2707 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2708 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2709 f
->sym
->name
, &a
->expr
->where
);
2713 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2714 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2715 && a
->expr
->ts
.type
== BT_CHARACTER
)
2718 gfc_error ("Actual argument at %L to allocatable or "
2719 "pointer dummy argument %qs must have a deferred "
2720 "length type parameter if and only if the dummy has one",
2721 &a
->expr
->where
, f
->sym
->name
);
2725 if (f
->sym
->ts
.type
== BT_CLASS
)
2726 goto skip_size_check
;
2728 actual_size
= get_expr_storage_size (a
->expr
);
2729 formal_size
= get_sym_storage_size (f
->sym
);
2730 if (actual_size
!= 0 && actual_size
< formal_size
2731 && a
->expr
->ts
.type
!= BT_PROCEDURE
2732 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2734 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2735 gfc_warning ("Character length of actual argument shorter "
2736 "than of dummy argument %qs (%lu/%lu) at %L",
2737 f
->sym
->name
, actual_size
, formal_size
,
2740 gfc_warning ("Actual argument contains too few "
2741 "elements for dummy argument %qs (%lu/%lu) at %L",
2742 f
->sym
->name
, actual_size
, formal_size
,
2749 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2750 argument is provided for a procedure pointer formal argument. */
2751 if (f
->sym
->attr
.proc_pointer
2752 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2753 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2754 || gfc_is_proc_ptr_comp (a
->expr
)))
2755 || (a
->expr
->expr_type
== EXPR_FUNCTION
2756 && is_procptr_result (a
->expr
))))
2759 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2760 f
->sym
->name
, &a
->expr
->where
);
2764 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2765 provided for a procedure formal argument. */
2766 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2767 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2768 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2769 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2770 || gfc_is_proc_ptr_comp (a
->expr
)))
2771 || (a
->expr
->expr_type
== EXPR_FUNCTION
2772 && is_procptr_result (a
->expr
))))
2775 gfc_error ("Expected a procedure for argument %qs at %L",
2776 f
->sym
->name
, &a
->expr
->where
);
2780 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2781 && a
->expr
->expr_type
== EXPR_VARIABLE
2782 && a
->expr
->symtree
->n
.sym
->as
2783 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2784 && (a
->expr
->ref
== NULL
2785 || (a
->expr
->ref
->type
== REF_ARRAY
2786 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2789 gfc_error ("Actual argument for %qs cannot be an assumed-size"
2790 " array at %L", f
->sym
->name
, where
);
2794 if (a
->expr
->expr_type
!= EXPR_NULL
2795 && compare_pointer (f
->sym
, a
->expr
) == 0)
2798 gfc_error ("Actual argument for %qs must be a pointer at %L",
2799 f
->sym
->name
, &a
->expr
->where
);
2803 if (a
->expr
->expr_type
!= EXPR_NULL
2804 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2805 && compare_pointer (f
->sym
, a
->expr
) == 2)
2808 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2809 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
2814 /* Fortran 2008, C1242. */
2815 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2818 gfc_error ("Coindexed actual argument at %L to pointer "
2820 &a
->expr
->where
, f
->sym
->name
);
2824 /* Fortran 2008, 12.5.2.5 (no constraint). */
2825 if (a
->expr
->expr_type
== EXPR_VARIABLE
2826 && f
->sym
->attr
.intent
!= INTENT_IN
2827 && f
->sym
->attr
.allocatable
2828 && gfc_is_coindexed (a
->expr
))
2831 gfc_error ("Coindexed actual argument at %L to allocatable "
2832 "dummy %qs requires INTENT(IN)",
2833 &a
->expr
->where
, f
->sym
->name
);
2837 /* Fortran 2008, C1237. */
2838 if (a
->expr
->expr_type
== EXPR_VARIABLE
2839 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2840 && gfc_is_coindexed (a
->expr
)
2841 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2842 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2845 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2846 "%L requires that dummy %qs has neither "
2847 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2852 /* Fortran 2008, 12.5.2.4 (no constraint). */
2853 if (a
->expr
->expr_type
== EXPR_VARIABLE
2854 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2855 && gfc_is_coindexed (a
->expr
)
2856 && gfc_has_ultimate_allocatable (a
->expr
))
2859 gfc_error ("Coindexed actual argument at %L with allocatable "
2860 "ultimate component to dummy %qs requires either VALUE "
2861 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2865 if (f
->sym
->ts
.type
== BT_CLASS
2866 && CLASS_DATA (f
->sym
)->attr
.allocatable
2867 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2871 gfc_error ("Actual CLASS array argument for %qs must be a full "
2872 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2877 if (a
->expr
->expr_type
!= EXPR_NULL
2878 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2881 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
2882 f
->sym
->name
, &a
->expr
->where
);
2886 /* Check intent = OUT/INOUT for definable actual argument. */
2887 if ((f
->sym
->attr
.intent
== INTENT_OUT
2888 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2890 const char* context
= (where
2891 ? _("actual argument to INTENT = OUT/INOUT")
2894 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2895 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2896 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2897 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
2899 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
2903 if ((f
->sym
->attr
.intent
== INTENT_OUT
2904 || f
->sym
->attr
.intent
== INTENT_INOUT
2905 || f
->sym
->attr
.volatile_
2906 || f
->sym
->attr
.asynchronous
)
2907 && gfc_has_vector_subscript (a
->expr
))
2910 gfc_error ("Array-section actual argument with vector "
2911 "subscripts at %L is incompatible with INTENT(OUT), "
2912 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2913 "of the dummy argument %qs",
2914 &a
->expr
->where
, f
->sym
->name
);
2918 /* C1232 (R1221) For an actual argument which is an array section or
2919 an assumed-shape array, the dummy argument shall be an assumed-
2920 shape array, if the dummy argument has the VOLATILE attribute. */
2922 if (f
->sym
->attr
.volatile_
2923 && a
->expr
->symtree
->n
.sym
->as
2924 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2925 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2928 gfc_error ("Assumed-shape actual argument at %L is "
2929 "incompatible with the non-assumed-shape "
2930 "dummy argument %qs due to VOLATILE attribute",
2931 &a
->expr
->where
,f
->sym
->name
);
2935 if (f
->sym
->attr
.volatile_
2936 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2937 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2940 gfc_error ("Array-section actual argument at %L is "
2941 "incompatible with the non-assumed-shape "
2942 "dummy argument %qs due to VOLATILE attribute",
2943 &a
->expr
->where
,f
->sym
->name
);
2947 /* C1233 (R1221) For an actual argument which is a pointer array, the
2948 dummy argument shall be an assumed-shape or pointer array, if the
2949 dummy argument has the VOLATILE attribute. */
2951 if (f
->sym
->attr
.volatile_
2952 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2953 && a
->expr
->symtree
->n
.sym
->as
2955 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2956 || f
->sym
->attr
.pointer
)))
2959 gfc_error ("Pointer-array actual argument at %L requires "
2960 "an assumed-shape or pointer-array dummy "
2961 "argument %qs due to VOLATILE attribute",
2962 &a
->expr
->where
,f
->sym
->name
);
2973 /* Make sure missing actual arguments are optional. */
2975 for (f
= formal
; f
; f
= f
->next
, i
++)
2977 if (new_arg
[i
] != NULL
)
2982 gfc_error ("Missing alternate return spec in subroutine call "
2986 if (!f
->sym
->attr
.optional
)
2989 gfc_error ("Missing actual argument for argument %qs at %L",
2990 f
->sym
->name
, where
);
2995 /* The argument lists are compatible. We now relink a new actual
2996 argument list with null arguments in the right places. The head
2997 of the list remains the head. */
2998 for (i
= 0; i
< n
; i
++)
2999 if (new_arg
[i
] == NULL
)
3000 new_arg
[i
] = gfc_get_actual_arglist ();
3005 *new_arg
[0] = *actual
;
3009 new_arg
[0] = new_arg
[na
];
3013 for (i
= 0; i
< n
- 1; i
++)
3014 new_arg
[i
]->next
= new_arg
[i
+ 1];
3016 new_arg
[i
]->next
= NULL
;
3018 if (*ap
== NULL
&& n
> 0)
3021 /* Note the types of omitted optional arguments. */
3022 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3023 if (a
->expr
== NULL
&& a
->label
== NULL
)
3024 a
->missing_arg_type
= f
->sym
->ts
.type
;
3032 gfc_formal_arglist
*f
;
3033 gfc_actual_arglist
*a
;
3037 /* qsort comparison function for argument pairs, with the following
3039 - p->a->expr == NULL
3040 - p->a->expr->expr_type != EXPR_VARIABLE
3041 - growing p->a->expr->symbol. */
3044 pair_cmp (const void *p1
, const void *p2
)
3046 const gfc_actual_arglist
*a1
, *a2
;
3048 /* *p1 and *p2 are elements of the to-be-sorted array. */
3049 a1
= ((const argpair
*) p1
)->a
;
3050 a2
= ((const argpair
*) p2
)->a
;
3059 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3061 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3065 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3067 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3071 /* Given two expressions from some actual arguments, test whether they
3072 refer to the same expression. The analysis is conservative.
3073 Returning false will produce no warning. */
3076 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3078 const gfc_ref
*r1
, *r2
;
3081 || e1
->expr_type
!= EXPR_VARIABLE
3082 || e2
->expr_type
!= EXPR_VARIABLE
3083 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3086 /* TODO: improve comparison, see expr.c:show_ref(). */
3087 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3089 if (r1
->type
!= r2
->type
)
3094 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3096 /* TODO: At the moment, consider only full arrays;
3097 we could do better. */
3098 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3103 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3111 gfc_internal_error ("compare_actual_expr(): Bad component code");
3120 /* Given formal and actual argument lists that correspond to one
3121 another, check that identical actual arguments aren't not
3122 associated with some incompatible INTENTs. */
3125 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3127 sym_intent f1_intent
, f2_intent
;
3128 gfc_formal_arglist
*f1
;
3129 gfc_actual_arglist
*a1
;
3135 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3137 if (f1
== NULL
&& a1
== NULL
)
3139 if (f1
== NULL
|| a1
== NULL
)
3140 gfc_internal_error ("check_some_aliasing(): List mismatch");
3145 p
= XALLOCAVEC (argpair
, n
);
3147 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3153 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3155 for (i
= 0; i
< n
; i
++)
3158 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3159 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3161 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3162 for (j
= i
+ 1; j
< n
; j
++)
3164 /* Expected order after the sort. */
3165 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3166 gfc_internal_error ("check_some_aliasing(): corrupted data");
3168 /* Are the expression the same? */
3169 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3171 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3172 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3173 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3174 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3176 gfc_warning ("Same actual argument associated with INTENT(%s) "
3177 "argument %qs and INTENT(%s) argument %qs at %L",
3178 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3179 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3180 &p
[i
].a
->expr
->where
);
3190 /* Given formal and actual argument lists that correspond to one
3191 another, check that they are compatible in the sense that intents
3192 are not mismatched. */
3195 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3197 sym_intent f_intent
;
3199 for (;; f
= f
->next
, a
= a
->next
)
3203 if (f
== NULL
&& a
== NULL
)
3205 if (f
== NULL
|| a
== NULL
)
3206 gfc_internal_error ("check_intents(): List mismatch");
3208 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3209 && a
->expr
->value
.function
.isym
3210 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3211 expr
= a
->expr
->value
.function
.actual
->expr
;
3215 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3218 f_intent
= f
->sym
->attr
.intent
;
3220 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3222 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3223 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3224 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3226 gfc_error ("Procedure argument at %L is local to a PURE "
3227 "procedure and has the POINTER attribute",
3233 /* Fortran 2008, C1283. */
3234 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3236 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3238 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3239 "is passed to an INTENT(%s) argument",
3240 &expr
->where
, gfc_intent_string (f_intent
));
3244 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3245 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3246 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3248 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3249 "is passed to a POINTER dummy argument",
3255 /* F2008, Section 12.5.2.4. */
3256 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3257 && gfc_is_coindexed (expr
))
3259 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3260 "polymorphic dummy argument %qs",
3261 &expr
->where
, f
->sym
->name
);
3270 /* Check how a procedure is used against its interface. If all goes
3271 well, the actual argument list will also end up being properly
3275 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3277 gfc_formal_arglist
*dummy_args
;
3279 /* Warn about calls with an implicit interface. Special case
3280 for calling a ISO_C_BINDING because c_loc and c_funloc
3281 are pseudo-unknown. Additionally, warn about procedures not
3282 explicitly declared at all if requested. */
3283 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3285 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3287 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3291 if (warn_implicit_interface
)
3292 gfc_warning (OPT_Wimplicit_interface
,
3293 "Procedure %qs called with an implicit interface at %L",
3295 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3296 gfc_warning (OPT_Wimplicit_procedure
,
3297 "Procedure %qs called at %L is not explicitly declared",
3301 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3303 gfc_actual_arglist
*a
;
3305 if (sym
->attr
.pointer
)
3307 gfc_error ("The pointer object %qs at %L must have an explicit "
3308 "function interface or be declared as array",
3313 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3315 gfc_error ("The allocatable object %qs at %L must have an explicit "
3316 "function interface or be declared as array",
3321 if (sym
->attr
.allocatable
)
3323 gfc_error ("Allocatable function %qs at %L must have an explicit "
3324 "function interface", sym
->name
, where
);
3328 for (a
= *ap
; a
; a
= a
->next
)
3330 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3331 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3333 gfc_error ("Keyword argument requires explicit interface "
3334 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3338 /* TS 29113, 6.2. */
3339 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3340 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3342 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3343 "interface", a
->expr
->symtree
->n
.sym
->name
,
3348 /* F2008, C1303 and C1304. */
3350 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3351 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3352 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3353 || gfc_expr_attr (a
->expr
).lock_comp
))
3355 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3356 "component at %L requires an explicit interface for "
3357 "procedure %qs", &a
->expr
->where
, sym
->name
);
3361 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3362 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3364 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3368 /* TS 29113, C407b. */
3369 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3370 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3372 gfc_error ("Assumed-rank argument requires an explicit interface "
3373 "at %L", &a
->expr
->where
);
3381 dummy_args
= gfc_sym_get_dummy_args (sym
);
3383 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3386 if (!check_intents (dummy_args
, *ap
))
3390 check_some_aliasing (dummy_args
, *ap
);
3396 /* Check how a procedure pointer component is used against its interface.
3397 If all goes well, the actual argument list will also end up being properly
3398 sorted. Completely analogous to gfc_procedure_use. */
3401 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3403 /* Warn about calls with an implicit interface. Special case
3404 for calling a ISO_C_BINDING because c_loc and c_funloc
3405 are pseudo-unknown. */
3406 if (warn_implicit_interface
3407 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3408 && !comp
->attr
.is_iso_c
)
3409 gfc_warning (OPT_Wimplicit_interface
,
3410 "Procedure pointer component %qs called with an implicit "
3411 "interface at %L", comp
->name
, where
);
3413 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3415 gfc_actual_arglist
*a
;
3416 for (a
= *ap
; a
; a
= a
->next
)
3418 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3419 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3421 gfc_error ("Keyword argument requires explicit interface "
3422 "for procedure pointer component %qs at %L",
3423 comp
->name
, &a
->expr
->where
);
3431 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3432 comp
->attr
.elemental
, where
))
3435 check_intents (comp
->ts
.interface
->formal
, *ap
);
3437 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3441 /* Try if an actual argument list matches the formal list of a symbol,
3442 respecting the symbol's attributes like ELEMENTAL. This is used for
3443 GENERIC resolution. */
3446 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3448 gfc_formal_arglist
*dummy_args
;
3451 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3453 dummy_args
= gfc_sym_get_dummy_args (sym
);
3455 r
= !sym
->attr
.elemental
;
3456 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3458 check_intents (dummy_args
, *args
);
3460 check_some_aliasing (dummy_args
, *args
);
3468 /* Given an interface pointer and an actual argument list, search for
3469 a formal argument list that matches the actual. If found, returns
3470 a pointer to the symbol of the correct interface. Returns NULL if
3474 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3475 gfc_actual_arglist
**ap
)
3477 gfc_symbol
*elem_sym
= NULL
;
3478 gfc_symbol
*null_sym
= NULL
;
3479 locus null_expr_loc
;
3480 gfc_actual_arglist
*a
;
3481 bool has_null_arg
= false;
3483 for (a
= *ap
; a
; a
= a
->next
)
3484 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3485 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3487 has_null_arg
= true;
3488 null_expr_loc
= a
->expr
->where
;
3492 for (; intr
; intr
= intr
->next
)
3494 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3496 if (sub_flag
&& intr
->sym
->attr
.function
)
3498 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3501 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3503 if (has_null_arg
&& null_sym
)
3505 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3506 "between specific functions %s and %s",
3507 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3510 else if (has_null_arg
)
3512 null_sym
= intr
->sym
;
3516 /* Satisfy 12.4.4.1 such that an elemental match has lower
3517 weight than a non-elemental match. */
3518 if (intr
->sym
->attr
.elemental
)
3520 elem_sym
= intr
->sym
;
3530 return elem_sym
? elem_sym
: NULL
;
3534 /* Do a brute force recursive search for a symbol. */
3536 static gfc_symtree
*
3537 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3541 if (root
->n
.sym
== sym
)
3546 st
= find_symtree0 (root
->left
, sym
);
3547 if (root
->right
&& ! st
)
3548 st
= find_symtree0 (root
->right
, sym
);
3553 /* Find a symtree for a symbol. */
3556 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3561 /* First try to find it by name. */
3562 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3563 if (st
&& st
->n
.sym
== sym
)
3566 /* If it's been renamed, resort to a brute-force search. */
3567 /* TODO: avoid having to do this search. If the symbol doesn't exist
3568 in the symtree for the current namespace, it should probably be added. */
3569 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3571 st
= find_symtree0 (ns
->sym_root
, sym
);
3575 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3580 /* See if the arglist to an operator-call contains a derived-type argument
3581 with a matching type-bound operator. If so, return the matching specific
3582 procedure defined as operator-target as well as the base-object to use
3583 (which is the found derived-type argument with operator). The generic
3584 name, if any, is transmitted to the final expression via 'gname'. */
3586 static gfc_typebound_proc
*
3587 matching_typebound_op (gfc_expr
** tb_base
,
3588 gfc_actual_arglist
* args
,
3589 gfc_intrinsic_op op
, const char* uop
,
3590 const char ** gname
)
3592 gfc_actual_arglist
* base
;
3594 for (base
= args
; base
; base
= base
->next
)
3595 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3597 gfc_typebound_proc
* tb
;
3598 gfc_symbol
* derived
;
3601 while (base
->expr
->expr_type
== EXPR_OP
3602 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3603 base
->expr
= base
->expr
->value
.op
.op1
;
3605 if (base
->expr
->ts
.type
== BT_CLASS
)
3607 if (CLASS_DATA (base
->expr
) == NULL
3608 || !gfc_expr_attr (base
->expr
).class_ok
)
3610 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3613 derived
= base
->expr
->ts
.u
.derived
;
3615 if (op
== INTRINSIC_USER
)
3617 gfc_symtree
* tb_uop
;
3620 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3629 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3632 /* This means we hit a PRIVATE operator which is use-associated and
3633 should thus not be seen. */
3637 /* Look through the super-type hierarchy for a matching specific
3639 for (; tb
; tb
= tb
->overridden
)
3643 gcc_assert (tb
->is_generic
);
3644 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3647 gfc_actual_arglist
* argcopy
;
3650 gcc_assert (g
->specific
);
3651 if (g
->specific
->error
)
3654 target
= g
->specific
->u
.specific
->n
.sym
;
3656 /* Check if this arglist matches the formal. */
3657 argcopy
= gfc_copy_actual_arglist (args
);
3658 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3659 gfc_free_actual_arglist (argcopy
);
3661 /* Return if we found a match. */
3664 *tb_base
= base
->expr
;
3665 *gname
= g
->specific_st
->name
;
3676 /* For the 'actual arglist' of an operator call and a specific typebound
3677 procedure that has been found the target of a type-bound operator, build the
3678 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3679 type-bound procedures rather than resolving type-bound operators 'directly'
3680 so that we can reuse the existing logic. */
3683 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3684 gfc_expr
* base
, gfc_typebound_proc
* target
,
3687 e
->expr_type
= EXPR_COMPCALL
;
3688 e
->value
.compcall
.tbp
= target
;
3689 e
->value
.compcall
.name
= gname
? gname
: "$op";
3690 e
->value
.compcall
.actual
= actual
;
3691 e
->value
.compcall
.base_object
= base
;
3692 e
->value
.compcall
.ignore_pass
= 1;
3693 e
->value
.compcall
.assign
= 0;
3694 if (e
->ts
.type
== BT_UNKNOWN
3695 && target
->function
)
3697 if (target
->is_generic
)
3698 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3700 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3705 /* This subroutine is called when an expression is being resolved.
3706 The expression node in question is either a user defined operator
3707 or an intrinsic operator with arguments that aren't compatible
3708 with the operator. This subroutine builds an actual argument list
3709 corresponding to the operands, then searches for a compatible
3710 interface. If one is found, the expression node is replaced with
3711 the appropriate function call. We use the 'match' enum to specify
3712 whether a replacement has been made or not, or if an error occurred. */
3715 gfc_extend_expr (gfc_expr
*e
)
3717 gfc_actual_arglist
*actual
;
3726 actual
= gfc_get_actual_arglist ();
3727 actual
->expr
= e
->value
.op
.op1
;
3731 if (e
->value
.op
.op2
!= NULL
)
3733 actual
->next
= gfc_get_actual_arglist ();
3734 actual
->next
->expr
= e
->value
.op
.op2
;
3737 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3739 if (i
== INTRINSIC_USER
)
3741 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3743 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3747 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3754 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3756 /* Due to the distinction between '==' and '.eq.' and friends, one has
3757 to check if either is defined. */
3760 #define CHECK_OS_COMPARISON(comp) \
3761 case INTRINSIC_##comp: \
3762 case INTRINSIC_##comp##_OS: \
3763 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3765 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3767 CHECK_OS_COMPARISON(EQ
)
3768 CHECK_OS_COMPARISON(NE
)
3769 CHECK_OS_COMPARISON(GT
)
3770 CHECK_OS_COMPARISON(GE
)
3771 CHECK_OS_COMPARISON(LT
)
3772 CHECK_OS_COMPARISON(LE
)
3773 #undef CHECK_OS_COMPARISON
3776 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3784 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3785 found rather than just taking the first one and not checking further. */
3789 gfc_typebound_proc
* tbo
;
3792 /* See if we find a matching type-bound operator. */
3793 if (i
== INTRINSIC_USER
)
3794 tbo
= matching_typebound_op (&tb_base
, actual
,
3795 i
, e
->value
.op
.uop
->name
, &gname
);
3799 #define CHECK_OS_COMPARISON(comp) \
3800 case INTRINSIC_##comp: \
3801 case INTRINSIC_##comp##_OS: \
3802 tbo = matching_typebound_op (&tb_base, actual, \
3803 INTRINSIC_##comp, NULL, &gname); \
3805 tbo = matching_typebound_op (&tb_base, actual, \
3806 INTRINSIC_##comp##_OS, NULL, &gname); \
3808 CHECK_OS_COMPARISON(EQ
)
3809 CHECK_OS_COMPARISON(NE
)
3810 CHECK_OS_COMPARISON(GT
)
3811 CHECK_OS_COMPARISON(GE
)
3812 CHECK_OS_COMPARISON(LT
)
3813 CHECK_OS_COMPARISON(LE
)
3814 #undef CHECK_OS_COMPARISON
3817 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3821 /* If there is a matching typebound-operator, replace the expression with
3822 a call to it and succeed. */
3827 gcc_assert (tb_base
);
3828 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3830 result
= gfc_resolve_expr (e
);
3837 /* Don't use gfc_free_actual_arglist(). */
3838 free (actual
->next
);
3844 /* Change the expression node to a function call. */
3845 e
->expr_type
= EXPR_FUNCTION
;
3846 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3847 e
->value
.function
.actual
= actual
;
3848 e
->value
.function
.esym
= NULL
;
3849 e
->value
.function
.isym
= NULL
;
3850 e
->value
.function
.name
= NULL
;
3851 e
->user_operator
= 1;
3853 if (!gfc_resolve_expr (e
))
3860 /* Tries to replace an assignment code node with a subroutine call to the
3861 subroutine associated with the assignment operator. Return true if the node
3862 was replaced. On false, no error is generated. */
3865 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3867 gfc_actual_arglist
*actual
;
3868 gfc_expr
*lhs
, *rhs
, *tb_base
;
3869 gfc_symbol
*sym
= NULL
;
3870 const char *gname
= NULL
;
3871 gfc_typebound_proc
* tbo
;
3876 /* Don't allow an intrinsic assignment to be replaced. */
3877 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3878 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3879 && (lhs
->ts
.type
== rhs
->ts
.type
3880 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3883 actual
= gfc_get_actual_arglist ();
3886 actual
->next
= gfc_get_actual_arglist ();
3887 actual
->next
->expr
= rhs
;
3889 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3891 /* See if we find a matching type-bound assignment. */
3892 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
3897 /* Success: Replace the expression with a type-bound call. */
3898 gcc_assert (tb_base
);
3899 c
->expr1
= gfc_get_expr ();
3900 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3901 c
->expr1
->value
.compcall
.assign
= 1;
3902 c
->expr1
->where
= c
->loc
;
3904 c
->op
= EXEC_COMPCALL
;
3908 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
3909 for (; ns
; ns
= ns
->parent
)
3911 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3918 /* Success: Replace the assignment with the call. */
3919 c
->op
= EXEC_ASSIGN_CALL
;
3920 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3923 c
->ext
.actual
= actual
;
3927 /* Failure: No assignment procedure found. */
3928 free (actual
->next
);
3934 /* Make sure that the interface just parsed is not already present in
3935 the given interface list. Ambiguity isn't checked yet since module
3936 procedures can be present without interfaces. */
3939 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3943 for (ip
= base
; ip
; ip
= ip
->next
)
3945 if (ip
->sym
== new_sym
)
3947 gfc_error ("Entity %qs at %L is already present in the interface",
3948 new_sym
->name
, &loc
);
3957 /* Add a symbol to the current interface. */
3960 gfc_add_interface (gfc_symbol
*new_sym
)
3962 gfc_interface
**head
, *intr
;
3966 switch (current_interface
.type
)
3968 case INTERFACE_NAMELESS
:
3969 case INTERFACE_ABSTRACT
:
3972 case INTERFACE_INTRINSIC_OP
:
3973 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3974 switch (current_interface
.op
)
3977 case INTRINSIC_EQ_OS
:
3978 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3980 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
3981 new_sym
, gfc_current_locus
))
3986 case INTRINSIC_NE_OS
:
3987 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3989 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
3990 new_sym
, gfc_current_locus
))
3995 case INTRINSIC_GT_OS
:
3996 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
3997 new_sym
, gfc_current_locus
)
3998 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
3999 new_sym
, gfc_current_locus
))
4004 case INTRINSIC_GE_OS
:
4005 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4006 new_sym
, gfc_current_locus
)
4007 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4008 new_sym
, gfc_current_locus
))
4013 case INTRINSIC_LT_OS
:
4014 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4015 new_sym
, gfc_current_locus
)
4016 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4017 new_sym
, gfc_current_locus
))
4022 case INTRINSIC_LE_OS
:
4023 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4024 new_sym
, gfc_current_locus
)
4025 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4026 new_sym
, gfc_current_locus
))
4031 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4032 new_sym
, gfc_current_locus
))
4036 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4039 case INTERFACE_GENERIC
:
4040 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4042 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4046 if (!gfc_check_new_interface (sym
->generic
,
4047 new_sym
, gfc_current_locus
))
4051 head
= ¤t_interface
.sym
->generic
;
4054 case INTERFACE_USER_OP
:
4055 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4056 new_sym
, gfc_current_locus
))
4059 head
= ¤t_interface
.uop
->op
;
4063 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4066 intr
= gfc_get_interface ();
4067 intr
->sym
= new_sym
;
4068 intr
->where
= gfc_current_locus
;
4078 gfc_current_interface_head (void)
4080 switch (current_interface
.type
)
4082 case INTERFACE_INTRINSIC_OP
:
4083 return current_interface
.ns
->op
[current_interface
.op
];
4086 case INTERFACE_GENERIC
:
4087 return current_interface
.sym
->generic
;
4090 case INTERFACE_USER_OP
:
4091 return current_interface
.uop
->op
;
4101 gfc_set_current_interface_head (gfc_interface
*i
)
4103 switch (current_interface
.type
)
4105 case INTERFACE_INTRINSIC_OP
:
4106 current_interface
.ns
->op
[current_interface
.op
] = i
;
4109 case INTERFACE_GENERIC
:
4110 current_interface
.sym
->generic
= i
;
4113 case INTERFACE_USER_OP
:
4114 current_interface
.uop
->op
= i
;
4123 /* Gets rid of a formal argument list. We do not free symbols.
4124 Symbols are freed when a namespace is freed. */
4127 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4129 gfc_formal_arglist
*q
;
4139 /* Check that it is ok for the type-bound procedure 'proc' to override the
4140 procedure 'old', cf. F08:4.5.7.3. */
4143 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4146 gfc_symbol
*proc_target
, *old_target
;
4147 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4148 gfc_formal_arglist
*proc_formal
, *old_formal
;
4152 /* This procedure should only be called for non-GENERIC proc. */
4153 gcc_assert (!proc
->n
.tb
->is_generic
);
4155 /* If the overwritten procedure is GENERIC, this is an error. */
4156 if (old
->n
.tb
->is_generic
)
4158 gfc_error ("Can't overwrite GENERIC %qs at %L",
4159 old
->name
, &proc
->n
.tb
->where
);
4163 where
= proc
->n
.tb
->where
;
4164 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4165 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4167 /* Check that overridden binding is not NON_OVERRIDABLE. */
4168 if (old
->n
.tb
->non_overridable
)
4170 gfc_error ("%qs at %L overrides a procedure binding declared"
4171 " NON_OVERRIDABLE", proc
->name
, &where
);
4175 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4176 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4178 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4179 " non-DEFERRED binding", proc
->name
, &where
);
4183 /* If the overridden binding is PURE, the overriding must be, too. */
4184 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4186 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4187 proc
->name
, &where
);
4191 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4192 is not, the overriding must not be either. */
4193 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4195 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4196 " ELEMENTAL", proc
->name
, &where
);
4199 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4201 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4202 " be ELEMENTAL, either", proc
->name
, &where
);
4206 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4208 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4210 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4211 " SUBROUTINE", proc
->name
, &where
);
4215 /* If the overridden binding is a FUNCTION, the overriding must also be a
4216 FUNCTION and have the same characteristics. */
4217 if (old_target
->attr
.function
)
4219 if (!proc_target
->attr
.function
)
4221 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4222 " FUNCTION", proc
->name
, &where
);
4226 if (!check_result_characteristics (proc_target
, old_target
, err
,
4229 gfc_error ("Result mismatch for the overriding procedure "
4230 "%qs at %L: %s", proc
->name
, &where
, err
);
4235 /* If the overridden binding is PUBLIC, the overriding one must not be
4237 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4238 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4240 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4241 " PRIVATE", proc
->name
, &where
);
4245 /* Compare the formal argument lists of both procedures. This is also abused
4246 to find the position of the passed-object dummy arguments of both
4247 bindings as at least the overridden one might not yet be resolved and we
4248 need those positions in the check below. */
4249 proc_pass_arg
= old_pass_arg
= 0;
4250 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4252 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4255 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4256 old_formal
= gfc_sym_get_dummy_args (old_target
);
4257 for ( ; proc_formal
&& old_formal
;
4258 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4260 if (proc
->n
.tb
->pass_arg
4261 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4262 proc_pass_arg
= argpos
;
4263 if (old
->n
.tb
->pass_arg
4264 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4265 old_pass_arg
= argpos
;
4267 /* Check that the names correspond. */
4268 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4270 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4271 " to match the corresponding argument of the overridden"
4272 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4273 old_formal
->sym
->name
);
4277 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4278 if (!check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4279 check_type
, err
, sizeof(err
)))
4281 gfc_error ("Argument mismatch for the overriding procedure "
4282 "%qs at %L: %s", proc
->name
, &where
, err
);
4288 if (proc_formal
|| old_formal
)
4290 gfc_error ("%qs at %L must have the same number of formal arguments as"
4291 " the overridden procedure", proc
->name
, &where
);
4295 /* If the overridden binding is NOPASS, the overriding one must also be
4297 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4299 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4300 " NOPASS", proc
->name
, &where
);
4304 /* If the overridden binding is PASS(x), the overriding one must also be
4305 PASS and the passed-object dummy arguments must correspond. */
4306 if (!old
->n
.tb
->nopass
)
4308 if (proc
->n
.tb
->nopass
)
4310 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4311 " PASS", proc
->name
, &where
);
4315 if (proc_pass_arg
!= old_pass_arg
)
4317 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4318 " the same position as the passed-object dummy argument of"
4319 " the overridden procedure", proc
->name
, &where
);