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 (0, "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
->corank
!= s2
->as
->corank
)
1210 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1211 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1215 if (s1
->as
->type
== AS_EXPLICIT
)
1216 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1218 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1219 gfc_copy_expr (s1
->as
->lower
[i
]));
1220 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1221 gfc_copy_expr (s2
->as
->lower
[i
]));
1222 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1223 gfc_free_expr (shape1
);
1224 gfc_free_expr (shape2
);
1230 if (i
< s1
->as
->rank
)
1231 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1232 " argument '%s'", i
+ 1, s1
->name
);
1234 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1235 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1239 /* FIXME: Implement a warning for this case.
1240 gfc_warning (0, "Possible shape mismatch in argument %qs",
1248 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1249 "result %i of gfc_dep_compare_expr",
1260 /* Check if the characteristics of two function results match,
1264 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1265 char *errmsg
, int err_len
)
1267 gfc_symbol
*r1
, *r2
;
1269 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1270 r1
= s1
->ts
.interface
->result
;
1272 r1
= s1
->result
? s1
->result
: s1
;
1274 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1275 r2
= s2
->ts
.interface
->result
;
1277 r2
= s2
->result
? s2
->result
: s2
;
1279 if (r1
->ts
.type
== BT_UNKNOWN
)
1282 /* Check type and rank. */
1283 if (!compare_type (r1
, r2
))
1285 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1286 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1289 if (!compare_rank (r1
, r2
))
1291 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1292 symbol_rank (r1
), symbol_rank (r2
));
1296 /* Check ALLOCATABLE attribute. */
1297 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1299 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1304 /* Check POINTER attribute. */
1305 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1307 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1312 /* Check CONTIGUOUS attribute. */
1313 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1315 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1320 /* Check PROCEDURE POINTER attribute. */
1321 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1323 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1328 /* Check string length. */
1329 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1331 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1333 snprintf (errmsg
, err_len
, "Character length mismatch "
1334 "in function result");
1338 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1340 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1341 r2
->ts
.u
.cl
->length
);
1347 snprintf (errmsg
, err_len
, "Character length mismatch "
1348 "in function result");
1352 /* FIXME: Implement a warning for this case.
1353 snprintf (errmsg, err_len, "Possible character length mismatch "
1354 "in function result");*/
1361 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1362 "result %i of gfc_dep_compare_expr", compval
);
1368 /* Check array shape. */
1369 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1372 gfc_expr
*shape1
, *shape2
;
1374 if (r1
->as
->type
!= r2
->as
->type
)
1376 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1380 if (r1
->as
->type
== AS_EXPLICIT
)
1381 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1383 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1384 gfc_copy_expr (r1
->as
->lower
[i
]));
1385 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1386 gfc_copy_expr (r2
->as
->lower
[i
]));
1387 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1388 gfc_free_expr (shape1
);
1389 gfc_free_expr (shape2
);
1395 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1396 "function result", i
+ 1);
1400 /* FIXME: Implement a warning for this case.
1401 gfc_warning (0, "Possible shape mismatch in return value");*/
1408 gfc_internal_error ("check_result_characteristics (2): "
1409 "Unexpected result %i of "
1410 "gfc_dep_compare_expr", compval
);
1420 /* 'Compare' two formal interfaces associated with a pair of symbols.
1421 We return nonzero if there exists an actual argument list that
1422 would be ambiguous between the two interfaces, zero otherwise.
1423 'strict_flag' specifies whether all the characteristics are
1424 required to match, which is not the case for ambiguity checks.
1425 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1428 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1429 int generic_flag
, int strict_flag
,
1430 char *errmsg
, int err_len
,
1431 const char *p1
, const char *p2
)
1433 gfc_formal_arglist
*f1
, *f2
;
1435 gcc_assert (name2
!= NULL
);
1437 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1438 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1439 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1442 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1446 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1449 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1453 /* Do strict checks on all characteristics
1454 (for dummy procedures and procedure pointer assignments). */
1455 if (!generic_flag
&& strict_flag
)
1457 if (s1
->attr
.function
&& s2
->attr
.function
)
1459 /* If both are functions, check result characteristics. */
1460 if (!check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1461 || !check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1465 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1467 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1470 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1472 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1477 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1478 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1481 f1
= gfc_sym_get_dummy_args (s1
);
1482 f2
= gfc_sym_get_dummy_args (s2
);
1484 if (f1
== NULL
&& f2
== NULL
)
1485 return 1; /* Special case: No arguments. */
1489 if (count_types_test (f1
, f2
, p1
, p2
)
1490 || count_types_test (f2
, f1
, p2
, p1
))
1492 if (generic_correspondence (f1
, f2
, p1
, p2
)
1493 || generic_correspondence (f2
, f1
, p2
, p1
))
1497 /* Perform the abbreviated correspondence test for operators (the
1498 arguments cannot be optional and are always ordered correctly).
1499 This is also done when comparing interfaces for dummy procedures and in
1500 procedure pointer assignments. */
1504 /* Check existence. */
1505 if (f1
== NULL
&& f2
== NULL
)
1507 if (f1
== NULL
|| f2
== NULL
)
1510 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1511 "arguments", name2
);
1515 if (UNLIMITED_POLY (f1
->sym
))
1520 /* Check all characteristics. */
1521 if (!check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1527 /* Only check type and rank. */
1528 if (!compare_type (f2
->sym
, f1
->sym
))
1531 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1532 "(%s/%s)", f1
->sym
->name
,
1533 gfc_typename (&f1
->sym
->ts
),
1534 gfc_typename (&f2
->sym
->ts
));
1537 if (!compare_rank (f2
->sym
, f1
->sym
))
1540 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1541 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1542 symbol_rank (f2
->sym
));
1555 /* Given a pointer to an interface pointer, remove duplicate
1556 interfaces and make sure that all symbols are either functions
1557 or subroutines, and all of the same kind. Returns nonzero if
1558 something goes wrong. */
1561 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1563 gfc_interface
*psave
, *q
, *qlast
;
1566 for (; p
; p
= p
->next
)
1568 /* Make sure all symbols in the interface have been defined as
1569 functions or subroutines. */
1570 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1571 || !p
->sym
->attr
.if_source
)
1572 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1574 if (p
->sym
->attr
.external
)
1575 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1576 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1578 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1579 "subroutine", p
->sym
->name
, interface_name
,
1580 &p
->sym
->declared_at
);
1584 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1585 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1586 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1587 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1589 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1590 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1591 " or all FUNCTIONs", interface_name
,
1592 &p
->sym
->declared_at
);
1594 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1595 "generic name is also the name of a derived type",
1596 interface_name
, &p
->sym
->declared_at
);
1600 /* F2003, C1207. F2008, C1207. */
1601 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1602 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1603 "%qs in %s at %L", p
->sym
->name
,
1604 interface_name
, &p
->sym
->declared_at
))
1609 /* Remove duplicate interfaces in this interface list. */
1610 for (; p
; p
= p
->next
)
1614 for (q
= p
->next
; q
;)
1616 if (p
->sym
!= q
->sym
)
1623 /* Duplicate interface. */
1624 qlast
->next
= q
->next
;
1635 /* Check lists of interfaces to make sure that no two interfaces are
1636 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1639 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1640 int generic_flag
, const char *interface_name
,
1644 for (; p
; p
= p
->next
)
1645 for (q
= q0
; q
; q
= q
->next
)
1647 if (p
->sym
== q
->sym
)
1648 continue; /* Duplicates OK here. */
1650 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1653 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1654 && q
->sym
->attr
.flavor
!= FL_DERIVED
1655 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1656 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1659 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1660 p
->sym
->name
, q
->sym
->name
, interface_name
,
1662 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1663 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
1664 p
->sym
->name
, q
->sym
->name
, interface_name
,
1667 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1668 "interfaces at %L", interface_name
, &p
->where
);
1676 /* Check the generic and operator interfaces of symbols to make sure
1677 that none of the interfaces conflict. The check has to be done
1678 after all of the symbols are actually loaded. */
1681 check_sym_interfaces (gfc_symbol
*sym
)
1683 char interface_name
[100];
1686 if (sym
->ns
!= gfc_current_ns
)
1689 if (sym
->generic
!= NULL
)
1691 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1692 if (check_interface0 (sym
->generic
, interface_name
))
1695 for (p
= sym
->generic
; p
; p
= p
->next
)
1697 if (p
->sym
->attr
.mod_proc
1698 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1699 || p
->sym
->attr
.procedure
))
1701 gfc_error ("%qs at %L is not a module procedure",
1702 p
->sym
->name
, &p
->where
);
1707 /* Originally, this test was applied to host interfaces too;
1708 this is incorrect since host associated symbols, from any
1709 source, cannot be ambiguous with local symbols. */
1710 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1711 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1717 check_uop_interfaces (gfc_user_op
*uop
)
1719 char interface_name
[100];
1723 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1724 if (check_interface0 (uop
->op
, interface_name
))
1727 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1729 uop2
= gfc_find_uop (uop
->name
, ns
);
1733 check_interface1 (uop
->op
, uop2
->op
, 0,
1734 interface_name
, true);
1738 /* Given an intrinsic op, return an equivalent op if one exists,
1739 or INTRINSIC_NONE otherwise. */
1742 gfc_equivalent_op (gfc_intrinsic_op op
)
1747 return INTRINSIC_EQ_OS
;
1749 case INTRINSIC_EQ_OS
:
1750 return INTRINSIC_EQ
;
1753 return INTRINSIC_NE_OS
;
1755 case INTRINSIC_NE_OS
:
1756 return INTRINSIC_NE
;
1759 return INTRINSIC_GT_OS
;
1761 case INTRINSIC_GT_OS
:
1762 return INTRINSIC_GT
;
1765 return INTRINSIC_GE_OS
;
1767 case INTRINSIC_GE_OS
:
1768 return INTRINSIC_GE
;
1771 return INTRINSIC_LT_OS
;
1773 case INTRINSIC_LT_OS
:
1774 return INTRINSIC_LT
;
1777 return INTRINSIC_LE_OS
;
1779 case INTRINSIC_LE_OS
:
1780 return INTRINSIC_LE
;
1783 return INTRINSIC_NONE
;
1787 /* For the namespace, check generic, user operator and intrinsic
1788 operator interfaces for consistency and to remove duplicate
1789 interfaces. We traverse the whole namespace, counting on the fact
1790 that most symbols will not have generic or operator interfaces. */
1793 gfc_check_interfaces (gfc_namespace
*ns
)
1795 gfc_namespace
*old_ns
, *ns2
;
1796 char interface_name
[100];
1799 old_ns
= gfc_current_ns
;
1800 gfc_current_ns
= ns
;
1802 gfc_traverse_ns (ns
, check_sym_interfaces
);
1804 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1806 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1808 if (i
== INTRINSIC_USER
)
1811 if (i
== INTRINSIC_ASSIGN
)
1812 strcpy (interface_name
, "intrinsic assignment operator");
1814 sprintf (interface_name
, "intrinsic '%s' operator",
1815 gfc_op2string ((gfc_intrinsic_op
) i
));
1817 if (check_interface0 (ns
->op
[i
], interface_name
))
1821 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1824 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1826 gfc_intrinsic_op other_op
;
1828 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1829 interface_name
, true))
1832 /* i should be gfc_intrinsic_op, but has to be int with this cast
1833 here for stupid C++ compatibility rules. */
1834 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1835 if (other_op
!= INTRINSIC_NONE
1836 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1837 0, interface_name
, true))
1843 gfc_current_ns
= old_ns
;
1847 /* Given a symbol of a formal argument list and an expression, if the
1848 formal argument is allocatable, check that the actual argument is
1849 allocatable. Returns nonzero if compatible, zero if not compatible. */
1852 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1854 symbol_attribute attr
;
1856 if (formal
->attr
.allocatable
1857 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1859 attr
= gfc_expr_attr (actual
);
1860 if (!attr
.allocatable
)
1868 /* Given a symbol of a formal argument list and an expression, if the
1869 formal argument is a pointer, see if the actual argument is a
1870 pointer. Returns nonzero if compatible, zero if not compatible. */
1873 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1875 symbol_attribute attr
;
1877 if (formal
->attr
.pointer
1878 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1879 && CLASS_DATA (formal
)->attr
.class_pointer
))
1881 attr
= gfc_expr_attr (actual
);
1883 /* Fortran 2008 allows non-pointer actual arguments. */
1884 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1895 /* Emit clear error messages for rank mismatch. */
1898 argument_rank_mismatch (const char *name
, locus
*where
,
1899 int rank1
, int rank2
)
1902 /* TS 29113, C407b. */
1905 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1906 " %qs has assumed-rank", where
, name
);
1908 else if (rank1
== 0)
1910 gfc_error ("Rank mismatch in argument %qs at %L "
1911 "(scalar and rank-%d)", name
, where
, rank2
);
1913 else if (rank2
== 0)
1915 gfc_error ("Rank mismatch in argument %qs at %L "
1916 "(rank-%d and scalar)", name
, where
, rank1
);
1920 gfc_error ("Rank mismatch in argument %qs at %L "
1921 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1926 /* Given a symbol of a formal argument list and an expression, see if
1927 the two are compatible as arguments. Returns nonzero if
1928 compatible, zero if not compatible. */
1931 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1932 int ranks_must_agree
, int is_elemental
, locus
*where
)
1935 bool rank_check
, is_pointer
;
1939 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1940 procs c_f_pointer or c_f_procpointer, and we need to accept most
1941 pointers the user could give us. This should allow that. */
1942 if (formal
->ts
.type
== BT_VOID
)
1945 if (formal
->ts
.type
== BT_DERIVED
1946 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1947 && actual
->ts
.type
== BT_DERIVED
1948 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1951 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1952 /* Make sure the vtab symbol is present when
1953 the module variables are generated. */
1954 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1956 if (actual
->ts
.type
== BT_PROCEDURE
)
1958 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1960 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1963 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1967 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1968 sizeof(err
), NULL
, NULL
))
1971 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
1972 formal
->name
, &actual
->where
, err
);
1976 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1978 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1979 &act_sym
->declared_at
);
1980 if (act_sym
->ts
.type
== BT_UNKNOWN
1981 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
1984 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1985 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1986 &act_sym
->declared_at
);
1991 ppc
= gfc_get_proc_ptr_comp (actual
);
1994 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
1995 err
, sizeof(err
), NULL
, NULL
))
1998 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
1999 formal
->name
, &actual
->where
, err
);
2005 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2006 && !gfc_is_simply_contiguous (actual
, true))
2009 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2010 "must be simply contiguous", formal
->name
, &actual
->where
);
2014 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2015 && actual
->ts
.type
!= BT_HOLLERITH
2016 && formal
->ts
.type
!= BT_ASSUMED
2017 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2018 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2019 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2020 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2021 CLASS_DATA (actual
)->ts
.u
.derived
)))
2024 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2025 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
2026 gfc_typename (&formal
->ts
));
2030 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2033 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2034 "argument %qs is of assumed type", &actual
->where
,
2039 /* F2008, 12.5.2.5; IR F08/0073. */
2040 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2041 && actual
->expr_type
!= EXPR_NULL
2042 && ((CLASS_DATA (formal
)->attr
.class_pointer
2043 && formal
->attr
.intent
!= INTENT_IN
)
2044 || CLASS_DATA (formal
)->attr
.allocatable
))
2046 if (actual
->ts
.type
!= BT_CLASS
)
2049 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2050 formal
->name
, &actual
->where
);
2054 if (!gfc_expr_attr (actual
).class_ok
)
2057 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2058 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2059 CLASS_DATA (formal
)->ts
.u
.derived
))
2062 gfc_error ("Actual argument to %qs at %L must have the same "
2063 "declared type", formal
->name
, &actual
->where
);
2068 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2069 is necessary also for F03, so retain error for both.
2070 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2071 compatible, no attempt has been made to channel to this one. */
2072 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2073 && (CLASS_DATA (formal
)->attr
.allocatable
2074 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2077 gfc_error ("Actual argument to %qs at %L must be unlimited "
2078 "polymorphic since the formal argument is a "
2079 "pointer or allocatable unlimited polymorphic "
2080 "entity [F2008: 12.5.2.5]", formal
->name
,
2085 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2088 gfc_error ("Actual argument to %qs at %L must be a coarray",
2089 formal
->name
, &actual
->where
);
2093 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2095 gfc_ref
*last
= NULL
;
2097 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2098 if (ref
->type
== REF_COMPONENT
)
2101 /* F2008, 12.5.2.6. */
2102 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2104 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2107 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2108 formal
->name
, &actual
->where
, formal
->as
->corank
,
2109 last
? last
->u
.c
.component
->as
->corank
2110 : actual
->symtree
->n
.sym
->as
->corank
);
2115 if (formal
->attr
.codimension
)
2117 /* F2008, 12.5.2.8. */
2118 if (formal
->attr
.dimension
2119 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2120 && gfc_expr_attr (actual
).dimension
2121 && !gfc_is_simply_contiguous (actual
, true))
2124 gfc_error ("Actual argument to %qs at %L must be simply "
2125 "contiguous", formal
->name
, &actual
->where
);
2129 /* F2008, C1303 and C1304. */
2130 if (formal
->attr
.intent
!= INTENT_INOUT
2131 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2132 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2133 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2134 || formal
->attr
.lock_comp
))
2138 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2139 "which is LOCK_TYPE or has a LOCK_TYPE component",
2140 formal
->name
, &actual
->where
);
2145 /* F2008, C1239/C1240. */
2146 if (actual
->expr_type
== EXPR_VARIABLE
2147 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2148 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2149 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2150 && actual
->rank
&& formal
->as
&& !gfc_is_simply_contiguous (actual
, true)
2151 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2152 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2153 || formal
->attr
.contiguous
))
2156 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2157 "assumed-rank array without CONTIGUOUS attribute - as actual"
2158 " argument at %L is not simply contiguous and both are "
2159 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2163 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2164 && gfc_expr_attr (actual
).codimension
)
2166 if (formal
->attr
.intent
== INTENT_OUT
)
2169 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2170 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2174 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2175 gfc_warning (OPT_Wsurprising
,
2176 "Passing coarray at %L to allocatable, noncoarray dummy "
2177 "argument %qs, which is invalid if the allocation status"
2178 " is modified", &actual
->where
, formal
->name
);
2181 /* If the rank is the same or the formal argument has assumed-rank. */
2182 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2185 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2186 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2187 || formal
->as
->type
== AS_DEFERRED
)
2188 && actual
->expr_type
!= EXPR_NULL
;
2190 /* Skip rank checks for NO_ARG_CHECK. */
2191 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2194 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2195 if (rank_check
|| ranks_must_agree
2196 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2197 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2198 || (actual
->rank
== 0
2199 && ((formal
->ts
.type
== BT_CLASS
2200 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2201 || (formal
->ts
.type
!= BT_CLASS
2202 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2203 && actual
->expr_type
!= EXPR_NULL
)
2204 || (actual
->rank
== 0 && formal
->attr
.dimension
2205 && gfc_is_coindexed (actual
)))
2208 argument_rank_mismatch (formal
->name
, &actual
->where
,
2209 symbol_rank (formal
), actual
->rank
);
2212 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2215 /* At this point, we are considering a scalar passed to an array. This
2216 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2217 - if the actual argument is (a substring of) an element of a
2218 non-assumed-shape/non-pointer/non-polymorphic array; or
2219 - (F2003) if the actual argument is of type character of default/c_char
2222 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2223 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2225 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2227 if (ref
->type
== REF_COMPONENT
)
2228 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2229 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2230 && ref
->u
.ar
.dimen
> 0
2232 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2236 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2239 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2240 "at %L", formal
->name
, &actual
->where
);
2244 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2245 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2248 gfc_error ("Element of assumed-shaped or pointer "
2249 "array passed to array dummy argument %qs at %L",
2250 formal
->name
, &actual
->where
);
2254 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2255 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2257 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2260 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2261 "CHARACTER actual argument with array dummy argument "
2262 "%qs at %L", formal
->name
, &actual
->where
);
2266 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2268 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2269 "array dummy argument %qs at %L",
2270 formal
->name
, &actual
->where
);
2273 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2279 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2282 argument_rank_mismatch (formal
->name
, &actual
->where
,
2283 symbol_rank (formal
), actual
->rank
);
2291 /* Returns the storage size of a symbol (formal argument) or
2292 zero if it cannot be determined. */
2294 static unsigned long
2295 get_sym_storage_size (gfc_symbol
*sym
)
2298 unsigned long strlen
, elements
;
2300 if (sym
->ts
.type
== BT_CHARACTER
)
2302 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2303 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2304 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2311 if (symbol_rank (sym
) == 0)
2315 if (sym
->as
->type
!= AS_EXPLICIT
)
2317 for (i
= 0; i
< sym
->as
->rank
; i
++)
2319 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2320 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2323 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2324 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2327 return strlen
*elements
;
2331 /* Returns the storage size of an expression (actual argument) or
2332 zero if it cannot be determined. For an array element, it returns
2333 the remaining size as the element sequence consists of all storage
2334 units of the actual argument up to the end of the array. */
2336 static unsigned long
2337 get_expr_storage_size (gfc_expr
*e
)
2340 long int strlen
, elements
;
2341 long int substrlen
= 0;
2342 bool is_str_storage
= false;
2348 if (e
->ts
.type
== BT_CHARACTER
)
2350 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2351 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2352 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2353 else if (e
->expr_type
== EXPR_CONSTANT
2354 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2355 strlen
= e
->value
.character
.length
;
2360 strlen
= 1; /* Length per element. */
2362 if (e
->rank
== 0 && !e
->ref
)
2370 for (i
= 0; i
< e
->rank
; i
++)
2371 elements
*= mpz_get_si (e
->shape
[i
]);
2372 return elements
*strlen
;
2375 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2377 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2378 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2382 /* The string length is the substring length.
2383 Set now to full string length. */
2384 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2385 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2388 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2390 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2394 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2395 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2397 long int start
, end
, stride
;
2400 if (ref
->u
.ar
.stride
[i
])
2402 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2403 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2408 if (ref
->u
.ar
.start
[i
])
2410 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2411 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2415 else if (ref
->u
.ar
.as
->lower
[i
]
2416 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2417 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2421 if (ref
->u
.ar
.end
[i
])
2423 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2424 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2428 else if (ref
->u
.ar
.as
->upper
[i
]
2429 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2430 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2434 elements
*= (end
- start
)/stride
+ 1L;
2436 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2437 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2439 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2440 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2441 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2442 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2443 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2448 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2449 && e
->expr_type
== EXPR_VARIABLE
)
2451 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2452 || e
->symtree
->n
.sym
->attr
.pointer
)
2458 /* Determine the number of remaining elements in the element
2459 sequence for array element designators. */
2460 is_str_storage
= true;
2461 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2463 if (ref
->u
.ar
.start
[i
] == NULL
2464 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2465 || ref
->u
.ar
.as
->upper
[i
] == NULL
2466 || ref
->u
.ar
.as
->lower
[i
] == NULL
2467 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2468 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2473 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2474 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2476 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2477 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2480 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2481 && ref
->u
.c
.component
->attr
.proc_pointer
2482 && ref
->u
.c
.component
->attr
.dimension
)
2484 /* Array-valued procedure-pointer components. */
2485 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2486 for (i
= 0; i
< as
->rank
; i
++)
2488 if (!as
->upper
[i
] || !as
->lower
[i
]
2489 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2490 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2494 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2495 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2501 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2504 return elements
*strlen
;
2508 /* Given an expression, check whether it is an array section
2509 which has a vector subscript. If it has, one is returned,
2513 gfc_has_vector_subscript (gfc_expr
*e
)
2518 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2521 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2522 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2523 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2524 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2532 is_procptr_result (gfc_expr
*expr
)
2534 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2536 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2538 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2539 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2543 /* Given formal and actual argument lists, see if they are compatible.
2544 If they are compatible, the actual argument list is sorted to
2545 correspond with the formal list, and elements for missing optional
2546 arguments are inserted. If WHERE pointer is nonnull, then we issue
2547 errors when things don't match instead of just returning the status
2551 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2552 int ranks_must_agree
, int is_elemental
, locus
*where
)
2554 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2555 gfc_formal_arglist
*f
;
2557 unsigned long actual_size
, formal_size
;
2558 bool full_array
= false;
2562 if (actual
== NULL
&& formal
== NULL
)
2566 for (f
= formal
; f
; f
= f
->next
)
2569 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2571 for (i
= 0; i
< n
; i
++)
2578 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2580 /* Look for keywords but ignore g77 extensions like %VAL. */
2581 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2584 for (f
= formal
; f
; f
= f
->next
, i
++)
2588 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2595 gfc_error ("Keyword argument %qs at %L is not in "
2596 "the procedure", a
->name
, &a
->expr
->where
);
2600 if (new_arg
[i
] != NULL
)
2603 gfc_error ("Keyword argument %qs at %L is already associated "
2604 "with another actual argument", a
->name
,
2613 gfc_error ("More actual than formal arguments in procedure "
2614 "call at %L", where
);
2619 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2625 gfc_error ("Missing alternate return spec in subroutine call "
2630 if (a
->expr
== NULL
)
2633 gfc_error ("Unexpected alternate return spec in subroutine "
2634 "call at %L", where
);
2638 /* Make sure that intrinsic vtables exist for calls to unlimited
2639 polymorphic formal arguments. */
2640 if (UNLIMITED_POLY (f
->sym
)
2641 && a
->expr
->ts
.type
!= BT_DERIVED
2642 && a
->expr
->ts
.type
!= BT_CLASS
)
2643 gfc_find_vtab (&a
->expr
->ts
);
2645 if (a
->expr
->expr_type
== EXPR_NULL
2646 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2647 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2648 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2649 || (f
->sym
->ts
.type
== BT_CLASS
2650 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2651 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2652 || !f
->sym
->attr
.optional
2653 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2656 && (!f
->sym
->attr
.optional
2657 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2658 || (f
->sym
->ts
.type
== BT_CLASS
2659 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2660 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2661 where
, f
->sym
->name
);
2663 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2664 "dummy %qs", where
, f
->sym
->name
);
2669 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2670 is_elemental
, where
))
2673 /* TS 29113, 6.3p2. */
2674 if (f
->sym
->ts
.type
== BT_ASSUMED
2675 && (a
->expr
->ts
.type
== BT_DERIVED
2676 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2678 gfc_namespace
*f2k_derived
;
2680 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2681 ? a
->expr
->ts
.u
.derived
->f2k_derived
2682 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2685 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2687 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2688 "derived type with type-bound or FINAL procedures",
2694 /* Special case for character arguments. For allocatable, pointer
2695 and assumed-shape dummies, the string length needs to match
2697 if (a
->expr
->ts
.type
== BT_CHARACTER
2698 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2699 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2700 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2701 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2702 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2703 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2704 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2705 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2707 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2709 "Character length mismatch (%ld/%ld) between actual "
2710 "argument and pointer or allocatable dummy argument "
2712 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2713 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2714 f
->sym
->name
, &a
->expr
->where
);
2717 "Character length mismatch (%ld/%ld) between actual "
2718 "argument and assumed-shape dummy argument %qs "
2720 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2721 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2722 f
->sym
->name
, &a
->expr
->where
);
2726 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2727 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2728 && a
->expr
->ts
.type
== BT_CHARACTER
)
2731 gfc_error ("Actual argument at %L to allocatable or "
2732 "pointer dummy argument %qs must have a deferred "
2733 "length type parameter if and only if the dummy has one",
2734 &a
->expr
->where
, f
->sym
->name
);
2738 if (f
->sym
->ts
.type
== BT_CLASS
)
2739 goto skip_size_check
;
2741 actual_size
= get_expr_storage_size (a
->expr
);
2742 formal_size
= get_sym_storage_size (f
->sym
);
2743 if (actual_size
!= 0 && actual_size
< formal_size
2744 && a
->expr
->ts
.type
!= BT_PROCEDURE
2745 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2747 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2748 gfc_warning (0, "Character length of actual argument shorter "
2749 "than of dummy argument %qs (%lu/%lu) at %L",
2750 f
->sym
->name
, actual_size
, formal_size
,
2753 gfc_warning (0, "Actual argument contains too few "
2754 "elements for dummy argument %qs (%lu/%lu) at %L",
2755 f
->sym
->name
, actual_size
, formal_size
,
2762 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2763 argument is provided for a procedure pointer formal argument. */
2764 if (f
->sym
->attr
.proc_pointer
2765 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2766 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2767 || gfc_is_proc_ptr_comp (a
->expr
)))
2768 || (a
->expr
->expr_type
== EXPR_FUNCTION
2769 && is_procptr_result (a
->expr
))))
2772 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2773 f
->sym
->name
, &a
->expr
->where
);
2777 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2778 provided for a procedure formal argument. */
2779 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2780 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2781 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2782 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2783 || gfc_is_proc_ptr_comp (a
->expr
)))
2784 || (a
->expr
->expr_type
== EXPR_FUNCTION
2785 && is_procptr_result (a
->expr
))))
2788 gfc_error ("Expected a procedure for argument %qs at %L",
2789 f
->sym
->name
, &a
->expr
->where
);
2793 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2794 && a
->expr
->expr_type
== EXPR_VARIABLE
2795 && a
->expr
->symtree
->n
.sym
->as
2796 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2797 && (a
->expr
->ref
== NULL
2798 || (a
->expr
->ref
->type
== REF_ARRAY
2799 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2802 gfc_error ("Actual argument for %qs cannot be an assumed-size"
2803 " array at %L", f
->sym
->name
, where
);
2807 if (a
->expr
->expr_type
!= EXPR_NULL
2808 && compare_pointer (f
->sym
, a
->expr
) == 0)
2811 gfc_error ("Actual argument for %qs must be a pointer at %L",
2812 f
->sym
->name
, &a
->expr
->where
);
2816 if (a
->expr
->expr_type
!= EXPR_NULL
2817 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2818 && compare_pointer (f
->sym
, a
->expr
) == 2)
2821 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2822 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
2827 /* Fortran 2008, C1242. */
2828 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2831 gfc_error ("Coindexed actual argument at %L to pointer "
2833 &a
->expr
->where
, f
->sym
->name
);
2837 /* Fortran 2008, 12.5.2.5 (no constraint). */
2838 if (a
->expr
->expr_type
== EXPR_VARIABLE
2839 && f
->sym
->attr
.intent
!= INTENT_IN
2840 && f
->sym
->attr
.allocatable
2841 && gfc_is_coindexed (a
->expr
))
2844 gfc_error ("Coindexed actual argument at %L to allocatable "
2845 "dummy %qs requires INTENT(IN)",
2846 &a
->expr
->where
, f
->sym
->name
);
2850 /* Fortran 2008, C1237. */
2851 if (a
->expr
->expr_type
== EXPR_VARIABLE
2852 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2853 && gfc_is_coindexed (a
->expr
)
2854 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2855 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2858 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2859 "%L requires that dummy %qs has neither "
2860 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2865 /* Fortran 2008, 12.5.2.4 (no constraint). */
2866 if (a
->expr
->expr_type
== EXPR_VARIABLE
2867 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2868 && gfc_is_coindexed (a
->expr
)
2869 && gfc_has_ultimate_allocatable (a
->expr
))
2872 gfc_error ("Coindexed actual argument at %L with allocatable "
2873 "ultimate component to dummy %qs requires either VALUE "
2874 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2878 if (f
->sym
->ts
.type
== BT_CLASS
2879 && CLASS_DATA (f
->sym
)->attr
.allocatable
2880 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2884 gfc_error ("Actual CLASS array argument for %qs must be a full "
2885 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2890 if (a
->expr
->expr_type
!= EXPR_NULL
2891 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2894 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
2895 f
->sym
->name
, &a
->expr
->where
);
2899 /* Check intent = OUT/INOUT for definable actual argument. */
2900 if ((f
->sym
->attr
.intent
== INTENT_OUT
2901 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2903 const char* context
= (where
2904 ? _("actual argument to INTENT = OUT/INOUT")
2907 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2908 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2909 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2910 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
2912 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
2916 if ((f
->sym
->attr
.intent
== INTENT_OUT
2917 || f
->sym
->attr
.intent
== INTENT_INOUT
2918 || f
->sym
->attr
.volatile_
2919 || f
->sym
->attr
.asynchronous
)
2920 && gfc_has_vector_subscript (a
->expr
))
2923 gfc_error ("Array-section actual argument with vector "
2924 "subscripts at %L is incompatible with INTENT(OUT), "
2925 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2926 "of the dummy argument %qs",
2927 &a
->expr
->where
, f
->sym
->name
);
2931 /* C1232 (R1221) For an actual argument which is an array section or
2932 an assumed-shape array, the dummy argument shall be an assumed-
2933 shape array, if the dummy argument has the VOLATILE attribute. */
2935 if (f
->sym
->attr
.volatile_
2936 && a
->expr
->symtree
->n
.sym
->as
2937 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2938 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2941 gfc_error ("Assumed-shape actual argument at %L is "
2942 "incompatible with the non-assumed-shape "
2943 "dummy argument %qs due to VOLATILE attribute",
2944 &a
->expr
->where
,f
->sym
->name
);
2948 if (f
->sym
->attr
.volatile_
2949 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2950 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2953 gfc_error ("Array-section actual argument at %L is "
2954 "incompatible with the non-assumed-shape "
2955 "dummy argument %qs due to VOLATILE attribute",
2956 &a
->expr
->where
,f
->sym
->name
);
2960 /* C1233 (R1221) For an actual argument which is a pointer array, the
2961 dummy argument shall be an assumed-shape or pointer array, if the
2962 dummy argument has the VOLATILE attribute. */
2964 if (f
->sym
->attr
.volatile_
2965 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2966 && a
->expr
->symtree
->n
.sym
->as
2968 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2969 || f
->sym
->attr
.pointer
)))
2972 gfc_error ("Pointer-array actual argument at %L requires "
2973 "an assumed-shape or pointer-array dummy "
2974 "argument %qs due to VOLATILE attribute",
2975 &a
->expr
->where
,f
->sym
->name
);
2986 /* Make sure missing actual arguments are optional. */
2988 for (f
= formal
; f
; f
= f
->next
, i
++)
2990 if (new_arg
[i
] != NULL
)
2995 gfc_error ("Missing alternate return spec in subroutine call "
2999 if (!f
->sym
->attr
.optional
)
3002 gfc_error ("Missing actual argument for argument %qs at %L",
3003 f
->sym
->name
, where
);
3008 /* The argument lists are compatible. We now relink a new actual
3009 argument list with null arguments in the right places. The head
3010 of the list remains the head. */
3011 for (i
= 0; i
< n
; i
++)
3012 if (new_arg
[i
] == NULL
)
3013 new_arg
[i
] = gfc_get_actual_arglist ();
3018 *new_arg
[0] = *actual
;
3022 new_arg
[0] = new_arg
[na
];
3026 for (i
= 0; i
< n
- 1; i
++)
3027 new_arg
[i
]->next
= new_arg
[i
+ 1];
3029 new_arg
[i
]->next
= NULL
;
3031 if (*ap
== NULL
&& n
> 0)
3034 /* Note the types of omitted optional arguments. */
3035 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3036 if (a
->expr
== NULL
&& a
->label
== NULL
)
3037 a
->missing_arg_type
= f
->sym
->ts
.type
;
3045 gfc_formal_arglist
*f
;
3046 gfc_actual_arglist
*a
;
3050 /* qsort comparison function for argument pairs, with the following
3052 - p->a->expr == NULL
3053 - p->a->expr->expr_type != EXPR_VARIABLE
3054 - growing p->a->expr->symbol. */
3057 pair_cmp (const void *p1
, const void *p2
)
3059 const gfc_actual_arglist
*a1
, *a2
;
3061 /* *p1 and *p2 are elements of the to-be-sorted array. */
3062 a1
= ((const argpair
*) p1
)->a
;
3063 a2
= ((const argpair
*) p2
)->a
;
3072 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3074 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3078 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3080 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3084 /* Given two expressions from some actual arguments, test whether they
3085 refer to the same expression. The analysis is conservative.
3086 Returning false will produce no warning. */
3089 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3091 const gfc_ref
*r1
, *r2
;
3094 || e1
->expr_type
!= EXPR_VARIABLE
3095 || e2
->expr_type
!= EXPR_VARIABLE
3096 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3099 /* TODO: improve comparison, see expr.c:show_ref(). */
3100 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3102 if (r1
->type
!= r2
->type
)
3107 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3109 /* TODO: At the moment, consider only full arrays;
3110 we could do better. */
3111 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3116 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3124 gfc_internal_error ("compare_actual_expr(): Bad component code");
3133 /* Given formal and actual argument lists that correspond to one
3134 another, check that identical actual arguments aren't not
3135 associated with some incompatible INTENTs. */
3138 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3140 sym_intent f1_intent
, f2_intent
;
3141 gfc_formal_arglist
*f1
;
3142 gfc_actual_arglist
*a1
;
3148 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3150 if (f1
== NULL
&& a1
== NULL
)
3152 if (f1
== NULL
|| a1
== NULL
)
3153 gfc_internal_error ("check_some_aliasing(): List mismatch");
3158 p
= XALLOCAVEC (argpair
, n
);
3160 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3166 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3168 for (i
= 0; i
< n
; i
++)
3171 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3172 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3174 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3175 for (j
= i
+ 1; j
< n
; j
++)
3177 /* Expected order after the sort. */
3178 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3179 gfc_internal_error ("check_some_aliasing(): corrupted data");
3181 /* Are the expression the same? */
3182 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3184 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3185 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3186 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3187 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3189 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3190 "argument %qs and INTENT(%s) argument %qs at %L",
3191 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3192 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3193 &p
[i
].a
->expr
->where
);
3203 /* Given formal and actual argument lists that correspond to one
3204 another, check that they are compatible in the sense that intents
3205 are not mismatched. */
3208 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3210 sym_intent f_intent
;
3212 for (;; f
= f
->next
, a
= a
->next
)
3216 if (f
== NULL
&& a
== NULL
)
3218 if (f
== NULL
|| a
== NULL
)
3219 gfc_internal_error ("check_intents(): List mismatch");
3221 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3222 && a
->expr
->value
.function
.isym
3223 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3224 expr
= a
->expr
->value
.function
.actual
->expr
;
3228 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3231 f_intent
= f
->sym
->attr
.intent
;
3233 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3235 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3236 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3237 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3239 gfc_error ("Procedure argument at %L is local to a PURE "
3240 "procedure and has the POINTER attribute",
3246 /* Fortran 2008, C1283. */
3247 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3249 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3251 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3252 "is passed to an INTENT(%s) argument",
3253 &expr
->where
, gfc_intent_string (f_intent
));
3257 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3258 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3259 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3261 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3262 "is passed to a POINTER dummy argument",
3268 /* F2008, Section 12.5.2.4. */
3269 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3270 && gfc_is_coindexed (expr
))
3272 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3273 "polymorphic dummy argument %qs",
3274 &expr
->where
, f
->sym
->name
);
3283 /* Check how a procedure is used against its interface. If all goes
3284 well, the actual argument list will also end up being properly
3288 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3290 gfc_formal_arglist
*dummy_args
;
3292 /* Warn about calls with an implicit interface. Special case
3293 for calling a ISO_C_BINDING because c_loc and c_funloc
3294 are pseudo-unknown. Additionally, warn about procedures not
3295 explicitly declared at all if requested. */
3296 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3298 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3300 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3304 if (warn_implicit_interface
)
3305 gfc_warning (OPT_Wimplicit_interface
,
3306 "Procedure %qs called with an implicit interface at %L",
3308 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3309 gfc_warning (OPT_Wimplicit_procedure
,
3310 "Procedure %qs called at %L is not explicitly declared",
3314 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3316 gfc_actual_arglist
*a
;
3318 if (sym
->attr
.pointer
)
3320 gfc_error ("The pointer object %qs at %L must have an explicit "
3321 "function interface or be declared as array",
3326 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3328 gfc_error ("The allocatable object %qs at %L must have an explicit "
3329 "function interface or be declared as array",
3334 if (sym
->attr
.allocatable
)
3336 gfc_error ("Allocatable function %qs at %L must have an explicit "
3337 "function interface", sym
->name
, where
);
3341 for (a
= *ap
; a
; a
= a
->next
)
3343 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3344 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3346 gfc_error ("Keyword argument requires explicit interface "
3347 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3351 /* TS 29113, 6.2. */
3352 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3353 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3355 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3356 "interface", a
->expr
->symtree
->n
.sym
->name
,
3361 /* F2008, C1303 and C1304. */
3363 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3364 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3365 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3366 || gfc_expr_attr (a
->expr
).lock_comp
))
3368 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3369 "component at %L requires an explicit interface for "
3370 "procedure %qs", &a
->expr
->where
, sym
->name
);
3374 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3375 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3377 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3381 /* TS 29113, C407b. */
3382 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3383 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3385 gfc_error ("Assumed-rank argument requires an explicit interface "
3386 "at %L", &a
->expr
->where
);
3394 dummy_args
= gfc_sym_get_dummy_args (sym
);
3396 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3399 if (!check_intents (dummy_args
, *ap
))
3403 check_some_aliasing (dummy_args
, *ap
);
3409 /* Check how a procedure pointer component is used against its interface.
3410 If all goes well, the actual argument list will also end up being properly
3411 sorted. Completely analogous to gfc_procedure_use. */
3414 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3416 /* Warn about calls with an implicit interface. Special case
3417 for calling a ISO_C_BINDING because c_loc and c_funloc
3418 are pseudo-unknown. */
3419 if (warn_implicit_interface
3420 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3421 && !comp
->attr
.is_iso_c
)
3422 gfc_warning (OPT_Wimplicit_interface
,
3423 "Procedure pointer component %qs called with an implicit "
3424 "interface at %L", comp
->name
, where
);
3426 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3428 gfc_actual_arglist
*a
;
3429 for (a
= *ap
; a
; a
= a
->next
)
3431 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3432 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3434 gfc_error ("Keyword argument requires explicit interface "
3435 "for procedure pointer component %qs at %L",
3436 comp
->name
, &a
->expr
->where
);
3444 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3445 comp
->attr
.elemental
, where
))
3448 check_intents (comp
->ts
.interface
->formal
, *ap
);
3450 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3454 /* Try if an actual argument list matches the formal list of a symbol,
3455 respecting the symbol's attributes like ELEMENTAL. This is used for
3456 GENERIC resolution. */
3459 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3461 gfc_formal_arglist
*dummy_args
;
3464 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3466 dummy_args
= gfc_sym_get_dummy_args (sym
);
3468 r
= !sym
->attr
.elemental
;
3469 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3471 check_intents (dummy_args
, *args
);
3473 check_some_aliasing (dummy_args
, *args
);
3481 /* Given an interface pointer and an actual argument list, search for
3482 a formal argument list that matches the actual. If found, returns
3483 a pointer to the symbol of the correct interface. Returns NULL if
3487 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3488 gfc_actual_arglist
**ap
)
3490 gfc_symbol
*elem_sym
= NULL
;
3491 gfc_symbol
*null_sym
= NULL
;
3492 locus null_expr_loc
;
3493 gfc_actual_arglist
*a
;
3494 bool has_null_arg
= false;
3496 for (a
= *ap
; a
; a
= a
->next
)
3497 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3498 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3500 has_null_arg
= true;
3501 null_expr_loc
= a
->expr
->where
;
3505 for (; intr
; intr
= intr
->next
)
3507 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3509 if (sub_flag
&& intr
->sym
->attr
.function
)
3511 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3514 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3516 if (has_null_arg
&& null_sym
)
3518 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3519 "between specific functions %s and %s",
3520 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3523 else if (has_null_arg
)
3525 null_sym
= intr
->sym
;
3529 /* Satisfy 12.4.4.1 such that an elemental match has lower
3530 weight than a non-elemental match. */
3531 if (intr
->sym
->attr
.elemental
)
3533 elem_sym
= intr
->sym
;
3543 return elem_sym
? elem_sym
: NULL
;
3547 /* Do a brute force recursive search for a symbol. */
3549 static gfc_symtree
*
3550 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3554 if (root
->n
.sym
== sym
)
3559 st
= find_symtree0 (root
->left
, sym
);
3560 if (root
->right
&& ! st
)
3561 st
= find_symtree0 (root
->right
, sym
);
3566 /* Find a symtree for a symbol. */
3569 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3574 /* First try to find it by name. */
3575 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3576 if (st
&& st
->n
.sym
== sym
)
3579 /* If it's been renamed, resort to a brute-force search. */
3580 /* TODO: avoid having to do this search. If the symbol doesn't exist
3581 in the symtree for the current namespace, it should probably be added. */
3582 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3584 st
= find_symtree0 (ns
->sym_root
, sym
);
3588 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3593 /* See if the arglist to an operator-call contains a derived-type argument
3594 with a matching type-bound operator. If so, return the matching specific
3595 procedure defined as operator-target as well as the base-object to use
3596 (which is the found derived-type argument with operator). The generic
3597 name, if any, is transmitted to the final expression via 'gname'. */
3599 static gfc_typebound_proc
*
3600 matching_typebound_op (gfc_expr
** tb_base
,
3601 gfc_actual_arglist
* args
,
3602 gfc_intrinsic_op op
, const char* uop
,
3603 const char ** gname
)
3605 gfc_actual_arglist
* base
;
3607 for (base
= args
; base
; base
= base
->next
)
3608 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3610 gfc_typebound_proc
* tb
;
3611 gfc_symbol
* derived
;
3614 while (base
->expr
->expr_type
== EXPR_OP
3615 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3616 base
->expr
= base
->expr
->value
.op
.op1
;
3618 if (base
->expr
->ts
.type
== BT_CLASS
)
3620 if (CLASS_DATA (base
->expr
) == NULL
3621 || !gfc_expr_attr (base
->expr
).class_ok
)
3623 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3626 derived
= base
->expr
->ts
.u
.derived
;
3628 if (op
== INTRINSIC_USER
)
3630 gfc_symtree
* tb_uop
;
3633 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3642 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3645 /* This means we hit a PRIVATE operator which is use-associated and
3646 should thus not be seen. */
3650 /* Look through the super-type hierarchy for a matching specific
3652 for (; tb
; tb
= tb
->overridden
)
3656 gcc_assert (tb
->is_generic
);
3657 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3660 gfc_actual_arglist
* argcopy
;
3663 gcc_assert (g
->specific
);
3664 if (g
->specific
->error
)
3667 target
= g
->specific
->u
.specific
->n
.sym
;
3669 /* Check if this arglist matches the formal. */
3670 argcopy
= gfc_copy_actual_arglist (args
);
3671 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3672 gfc_free_actual_arglist (argcopy
);
3674 /* Return if we found a match. */
3677 *tb_base
= base
->expr
;
3678 *gname
= g
->specific_st
->name
;
3689 /* For the 'actual arglist' of an operator call and a specific typebound
3690 procedure that has been found the target of a type-bound operator, build the
3691 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3692 type-bound procedures rather than resolving type-bound operators 'directly'
3693 so that we can reuse the existing logic. */
3696 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3697 gfc_expr
* base
, gfc_typebound_proc
* target
,
3700 e
->expr_type
= EXPR_COMPCALL
;
3701 e
->value
.compcall
.tbp
= target
;
3702 e
->value
.compcall
.name
= gname
? gname
: "$op";
3703 e
->value
.compcall
.actual
= actual
;
3704 e
->value
.compcall
.base_object
= base
;
3705 e
->value
.compcall
.ignore_pass
= 1;
3706 e
->value
.compcall
.assign
= 0;
3707 if (e
->ts
.type
== BT_UNKNOWN
3708 && target
->function
)
3710 if (target
->is_generic
)
3711 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3713 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3718 /* This subroutine is called when an expression is being resolved.
3719 The expression node in question is either a user defined operator
3720 or an intrinsic operator with arguments that aren't compatible
3721 with the operator. This subroutine builds an actual argument list
3722 corresponding to the operands, then searches for a compatible
3723 interface. If one is found, the expression node is replaced with
3724 the appropriate function call. We use the 'match' enum to specify
3725 whether a replacement has been made or not, or if an error occurred. */
3728 gfc_extend_expr (gfc_expr
*e
)
3730 gfc_actual_arglist
*actual
;
3736 gfc_typebound_proc
* tbo
;
3741 actual
= gfc_get_actual_arglist ();
3742 actual
->expr
= e
->value
.op
.op1
;
3746 if (e
->value
.op
.op2
!= NULL
)
3748 actual
->next
= gfc_get_actual_arglist ();
3749 actual
->next
->expr
= e
->value
.op
.op2
;
3752 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3754 /* See if we find a matching type-bound operator. */
3755 if (i
== INTRINSIC_USER
)
3756 tbo
= matching_typebound_op (&tb_base
, actual
,
3757 i
, e
->value
.op
.uop
->name
, &gname
);
3761 #define CHECK_OS_COMPARISON(comp) \
3762 case INTRINSIC_##comp: \
3763 case INTRINSIC_##comp##_OS: \
3764 tbo = matching_typebound_op (&tb_base, actual, \
3765 INTRINSIC_##comp, NULL, &gname); \
3767 tbo = matching_typebound_op (&tb_base, actual, \
3768 INTRINSIC_##comp##_OS, NULL, &gname); \
3770 CHECK_OS_COMPARISON(EQ
)
3771 CHECK_OS_COMPARISON(NE
)
3772 CHECK_OS_COMPARISON(GT
)
3773 CHECK_OS_COMPARISON(GE
)
3774 CHECK_OS_COMPARISON(LT
)
3775 CHECK_OS_COMPARISON(LE
)
3776 #undef CHECK_OS_COMPARISON
3779 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3783 /* If there is a matching typebound-operator, replace the expression with
3784 a call to it and succeed. */
3787 gcc_assert (tb_base
);
3788 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3790 if (!gfc_resolve_expr (e
))
3796 if (i
== INTRINSIC_USER
)
3798 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3800 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3804 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3811 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3813 /* Due to the distinction between '==' and '.eq.' and friends, one has
3814 to check if either is defined. */
3817 #define CHECK_OS_COMPARISON(comp) \
3818 case INTRINSIC_##comp: \
3819 case INTRINSIC_##comp##_OS: \
3820 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3822 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3824 CHECK_OS_COMPARISON(EQ
)
3825 CHECK_OS_COMPARISON(NE
)
3826 CHECK_OS_COMPARISON(GT
)
3827 CHECK_OS_COMPARISON(GE
)
3828 CHECK_OS_COMPARISON(LT
)
3829 CHECK_OS_COMPARISON(LE
)
3830 #undef CHECK_OS_COMPARISON
3833 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3841 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3842 found rather than just taking the first one and not checking further. */
3846 /* Don't use gfc_free_actual_arglist(). */
3847 free (actual
->next
);
3852 /* Change the expression node to a function call. */
3853 e
->expr_type
= EXPR_FUNCTION
;
3854 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3855 e
->value
.function
.actual
= actual
;
3856 e
->value
.function
.esym
= NULL
;
3857 e
->value
.function
.isym
= NULL
;
3858 e
->value
.function
.name
= NULL
;
3859 e
->user_operator
= 1;
3861 if (!gfc_resolve_expr (e
))
3868 /* Tries to replace an assignment code node with a subroutine call to the
3869 subroutine associated with the assignment operator. Return true if the node
3870 was replaced. On false, no error is generated. */
3873 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3875 gfc_actual_arglist
*actual
;
3876 gfc_expr
*lhs
, *rhs
, *tb_base
;
3877 gfc_symbol
*sym
= NULL
;
3878 const char *gname
= NULL
;
3879 gfc_typebound_proc
* tbo
;
3884 /* Don't allow an intrinsic assignment to be replaced. */
3885 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3886 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3887 && (lhs
->ts
.type
== rhs
->ts
.type
3888 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3891 actual
= gfc_get_actual_arglist ();
3894 actual
->next
= gfc_get_actual_arglist ();
3895 actual
->next
->expr
= rhs
;
3897 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3899 /* See if we find a matching type-bound assignment. */
3900 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
3905 /* Success: Replace the expression with a type-bound call. */
3906 gcc_assert (tb_base
);
3907 c
->expr1
= gfc_get_expr ();
3908 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3909 c
->expr1
->value
.compcall
.assign
= 1;
3910 c
->expr1
->where
= c
->loc
;
3912 c
->op
= EXEC_COMPCALL
;
3916 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
3917 for (; ns
; ns
= ns
->parent
)
3919 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3926 /* Success: Replace the assignment with the call. */
3927 c
->op
= EXEC_ASSIGN_CALL
;
3928 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3931 c
->ext
.actual
= actual
;
3935 /* Failure: No assignment procedure found. */
3936 free (actual
->next
);
3942 /* Make sure that the interface just parsed is not already present in
3943 the given interface list. Ambiguity isn't checked yet since module
3944 procedures can be present without interfaces. */
3947 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3951 for (ip
= base
; ip
; ip
= ip
->next
)
3953 if (ip
->sym
== new_sym
)
3955 gfc_error ("Entity %qs at %L is already present in the interface",
3956 new_sym
->name
, &loc
);
3965 /* Add a symbol to the current interface. */
3968 gfc_add_interface (gfc_symbol
*new_sym
)
3970 gfc_interface
**head
, *intr
;
3974 switch (current_interface
.type
)
3976 case INTERFACE_NAMELESS
:
3977 case INTERFACE_ABSTRACT
:
3980 case INTERFACE_INTRINSIC_OP
:
3981 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3982 switch (current_interface
.op
)
3985 case INTRINSIC_EQ_OS
:
3986 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3988 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
3989 new_sym
, gfc_current_locus
))
3994 case INTRINSIC_NE_OS
:
3995 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3997 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
3998 new_sym
, gfc_current_locus
))
4003 case INTRINSIC_GT_OS
:
4004 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4005 new_sym
, gfc_current_locus
)
4006 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4007 new_sym
, gfc_current_locus
))
4012 case INTRINSIC_GE_OS
:
4013 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4014 new_sym
, gfc_current_locus
)
4015 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4016 new_sym
, gfc_current_locus
))
4021 case INTRINSIC_LT_OS
:
4022 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4023 new_sym
, gfc_current_locus
)
4024 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4025 new_sym
, gfc_current_locus
))
4030 case INTRINSIC_LE_OS
:
4031 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4032 new_sym
, gfc_current_locus
)
4033 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4034 new_sym
, gfc_current_locus
))
4039 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4040 new_sym
, gfc_current_locus
))
4044 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4047 case INTERFACE_GENERIC
:
4048 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4050 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4054 if (!gfc_check_new_interface (sym
->generic
,
4055 new_sym
, gfc_current_locus
))
4059 head
= ¤t_interface
.sym
->generic
;
4062 case INTERFACE_USER_OP
:
4063 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4064 new_sym
, gfc_current_locus
))
4067 head
= ¤t_interface
.uop
->op
;
4071 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4074 intr
= gfc_get_interface ();
4075 intr
->sym
= new_sym
;
4076 intr
->where
= gfc_current_locus
;
4086 gfc_current_interface_head (void)
4088 switch (current_interface
.type
)
4090 case INTERFACE_INTRINSIC_OP
:
4091 return current_interface
.ns
->op
[current_interface
.op
];
4094 case INTERFACE_GENERIC
:
4095 return current_interface
.sym
->generic
;
4098 case INTERFACE_USER_OP
:
4099 return current_interface
.uop
->op
;
4109 gfc_set_current_interface_head (gfc_interface
*i
)
4111 switch (current_interface
.type
)
4113 case INTERFACE_INTRINSIC_OP
:
4114 current_interface
.ns
->op
[current_interface
.op
] = i
;
4117 case INTERFACE_GENERIC
:
4118 current_interface
.sym
->generic
= i
;
4121 case INTERFACE_USER_OP
:
4122 current_interface
.uop
->op
= i
;
4131 /* Gets rid of a formal argument list. We do not free symbols.
4132 Symbols are freed when a namespace is freed. */
4135 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4137 gfc_formal_arglist
*q
;
4147 /* Check that it is ok for the type-bound procedure 'proc' to override the
4148 procedure 'old', cf. F08:4.5.7.3. */
4151 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4154 gfc_symbol
*proc_target
, *old_target
;
4155 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4156 gfc_formal_arglist
*proc_formal
, *old_formal
;
4160 /* This procedure should only be called for non-GENERIC proc. */
4161 gcc_assert (!proc
->n
.tb
->is_generic
);
4163 /* If the overwritten procedure is GENERIC, this is an error. */
4164 if (old
->n
.tb
->is_generic
)
4166 gfc_error ("Can't overwrite GENERIC %qs at %L",
4167 old
->name
, &proc
->n
.tb
->where
);
4171 where
= proc
->n
.tb
->where
;
4172 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4173 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4175 /* Check that overridden binding is not NON_OVERRIDABLE. */
4176 if (old
->n
.tb
->non_overridable
)
4178 gfc_error ("%qs at %L overrides a procedure binding declared"
4179 " NON_OVERRIDABLE", proc
->name
, &where
);
4183 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4184 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4186 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4187 " non-DEFERRED binding", proc
->name
, &where
);
4191 /* If the overridden binding is PURE, the overriding must be, too. */
4192 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4194 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4195 proc
->name
, &where
);
4199 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4200 is not, the overriding must not be either. */
4201 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4203 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4204 " ELEMENTAL", proc
->name
, &where
);
4207 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4209 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4210 " be ELEMENTAL, either", proc
->name
, &where
);
4214 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4216 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4218 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4219 " SUBROUTINE", proc
->name
, &where
);
4223 /* If the overridden binding is a FUNCTION, the overriding must also be a
4224 FUNCTION and have the same characteristics. */
4225 if (old_target
->attr
.function
)
4227 if (!proc_target
->attr
.function
)
4229 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4230 " FUNCTION", proc
->name
, &where
);
4234 if (!check_result_characteristics (proc_target
, old_target
, err
,
4237 gfc_error ("Result mismatch for the overriding procedure "
4238 "%qs at %L: %s", proc
->name
, &where
, err
);
4243 /* If the overridden binding is PUBLIC, the overriding one must not be
4245 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4246 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4248 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4249 " PRIVATE", proc
->name
, &where
);
4253 /* Compare the formal argument lists of both procedures. This is also abused
4254 to find the position of the passed-object dummy arguments of both
4255 bindings as at least the overridden one might not yet be resolved and we
4256 need those positions in the check below. */
4257 proc_pass_arg
= old_pass_arg
= 0;
4258 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4260 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4263 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4264 old_formal
= gfc_sym_get_dummy_args (old_target
);
4265 for ( ; proc_formal
&& old_formal
;
4266 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4268 if (proc
->n
.tb
->pass_arg
4269 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4270 proc_pass_arg
= argpos
;
4271 if (old
->n
.tb
->pass_arg
4272 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4273 old_pass_arg
= argpos
;
4275 /* Check that the names correspond. */
4276 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4278 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4279 " to match the corresponding argument of the overridden"
4280 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4281 old_formal
->sym
->name
);
4285 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4286 if (!check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4287 check_type
, err
, sizeof(err
)))
4289 gfc_error ("Argument mismatch for the overriding procedure "
4290 "%qs at %L: %s", proc
->name
, &where
, err
);
4296 if (proc_formal
|| old_formal
)
4298 gfc_error ("%qs at %L must have the same number of formal arguments as"
4299 " the overridden procedure", proc
->name
, &where
);
4303 /* If the overridden binding is NOPASS, the overriding one must also be
4305 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4307 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4308 " NOPASS", proc
->name
, &where
);
4312 /* If the overridden binding is PASS(x), the overriding one must also be
4313 PASS and the passed-object dummy arguments must correspond. */
4314 if (!old
->n
.tb
->nopass
)
4316 if (proc
->n
.tb
->nopass
)
4318 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4319 " PASS", proc
->name
, &where
);
4323 if (proc_pass_arg
!= old_pass_arg
)
4325 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4326 " the same position as the passed-object dummy argument of"
4327 " the overridden procedure", proc
->name
, &where
);