1 /* Deal with interfaces.
2 Copyright (C) 2000-2013 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"
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface
;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface
*intr
)
87 for (; intr
; intr
= next
)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary_intrinsic (gfc_intrinsic_op op
)
103 case INTRINSIC_UPLUS
:
106 case INTRINSIC_UMINUS
:
107 op
= INTRINSIC_MINUS
;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'op' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type
*type
,
124 gfc_intrinsic_op
*op
)
126 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES
)
132 *type
= INTERFACE_INTRINSIC_OP
;
133 *op
= INTRINSIC_ASSIGN
;
137 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
139 *type
= INTERFACE_INTRINSIC_OP
;
140 *op
= fold_unary_intrinsic (i
);
144 *op
= INTRINSIC_NONE
;
145 if (gfc_match (" operator ( ") == MATCH_YES
)
147 m
= gfc_match_defined_op_name (buffer
, 1);
153 m
= gfc_match_char (')');
159 strcpy (name
, buffer
);
160 *type
= INTERFACE_USER_OP
;
164 if (gfc_match_name (buffer
) == MATCH_YES
)
166 strcpy (name
, buffer
);
167 *type
= INTERFACE_GENERIC
;
171 *type
= INTERFACE_NAMELESS
;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five F95 forms of an interface statement. The
181 matcher for the abstract interface follows. */
184 gfc_match_interface (void)
186 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
192 m
= gfc_match_space ();
194 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
202 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
207 current_interface
.type
= type
;
211 case INTERFACE_GENERIC
:
212 if (gfc_get_symbol (name
, NULL
, &sym
))
215 if (!sym
->attr
.generic
216 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
221 gfc_error ("Dummy procedure '%s' at %C cannot have a "
222 "generic interface", sym
->name
);
226 current_interface
.sym
= gfc_new_block
= sym
;
229 case INTERFACE_USER_OP
:
230 current_interface
.uop
= gfc_get_uop (name
);
233 case INTERFACE_INTRINSIC_OP
:
234 current_interface
.op
= op
;
237 case INTERFACE_NAMELESS
:
238 case INTERFACE_ABSTRACT
:
247 /* Match a F2003 abstract interface. */
250 gfc_match_abstract_interface (void)
254 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
257 m
= gfc_match_eos ();
261 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
265 current_interface
.type
= INTERFACE_ABSTRACT
;
271 /* Match the different sort of generic-specs that can be present after
272 the END INTERFACE itself. */
275 gfc_match_end_interface (void)
277 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
282 m
= gfc_match_space ();
284 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
287 /* If we're not looking at the end of the statement now, or if this
288 is not a nameless interface but we did not see a space, punt. */
289 if (gfc_match_eos () != MATCH_YES
290 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
292 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
299 switch (current_interface
.type
)
301 case INTERFACE_NAMELESS
:
302 case INTERFACE_ABSTRACT
:
303 if (type
!= INTERFACE_NAMELESS
)
305 gfc_error ("Expected a nameless interface at %C");
311 case INTERFACE_INTRINSIC_OP
:
312 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
315 if (current_interface
.op
== INTRINSIC_ASSIGN
)
318 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
323 s1
= gfc_op2string (current_interface
.op
);
324 s2
= gfc_op2string (op
);
326 /* The following if-statements are used to enforce C1202
328 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
329 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
331 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
332 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
334 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
335 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
337 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
338 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
340 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
341 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
343 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
344 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
348 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
349 "but got %s", s1
, s2
);
356 case INTERFACE_USER_OP
:
357 /* Comparing the symbol node names is OK because only use-associated
358 symbols can be renamed. */
359 if (type
!= current_interface
.type
360 || strcmp (current_interface
.uop
->name
, name
) != 0)
362 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
363 current_interface
.uop
->name
);
369 case INTERFACE_GENERIC
:
370 if (type
!= current_interface
.type
371 || strcmp (current_interface
.sym
->name
, name
) != 0)
373 gfc_error ("Expecting 'END INTERFACE %s' at %C",
374 current_interface
.sym
->name
);
385 /* Compare two derived types using the criteria in 4.4.2 of the standard,
386 recursing through gfc_compare_types for the components. */
389 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
391 gfc_component
*dt1
, *dt2
;
393 if (derived1
== derived2
)
396 gcc_assert (derived1
&& derived2
);
398 /* Special case for comparing derived types across namespaces. If the
399 true names and module names are the same and the module name is
400 nonnull, then they are equal. */
401 if (strcmp (derived1
->name
, derived2
->name
) == 0
402 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
403 && strcmp (derived1
->module
, derived2
->module
) == 0)
406 /* Compare type via the rules of the standard. Both types must have
407 the SEQUENCE or BIND(C) attribute to be equal. */
409 if (strcmp (derived1
->name
, derived2
->name
))
412 if (derived1
->component_access
== ACCESS_PRIVATE
413 || derived2
->component_access
== ACCESS_PRIVATE
)
416 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
417 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
420 dt1
= derived1
->components
;
421 dt2
= derived2
->components
;
423 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
424 simple test can speed things up. Otherwise, lots of things have to
428 if (strcmp (dt1
->name
, dt2
->name
) != 0)
431 if (dt1
->attr
.access
!= dt2
->attr
.access
)
434 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
437 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
440 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
443 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
446 /* Make sure that link lists do not put this function into an
447 endless recursive loop! */
448 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
449 && !(dt2
->ts
.type
== BT_DERIVED
&& derived2
== dt2
->ts
.u
.derived
)
450 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
453 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
454 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
457 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
458 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
464 if (dt1
== NULL
&& dt2
== NULL
)
466 if (dt1
== NULL
|| dt2
== NULL
)
474 /* Compare two typespecs, recursively if necessary. */
477 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
479 /* See if one of the typespecs is a BT_VOID, which is what is being used
480 to allow the funcs like c_f_pointer to accept any pointer type.
481 TODO: Possibly should narrow this to just the one typespec coming in
482 that is for the formal arg, but oh well. */
483 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
486 if (ts1
->type
== BT_CLASS
487 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
491 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
492 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
493 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
496 if (ts1
->type
!= ts2
->type
497 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
498 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
500 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
501 return (ts1
->kind
== ts2
->kind
);
503 /* Compare derived types. */
504 if (gfc_type_compatible (ts1
, ts2
))
507 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
512 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
514 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
517 /* TYPE and CLASS of the same declared type are type compatible,
518 but have different characteristics. */
519 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
520 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
523 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
528 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
530 gfc_array_spec
*as1
, *as2
;
533 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
536 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
537 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
539 r1
= as1
? as1
->rank
: 0;
540 r2
= as2
? as2
->rank
: 0;
542 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
543 return 0; /* Ranks differ. */
549 /* Given two symbols that are formal arguments, compare their ranks
550 and types. Returns nonzero if they have the same rank and type,
554 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
556 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
560 /* Given two symbols that are formal arguments, compare their types
561 and rank and their formal interfaces if they are both dummy
562 procedures. Returns nonzero if the same, zero if different. */
565 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
567 if (s1
== NULL
|| s2
== NULL
)
568 return s1
== s2
? 1 : 0;
573 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
574 return compare_type_rank (s1
, s2
);
576 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
579 /* At this point, both symbols are procedures. It can happen that
580 external procedures are compared, where one is identified by usage
581 to be a function or subroutine but the other is not. Check TKR
582 nonetheless for these cases. */
583 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
584 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
586 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
587 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
589 /* Now the type of procedure has been identified. */
590 if (s1
->attr
.function
!= s2
->attr
.function
591 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
594 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
597 /* Originally, gfortran recursed here to check the interfaces of passed
598 procedures. This is explicitly not required by the standard. */
603 /* Given a formal argument list and a keyword name, search the list
604 for that keyword. Returns the correct symbol node if found, NULL
608 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
610 for (; f
; f
= f
->next
)
611 if (strcmp (f
->sym
->name
, name
) == 0)
618 /******** Interface checking subroutines **********/
621 /* Given an operator interface and the operator, make sure that all
622 interfaces for that operator are legal. */
625 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
628 gfc_formal_arglist
*formal
;
631 int args
, r1
, r2
, k1
, k2
;
636 t1
= t2
= BT_UNKNOWN
;
637 i1
= i2
= INTENT_UNKNOWN
;
641 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
643 gfc_symbol
*fsym
= formal
->sym
;
646 gfc_error ("Alternate return cannot appear in operator "
647 "interface at %L", &sym
->declared_at
);
653 i1
= fsym
->attr
.intent
;
654 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
660 i2
= fsym
->attr
.intent
;
661 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
667 /* Only +, - and .not. can be unary operators.
668 .not. cannot be a binary operator. */
669 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
670 && op
!= INTRINSIC_MINUS
671 && op
!= INTRINSIC_NOT
)
672 || (args
== 2 && op
== INTRINSIC_NOT
))
674 if (op
== INTRINSIC_ASSIGN
)
675 gfc_error ("Assignment operator interface at %L must have "
676 "two arguments", &sym
->declared_at
);
678 gfc_error ("Operator interface at %L has the wrong number of arguments",
683 /* Check that intrinsics are mapped to functions, except
684 INTRINSIC_ASSIGN which should map to a subroutine. */
685 if (op
== INTRINSIC_ASSIGN
)
687 gfc_formal_arglist
*dummy_args
;
689 if (!sym
->attr
.subroutine
)
691 gfc_error ("Assignment operator interface at %L must be "
692 "a SUBROUTINE", &sym
->declared_at
);
696 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
697 - First argument an array with different rank than second,
698 - First argument is a scalar and second an array,
699 - Types and kinds do not conform, or
700 - First argument is of derived type. */
701 dummy_args
= gfc_sym_get_dummy_args (sym
);
702 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
703 && dummy_args
->sym
->ts
.type
!= BT_CLASS
704 && (r2
== 0 || r1
== r2
)
705 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
706 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
707 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
709 gfc_error ("Assignment operator interface at %L must not redefine "
710 "an INTRINSIC type assignment", &sym
->declared_at
);
716 if (!sym
->attr
.function
)
718 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
724 /* Check intents on operator interfaces. */
725 if (op
== INTRINSIC_ASSIGN
)
727 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
729 gfc_error ("First argument of defined assignment at %L must be "
730 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
736 gfc_error ("Second argument of defined assignment at %L must be "
737 "INTENT(IN)", &sym
->declared_at
);
745 gfc_error ("First argument of operator interface at %L must be "
746 "INTENT(IN)", &sym
->declared_at
);
750 if (args
== 2 && i2
!= INTENT_IN
)
752 gfc_error ("Second argument of operator interface at %L must be "
753 "INTENT(IN)", &sym
->declared_at
);
758 /* From now on, all we have to do is check that the operator definition
759 doesn't conflict with an intrinsic operator. The rules for this
760 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
761 as well as 12.3.2.1.1 of Fortran 2003:
763 "If the operator is an intrinsic-operator (R310), the number of
764 function arguments shall be consistent with the intrinsic uses of
765 that operator, and the types, kind type parameters, or ranks of the
766 dummy arguments shall differ from those required for the intrinsic
767 operation (7.1.2)." */
769 #define IS_NUMERIC_TYPE(t) \
770 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
772 /* Unary ops are easy, do them first. */
773 if (op
== INTRINSIC_NOT
)
775 if (t1
== BT_LOGICAL
)
781 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
783 if (IS_NUMERIC_TYPE (t1
))
789 /* Character intrinsic operators have same character kind, thus
790 operator definitions with operands of different character kinds
792 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
795 /* Intrinsic operators always perform on arguments of same rank,
796 so different ranks is also always safe. (rank == 0) is an exception
797 to that, because all intrinsic operators are elemental. */
798 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
804 case INTRINSIC_EQ_OS
:
806 case INTRINSIC_NE_OS
:
807 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
812 case INTRINSIC_MINUS
:
813 case INTRINSIC_TIMES
:
814 case INTRINSIC_DIVIDE
:
815 case INTRINSIC_POWER
:
816 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
821 case INTRINSIC_GT_OS
:
823 case INTRINSIC_GE_OS
:
825 case INTRINSIC_LT_OS
:
827 case INTRINSIC_LE_OS
:
828 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
830 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
831 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
835 case INTRINSIC_CONCAT
:
836 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
844 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
854 #undef IS_NUMERIC_TYPE
857 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
863 /* Given a pair of formal argument lists, we see if the two lists can
864 be distinguished by counting the number of nonoptional arguments of
865 a given type/rank in f1 and seeing if there are less then that
866 number of those arguments in f2 (including optional arguments).
867 Since this test is asymmetric, it has to be called twice to make it
868 symmetric. Returns nonzero if the argument lists are incompatible
869 by this test. This subroutine implements rule 1 of section F03:16.2.3.
870 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
873 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
874 const char *p1
, const char *p2
)
876 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
877 gfc_formal_arglist
*f
;
890 for (f
= f1
; f
; f
= f
->next
)
893 /* Build an array of integers that gives the same integer to
894 arguments of the same type/rank. */
895 arg
= XCNEWVEC (arginfo
, n1
);
898 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
906 for (i
= 0; i
< n1
; i
++)
908 if (arg
[i
].flag
!= -1)
911 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
912 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
913 continue; /* Skip OPTIONAL and PASS arguments. */
917 /* Find other non-optional, non-pass arguments of the same type/rank. */
918 for (j
= i
+ 1; j
< n1
; j
++)
919 if ((arg
[j
].sym
== NULL
920 || !(arg
[j
].sym
->attr
.optional
921 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
922 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
923 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
929 /* Now loop over each distinct type found in f1. */
933 for (i
= 0; i
< n1
; i
++)
935 if (arg
[i
].flag
!= k
)
939 for (j
= i
+ 1; j
< n1
; j
++)
940 if (arg
[j
].flag
== k
)
943 /* Count the number of non-pass arguments in f2 with that type,
944 including those that are optional. */
947 for (f
= f2
; f
; f
= f
->next
)
948 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
949 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
950 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
968 /* Perform the correspondence test in rule (3) of F08:C1215.
969 Returns zero if no argument is found that satisfies this rule,
970 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
973 This test is also not symmetric in f1 and f2 and must be called
974 twice. This test finds problems caused by sorting the actual
975 argument list with keywords. For example:
979 INTEGER :: A ; REAL :: B
983 INTEGER :: A ; REAL :: B
987 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
990 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
991 const char *p1
, const char *p2
)
993 gfc_formal_arglist
*f2_save
, *g
;
1000 if (f1
->sym
->attr
.optional
)
1003 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1005 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1008 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1009 || compare_type_rank (f2
->sym
, f1
->sym
))
1010 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1011 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1012 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1015 /* Now search for a disambiguating keyword argument starting at
1016 the current non-match. */
1017 for (g
= f1
; g
; g
= g
->next
)
1019 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1022 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1023 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1024 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1025 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1026 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1042 symbol_rank (gfc_symbol
*sym
)
1045 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1046 return as
? as
->rank
: 0;
1050 /* Check if the characteristics of two dummy arguments match,
1054 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1055 bool type_must_agree
, char *errmsg
, int err_len
)
1057 if (s1
== NULL
|| s2
== NULL
)
1058 return s1
== s2
? true : false;
1060 /* Check type and rank. */
1061 if (type_must_agree
)
1063 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1065 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1066 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1069 if (!compare_rank (s1
, s2
))
1071 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1072 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1078 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1080 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1085 /* Check OPTIONAL attribute. */
1086 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1088 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1093 /* Check ALLOCATABLE attribute. */
1094 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1096 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1101 /* Check POINTER attribute. */
1102 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1104 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1109 /* Check TARGET attribute. */
1110 if (s1
->attr
.target
!= s2
->attr
.target
)
1112 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1117 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1118 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1120 /* Check interface of dummy procedures. */
1121 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1124 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1127 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1128 "'%s': %s", s1
->name
, err
);
1133 /* Check string length. */
1134 if (s1
->ts
.type
== BT_CHARACTER
1135 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1136 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1138 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1139 s2
->ts
.u
.cl
->length
);
1145 snprintf (errmsg
, err_len
, "Character length mismatch "
1146 "in argument '%s'", s1
->name
);
1150 /* FIXME: Implement a warning for this case.
1151 gfc_warning ("Possible character length mismatch in argument '%s'",
1159 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1160 "%i of gfc_dep_compare_expr", compval
);
1165 /* Check array shape. */
1166 if (s1
->as
&& s2
->as
)
1169 gfc_expr
*shape1
, *shape2
;
1171 if (s1
->as
->type
!= s2
->as
->type
)
1173 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1178 if (s1
->as
->type
== AS_EXPLICIT
)
1179 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1181 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1182 gfc_copy_expr (s1
->as
->lower
[i
]));
1183 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1184 gfc_copy_expr (s2
->as
->lower
[i
]));
1185 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1186 gfc_free_expr (shape1
);
1187 gfc_free_expr (shape2
);
1193 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1194 "argument '%s'", i
+ 1, s1
->name
);
1198 /* FIXME: Implement a warning for this case.
1199 gfc_warning ("Possible shape mismatch in argument '%s'",
1207 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1208 "result %i of gfc_dep_compare_expr",
1219 /* Check if the characteristics of two function results match,
1223 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1224 char *errmsg
, int err_len
)
1226 gfc_symbol
*r1
, *r2
;
1228 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1229 r1
= s1
->ts
.interface
->result
;
1231 r1
= s1
->result
? s1
->result
: s1
;
1233 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1234 r2
= s2
->ts
.interface
->result
;
1236 r2
= s2
->result
? s2
->result
: s2
;
1238 if (r1
->ts
.type
== BT_UNKNOWN
)
1241 /* Check type and rank. */
1242 if (!compare_type (r1
, r2
))
1244 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1245 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1248 if (!compare_rank (r1
, r2
))
1250 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1251 symbol_rank (r1
), symbol_rank (r2
));
1255 /* Check ALLOCATABLE attribute. */
1256 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1258 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1263 /* Check POINTER attribute. */
1264 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1266 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1271 /* Check CONTIGUOUS attribute. */
1272 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1274 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1279 /* Check PROCEDURE POINTER attribute. */
1280 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1282 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1287 /* Check string length. */
1288 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1290 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1292 snprintf (errmsg
, err_len
, "Character length mismatch "
1293 "in function result");
1297 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1299 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1300 r2
->ts
.u
.cl
->length
);
1306 snprintf (errmsg
, err_len
, "Character length mismatch "
1307 "in function result");
1311 /* FIXME: Implement a warning for this case.
1312 snprintf (errmsg, err_len, "Possible character length mismatch "
1313 "in function result");*/
1320 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1321 "result %i of gfc_dep_compare_expr", compval
);
1327 /* Check array shape. */
1328 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1331 gfc_expr
*shape1
, *shape2
;
1333 if (r1
->as
->type
!= r2
->as
->type
)
1335 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1339 if (r1
->as
->type
== AS_EXPLICIT
)
1340 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1342 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1343 gfc_copy_expr (r1
->as
->lower
[i
]));
1344 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1345 gfc_copy_expr (r2
->as
->lower
[i
]));
1346 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1347 gfc_free_expr (shape1
);
1348 gfc_free_expr (shape2
);
1354 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1355 "function result", i
+ 1);
1359 /* FIXME: Implement a warning for this case.
1360 gfc_warning ("Possible shape mismatch in return value");*/
1367 gfc_internal_error ("check_result_characteristics (2): "
1368 "Unexpected result %i of "
1369 "gfc_dep_compare_expr", compval
);
1379 /* 'Compare' two formal interfaces associated with a pair of symbols.
1380 We return nonzero if there exists an actual argument list that
1381 would be ambiguous between the two interfaces, zero otherwise.
1382 'strict_flag' specifies whether all the characteristics are
1383 required to match, which is not the case for ambiguity checks.
1384 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1387 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1388 int generic_flag
, int strict_flag
,
1389 char *errmsg
, int err_len
,
1390 const char *p1
, const char *p2
)
1392 gfc_formal_arglist
*f1
, *f2
;
1394 gcc_assert (name2
!= NULL
);
1396 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1397 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1398 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1401 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1405 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1408 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1412 /* Do strict checks on all characteristics
1413 (for dummy procedures and procedure pointer assignments). */
1414 if (!generic_flag
&& strict_flag
)
1416 if (s1
->attr
.function
&& s2
->attr
.function
)
1418 /* If both are functions, check result characteristics. */
1419 if (!check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1420 || !check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1424 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1426 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1429 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1431 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1436 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1437 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1440 f1
= gfc_sym_get_dummy_args (s1
);
1441 f2
= gfc_sym_get_dummy_args (s2
);
1443 if (f1
== NULL
&& f2
== NULL
)
1444 return 1; /* Special case: No arguments. */
1448 if (count_types_test (f1
, f2
, p1
, p2
)
1449 || count_types_test (f2
, f1
, p2
, p1
))
1451 if (generic_correspondence (f1
, f2
, p1
, p2
)
1452 || generic_correspondence (f2
, f1
, p2
, p1
))
1456 /* Perform the abbreviated correspondence test for operators (the
1457 arguments cannot be optional and are always ordered correctly).
1458 This is also done when comparing interfaces for dummy procedures and in
1459 procedure pointer assignments. */
1463 /* Check existence. */
1464 if (f1
== NULL
&& f2
== NULL
)
1466 if (f1
== NULL
|| f2
== NULL
)
1469 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1470 "arguments", name2
);
1474 if (UNLIMITED_POLY (f1
->sym
))
1479 /* Check all characteristics. */
1480 if (!check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1486 /* Only check type and rank. */
1487 if (!compare_type (f2
->sym
, f1
->sym
))
1490 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1491 "(%s/%s)", f1
->sym
->name
,
1492 gfc_typename (&f1
->sym
->ts
),
1493 gfc_typename (&f2
->sym
->ts
));
1496 if (!compare_rank (f2
->sym
, f1
->sym
))
1499 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1500 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1501 symbol_rank (f2
->sym
));
1514 /* Given a pointer to an interface pointer, remove duplicate
1515 interfaces and make sure that all symbols are either functions
1516 or subroutines, and all of the same kind. Returns nonzero if
1517 something goes wrong. */
1520 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1522 gfc_interface
*psave
, *q
, *qlast
;
1525 for (; p
; p
= p
->next
)
1527 /* Make sure all symbols in the interface have been defined as
1528 functions or subroutines. */
1529 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1530 || !p
->sym
->attr
.if_source
)
1531 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1533 if (p
->sym
->attr
.external
)
1534 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1535 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1537 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1538 "subroutine", p
->sym
->name
, interface_name
,
1539 &p
->sym
->declared_at
);
1543 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1544 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1545 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1546 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1548 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1549 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1550 " or all FUNCTIONs", interface_name
,
1551 &p
->sym
->declared_at
);
1553 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1554 "generic name is also the name of a derived type",
1555 interface_name
, &p
->sym
->declared_at
);
1559 /* F2003, C1207. F2008, C1207. */
1560 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1561 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1562 "'%s' in %s at %L", p
->sym
->name
,
1563 interface_name
, &p
->sym
->declared_at
))
1568 /* Remove duplicate interfaces in this interface list. */
1569 for (; p
; p
= p
->next
)
1573 for (q
= p
->next
; q
;)
1575 if (p
->sym
!= q
->sym
)
1582 /* Duplicate interface. */
1583 qlast
->next
= q
->next
;
1594 /* Check lists of interfaces to make sure that no two interfaces are
1595 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1598 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1599 int generic_flag
, const char *interface_name
,
1603 for (; p
; p
= p
->next
)
1604 for (q
= q0
; q
; q
= q
->next
)
1606 if (p
->sym
== q
->sym
)
1607 continue; /* Duplicates OK here. */
1609 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1612 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1613 && q
->sym
->attr
.flavor
!= FL_DERIVED
1614 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1615 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1618 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1619 p
->sym
->name
, q
->sym
->name
, interface_name
,
1621 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1622 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1623 p
->sym
->name
, q
->sym
->name
, interface_name
,
1626 gfc_warning ("Although not referenced, '%s' has ambiguous "
1627 "interfaces at %L", interface_name
, &p
->where
);
1635 /* Check the generic and operator interfaces of symbols to make sure
1636 that none of the interfaces conflict. The check has to be done
1637 after all of the symbols are actually loaded. */
1640 check_sym_interfaces (gfc_symbol
*sym
)
1642 char interface_name
[100];
1645 if (sym
->ns
!= gfc_current_ns
)
1648 if (sym
->generic
!= NULL
)
1650 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1651 if (check_interface0 (sym
->generic
, interface_name
))
1654 for (p
= sym
->generic
; p
; p
= p
->next
)
1656 if (p
->sym
->attr
.mod_proc
1657 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1658 || p
->sym
->attr
.procedure
))
1660 gfc_error ("'%s' at %L is not a module procedure",
1661 p
->sym
->name
, &p
->where
);
1666 /* Originally, this test was applied to host interfaces too;
1667 this is incorrect since host associated symbols, from any
1668 source, cannot be ambiguous with local symbols. */
1669 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1670 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1676 check_uop_interfaces (gfc_user_op
*uop
)
1678 char interface_name
[100];
1682 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1683 if (check_interface0 (uop
->op
, interface_name
))
1686 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1688 uop2
= gfc_find_uop (uop
->name
, ns
);
1692 check_interface1 (uop
->op
, uop2
->op
, 0,
1693 interface_name
, true);
1697 /* Given an intrinsic op, return an equivalent op if one exists,
1698 or INTRINSIC_NONE otherwise. */
1701 gfc_equivalent_op (gfc_intrinsic_op op
)
1706 return INTRINSIC_EQ_OS
;
1708 case INTRINSIC_EQ_OS
:
1709 return INTRINSIC_EQ
;
1712 return INTRINSIC_NE_OS
;
1714 case INTRINSIC_NE_OS
:
1715 return INTRINSIC_NE
;
1718 return INTRINSIC_GT_OS
;
1720 case INTRINSIC_GT_OS
:
1721 return INTRINSIC_GT
;
1724 return INTRINSIC_GE_OS
;
1726 case INTRINSIC_GE_OS
:
1727 return INTRINSIC_GE
;
1730 return INTRINSIC_LT_OS
;
1732 case INTRINSIC_LT_OS
:
1733 return INTRINSIC_LT
;
1736 return INTRINSIC_LE_OS
;
1738 case INTRINSIC_LE_OS
:
1739 return INTRINSIC_LE
;
1742 return INTRINSIC_NONE
;
1746 /* For the namespace, check generic, user operator and intrinsic
1747 operator interfaces for consistency and to remove duplicate
1748 interfaces. We traverse the whole namespace, counting on the fact
1749 that most symbols will not have generic or operator interfaces. */
1752 gfc_check_interfaces (gfc_namespace
*ns
)
1754 gfc_namespace
*old_ns
, *ns2
;
1755 char interface_name
[100];
1758 old_ns
= gfc_current_ns
;
1759 gfc_current_ns
= ns
;
1761 gfc_traverse_ns (ns
, check_sym_interfaces
);
1763 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1765 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1767 if (i
== INTRINSIC_USER
)
1770 if (i
== INTRINSIC_ASSIGN
)
1771 strcpy (interface_name
, "intrinsic assignment operator");
1773 sprintf (interface_name
, "intrinsic '%s' operator",
1774 gfc_op2string ((gfc_intrinsic_op
) i
));
1776 if (check_interface0 (ns
->op
[i
], interface_name
))
1780 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1783 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1785 gfc_intrinsic_op other_op
;
1787 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1788 interface_name
, true))
1791 /* i should be gfc_intrinsic_op, but has to be int with this cast
1792 here for stupid C++ compatibility rules. */
1793 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1794 if (other_op
!= INTRINSIC_NONE
1795 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1796 0, interface_name
, true))
1802 gfc_current_ns
= old_ns
;
1806 /* Given a symbol of a formal argument list and an expression, if the
1807 formal argument is allocatable, check that the actual argument is
1808 allocatable. Returns nonzero if compatible, zero if not compatible. */
1811 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1813 symbol_attribute attr
;
1815 if (formal
->attr
.allocatable
1816 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1818 attr
= gfc_expr_attr (actual
);
1819 if (!attr
.allocatable
)
1827 /* Given a symbol of a formal argument list and an expression, if the
1828 formal argument is a pointer, see if the actual argument is a
1829 pointer. Returns nonzero if compatible, zero if not compatible. */
1832 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1834 symbol_attribute attr
;
1836 if (formal
->attr
.pointer
1837 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1838 && CLASS_DATA (formal
)->attr
.class_pointer
))
1840 attr
= gfc_expr_attr (actual
);
1842 /* Fortran 2008 allows non-pointer actual arguments. */
1843 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1854 /* Emit clear error messages for rank mismatch. */
1857 argument_rank_mismatch (const char *name
, locus
*where
,
1858 int rank1
, int rank2
)
1861 /* TS 29113, C407b. */
1864 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1865 " '%s' has assumed-rank", where
, name
);
1867 else if (rank1
== 0)
1869 gfc_error ("Rank mismatch in argument '%s' at %L "
1870 "(scalar and rank-%d)", name
, where
, rank2
);
1872 else if (rank2
== 0)
1874 gfc_error ("Rank mismatch in argument '%s' at %L "
1875 "(rank-%d and scalar)", name
, where
, rank1
);
1879 gfc_error ("Rank mismatch in argument '%s' at %L "
1880 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1885 /* Given a symbol of a formal argument list and an expression, see if
1886 the two are compatible as arguments. Returns nonzero if
1887 compatible, zero if not compatible. */
1890 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1891 int ranks_must_agree
, int is_elemental
, locus
*where
)
1894 bool rank_check
, is_pointer
;
1896 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1897 procs c_f_pointer or c_f_procpointer, and we need to accept most
1898 pointers the user could give us. This should allow that. */
1899 if (formal
->ts
.type
== BT_VOID
)
1902 if (formal
->ts
.type
== BT_DERIVED
1903 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1904 && actual
->ts
.type
== BT_DERIVED
1905 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1908 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1909 /* Make sure the vtab symbol is present when
1910 the module variables are generated. */
1911 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1913 if (actual
->ts
.type
== BT_PROCEDURE
)
1916 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1918 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1921 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1925 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1926 sizeof(err
), NULL
, NULL
))
1929 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1930 formal
->name
, &actual
->where
, err
);
1934 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1936 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1937 &act_sym
->declared_at
);
1938 if (act_sym
->ts
.type
== BT_UNKNOWN
1939 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
1942 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1943 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1944 &act_sym
->declared_at
);
1950 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1951 && !gfc_is_simply_contiguous (actual
, true))
1954 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1955 "must be simply contiguous", formal
->name
, &actual
->where
);
1959 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1960 && actual
->ts
.type
!= BT_HOLLERITH
1961 && formal
->ts
.type
!= BT_ASSUMED
1962 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
1963 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
1964 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
1965 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
1966 CLASS_DATA (actual
)->ts
.u
.derived
)))
1969 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1970 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1971 gfc_typename (&formal
->ts
));
1975 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
1978 gfc_error ("Assumed-type actual argument at %L requires that dummy "
1979 "argument '%s' is of assumed type", &actual
->where
,
1984 /* F2008, 12.5.2.5; IR F08/0073. */
1985 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
1986 && actual
->expr_type
!= EXPR_NULL
1987 && ((CLASS_DATA (formal
)->attr
.class_pointer
1988 && !formal
->attr
.intent
== INTENT_IN
)
1989 || CLASS_DATA (formal
)->attr
.allocatable
))
1991 if (actual
->ts
.type
!= BT_CLASS
)
1994 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1995 formal
->name
, &actual
->where
);
1999 if (!gfc_expr_attr (actual
).class_ok
)
2002 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2003 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2004 CLASS_DATA (formal
)->ts
.u
.derived
))
2007 gfc_error ("Actual argument to '%s' at %L must have the same "
2008 "declared type", formal
->name
, &actual
->where
);
2013 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2014 is necessary also for F03, so retain error for both.
2015 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2016 compatible, no attempt has been made to channel to this one. */
2017 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2018 && (CLASS_DATA (formal
)->attr
.allocatable
2019 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2022 gfc_error ("Actual argument to '%s' at %L must be unlimited "
2023 "polymorphic since the formal argument is a "
2024 "pointer or allocatable unlimited polymorphic "
2025 "entity [F2008: 12.5.2.5]", formal
->name
,
2030 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2033 gfc_error ("Actual argument to '%s' at %L must be a coarray",
2034 formal
->name
, &actual
->where
);
2038 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2040 gfc_ref
*last
= NULL
;
2042 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2043 if (ref
->type
== REF_COMPONENT
)
2046 /* F2008, 12.5.2.6. */
2047 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2049 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2052 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
2053 formal
->name
, &actual
->where
, formal
->as
->corank
,
2054 last
? last
->u
.c
.component
->as
->corank
2055 : actual
->symtree
->n
.sym
->as
->corank
);
2060 if (formal
->attr
.codimension
)
2062 /* F2008, 12.5.2.8. */
2063 if (formal
->attr
.dimension
2064 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2065 && gfc_expr_attr (actual
).dimension
2066 && !gfc_is_simply_contiguous (actual
, true))
2069 gfc_error ("Actual argument to '%s' at %L must be simply "
2070 "contiguous", formal
->name
, &actual
->where
);
2074 /* F2008, C1303 and C1304. */
2075 if (formal
->attr
.intent
!= INTENT_INOUT
2076 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2077 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2078 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2079 || formal
->attr
.lock_comp
))
2083 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
2084 "which is LOCK_TYPE or has a LOCK_TYPE component",
2085 formal
->name
, &actual
->where
);
2090 /* F2008, C1239/C1240. */
2091 if (actual
->expr_type
== EXPR_VARIABLE
2092 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2093 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2094 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2095 && actual
->rank
&& formal
->as
&& !gfc_is_simply_contiguous (actual
, true)
2096 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2097 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2098 || formal
->attr
.contiguous
))
2101 gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or "
2102 "assumed-rank array without CONTIGUOUS attribute - as actual"
2103 " argument at %L is not simply contiguous and both are "
2104 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2108 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2109 && gfc_expr_attr (actual
).codimension
)
2111 if (formal
->attr
.intent
== INTENT_OUT
)
2114 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2115 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
2119 else if (gfc_option
.warn_surprising
&& where
2120 && formal
->attr
.intent
!= INTENT_IN
)
2121 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2122 "argument '%s', which is invalid if the allocation status"
2123 " is modified", &actual
->where
, formal
->name
);
2126 /* If the rank is the same or the formal argument has assumed-rank. */
2127 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2130 if (actual
->ts
.type
== BT_CLASS
&& CLASS_DATA (actual
)->as
2131 && CLASS_DATA (actual
)->as
->rank
== symbol_rank (formal
))
2134 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2135 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2136 || formal
->as
->type
== AS_DEFERRED
)
2137 && actual
->expr_type
!= EXPR_NULL
;
2139 /* Skip rank checks for NO_ARG_CHECK. */
2140 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2143 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2144 if (rank_check
|| ranks_must_agree
2145 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2146 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2147 || (actual
->rank
== 0
2148 && ((formal
->ts
.type
== BT_CLASS
2149 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2150 || (formal
->ts
.type
!= BT_CLASS
2151 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2152 && actual
->expr_type
!= EXPR_NULL
)
2153 || (actual
->rank
== 0 && formal
->attr
.dimension
2154 && gfc_is_coindexed (actual
)))
2157 argument_rank_mismatch (formal
->name
, &actual
->where
,
2158 symbol_rank (formal
), actual
->rank
);
2161 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2164 /* At this point, we are considering a scalar passed to an array. This
2165 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2166 - if the actual argument is (a substring of) an element of a
2167 non-assumed-shape/non-pointer/non-polymorphic array; or
2168 - (F2003) if the actual argument is of type character of default/c_char
2171 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2172 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2174 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2176 if (ref
->type
== REF_COMPONENT
)
2177 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2178 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2179 && ref
->u
.ar
.dimen
> 0
2181 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2185 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2188 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2189 "at %L", formal
->name
, &actual
->where
);
2193 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2194 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2197 gfc_error ("Element of assumed-shaped or pointer "
2198 "array passed to array dummy argument '%s' at %L",
2199 formal
->name
, &actual
->where
);
2203 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2204 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2206 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2209 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2210 "CHARACTER actual argument with array dummy argument "
2211 "'%s' at %L", formal
->name
, &actual
->where
);
2215 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2217 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2218 "array dummy argument '%s' at %L",
2219 formal
->name
, &actual
->where
);
2222 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2228 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2231 argument_rank_mismatch (formal
->name
, &actual
->where
,
2232 symbol_rank (formal
), actual
->rank
);
2240 /* Returns the storage size of a symbol (formal argument) or
2241 zero if it cannot be determined. */
2243 static unsigned long
2244 get_sym_storage_size (gfc_symbol
*sym
)
2247 unsigned long strlen
, elements
;
2249 if (sym
->ts
.type
== BT_CHARACTER
)
2251 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2252 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2253 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2260 if (symbol_rank (sym
) == 0)
2264 if (sym
->as
->type
!= AS_EXPLICIT
)
2266 for (i
= 0; i
< sym
->as
->rank
; i
++)
2268 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2269 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2272 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2273 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2276 return strlen
*elements
;
2280 /* Returns the storage size of an expression (actual argument) or
2281 zero if it cannot be determined. For an array element, it returns
2282 the remaining size as the element sequence consists of all storage
2283 units of the actual argument up to the end of the array. */
2285 static unsigned long
2286 get_expr_storage_size (gfc_expr
*e
)
2289 long int strlen
, elements
;
2290 long int substrlen
= 0;
2291 bool is_str_storage
= false;
2297 if (e
->ts
.type
== BT_CHARACTER
)
2299 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2300 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2301 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2302 else if (e
->expr_type
== EXPR_CONSTANT
2303 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2304 strlen
= e
->value
.character
.length
;
2309 strlen
= 1; /* Length per element. */
2311 if (e
->rank
== 0 && !e
->ref
)
2319 for (i
= 0; i
< e
->rank
; i
++)
2320 elements
*= mpz_get_si (e
->shape
[i
]);
2321 return elements
*strlen
;
2324 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2326 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2327 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2331 /* The string length is the substring length.
2332 Set now to full string length. */
2333 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2334 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2337 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2339 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2343 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2344 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2346 long int start
, end
, stride
;
2349 if (ref
->u
.ar
.stride
[i
])
2351 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2352 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2357 if (ref
->u
.ar
.start
[i
])
2359 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2360 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2364 else if (ref
->u
.ar
.as
->lower
[i
]
2365 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2366 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2370 if (ref
->u
.ar
.end
[i
])
2372 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2373 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2377 else if (ref
->u
.ar
.as
->upper
[i
]
2378 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2379 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2383 elements
*= (end
- start
)/stride
+ 1L;
2385 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2386 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2388 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2389 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2390 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2391 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2392 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2397 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2398 && e
->expr_type
== EXPR_VARIABLE
)
2400 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2401 || e
->symtree
->n
.sym
->attr
.pointer
)
2407 /* Determine the number of remaining elements in the element
2408 sequence for array element designators. */
2409 is_str_storage
= true;
2410 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2412 if (ref
->u
.ar
.start
[i
] == NULL
2413 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2414 || ref
->u
.ar
.as
->upper
[i
] == NULL
2415 || ref
->u
.ar
.as
->lower
[i
] == NULL
2416 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2417 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2422 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2423 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2425 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2426 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2432 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2435 return elements
*strlen
;
2439 /* Given an expression, check whether it is an array section
2440 which has a vector subscript. If it has, one is returned,
2444 gfc_has_vector_subscript (gfc_expr
*e
)
2449 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2452 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2453 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2454 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2455 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2462 /* Given formal and actual argument lists, see if they are compatible.
2463 If they are compatible, the actual argument list is sorted to
2464 correspond with the formal list, and elements for missing optional
2465 arguments are inserted. If WHERE pointer is nonnull, then we issue
2466 errors when things don't match instead of just returning the status
2470 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2471 int ranks_must_agree
, int is_elemental
, locus
*where
)
2473 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2474 gfc_formal_arglist
*f
;
2476 unsigned long actual_size
, formal_size
;
2477 bool full_array
= false;
2481 if (actual
== NULL
&& formal
== NULL
)
2485 for (f
= formal
; f
; f
= f
->next
)
2488 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2490 for (i
= 0; i
< n
; i
++)
2497 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2499 /* Look for keywords but ignore g77 extensions like %VAL. */
2500 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2503 for (f
= formal
; f
; f
= f
->next
, i
++)
2507 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2514 gfc_error ("Keyword argument '%s' at %L is not in "
2515 "the procedure", a
->name
, &a
->expr
->where
);
2519 if (new_arg
[i
] != NULL
)
2522 gfc_error ("Keyword argument '%s' at %L is already associated "
2523 "with another actual argument", a
->name
,
2532 gfc_error ("More actual than formal arguments in procedure "
2533 "call at %L", where
);
2538 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2544 gfc_error ("Missing alternate return spec in subroutine call "
2549 if (a
->expr
== NULL
)
2552 gfc_error ("Unexpected alternate return spec in subroutine "
2553 "call at %L", where
);
2557 /* Make sure that intrinsic vtables exist for calls to unlimited
2558 polymorphic formal arguments. */
2559 if (UNLIMITED_POLY (f
->sym
)
2560 && a
->expr
->ts
.type
!= BT_DERIVED
2561 && a
->expr
->ts
.type
!= BT_CLASS
)
2562 gfc_find_intrinsic_vtab (&a
->expr
->ts
);
2564 if (a
->expr
->expr_type
== EXPR_NULL
2565 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2566 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2567 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2568 || (f
->sym
->ts
.type
== BT_CLASS
2569 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2570 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2571 || !f
->sym
->attr
.optional
2572 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2575 && (!f
->sym
->attr
.optional
2576 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2577 || (f
->sym
->ts
.type
== BT_CLASS
2578 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2579 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2580 where
, f
->sym
->name
);
2582 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2583 "dummy '%s'", where
, f
->sym
->name
);
2588 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2589 is_elemental
, where
))
2592 /* TS 29113, 6.3p2. */
2593 if (f
->sym
->ts
.type
== BT_ASSUMED
2594 && (a
->expr
->ts
.type
== BT_DERIVED
2595 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2597 gfc_namespace
*f2k_derived
;
2599 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2600 ? a
->expr
->ts
.u
.derived
->f2k_derived
2601 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2604 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2606 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2607 "derived type with type-bound or FINAL procedures",
2613 /* Special case for character arguments. For allocatable, pointer
2614 and assumed-shape dummies, the string length needs to match
2616 if (a
->expr
->ts
.type
== BT_CHARACTER
2617 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2618 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2619 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2620 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2621 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2622 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2623 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2624 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2626 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2627 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2628 "argument and pointer or allocatable dummy argument "
2630 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2631 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2632 f
->sym
->name
, &a
->expr
->where
);
2634 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2635 "argument and assumed-shape dummy argument '%s' "
2637 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2638 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2639 f
->sym
->name
, &a
->expr
->where
);
2643 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2644 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2645 && a
->expr
->ts
.type
== BT_CHARACTER
)
2648 gfc_error ("Actual argument at %L to allocatable or "
2649 "pointer dummy argument '%s' must have a deferred "
2650 "length type parameter if and only if the dummy has one",
2651 &a
->expr
->where
, f
->sym
->name
);
2655 if (f
->sym
->ts
.type
== BT_CLASS
)
2656 goto skip_size_check
;
2658 actual_size
= get_expr_storage_size (a
->expr
);
2659 formal_size
= get_sym_storage_size (f
->sym
);
2660 if (actual_size
!= 0 && actual_size
< formal_size
2661 && a
->expr
->ts
.type
!= BT_PROCEDURE
2662 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2664 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2665 gfc_warning ("Character length of actual argument shorter "
2666 "than of dummy argument '%s' (%lu/%lu) at %L",
2667 f
->sym
->name
, actual_size
, formal_size
,
2670 gfc_warning ("Actual argument contains too few "
2671 "elements for dummy argument '%s' (%lu/%lu) at %L",
2672 f
->sym
->name
, actual_size
, formal_size
,
2679 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2680 argument is provided for a procedure pointer formal argument. */
2681 if (f
->sym
->attr
.proc_pointer
2682 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2683 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2684 || (a
->expr
->expr_type
== EXPR_FUNCTION
2685 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2686 || gfc_is_proc_ptr_comp (a
->expr
)))
2689 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2690 f
->sym
->name
, &a
->expr
->where
);
2694 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2695 provided for a procedure formal argument. */
2696 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2697 && gfc_expr_attr (a
->expr
).flavor
!= FL_PROCEDURE
)
2700 gfc_error ("Expected a procedure for argument '%s' at %L",
2701 f
->sym
->name
, &a
->expr
->where
);
2705 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2706 && a
->expr
->expr_type
== EXPR_VARIABLE
2707 && a
->expr
->symtree
->n
.sym
->as
2708 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2709 && (a
->expr
->ref
== NULL
2710 || (a
->expr
->ref
->type
== REF_ARRAY
2711 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2714 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2715 " array at %L", f
->sym
->name
, where
);
2719 if (a
->expr
->expr_type
!= EXPR_NULL
2720 && compare_pointer (f
->sym
, a
->expr
) == 0)
2723 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2724 f
->sym
->name
, &a
->expr
->where
);
2728 if (a
->expr
->expr_type
!= EXPR_NULL
2729 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2730 && compare_pointer (f
->sym
, a
->expr
) == 2)
2733 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2734 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2739 /* Fortran 2008, C1242. */
2740 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2743 gfc_error ("Coindexed actual argument at %L to pointer "
2745 &a
->expr
->where
, f
->sym
->name
);
2749 /* Fortran 2008, 12.5.2.5 (no constraint). */
2750 if (a
->expr
->expr_type
== EXPR_VARIABLE
2751 && f
->sym
->attr
.intent
!= INTENT_IN
2752 && f
->sym
->attr
.allocatable
2753 && gfc_is_coindexed (a
->expr
))
2756 gfc_error ("Coindexed actual argument at %L to allocatable "
2757 "dummy '%s' requires INTENT(IN)",
2758 &a
->expr
->where
, f
->sym
->name
);
2762 /* Fortran 2008, C1237. */
2763 if (a
->expr
->expr_type
== EXPR_VARIABLE
2764 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2765 && gfc_is_coindexed (a
->expr
)
2766 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2767 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2770 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2771 "%L requires that dummy '%s' has neither "
2772 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2777 /* Fortran 2008, 12.5.2.4 (no constraint). */
2778 if (a
->expr
->expr_type
== EXPR_VARIABLE
2779 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2780 && gfc_is_coindexed (a
->expr
)
2781 && gfc_has_ultimate_allocatable (a
->expr
))
2784 gfc_error ("Coindexed actual argument at %L with allocatable "
2785 "ultimate component to dummy '%s' requires either VALUE "
2786 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2790 if (f
->sym
->ts
.type
== BT_CLASS
2791 && CLASS_DATA (f
->sym
)->attr
.allocatable
2792 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2796 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2797 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2802 if (a
->expr
->expr_type
!= EXPR_NULL
2803 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2806 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2807 f
->sym
->name
, &a
->expr
->where
);
2811 /* Check intent = OUT/INOUT for definable actual argument. */
2812 if ((f
->sym
->attr
.intent
== INTENT_OUT
2813 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2815 const char* context
= (where
2816 ? _("actual argument to INTENT = OUT/INOUT")
2819 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2820 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2821 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2822 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
2824 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
2828 if ((f
->sym
->attr
.intent
== INTENT_OUT
2829 || f
->sym
->attr
.intent
== INTENT_INOUT
2830 || f
->sym
->attr
.volatile_
2831 || f
->sym
->attr
.asynchronous
)
2832 && gfc_has_vector_subscript (a
->expr
))
2835 gfc_error ("Array-section actual argument with vector "
2836 "subscripts at %L is incompatible with INTENT(OUT), "
2837 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2838 "of the dummy argument '%s'",
2839 &a
->expr
->where
, f
->sym
->name
);
2843 /* C1232 (R1221) For an actual argument which is an array section or
2844 an assumed-shape array, the dummy argument shall be an assumed-
2845 shape array, if the dummy argument has the VOLATILE attribute. */
2847 if (f
->sym
->attr
.volatile_
2848 && a
->expr
->symtree
->n
.sym
->as
2849 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2850 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2853 gfc_error ("Assumed-shape actual argument at %L is "
2854 "incompatible with the non-assumed-shape "
2855 "dummy argument '%s' due to VOLATILE attribute",
2856 &a
->expr
->where
,f
->sym
->name
);
2860 if (f
->sym
->attr
.volatile_
2861 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2862 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2865 gfc_error ("Array-section actual argument at %L is "
2866 "incompatible with the non-assumed-shape "
2867 "dummy argument '%s' due to VOLATILE attribute",
2868 &a
->expr
->where
,f
->sym
->name
);
2872 /* C1233 (R1221) For an actual argument which is a pointer array, the
2873 dummy argument shall be an assumed-shape or pointer array, if the
2874 dummy argument has the VOLATILE attribute. */
2876 if (f
->sym
->attr
.volatile_
2877 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2878 && a
->expr
->symtree
->n
.sym
->as
2880 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2881 || f
->sym
->attr
.pointer
)))
2884 gfc_error ("Pointer-array actual argument at %L requires "
2885 "an assumed-shape or pointer-array dummy "
2886 "argument '%s' due to VOLATILE attribute",
2887 &a
->expr
->where
,f
->sym
->name
);
2898 /* Make sure missing actual arguments are optional. */
2900 for (f
= formal
; f
; f
= f
->next
, i
++)
2902 if (new_arg
[i
] != NULL
)
2907 gfc_error ("Missing alternate return spec in subroutine call "
2911 if (!f
->sym
->attr
.optional
)
2914 gfc_error ("Missing actual argument for argument '%s' at %L",
2915 f
->sym
->name
, where
);
2920 /* The argument lists are compatible. We now relink a new actual
2921 argument list with null arguments in the right places. The head
2922 of the list remains the head. */
2923 for (i
= 0; i
< n
; i
++)
2924 if (new_arg
[i
] == NULL
)
2925 new_arg
[i
] = gfc_get_actual_arglist ();
2930 *new_arg
[0] = *actual
;
2934 new_arg
[0] = new_arg
[na
];
2938 for (i
= 0; i
< n
- 1; i
++)
2939 new_arg
[i
]->next
= new_arg
[i
+ 1];
2941 new_arg
[i
]->next
= NULL
;
2943 if (*ap
== NULL
&& n
> 0)
2946 /* Note the types of omitted optional arguments. */
2947 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2948 if (a
->expr
== NULL
&& a
->label
== NULL
)
2949 a
->missing_arg_type
= f
->sym
->ts
.type
;
2957 gfc_formal_arglist
*f
;
2958 gfc_actual_arglist
*a
;
2962 /* qsort comparison function for argument pairs, with the following
2964 - p->a->expr == NULL
2965 - p->a->expr->expr_type != EXPR_VARIABLE
2966 - growing p->a->expr->symbol. */
2969 pair_cmp (const void *p1
, const void *p2
)
2971 const gfc_actual_arglist
*a1
, *a2
;
2973 /* *p1 and *p2 are elements of the to-be-sorted array. */
2974 a1
= ((const argpair
*) p1
)->a
;
2975 a2
= ((const argpair
*) p2
)->a
;
2984 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2986 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2990 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2992 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2996 /* Given two expressions from some actual arguments, test whether they
2997 refer to the same expression. The analysis is conservative.
2998 Returning false will produce no warning. */
3001 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3003 const gfc_ref
*r1
, *r2
;
3006 || e1
->expr_type
!= EXPR_VARIABLE
3007 || e2
->expr_type
!= EXPR_VARIABLE
3008 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3011 /* TODO: improve comparison, see expr.c:show_ref(). */
3012 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3014 if (r1
->type
!= r2
->type
)
3019 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3021 /* TODO: At the moment, consider only full arrays;
3022 we could do better. */
3023 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3028 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3036 gfc_internal_error ("compare_actual_expr(): Bad component code");
3045 /* Given formal and actual argument lists that correspond to one
3046 another, check that identical actual arguments aren't not
3047 associated with some incompatible INTENTs. */
3050 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3052 sym_intent f1_intent
, f2_intent
;
3053 gfc_formal_arglist
*f1
;
3054 gfc_actual_arglist
*a1
;
3060 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3062 if (f1
== NULL
&& a1
== NULL
)
3064 if (f1
== NULL
|| a1
== NULL
)
3065 gfc_internal_error ("check_some_aliasing(): List mismatch");
3070 p
= XALLOCAVEC (argpair
, n
);
3072 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3078 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3080 for (i
= 0; i
< n
; i
++)
3083 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3084 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3086 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3087 for (j
= i
+ 1; j
< n
; j
++)
3089 /* Expected order after the sort. */
3090 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3091 gfc_internal_error ("check_some_aliasing(): corrupted data");
3093 /* Are the expression the same? */
3094 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3096 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3097 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3098 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3099 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3101 gfc_warning ("Same actual argument associated with INTENT(%s) "
3102 "argument '%s' and INTENT(%s) argument '%s' at %L",
3103 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3104 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3105 &p
[i
].a
->expr
->where
);
3115 /* Given formal and actual argument lists that correspond to one
3116 another, check that they are compatible in the sense that intents
3117 are not mismatched. */
3120 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3122 sym_intent f_intent
;
3124 for (;; f
= f
->next
, a
= a
->next
)
3126 if (f
== NULL
&& a
== NULL
)
3128 if (f
== NULL
|| a
== NULL
)
3129 gfc_internal_error ("check_intents(): List mismatch");
3131 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
3134 f_intent
= f
->sym
->attr
.intent
;
3136 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
3138 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3139 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3140 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3142 gfc_error ("Procedure argument at %L is local to a PURE "
3143 "procedure and has the POINTER attribute",
3149 /* Fortran 2008, C1283. */
3150 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
3152 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3154 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3155 "is passed to an INTENT(%s) argument",
3156 &a
->expr
->where
, gfc_intent_string (f_intent
));
3160 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3161 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3162 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3164 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3165 "is passed to a POINTER dummy argument",
3171 /* F2008, Section 12.5.2.4. */
3172 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3173 && gfc_is_coindexed (a
->expr
))
3175 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3176 "polymorphic dummy argument '%s'",
3177 &a
->expr
->where
, f
->sym
->name
);
3186 /* Check how a procedure is used against its interface. If all goes
3187 well, the actual argument list will also end up being properly
3191 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3193 gfc_formal_arglist
*dummy_args
;
3195 /* Warn about calls with an implicit interface. Special case
3196 for calling a ISO_C_BINDING because c_loc and c_funloc
3197 are pseudo-unknown. Additionally, warn about procedures not
3198 explicitly declared at all if requested. */
3199 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
3201 if (gfc_option
.warn_implicit_interface
)
3202 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3204 else if (gfc_option
.warn_implicit_procedure
3205 && sym
->attr
.proc
== PROC_UNKNOWN
)
3206 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3210 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3212 gfc_actual_arglist
*a
;
3214 if (sym
->attr
.pointer
)
3216 gfc_error("The pointer object '%s' at %L must have an explicit "
3217 "function interface or be declared as array",
3222 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3224 gfc_error("The allocatable object '%s' at %L must have an explicit "
3225 "function interface or be declared as array",
3230 if (sym
->attr
.allocatable
)
3232 gfc_error("Allocatable function '%s' at %L must have an explicit "
3233 "function interface", sym
->name
, where
);
3237 for (a
= *ap
; a
; a
= a
->next
)
3239 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3240 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3242 gfc_error("Keyword argument requires explicit interface "
3243 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
3247 /* TS 29113, 6.2. */
3248 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3249 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3251 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3252 "interface", a
->expr
->symtree
->n
.sym
->name
,
3257 /* F2008, C1303 and C1304. */
3259 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3260 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3261 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3262 || gfc_expr_attr (a
->expr
).lock_comp
))
3264 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3265 "component at %L requires an explicit interface for "
3266 "procedure '%s'", &a
->expr
->where
, sym
->name
);
3270 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3271 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3273 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3277 /* TS 29113, C407b. */
3278 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3279 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3281 gfc_error ("Assumed-rank argument requires an explicit interface "
3282 "at %L", &a
->expr
->where
);
3290 dummy_args
= gfc_sym_get_dummy_args (sym
);
3292 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3295 if (!check_intents (dummy_args
, *ap
))
3298 if (gfc_option
.warn_aliasing
)
3299 check_some_aliasing (dummy_args
, *ap
);
3305 /* Check how a procedure pointer component is used against its interface.
3306 If all goes well, the actual argument list will also end up being properly
3307 sorted. Completely analogous to gfc_procedure_use. */
3310 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3312 /* Warn about calls with an implicit interface. Special case
3313 for calling a ISO_C_BINDING because c_loc and c_funloc
3314 are pseudo-unknown. */
3315 if (gfc_option
.warn_implicit_interface
3316 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3317 && !comp
->attr
.is_iso_c
)
3318 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3319 "interface at %L", comp
->name
, where
);
3321 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3323 gfc_actual_arglist
*a
;
3324 for (a
= *ap
; a
; a
= a
->next
)
3326 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3327 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3329 gfc_error("Keyword argument requires explicit interface "
3330 "for procedure pointer component '%s' at %L",
3331 comp
->name
, &a
->expr
->where
);
3339 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3340 comp
->attr
.elemental
, where
))
3343 check_intents (comp
->ts
.interface
->formal
, *ap
);
3344 if (gfc_option
.warn_aliasing
)
3345 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3349 /* Try if an actual argument list matches the formal list of a symbol,
3350 respecting the symbol's attributes like ELEMENTAL. This is used for
3351 GENERIC resolution. */
3354 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3356 gfc_formal_arglist
*dummy_args
;
3359 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3361 dummy_args
= gfc_sym_get_dummy_args (sym
);
3363 r
= !sym
->attr
.elemental
;
3364 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3366 check_intents (dummy_args
, *args
);
3367 if (gfc_option
.warn_aliasing
)
3368 check_some_aliasing (dummy_args
, *args
);
3376 /* Given an interface pointer and an actual argument list, search for
3377 a formal argument list that matches the actual. If found, returns
3378 a pointer to the symbol of the correct interface. Returns NULL if
3382 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3383 gfc_actual_arglist
**ap
)
3385 gfc_symbol
*elem_sym
= NULL
;
3386 gfc_symbol
*null_sym
= NULL
;
3387 locus null_expr_loc
;
3388 gfc_actual_arglist
*a
;
3389 bool has_null_arg
= false;
3391 for (a
= *ap
; a
; a
= a
->next
)
3392 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3393 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3395 has_null_arg
= true;
3396 null_expr_loc
= a
->expr
->where
;
3400 for (; intr
; intr
= intr
->next
)
3402 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3404 if (sub_flag
&& intr
->sym
->attr
.function
)
3406 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3409 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3411 if (has_null_arg
&& null_sym
)
3413 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3414 "between specific functions %s and %s",
3415 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3418 else if (has_null_arg
)
3420 null_sym
= intr
->sym
;
3424 /* Satisfy 12.4.4.1 such that an elemental match has lower
3425 weight than a non-elemental match. */
3426 if (intr
->sym
->attr
.elemental
)
3428 elem_sym
= intr
->sym
;
3438 return elem_sym
? elem_sym
: NULL
;
3442 /* Do a brute force recursive search for a symbol. */
3444 static gfc_symtree
*
3445 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3449 if (root
->n
.sym
== sym
)
3454 st
= find_symtree0 (root
->left
, sym
);
3455 if (root
->right
&& ! st
)
3456 st
= find_symtree0 (root
->right
, sym
);
3461 /* Find a symtree for a symbol. */
3464 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3469 /* First try to find it by name. */
3470 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3471 if (st
&& st
->n
.sym
== sym
)
3474 /* If it's been renamed, resort to a brute-force search. */
3475 /* TODO: avoid having to do this search. If the symbol doesn't exist
3476 in the symtree for the current namespace, it should probably be added. */
3477 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3479 st
= find_symtree0 (ns
->sym_root
, sym
);
3483 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3488 /* See if the arglist to an operator-call contains a derived-type argument
3489 with a matching type-bound operator. If so, return the matching specific
3490 procedure defined as operator-target as well as the base-object to use
3491 (which is the found derived-type argument with operator). The generic
3492 name, if any, is transmitted to the final expression via 'gname'. */
3494 static gfc_typebound_proc
*
3495 matching_typebound_op (gfc_expr
** tb_base
,
3496 gfc_actual_arglist
* args
,
3497 gfc_intrinsic_op op
, const char* uop
,
3498 const char ** gname
)
3500 gfc_actual_arglist
* base
;
3502 for (base
= args
; base
; base
= base
->next
)
3503 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3505 gfc_typebound_proc
* tb
;
3506 gfc_symbol
* derived
;
3509 while (base
->expr
->expr_type
== EXPR_OP
3510 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3511 base
->expr
= base
->expr
->value
.op
.op1
;
3513 if (base
->expr
->ts
.type
== BT_CLASS
)
3515 if (CLASS_DATA (base
->expr
) == NULL
3516 || !gfc_expr_attr (base
->expr
).class_ok
)
3518 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3521 derived
= base
->expr
->ts
.u
.derived
;
3523 if (op
== INTRINSIC_USER
)
3525 gfc_symtree
* tb_uop
;
3528 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3537 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3540 /* This means we hit a PRIVATE operator which is use-associated and
3541 should thus not be seen. */
3545 /* Look through the super-type hierarchy for a matching specific
3547 for (; tb
; tb
= tb
->overridden
)
3551 gcc_assert (tb
->is_generic
);
3552 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3555 gfc_actual_arglist
* argcopy
;
3558 gcc_assert (g
->specific
);
3559 if (g
->specific
->error
)
3562 target
= g
->specific
->u
.specific
->n
.sym
;
3564 /* Check if this arglist matches the formal. */
3565 argcopy
= gfc_copy_actual_arglist (args
);
3566 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3567 gfc_free_actual_arglist (argcopy
);
3569 /* Return if we found a match. */
3572 *tb_base
= base
->expr
;
3573 *gname
= g
->specific_st
->name
;
3584 /* For the 'actual arglist' of an operator call and a specific typebound
3585 procedure that has been found the target of a type-bound operator, build the
3586 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3587 type-bound procedures rather than resolving type-bound operators 'directly'
3588 so that we can reuse the existing logic. */
3591 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3592 gfc_expr
* base
, gfc_typebound_proc
* target
,
3595 e
->expr_type
= EXPR_COMPCALL
;
3596 e
->value
.compcall
.tbp
= target
;
3597 e
->value
.compcall
.name
= gname
? gname
: "$op";
3598 e
->value
.compcall
.actual
= actual
;
3599 e
->value
.compcall
.base_object
= base
;
3600 e
->value
.compcall
.ignore_pass
= 1;
3601 e
->value
.compcall
.assign
= 0;
3602 if (e
->ts
.type
== BT_UNKNOWN
3603 && target
->function
)
3605 if (target
->is_generic
)
3606 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3608 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3613 /* This subroutine is called when an expression is being resolved.
3614 The expression node in question is either a user defined operator
3615 or an intrinsic operator with arguments that aren't compatible
3616 with the operator. This subroutine builds an actual argument list
3617 corresponding to the operands, then searches for a compatible
3618 interface. If one is found, the expression node is replaced with
3619 the appropriate function call. We use the 'match' enum to specify
3620 whether a replacement has been made or not, or if an error occurred. */
3623 gfc_extend_expr (gfc_expr
*e
)
3625 gfc_actual_arglist
*actual
;
3634 actual
= gfc_get_actual_arglist ();
3635 actual
->expr
= e
->value
.op
.op1
;
3639 if (e
->value
.op
.op2
!= NULL
)
3641 actual
->next
= gfc_get_actual_arglist ();
3642 actual
->next
->expr
= e
->value
.op
.op2
;
3645 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3647 if (i
== INTRINSIC_USER
)
3649 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3651 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3655 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3662 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3664 /* Due to the distinction between '==' and '.eq.' and friends, one has
3665 to check if either is defined. */
3668 #define CHECK_OS_COMPARISON(comp) \
3669 case INTRINSIC_##comp: \
3670 case INTRINSIC_##comp##_OS: \
3671 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3673 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3675 CHECK_OS_COMPARISON(EQ
)
3676 CHECK_OS_COMPARISON(NE
)
3677 CHECK_OS_COMPARISON(GT
)
3678 CHECK_OS_COMPARISON(GE
)
3679 CHECK_OS_COMPARISON(LT
)
3680 CHECK_OS_COMPARISON(LE
)
3681 #undef CHECK_OS_COMPARISON
3684 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3692 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3693 found rather than just taking the first one and not checking further. */
3697 gfc_typebound_proc
* tbo
;
3700 /* See if we find a matching type-bound operator. */
3701 if (i
== INTRINSIC_USER
)
3702 tbo
= matching_typebound_op (&tb_base
, actual
,
3703 i
, e
->value
.op
.uop
->name
, &gname
);
3707 #define CHECK_OS_COMPARISON(comp) \
3708 case INTRINSIC_##comp: \
3709 case INTRINSIC_##comp##_OS: \
3710 tbo = matching_typebound_op (&tb_base, actual, \
3711 INTRINSIC_##comp, NULL, &gname); \
3713 tbo = matching_typebound_op (&tb_base, actual, \
3714 INTRINSIC_##comp##_OS, NULL, &gname); \
3716 CHECK_OS_COMPARISON(EQ
)
3717 CHECK_OS_COMPARISON(NE
)
3718 CHECK_OS_COMPARISON(GT
)
3719 CHECK_OS_COMPARISON(GE
)
3720 CHECK_OS_COMPARISON(LT
)
3721 CHECK_OS_COMPARISON(LE
)
3722 #undef CHECK_OS_COMPARISON
3725 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3729 /* If there is a matching typebound-operator, replace the expression with
3730 a call to it and succeed. */
3735 gcc_assert (tb_base
);
3736 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3738 result
= gfc_resolve_expr (e
);
3745 /* Don't use gfc_free_actual_arglist(). */
3746 free (actual
->next
);
3752 /* Change the expression node to a function call. */
3753 e
->expr_type
= EXPR_FUNCTION
;
3754 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3755 e
->value
.function
.actual
= actual
;
3756 e
->value
.function
.esym
= NULL
;
3757 e
->value
.function
.isym
= NULL
;
3758 e
->value
.function
.name
= NULL
;
3759 e
->user_operator
= 1;
3761 if (!gfc_resolve_expr (e
))
3768 /* Tries to replace an assignment code node with a subroutine call to the
3769 subroutine associated with the assignment operator. Return true if the node
3770 was replaced. On false, no error is generated. */
3773 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3775 gfc_actual_arglist
*actual
;
3776 gfc_expr
*lhs
, *rhs
, *tb_base
;
3777 gfc_symbol
*sym
= NULL
;
3778 const char *gname
= NULL
;
3779 gfc_typebound_proc
* tbo
;
3784 /* Don't allow an intrinsic assignment to be replaced. */
3785 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3786 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3787 && (lhs
->ts
.type
== rhs
->ts
.type
3788 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3791 actual
= gfc_get_actual_arglist ();
3794 actual
->next
= gfc_get_actual_arglist ();
3795 actual
->next
->expr
= rhs
;
3797 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3799 /* See if we find a matching type-bound assignment. */
3800 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
3805 /* Success: Replace the expression with a type-bound call. */
3806 gcc_assert (tb_base
);
3807 c
->expr1
= gfc_get_expr ();
3808 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3809 c
->expr1
->value
.compcall
.assign
= 1;
3810 c
->expr1
->where
= c
->loc
;
3812 c
->op
= EXEC_COMPCALL
;
3816 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
3817 for (; ns
; ns
= ns
->parent
)
3819 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3826 /* Success: Replace the assignment with the call. */
3827 c
->op
= EXEC_ASSIGN_CALL
;
3828 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3831 c
->ext
.actual
= actual
;
3835 /* Failure: No assignment procedure found. */
3836 free (actual
->next
);
3842 /* Make sure that the interface just parsed is not already present in
3843 the given interface list. Ambiguity isn't checked yet since module
3844 procedures can be present without interfaces. */
3847 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3851 for (ip
= base
; ip
; ip
= ip
->next
)
3853 if (ip
->sym
== new_sym
)
3855 gfc_error ("Entity '%s' at %L is already present in the interface",
3856 new_sym
->name
, &loc
);
3865 /* Add a symbol to the current interface. */
3868 gfc_add_interface (gfc_symbol
*new_sym
)
3870 gfc_interface
**head
, *intr
;
3874 switch (current_interface
.type
)
3876 case INTERFACE_NAMELESS
:
3877 case INTERFACE_ABSTRACT
:
3880 case INTERFACE_INTRINSIC_OP
:
3881 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3882 switch (current_interface
.op
)
3885 case INTRINSIC_EQ_OS
:
3886 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3888 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
3889 new_sym
, gfc_current_locus
))
3894 case INTRINSIC_NE_OS
:
3895 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3897 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
3898 new_sym
, gfc_current_locus
))
3903 case INTRINSIC_GT_OS
:
3904 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
3905 new_sym
, gfc_current_locus
)
3906 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
3907 new_sym
, gfc_current_locus
))
3912 case INTRINSIC_GE_OS
:
3913 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
3914 new_sym
, gfc_current_locus
)
3915 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
3916 new_sym
, gfc_current_locus
))
3921 case INTRINSIC_LT_OS
:
3922 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
3923 new_sym
, gfc_current_locus
)
3924 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
3925 new_sym
, gfc_current_locus
))
3930 case INTRINSIC_LE_OS
:
3931 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
3932 new_sym
, gfc_current_locus
)
3933 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
3934 new_sym
, gfc_current_locus
))
3939 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
3940 new_sym
, gfc_current_locus
))
3944 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3947 case INTERFACE_GENERIC
:
3948 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3950 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3954 if (!gfc_check_new_interface (sym
->generic
,
3955 new_sym
, gfc_current_locus
))
3959 head
= ¤t_interface
.sym
->generic
;
3962 case INTERFACE_USER_OP
:
3963 if (!gfc_check_new_interface (current_interface
.uop
->op
,
3964 new_sym
, gfc_current_locus
))
3967 head
= ¤t_interface
.uop
->op
;
3971 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3974 intr
= gfc_get_interface ();
3975 intr
->sym
= new_sym
;
3976 intr
->where
= gfc_current_locus
;
3986 gfc_current_interface_head (void)
3988 switch (current_interface
.type
)
3990 case INTERFACE_INTRINSIC_OP
:
3991 return current_interface
.ns
->op
[current_interface
.op
];
3994 case INTERFACE_GENERIC
:
3995 return current_interface
.sym
->generic
;
3998 case INTERFACE_USER_OP
:
3999 return current_interface
.uop
->op
;
4009 gfc_set_current_interface_head (gfc_interface
*i
)
4011 switch (current_interface
.type
)
4013 case INTERFACE_INTRINSIC_OP
:
4014 current_interface
.ns
->op
[current_interface
.op
] = i
;
4017 case INTERFACE_GENERIC
:
4018 current_interface
.sym
->generic
= i
;
4021 case INTERFACE_USER_OP
:
4022 current_interface
.uop
->op
= i
;
4031 /* Gets rid of a formal argument list. We do not free symbols.
4032 Symbols are freed when a namespace is freed. */
4035 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4037 gfc_formal_arglist
*q
;
4047 /* Check that it is ok for the type-bound procedure 'proc' to override the
4048 procedure 'old', cf. F08:4.5.7.3. */
4051 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4054 gfc_symbol
*proc_target
, *old_target
;
4055 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4056 gfc_formal_arglist
*proc_formal
, *old_formal
;
4060 /* This procedure should only be called for non-GENERIC proc. */
4061 gcc_assert (!proc
->n
.tb
->is_generic
);
4063 /* If the overwritten procedure is GENERIC, this is an error. */
4064 if (old
->n
.tb
->is_generic
)
4066 gfc_error ("Can't overwrite GENERIC '%s' at %L",
4067 old
->name
, &proc
->n
.tb
->where
);
4071 where
= proc
->n
.tb
->where
;
4072 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4073 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4075 /* Check that overridden binding is not NON_OVERRIDABLE. */
4076 if (old
->n
.tb
->non_overridable
)
4078 gfc_error ("'%s' at %L overrides a procedure binding declared"
4079 " NON_OVERRIDABLE", proc
->name
, &where
);
4083 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4084 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4086 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
4087 " non-DEFERRED binding", proc
->name
, &where
);
4091 /* If the overridden binding is PURE, the overriding must be, too. */
4092 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4094 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
4095 proc
->name
, &where
);
4099 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4100 is not, the overriding must not be either. */
4101 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4103 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
4104 " ELEMENTAL", proc
->name
, &where
);
4107 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4109 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
4110 " be ELEMENTAL, either", proc
->name
, &where
);
4114 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4116 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4118 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4119 " SUBROUTINE", proc
->name
, &where
);
4123 /* If the overridden binding is a FUNCTION, the overriding must also be a
4124 FUNCTION and have the same characteristics. */
4125 if (old_target
->attr
.function
)
4127 if (!proc_target
->attr
.function
)
4129 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4130 " FUNCTION", proc
->name
, &where
);
4134 if (!check_result_characteristics (proc_target
, old_target
, err
,
4137 gfc_error ("Result mismatch for the overriding procedure "
4138 "'%s' at %L: %s", proc
->name
, &where
, err
);
4143 /* If the overridden binding is PUBLIC, the overriding one must not be
4145 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4146 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4148 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4149 " PRIVATE", proc
->name
, &where
);
4153 /* Compare the formal argument lists of both procedures. This is also abused
4154 to find the position of the passed-object dummy arguments of both
4155 bindings as at least the overridden one might not yet be resolved and we
4156 need those positions in the check below. */
4157 proc_pass_arg
= old_pass_arg
= 0;
4158 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4160 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4163 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4164 old_formal
= gfc_sym_get_dummy_args (old_target
);
4165 for ( ; proc_formal
&& old_formal
;
4166 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4168 if (proc
->n
.tb
->pass_arg
4169 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4170 proc_pass_arg
= argpos
;
4171 if (old
->n
.tb
->pass_arg
4172 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4173 old_pass_arg
= argpos
;
4175 /* Check that the names correspond. */
4176 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4178 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4179 " to match the corresponding argument of the overridden"
4180 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4181 old_formal
->sym
->name
);
4185 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4186 if (!check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4187 check_type
, err
, sizeof(err
)))
4189 gfc_error ("Argument mismatch for the overriding procedure "
4190 "'%s' at %L: %s", proc
->name
, &where
, err
);
4196 if (proc_formal
|| old_formal
)
4198 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4199 " the overridden procedure", proc
->name
, &where
);
4203 /* If the overridden binding is NOPASS, the overriding one must also be
4205 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4207 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4208 " NOPASS", proc
->name
, &where
);
4212 /* If the overridden binding is PASS(x), the overriding one must also be
4213 PASS and the passed-object dummy arguments must correspond. */
4214 if (!old
->n
.tb
->nopass
)
4216 if (proc
->n
.tb
->nopass
)
4218 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4219 " PASS", proc
->name
, &where
);
4223 if (proc_pass_arg
!= old_pass_arg
)
4225 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4226 " the same position as the passed-object dummy argument of"
4227 " the overridden procedure", proc
->name
, &where
);