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
);
511 /* Given two symbols that are formal arguments, compare their ranks
512 and types. Returns nonzero if they have the same rank and type,
516 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
518 gfc_array_spec
*as1
, *as2
;
521 if (s1
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)
522 || s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
525 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
526 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
528 r1
= as1
? as1
->rank
: 0;
529 r2
= as2
? as2
->rank
: 0;
532 && (!as1
|| as1
->type
!= AS_ASSUMED_RANK
)
533 && (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
534 return 0; /* Ranks differ. */
536 return gfc_compare_types (&s1
->ts
, &s2
->ts
)
537 || s1
->ts
.type
== BT_ASSUMED
|| s2
->ts
.type
== BT_ASSUMED
;
541 /* Given two symbols that are formal arguments, compare their types
542 and rank and their formal interfaces if they are both dummy
543 procedures. Returns nonzero if the same, zero if different. */
546 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
548 if (s1
== NULL
|| s2
== NULL
)
549 return s1
== s2
? 1 : 0;
554 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
555 return compare_type_rank (s1
, s2
);
557 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
560 /* At this point, both symbols are procedures. It can happen that
561 external procedures are compared, where one is identified by usage
562 to be a function or subroutine but the other is not. Check TKR
563 nonetheless for these cases. */
564 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
565 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
567 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
568 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
570 /* Now the type of procedure has been identified. */
571 if (s1
->attr
.function
!= s2
->attr
.function
572 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
575 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
578 /* Originally, gfortran recursed here to check the interfaces of passed
579 procedures. This is explicitly not required by the standard. */
584 /* Given a formal argument list and a keyword name, search the list
585 for that keyword. Returns the correct symbol node if found, NULL
589 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
591 for (; f
; f
= f
->next
)
592 if (strcmp (f
->sym
->name
, name
) == 0)
599 /******** Interface checking subroutines **********/
602 /* Given an operator interface and the operator, make sure that all
603 interfaces for that operator are legal. */
606 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
609 gfc_formal_arglist
*formal
;
612 int args
, r1
, r2
, k1
, k2
;
617 t1
= t2
= BT_UNKNOWN
;
618 i1
= i2
= INTENT_UNKNOWN
;
622 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
624 gfc_symbol
*fsym
= formal
->sym
;
627 gfc_error ("Alternate return cannot appear in operator "
628 "interface at %L", &sym
->declared_at
);
634 i1
= fsym
->attr
.intent
;
635 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
641 i2
= fsym
->attr
.intent
;
642 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
648 /* Only +, - and .not. can be unary operators.
649 .not. cannot be a binary operator. */
650 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
651 && op
!= INTRINSIC_MINUS
652 && op
!= INTRINSIC_NOT
)
653 || (args
== 2 && op
== INTRINSIC_NOT
))
655 if (op
== INTRINSIC_ASSIGN
)
656 gfc_error ("Assignment operator interface at %L must have "
657 "two arguments", &sym
->declared_at
);
659 gfc_error ("Operator interface at %L has the wrong number of arguments",
664 /* Check that intrinsics are mapped to functions, except
665 INTRINSIC_ASSIGN which should map to a subroutine. */
666 if (op
== INTRINSIC_ASSIGN
)
668 gfc_formal_arglist
*dummy_args
;
670 if (!sym
->attr
.subroutine
)
672 gfc_error ("Assignment operator interface at %L must be "
673 "a SUBROUTINE", &sym
->declared_at
);
677 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
678 - First argument an array with different rank than second,
679 - First argument is a scalar and second an array,
680 - Types and kinds do not conform, or
681 - First argument is of derived type. */
682 dummy_args
= gfc_sym_get_dummy_args (sym
);
683 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
684 && dummy_args
->sym
->ts
.type
!= BT_CLASS
685 && (r2
== 0 || r1
== r2
)
686 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
687 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
688 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
690 gfc_error ("Assignment operator interface at %L must not redefine "
691 "an INTRINSIC type assignment", &sym
->declared_at
);
697 if (!sym
->attr
.function
)
699 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
705 /* Check intents on operator interfaces. */
706 if (op
== INTRINSIC_ASSIGN
)
708 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
710 gfc_error ("First argument of defined assignment at %L must be "
711 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
717 gfc_error ("Second argument of defined assignment at %L must be "
718 "INTENT(IN)", &sym
->declared_at
);
726 gfc_error ("First argument of operator interface at %L must be "
727 "INTENT(IN)", &sym
->declared_at
);
731 if (args
== 2 && i2
!= INTENT_IN
)
733 gfc_error ("Second argument of operator interface at %L must be "
734 "INTENT(IN)", &sym
->declared_at
);
739 /* From now on, all we have to do is check that the operator definition
740 doesn't conflict with an intrinsic operator. The rules for this
741 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
742 as well as 12.3.2.1.1 of Fortran 2003:
744 "If the operator is an intrinsic-operator (R310), the number of
745 function arguments shall be consistent with the intrinsic uses of
746 that operator, and the types, kind type parameters, or ranks of the
747 dummy arguments shall differ from those required for the intrinsic
748 operation (7.1.2)." */
750 #define IS_NUMERIC_TYPE(t) \
751 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
753 /* Unary ops are easy, do them first. */
754 if (op
== INTRINSIC_NOT
)
756 if (t1
== BT_LOGICAL
)
762 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
764 if (IS_NUMERIC_TYPE (t1
))
770 /* Character intrinsic operators have same character kind, thus
771 operator definitions with operands of different character kinds
773 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
776 /* Intrinsic operators always perform on arguments of same rank,
777 so different ranks is also always safe. (rank == 0) is an exception
778 to that, because all intrinsic operators are elemental. */
779 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
785 case INTRINSIC_EQ_OS
:
787 case INTRINSIC_NE_OS
:
788 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
793 case INTRINSIC_MINUS
:
794 case INTRINSIC_TIMES
:
795 case INTRINSIC_DIVIDE
:
796 case INTRINSIC_POWER
:
797 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
802 case INTRINSIC_GT_OS
:
804 case INTRINSIC_GE_OS
:
806 case INTRINSIC_LT_OS
:
808 case INTRINSIC_LE_OS
:
809 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
811 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
812 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
816 case INTRINSIC_CONCAT
:
817 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
825 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
835 #undef IS_NUMERIC_TYPE
838 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
844 /* Given a pair of formal argument lists, we see if the two lists can
845 be distinguished by counting the number of nonoptional arguments of
846 a given type/rank in f1 and seeing if there are less then that
847 number of those arguments in f2 (including optional arguments).
848 Since this test is asymmetric, it has to be called twice to make it
849 symmetric. Returns nonzero if the argument lists are incompatible
850 by this test. This subroutine implements rule 1 of section F03:16.2.3.
851 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
854 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
855 const char *p1
, const char *p2
)
857 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
858 gfc_formal_arglist
*f
;
871 for (f
= f1
; f
; f
= f
->next
)
874 /* Build an array of integers that gives the same integer to
875 arguments of the same type/rank. */
876 arg
= XCNEWVEC (arginfo
, n1
);
879 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
887 for (i
= 0; i
< n1
; i
++)
889 if (arg
[i
].flag
!= -1)
892 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
893 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
894 continue; /* Skip OPTIONAL and PASS arguments. */
898 /* Find other non-optional, non-pass arguments of the same type/rank. */
899 for (j
= i
+ 1; j
< n1
; j
++)
900 if ((arg
[j
].sym
== NULL
901 || !(arg
[j
].sym
->attr
.optional
902 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
903 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
904 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
910 /* Now loop over each distinct type found in f1. */
914 for (i
= 0; i
< n1
; i
++)
916 if (arg
[i
].flag
!= k
)
920 for (j
= i
+ 1; j
< n1
; j
++)
921 if (arg
[j
].flag
== k
)
924 /* Count the number of non-pass arguments in f2 with that type,
925 including those that are optional. */
928 for (f
= f2
; f
; f
= f
->next
)
929 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
930 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
931 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
949 /* Perform the correspondence test in rule (3) of F08:C1215.
950 Returns zero if no argument is found that satisfies this rule,
951 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
954 This test is also not symmetric in f1 and f2 and must be called
955 twice. This test finds problems caused by sorting the actual
956 argument list with keywords. For example:
960 INTEGER :: A ; REAL :: B
964 INTEGER :: A ; REAL :: B
968 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
971 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
972 const char *p1
, const char *p2
)
974 gfc_formal_arglist
*f2_save
, *g
;
981 if (f1
->sym
->attr
.optional
)
984 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
986 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
989 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
990 || compare_type_rank (f2
->sym
, f1
->sym
))
991 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
992 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
993 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
996 /* Now search for a disambiguating keyword argument starting at
997 the current non-match. */
998 for (g
= f1
; g
; g
= g
->next
)
1000 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1003 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1004 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1005 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1006 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1007 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1022 /* Check if the characteristics of two dummy arguments match,
1026 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1027 bool type_must_agree
, char *errmsg
, int err_len
)
1029 if (s1
== NULL
|| s2
== NULL
)
1030 return s1
== s2
? true : false;
1032 /* Check type and rank. */
1033 if (type_must_agree
&& !compare_type_rank (s2
, s1
))
1035 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1041 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1043 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1048 /* Check OPTIONAL attribute. */
1049 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1051 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1056 /* Check ALLOCATABLE attribute. */
1057 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1059 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1064 /* Check POINTER attribute. */
1065 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1067 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1072 /* Check TARGET attribute. */
1073 if (s1
->attr
.target
!= s2
->attr
.target
)
1075 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1080 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1081 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1083 /* Check interface of dummy procedures. */
1084 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1087 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1090 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1091 "'%s': %s", s1
->name
, err
);
1096 /* Check string length. */
1097 if (s1
->ts
.type
== BT_CHARACTER
1098 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1099 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1101 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1102 s2
->ts
.u
.cl
->length
);
1108 snprintf (errmsg
, err_len
, "Character length mismatch "
1109 "in argument '%s'", s1
->name
);
1113 /* FIXME: Implement a warning for this case.
1114 gfc_warning ("Possible character length mismatch in argument '%s'",
1122 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1123 "%i of gfc_dep_compare_expr", compval
);
1128 /* Check array shape. */
1129 if (s1
->as
&& s2
->as
)
1132 gfc_expr
*shape1
, *shape2
;
1134 if (s1
->as
->type
!= s2
->as
->type
)
1136 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1141 if (s1
->as
->type
== AS_EXPLICIT
)
1142 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1144 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1145 gfc_copy_expr (s1
->as
->lower
[i
]));
1146 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1147 gfc_copy_expr (s2
->as
->lower
[i
]));
1148 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1149 gfc_free_expr (shape1
);
1150 gfc_free_expr (shape2
);
1156 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1157 "argument '%s'", i
+ 1, s1
->name
);
1161 /* FIXME: Implement a warning for this case.
1162 gfc_warning ("Possible shape mismatch in argument '%s'",
1170 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1171 "result %i of gfc_dep_compare_expr",
1182 /* Check if the characteristics of two function results match,
1186 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1187 char *errmsg
, int err_len
)
1189 gfc_symbol
*r1
, *r2
;
1191 r1
= s1
->result
? s1
->result
: s1
;
1192 r2
= s2
->result
? s2
->result
: s2
;
1194 if (r1
->ts
.type
== BT_UNKNOWN
)
1197 /* Check type and rank. */
1198 if (!compare_type_rank (r1
, r2
))
1200 snprintf (errmsg
, err_len
, "Type/rank mismatch in function result");
1204 /* Check ALLOCATABLE attribute. */
1205 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1207 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1212 /* Check POINTER attribute. */
1213 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1215 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1220 /* Check CONTIGUOUS attribute. */
1221 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1223 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1228 /* Check PROCEDURE POINTER attribute. */
1229 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1231 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1236 /* Check string length. */
1237 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1239 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1241 snprintf (errmsg
, err_len
, "Character length mismatch "
1242 "in function result");
1246 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1248 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1249 r2
->ts
.u
.cl
->length
);
1255 snprintf (errmsg
, err_len
, "Character length mismatch "
1256 "in function result");
1260 /* FIXME: Implement a warning for this case.
1261 snprintf (errmsg, err_len, "Possible character length mismatch "
1262 "in function result");*/
1269 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1270 "result %i of gfc_dep_compare_expr", compval
);
1276 /* Check array shape. */
1277 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1280 gfc_expr
*shape1
, *shape2
;
1282 if (r1
->as
->type
!= r2
->as
->type
)
1284 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1288 if (r1
->as
->type
== AS_EXPLICIT
)
1289 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1291 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1292 gfc_copy_expr (r1
->as
->lower
[i
]));
1293 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1294 gfc_copy_expr (r2
->as
->lower
[i
]));
1295 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1296 gfc_free_expr (shape1
);
1297 gfc_free_expr (shape2
);
1303 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1304 "function result", i
+ 1);
1308 /* FIXME: Implement a warning for this case.
1309 gfc_warning ("Possible shape mismatch in return value");*/
1316 gfc_internal_error ("check_result_characteristics (2): "
1317 "Unexpected result %i of "
1318 "gfc_dep_compare_expr", compval
);
1328 /* 'Compare' two formal interfaces associated with a pair of symbols.
1329 We return nonzero if there exists an actual argument list that
1330 would be ambiguous between the two interfaces, zero otherwise.
1331 'strict_flag' specifies whether all the characteristics are
1332 required to match, which is not the case for ambiguity checks.
1333 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1336 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1337 int generic_flag
, int strict_flag
,
1338 char *errmsg
, int err_len
,
1339 const char *p1
, const char *p2
)
1341 gfc_formal_arglist
*f1
, *f2
;
1343 gcc_assert (name2
!= NULL
);
1345 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1346 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1347 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1350 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1354 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1357 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1361 /* Do strict checks on all characteristics
1362 (for dummy procedures and procedure pointer assignments). */
1363 if (!generic_flag
&& strict_flag
)
1365 if (s1
->attr
.function
&& s2
->attr
.function
)
1367 /* If both are functions, check result characteristics. */
1368 if (!check_result_characteristics (s1
, s2
, errmsg
, err_len
))
1372 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1374 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1377 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1379 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1384 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1385 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1388 f1
= gfc_sym_get_dummy_args (s1
);
1389 f2
= gfc_sym_get_dummy_args (s2
);
1391 if (f1
== NULL
&& f2
== NULL
)
1392 return 1; /* Special case: No arguments. */
1396 if (count_types_test (f1
, f2
, p1
, p2
)
1397 || count_types_test (f2
, f1
, p2
, p1
))
1399 if (generic_correspondence (f1
, f2
, p1
, p2
)
1400 || generic_correspondence (f2
, f1
, p2
, p1
))
1404 /* Perform the abbreviated correspondence test for operators (the
1405 arguments cannot be optional and are always ordered correctly).
1406 This is also done when comparing interfaces for dummy procedures and in
1407 procedure pointer assignments. */
1411 /* Check existence. */
1412 if (f1
== NULL
&& f2
== NULL
)
1414 if (f1
== NULL
|| f2
== NULL
)
1417 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1418 "arguments", name2
);
1422 if (UNLIMITED_POLY (f1
->sym
))
1427 /* Check all characteristics. */
1428 if (!check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1432 else if (!compare_type_rank (f2
->sym
, f1
->sym
))
1434 /* Only check type and rank. */
1436 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1449 /* Given a pointer to an interface pointer, remove duplicate
1450 interfaces and make sure that all symbols are either functions
1451 or subroutines, and all of the same kind. Returns nonzero if
1452 something goes wrong. */
1455 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1457 gfc_interface
*psave
, *q
, *qlast
;
1460 for (; p
; p
= p
->next
)
1462 /* Make sure all symbols in the interface have been defined as
1463 functions or subroutines. */
1464 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1465 || !p
->sym
->attr
.if_source
)
1466 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1468 if (p
->sym
->attr
.external
)
1469 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1470 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1472 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1473 "subroutine", p
->sym
->name
, interface_name
,
1474 &p
->sym
->declared_at
);
1478 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1479 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1480 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1481 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1483 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1484 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1485 " or all FUNCTIONs", interface_name
,
1486 &p
->sym
->declared_at
);
1488 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1489 "generic name is also the name of a derived type",
1490 interface_name
, &p
->sym
->declared_at
);
1494 /* F2003, C1207. F2008, C1207. */
1495 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1496 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1497 "'%s' in %s at %L", p
->sym
->name
,
1498 interface_name
, &p
->sym
->declared_at
))
1503 /* Remove duplicate interfaces in this interface list. */
1504 for (; p
; p
= p
->next
)
1508 for (q
= p
->next
; q
;)
1510 if (p
->sym
!= q
->sym
)
1517 /* Duplicate interface. */
1518 qlast
->next
= q
->next
;
1529 /* Check lists of interfaces to make sure that no two interfaces are
1530 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1533 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1534 int generic_flag
, const char *interface_name
,
1538 for (; p
; p
= p
->next
)
1539 for (q
= q0
; q
; q
= q
->next
)
1541 if (p
->sym
== q
->sym
)
1542 continue; /* Duplicates OK here. */
1544 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1547 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1548 && q
->sym
->attr
.flavor
!= FL_DERIVED
1549 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1550 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1553 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1554 p
->sym
->name
, q
->sym
->name
, interface_name
,
1556 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1557 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1558 p
->sym
->name
, q
->sym
->name
, interface_name
,
1561 gfc_warning ("Although not referenced, '%s' has ambiguous "
1562 "interfaces at %L", interface_name
, &p
->where
);
1570 /* Check the generic and operator interfaces of symbols to make sure
1571 that none of the interfaces conflict. The check has to be done
1572 after all of the symbols are actually loaded. */
1575 check_sym_interfaces (gfc_symbol
*sym
)
1577 char interface_name
[100];
1580 if (sym
->ns
!= gfc_current_ns
)
1583 if (sym
->generic
!= NULL
)
1585 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1586 if (check_interface0 (sym
->generic
, interface_name
))
1589 for (p
= sym
->generic
; p
; p
= p
->next
)
1591 if (p
->sym
->attr
.mod_proc
1592 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1593 || p
->sym
->attr
.procedure
))
1595 gfc_error ("'%s' at %L is not a module procedure",
1596 p
->sym
->name
, &p
->where
);
1601 /* Originally, this test was applied to host interfaces too;
1602 this is incorrect since host associated symbols, from any
1603 source, cannot be ambiguous with local symbols. */
1604 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1605 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1611 check_uop_interfaces (gfc_user_op
*uop
)
1613 char interface_name
[100];
1617 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1618 if (check_interface0 (uop
->op
, interface_name
))
1621 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1623 uop2
= gfc_find_uop (uop
->name
, ns
);
1627 check_interface1 (uop
->op
, uop2
->op
, 0,
1628 interface_name
, true);
1632 /* Given an intrinsic op, return an equivalent op if one exists,
1633 or INTRINSIC_NONE otherwise. */
1636 gfc_equivalent_op (gfc_intrinsic_op op
)
1641 return INTRINSIC_EQ_OS
;
1643 case INTRINSIC_EQ_OS
:
1644 return INTRINSIC_EQ
;
1647 return INTRINSIC_NE_OS
;
1649 case INTRINSIC_NE_OS
:
1650 return INTRINSIC_NE
;
1653 return INTRINSIC_GT_OS
;
1655 case INTRINSIC_GT_OS
:
1656 return INTRINSIC_GT
;
1659 return INTRINSIC_GE_OS
;
1661 case INTRINSIC_GE_OS
:
1662 return INTRINSIC_GE
;
1665 return INTRINSIC_LT_OS
;
1667 case INTRINSIC_LT_OS
:
1668 return INTRINSIC_LT
;
1671 return INTRINSIC_LE_OS
;
1673 case INTRINSIC_LE_OS
:
1674 return INTRINSIC_LE
;
1677 return INTRINSIC_NONE
;
1681 /* For the namespace, check generic, user operator and intrinsic
1682 operator interfaces for consistency and to remove duplicate
1683 interfaces. We traverse the whole namespace, counting on the fact
1684 that most symbols will not have generic or operator interfaces. */
1687 gfc_check_interfaces (gfc_namespace
*ns
)
1689 gfc_namespace
*old_ns
, *ns2
;
1690 char interface_name
[100];
1693 old_ns
= gfc_current_ns
;
1694 gfc_current_ns
= ns
;
1696 gfc_traverse_ns (ns
, check_sym_interfaces
);
1698 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1700 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1702 if (i
== INTRINSIC_USER
)
1705 if (i
== INTRINSIC_ASSIGN
)
1706 strcpy (interface_name
, "intrinsic assignment operator");
1708 sprintf (interface_name
, "intrinsic '%s' operator",
1709 gfc_op2string ((gfc_intrinsic_op
) i
));
1711 if (check_interface0 (ns
->op
[i
], interface_name
))
1715 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1718 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1720 gfc_intrinsic_op other_op
;
1722 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1723 interface_name
, true))
1726 /* i should be gfc_intrinsic_op, but has to be int with this cast
1727 here for stupid C++ compatibility rules. */
1728 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1729 if (other_op
!= INTRINSIC_NONE
1730 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1731 0, interface_name
, true))
1737 gfc_current_ns
= old_ns
;
1742 symbol_rank (gfc_symbol
*sym
)
1744 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
1745 return CLASS_DATA (sym
)->as
->rank
;
1747 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1751 /* Given a symbol of a formal argument list and an expression, if the
1752 formal argument is allocatable, check that the actual argument is
1753 allocatable. Returns nonzero if compatible, zero if not compatible. */
1756 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1758 symbol_attribute attr
;
1760 if (formal
->attr
.allocatable
1761 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1763 attr
= gfc_expr_attr (actual
);
1764 if (!attr
.allocatable
)
1772 /* Given a symbol of a formal argument list and an expression, if the
1773 formal argument is a pointer, see if the actual argument is a
1774 pointer. Returns nonzero if compatible, zero if not compatible. */
1777 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1779 symbol_attribute attr
;
1781 if (formal
->attr
.pointer
1782 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1783 && CLASS_DATA (formal
)->attr
.class_pointer
))
1785 attr
= gfc_expr_attr (actual
);
1787 /* Fortran 2008 allows non-pointer actual arguments. */
1788 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1799 /* Emit clear error messages for rank mismatch. */
1802 argument_rank_mismatch (const char *name
, locus
*where
,
1803 int rank1
, int rank2
)
1806 /* TS 29113, C407b. */
1809 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1810 " '%s' has assumed-rank", where
, name
);
1812 else if (rank1
== 0)
1814 gfc_error ("Rank mismatch in argument '%s' at %L "
1815 "(scalar and rank-%d)", name
, where
, rank2
);
1817 else if (rank2
== 0)
1819 gfc_error ("Rank mismatch in argument '%s' at %L "
1820 "(rank-%d and scalar)", name
, where
, rank1
);
1824 gfc_error ("Rank mismatch in argument '%s' at %L "
1825 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1830 /* Given a symbol of a formal argument list and an expression, see if
1831 the two are compatible as arguments. Returns nonzero if
1832 compatible, zero if not compatible. */
1835 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1836 int ranks_must_agree
, int is_elemental
, locus
*where
)
1839 bool rank_check
, is_pointer
;
1841 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1842 procs c_f_pointer or c_f_procpointer, and we need to accept most
1843 pointers the user could give us. This should allow that. */
1844 if (formal
->ts
.type
== BT_VOID
)
1847 if (formal
->ts
.type
== BT_DERIVED
1848 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1849 && actual
->ts
.type
== BT_DERIVED
1850 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1853 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1854 /* Make sure the vtab symbol is present when
1855 the module variables are generated. */
1856 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1858 if (actual
->ts
.type
== BT_PROCEDURE
)
1861 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1863 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1866 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1870 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1871 sizeof(err
), NULL
, NULL
))
1874 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1875 formal
->name
, &actual
->where
, err
);
1879 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1881 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1882 &act_sym
->declared_at
);
1883 if (act_sym
->ts
.type
== BT_UNKNOWN
1884 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
1887 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1888 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1889 &act_sym
->declared_at
);
1895 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1896 && !gfc_is_simply_contiguous (actual
, true))
1899 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1900 "must be simply contiguous", formal
->name
, &actual
->where
);
1904 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1905 && actual
->ts
.type
!= BT_HOLLERITH
1906 && formal
->ts
.type
!= BT_ASSUMED
1907 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
1908 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
1909 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
1910 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
1911 CLASS_DATA (actual
)->ts
.u
.derived
)))
1914 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1915 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1916 gfc_typename (&formal
->ts
));
1920 /* F2008, 12.5.2.5; IR F08/0073. */
1921 if (formal
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
1922 && ((CLASS_DATA (formal
)->attr
.class_pointer
1923 && !formal
->attr
.intent
== INTENT_IN
)
1924 || CLASS_DATA (formal
)->attr
.allocatable
))
1926 if (actual
->ts
.type
!= BT_CLASS
)
1929 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1930 formal
->name
, &actual
->where
);
1933 if (!gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
1934 CLASS_DATA (formal
)->ts
.u
.derived
))
1937 gfc_error ("Actual argument to '%s' at %L must have the same "
1938 "declared type", formal
->name
, &actual
->where
);
1943 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
1944 is necessary also for F03, so retain error for both.
1945 NOTE: Other type/kind errors pre-empt this error. Since they are F03
1946 compatible, no attempt has been made to channel to this one. */
1947 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
1948 && (CLASS_DATA (formal
)->attr
.allocatable
1949 ||CLASS_DATA (formal
)->attr
.class_pointer
))
1952 gfc_error ("Actual argument to '%s' at %L must be unlimited "
1953 "polymorphic since the formal argument is a "
1954 "pointer or allocatable unlimited polymorphic "
1955 "entity [F2008: 12.5.2.5]", formal
->name
,
1960 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
1963 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1964 formal
->name
, &actual
->where
);
1968 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
1970 gfc_ref
*last
= NULL
;
1972 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1973 if (ref
->type
== REF_COMPONENT
)
1976 /* F2008, 12.5.2.6. */
1977 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1979 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
1982 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1983 formal
->name
, &actual
->where
, formal
->as
->corank
,
1984 last
? last
->u
.c
.component
->as
->corank
1985 : actual
->symtree
->n
.sym
->as
->corank
);
1990 if (formal
->attr
.codimension
)
1992 /* F2008, 12.5.2.8. */
1993 if (formal
->attr
.dimension
1994 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1995 && gfc_expr_attr (actual
).dimension
1996 && !gfc_is_simply_contiguous (actual
, true))
1999 gfc_error ("Actual argument to '%s' at %L must be simply "
2000 "contiguous", formal
->name
, &actual
->where
);
2004 /* F2008, C1303 and C1304. */
2005 if (formal
->attr
.intent
!= INTENT_INOUT
2006 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2007 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2008 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2009 || formal
->attr
.lock_comp
))
2013 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
2014 "which is LOCK_TYPE or has a LOCK_TYPE component",
2015 formal
->name
, &actual
->where
);
2020 /* F2008, C1239/C1240. */
2021 if (actual
->expr_type
== EXPR_VARIABLE
2022 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2023 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2024 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2025 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
2026 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
2027 || formal
->attr
.contiguous
))
2030 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
2031 "array without CONTIGUOUS attribute - as actual argument at"
2032 " %L is not simply contiguous and both are ASYNCHRONOUS "
2033 "or VOLATILE", formal
->name
, &actual
->where
);
2037 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2038 && gfc_expr_attr (actual
).codimension
)
2040 if (formal
->attr
.intent
== INTENT_OUT
)
2043 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2044 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
2048 else if (gfc_option
.warn_surprising
&& where
2049 && formal
->attr
.intent
!= INTENT_IN
)
2050 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2051 "argument '%s', which is invalid if the allocation status"
2052 " is modified", &actual
->where
, formal
->name
);
2055 /* If the rank is the same or the formal argument has assumed-rank. */
2056 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2059 if (actual
->ts
.type
== BT_CLASS
&& CLASS_DATA (actual
)->as
2060 && CLASS_DATA (actual
)->as
->rank
== symbol_rank (formal
))
2063 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2064 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2065 || formal
->as
->type
== AS_DEFERRED
)
2066 && actual
->expr_type
!= EXPR_NULL
;
2068 /* Skip rank checks for NO_ARG_CHECK. */
2069 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2072 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2073 if (rank_check
|| ranks_must_agree
2074 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2075 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2076 || (actual
->rank
== 0
2077 && ((formal
->ts
.type
== BT_CLASS
2078 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2079 || (formal
->ts
.type
!= BT_CLASS
2080 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2081 && actual
->expr_type
!= EXPR_NULL
)
2082 || (actual
->rank
== 0 && formal
->attr
.dimension
2083 && gfc_is_coindexed (actual
)))
2086 argument_rank_mismatch (formal
->name
, &actual
->where
,
2087 symbol_rank (formal
), actual
->rank
);
2090 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2093 /* At this point, we are considering a scalar passed to an array. This
2094 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2095 - if the actual argument is (a substring of) an element of a
2096 non-assumed-shape/non-pointer/non-polymorphic array; or
2097 - (F2003) if the actual argument is of type character of default/c_char
2100 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2101 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2103 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2105 if (ref
->type
== REF_COMPONENT
)
2106 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2107 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2108 && ref
->u
.ar
.dimen
> 0
2110 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2114 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2117 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2118 "at %L", formal
->name
, &actual
->where
);
2122 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2123 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2126 gfc_error ("Element of assumed-shaped or pointer "
2127 "array passed to array dummy argument '%s' at %L",
2128 formal
->name
, &actual
->where
);
2132 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2133 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2135 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2138 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2139 "CHARACTER actual argument with array dummy argument "
2140 "'%s' at %L", formal
->name
, &actual
->where
);
2144 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2146 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2147 "array dummy argument '%s' at %L",
2148 formal
->name
, &actual
->where
);
2151 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2157 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2160 argument_rank_mismatch (formal
->name
, &actual
->where
,
2161 symbol_rank (formal
), actual
->rank
);
2169 /* Returns the storage size of a symbol (formal argument) or
2170 zero if it cannot be determined. */
2172 static unsigned long
2173 get_sym_storage_size (gfc_symbol
*sym
)
2176 unsigned long strlen
, elements
;
2178 if (sym
->ts
.type
== BT_CHARACTER
)
2180 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2181 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2182 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2189 if (symbol_rank (sym
) == 0)
2193 if (sym
->as
->type
!= AS_EXPLICIT
)
2195 for (i
= 0; i
< sym
->as
->rank
; i
++)
2197 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2198 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2201 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2202 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2205 return strlen
*elements
;
2209 /* Returns the storage size of an expression (actual argument) or
2210 zero if it cannot be determined. For an array element, it returns
2211 the remaining size as the element sequence consists of all storage
2212 units of the actual argument up to the end of the array. */
2214 static unsigned long
2215 get_expr_storage_size (gfc_expr
*e
)
2218 long int strlen
, elements
;
2219 long int substrlen
= 0;
2220 bool is_str_storage
= false;
2226 if (e
->ts
.type
== BT_CHARACTER
)
2228 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2229 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2230 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2231 else if (e
->expr_type
== EXPR_CONSTANT
2232 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2233 strlen
= e
->value
.character
.length
;
2238 strlen
= 1; /* Length per element. */
2240 if (e
->rank
== 0 && !e
->ref
)
2248 for (i
= 0; i
< e
->rank
; i
++)
2249 elements
*= mpz_get_si (e
->shape
[i
]);
2250 return elements
*strlen
;
2253 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2255 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2256 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2260 /* The string length is the substring length.
2261 Set now to full string length. */
2262 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2263 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2266 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2268 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2272 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2273 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2275 long int start
, end
, stride
;
2278 if (ref
->u
.ar
.stride
[i
])
2280 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2281 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2286 if (ref
->u
.ar
.start
[i
])
2288 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2289 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2293 else if (ref
->u
.ar
.as
->lower
[i
]
2294 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2295 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2299 if (ref
->u
.ar
.end
[i
])
2301 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2302 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2306 else if (ref
->u
.ar
.as
->upper
[i
]
2307 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2308 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2312 elements
*= (end
- start
)/stride
+ 1L;
2314 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2315 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2317 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2318 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2319 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2320 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2321 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2326 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2327 && e
->expr_type
== EXPR_VARIABLE
)
2329 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2330 || e
->symtree
->n
.sym
->attr
.pointer
)
2336 /* Determine the number of remaining elements in the element
2337 sequence for array element designators. */
2338 is_str_storage
= true;
2339 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2341 if (ref
->u
.ar
.start
[i
] == NULL
2342 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2343 || ref
->u
.ar
.as
->upper
[i
] == NULL
2344 || ref
->u
.ar
.as
->lower
[i
] == NULL
2345 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2346 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2351 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2352 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2354 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2355 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2361 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2364 return elements
*strlen
;
2368 /* Given an expression, check whether it is an array section
2369 which has a vector subscript. If it has, one is returned,
2373 gfc_has_vector_subscript (gfc_expr
*e
)
2378 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2381 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2382 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2383 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2384 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2391 /* Given formal and actual argument lists, see if they are compatible.
2392 If they are compatible, the actual argument list is sorted to
2393 correspond with the formal list, and elements for missing optional
2394 arguments are inserted. If WHERE pointer is nonnull, then we issue
2395 errors when things don't match instead of just returning the status
2399 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2400 int ranks_must_agree
, int is_elemental
, locus
*where
)
2402 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2403 gfc_formal_arglist
*f
;
2405 unsigned long actual_size
, formal_size
;
2406 bool full_array
= false;
2410 if (actual
== NULL
&& formal
== NULL
)
2414 for (f
= formal
; f
; f
= f
->next
)
2417 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2419 for (i
= 0; i
< n
; i
++)
2426 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2428 /* Look for keywords but ignore g77 extensions like %VAL. */
2429 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2432 for (f
= formal
; f
; f
= f
->next
, i
++)
2436 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2443 gfc_error ("Keyword argument '%s' at %L is not in "
2444 "the procedure", a
->name
, &a
->expr
->where
);
2448 if (new_arg
[i
] != NULL
)
2451 gfc_error ("Keyword argument '%s' at %L is already associated "
2452 "with another actual argument", a
->name
,
2461 gfc_error ("More actual than formal arguments in procedure "
2462 "call at %L", where
);
2467 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2473 gfc_error ("Missing alternate return spec in subroutine call "
2478 if (a
->expr
== NULL
)
2481 gfc_error ("Unexpected alternate return spec in subroutine "
2482 "call at %L", where
);
2486 /* Make sure that intrinsic vtables exist for calls to unlimited
2487 polymorphic formal arguments. */
2488 if (UNLIMITED_POLY (f
->sym
)
2489 && a
->expr
->ts
.type
!= BT_DERIVED
2490 && a
->expr
->ts
.type
!= BT_CLASS
)
2491 gfc_find_intrinsic_vtab (&a
->expr
->ts
);
2493 if (a
->expr
->expr_type
== EXPR_NULL
2494 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2495 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2496 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2497 || (f
->sym
->ts
.type
== BT_CLASS
2498 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2499 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2500 || !f
->sym
->attr
.optional
2501 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2504 && (!f
->sym
->attr
.optional
2505 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2506 || (f
->sym
->ts
.type
== BT_CLASS
2507 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2508 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2509 where
, f
->sym
->name
);
2511 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2512 "dummy '%s'", where
, f
->sym
->name
);
2517 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2518 is_elemental
, where
))
2521 /* TS 29113, 6.3p2. */
2522 if (f
->sym
->ts
.type
== BT_ASSUMED
2523 && (a
->expr
->ts
.type
== BT_DERIVED
2524 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2526 gfc_namespace
*f2k_derived
;
2528 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2529 ? a
->expr
->ts
.u
.derived
->f2k_derived
2530 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2533 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2535 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2536 "derived type with type-bound or FINAL procedures",
2542 /* Special case for character arguments. For allocatable, pointer
2543 and assumed-shape dummies, the string length needs to match
2545 if (a
->expr
->ts
.type
== BT_CHARACTER
2546 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2547 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2548 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2549 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2550 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2551 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2552 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2553 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2555 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2556 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2557 "argument and pointer or allocatable dummy argument "
2559 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2560 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2561 f
->sym
->name
, &a
->expr
->where
);
2563 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2564 "argument and assumed-shape dummy argument '%s' "
2566 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2567 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2568 f
->sym
->name
, &a
->expr
->where
);
2572 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2573 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2574 && a
->expr
->ts
.type
== BT_CHARACTER
)
2577 gfc_error ("Actual argument at %L to allocatable or "
2578 "pointer dummy argument '%s' must have a deferred "
2579 "length type parameter if and only if the dummy has one",
2580 &a
->expr
->where
, f
->sym
->name
);
2584 if (f
->sym
->ts
.type
== BT_CLASS
)
2585 goto skip_size_check
;
2587 actual_size
= get_expr_storage_size (a
->expr
);
2588 formal_size
= get_sym_storage_size (f
->sym
);
2589 if (actual_size
!= 0 && actual_size
< formal_size
2590 && a
->expr
->ts
.type
!= BT_PROCEDURE
2591 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2593 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2594 gfc_warning ("Character length of actual argument shorter "
2595 "than of dummy argument '%s' (%lu/%lu) at %L",
2596 f
->sym
->name
, actual_size
, formal_size
,
2599 gfc_warning ("Actual argument contains too few "
2600 "elements for dummy argument '%s' (%lu/%lu) at %L",
2601 f
->sym
->name
, actual_size
, formal_size
,
2608 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2609 argument is provided for a procedure pointer formal argument. */
2610 if (f
->sym
->attr
.proc_pointer
2611 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2612 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2613 || (a
->expr
->expr_type
== EXPR_FUNCTION
2614 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2615 || gfc_is_proc_ptr_comp (a
->expr
)))
2618 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2619 f
->sym
->name
, &a
->expr
->where
);
2623 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2624 provided for a procedure formal argument. */
2625 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2626 && gfc_expr_attr (a
->expr
).flavor
!= FL_PROCEDURE
)
2629 gfc_error ("Expected a procedure for argument '%s' at %L",
2630 f
->sym
->name
, &a
->expr
->where
);
2634 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2635 && a
->expr
->expr_type
== EXPR_VARIABLE
2636 && a
->expr
->symtree
->n
.sym
->as
2637 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2638 && (a
->expr
->ref
== NULL
2639 || (a
->expr
->ref
->type
== REF_ARRAY
2640 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2643 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2644 " array at %L", f
->sym
->name
, where
);
2648 if (a
->expr
->expr_type
!= EXPR_NULL
2649 && compare_pointer (f
->sym
, a
->expr
) == 0)
2652 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2653 f
->sym
->name
, &a
->expr
->where
);
2657 if (a
->expr
->expr_type
!= EXPR_NULL
2658 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2659 && compare_pointer (f
->sym
, a
->expr
) == 2)
2662 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2663 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2668 /* Fortran 2008, C1242. */
2669 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2672 gfc_error ("Coindexed actual argument at %L to pointer "
2674 &a
->expr
->where
, f
->sym
->name
);
2678 /* Fortran 2008, 12.5.2.5 (no constraint). */
2679 if (a
->expr
->expr_type
== EXPR_VARIABLE
2680 && f
->sym
->attr
.intent
!= INTENT_IN
2681 && f
->sym
->attr
.allocatable
2682 && gfc_is_coindexed (a
->expr
))
2685 gfc_error ("Coindexed actual argument at %L to allocatable "
2686 "dummy '%s' requires INTENT(IN)",
2687 &a
->expr
->where
, f
->sym
->name
);
2691 /* Fortran 2008, C1237. */
2692 if (a
->expr
->expr_type
== EXPR_VARIABLE
2693 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2694 && gfc_is_coindexed (a
->expr
)
2695 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2696 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2699 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2700 "%L requires that dummy '%s' has neither "
2701 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2706 /* Fortran 2008, 12.5.2.4 (no constraint). */
2707 if (a
->expr
->expr_type
== EXPR_VARIABLE
2708 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2709 && gfc_is_coindexed (a
->expr
)
2710 && gfc_has_ultimate_allocatable (a
->expr
))
2713 gfc_error ("Coindexed actual argument at %L with allocatable "
2714 "ultimate component to dummy '%s' requires either VALUE "
2715 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2719 if (f
->sym
->ts
.type
== BT_CLASS
2720 && CLASS_DATA (f
->sym
)->attr
.allocatable
2721 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2725 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2726 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2731 if (a
->expr
->expr_type
!= EXPR_NULL
2732 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2735 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2736 f
->sym
->name
, &a
->expr
->where
);
2740 /* Check intent = OUT/INOUT for definable actual argument. */
2741 if ((f
->sym
->attr
.intent
== INTENT_OUT
2742 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2744 const char* context
= (where
2745 ? _("actual argument to INTENT = OUT/INOUT")
2748 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2749 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2750 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2751 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
2753 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
2757 if ((f
->sym
->attr
.intent
== INTENT_OUT
2758 || f
->sym
->attr
.intent
== INTENT_INOUT
2759 || f
->sym
->attr
.volatile_
2760 || f
->sym
->attr
.asynchronous
)
2761 && gfc_has_vector_subscript (a
->expr
))
2764 gfc_error ("Array-section actual argument with vector "
2765 "subscripts at %L is incompatible with INTENT(OUT), "
2766 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2767 "of the dummy argument '%s'",
2768 &a
->expr
->where
, f
->sym
->name
);
2772 /* C1232 (R1221) For an actual argument which is an array section or
2773 an assumed-shape array, the dummy argument shall be an assumed-
2774 shape array, if the dummy argument has the VOLATILE attribute. */
2776 if (f
->sym
->attr
.volatile_
2777 && a
->expr
->symtree
->n
.sym
->as
2778 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2779 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2782 gfc_error ("Assumed-shape actual argument at %L is "
2783 "incompatible with the non-assumed-shape "
2784 "dummy argument '%s' due to VOLATILE attribute",
2785 &a
->expr
->where
,f
->sym
->name
);
2789 if (f
->sym
->attr
.volatile_
2790 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2791 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2794 gfc_error ("Array-section actual argument at %L is "
2795 "incompatible with the non-assumed-shape "
2796 "dummy argument '%s' due to VOLATILE attribute",
2797 &a
->expr
->where
,f
->sym
->name
);
2801 /* C1233 (R1221) For an actual argument which is a pointer array, the
2802 dummy argument shall be an assumed-shape or pointer array, if the
2803 dummy argument has the VOLATILE attribute. */
2805 if (f
->sym
->attr
.volatile_
2806 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2807 && a
->expr
->symtree
->n
.sym
->as
2809 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2810 || f
->sym
->attr
.pointer
)))
2813 gfc_error ("Pointer-array actual argument at %L requires "
2814 "an assumed-shape or pointer-array dummy "
2815 "argument '%s' due to VOLATILE attribute",
2816 &a
->expr
->where
,f
->sym
->name
);
2827 /* Make sure missing actual arguments are optional. */
2829 for (f
= formal
; f
; f
= f
->next
, i
++)
2831 if (new_arg
[i
] != NULL
)
2836 gfc_error ("Missing alternate return spec in subroutine call "
2840 if (!f
->sym
->attr
.optional
)
2843 gfc_error ("Missing actual argument for argument '%s' at %L",
2844 f
->sym
->name
, where
);
2849 /* The argument lists are compatible. We now relink a new actual
2850 argument list with null arguments in the right places. The head
2851 of the list remains the head. */
2852 for (i
= 0; i
< n
; i
++)
2853 if (new_arg
[i
] == NULL
)
2854 new_arg
[i
] = gfc_get_actual_arglist ();
2859 *new_arg
[0] = *actual
;
2863 new_arg
[0] = new_arg
[na
];
2867 for (i
= 0; i
< n
- 1; i
++)
2868 new_arg
[i
]->next
= new_arg
[i
+ 1];
2870 new_arg
[i
]->next
= NULL
;
2872 if (*ap
== NULL
&& n
> 0)
2875 /* Note the types of omitted optional arguments. */
2876 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2877 if (a
->expr
== NULL
&& a
->label
== NULL
)
2878 a
->missing_arg_type
= f
->sym
->ts
.type
;
2886 gfc_formal_arglist
*f
;
2887 gfc_actual_arglist
*a
;
2891 /* qsort comparison function for argument pairs, with the following
2893 - p->a->expr == NULL
2894 - p->a->expr->expr_type != EXPR_VARIABLE
2895 - growing p->a->expr->symbol. */
2898 pair_cmp (const void *p1
, const void *p2
)
2900 const gfc_actual_arglist
*a1
, *a2
;
2902 /* *p1 and *p2 are elements of the to-be-sorted array. */
2903 a1
= ((const argpair
*) p1
)->a
;
2904 a2
= ((const argpair
*) p2
)->a
;
2913 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2915 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2919 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2921 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2925 /* Given two expressions from some actual arguments, test whether they
2926 refer to the same expression. The analysis is conservative.
2927 Returning false will produce no warning. */
2930 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2932 const gfc_ref
*r1
, *r2
;
2935 || e1
->expr_type
!= EXPR_VARIABLE
2936 || e2
->expr_type
!= EXPR_VARIABLE
2937 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2940 /* TODO: improve comparison, see expr.c:show_ref(). */
2941 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2943 if (r1
->type
!= r2
->type
)
2948 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2950 /* TODO: At the moment, consider only full arrays;
2951 we could do better. */
2952 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2957 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2965 gfc_internal_error ("compare_actual_expr(): Bad component code");
2974 /* Given formal and actual argument lists that correspond to one
2975 another, check that identical actual arguments aren't not
2976 associated with some incompatible INTENTs. */
2979 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2981 sym_intent f1_intent
, f2_intent
;
2982 gfc_formal_arglist
*f1
;
2983 gfc_actual_arglist
*a1
;
2989 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2991 if (f1
== NULL
&& a1
== NULL
)
2993 if (f1
== NULL
|| a1
== NULL
)
2994 gfc_internal_error ("check_some_aliasing(): List mismatch");
2999 p
= XALLOCAVEC (argpair
, n
);
3001 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3007 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3009 for (i
= 0; i
< n
; i
++)
3012 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3013 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3015 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3016 for (j
= i
+ 1; j
< n
; j
++)
3018 /* Expected order after the sort. */
3019 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3020 gfc_internal_error ("check_some_aliasing(): corrupted data");
3022 /* Are the expression the same? */
3023 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3025 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3026 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3027 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
3029 gfc_warning ("Same actual argument associated with INTENT(%s) "
3030 "argument '%s' and INTENT(%s) argument '%s' at %L",
3031 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3032 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3033 &p
[i
].a
->expr
->where
);
3043 /* Given formal and actual argument lists that correspond to one
3044 another, check that they are compatible in the sense that intents
3045 are not mismatched. */
3048 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3050 sym_intent f_intent
;
3052 for (;; f
= f
->next
, a
= a
->next
)
3054 if (f
== NULL
&& a
== NULL
)
3056 if (f
== NULL
|| a
== NULL
)
3057 gfc_internal_error ("check_intents(): List mismatch");
3059 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
3062 f_intent
= f
->sym
->attr
.intent
;
3064 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
3066 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3067 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3068 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3070 gfc_error ("Procedure argument at %L is local to a PURE "
3071 "procedure and has the POINTER attribute",
3077 /* Fortran 2008, C1283. */
3078 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
3080 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3082 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3083 "is passed to an INTENT(%s) argument",
3084 &a
->expr
->where
, gfc_intent_string (f_intent
));
3088 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3089 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3090 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3092 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3093 "is passed to a POINTER dummy argument",
3099 /* F2008, Section 12.5.2.4. */
3100 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3101 && gfc_is_coindexed (a
->expr
))
3103 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3104 "polymorphic dummy argument '%s'",
3105 &a
->expr
->where
, f
->sym
->name
);
3114 /* Check how a procedure is used against its interface. If all goes
3115 well, the actual argument list will also end up being properly
3119 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3121 gfc_formal_arglist
*dummy_args
;
3123 /* Warn about calls with an implicit interface. Special case
3124 for calling a ISO_C_BINDING becase c_loc and c_funloc
3125 are pseudo-unknown. Additionally, warn about procedures not
3126 explicitly declared at all if requested. */
3127 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
3129 if (gfc_option
.warn_implicit_interface
)
3130 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3132 else if (gfc_option
.warn_implicit_procedure
3133 && sym
->attr
.proc
== PROC_UNKNOWN
)
3134 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3138 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3140 gfc_actual_arglist
*a
;
3142 if (sym
->attr
.pointer
)
3144 gfc_error("The pointer object '%s' at %L must have an explicit "
3145 "function interface or be declared as array",
3150 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3152 gfc_error("The allocatable object '%s' at %L must have an explicit "
3153 "function interface or be declared as array",
3158 if (sym
->attr
.allocatable
)
3160 gfc_error("Allocatable function '%s' at %L must have an explicit "
3161 "function interface", sym
->name
, where
);
3165 for (a
= *ap
; a
; a
= a
->next
)
3167 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3168 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3170 gfc_error("Keyword argument requires explicit interface "
3171 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
3175 /* TS 29113, 6.2. */
3176 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3177 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3179 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3180 "interface", a
->expr
->symtree
->n
.sym
->name
,
3185 /* F2008, C1303 and C1304. */
3187 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3188 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3189 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3190 || gfc_expr_attr (a
->expr
).lock_comp
))
3192 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3193 "component at %L requires an explicit interface for "
3194 "procedure '%s'", &a
->expr
->where
, sym
->name
);
3198 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3199 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3201 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3205 /* TS 29113, C407b. */
3206 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3207 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3209 gfc_error ("Assumed-rank argument requires an explicit interface "
3210 "at %L", &a
->expr
->where
);
3218 dummy_args
= gfc_sym_get_dummy_args (sym
);
3220 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3223 if (!check_intents (dummy_args
, *ap
))
3226 if (gfc_option
.warn_aliasing
)
3227 check_some_aliasing (dummy_args
, *ap
);
3233 /* Check how a procedure pointer component is used against its interface.
3234 If all goes well, the actual argument list will also end up being properly
3235 sorted. Completely analogous to gfc_procedure_use. */
3238 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3240 /* Warn about calls with an implicit interface. Special case
3241 for calling a ISO_C_BINDING becase c_loc and c_funloc
3242 are pseudo-unknown. */
3243 if (gfc_option
.warn_implicit_interface
3244 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3245 && !comp
->attr
.is_iso_c
)
3246 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3247 "interface at %L", comp
->name
, where
);
3249 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3251 gfc_actual_arglist
*a
;
3252 for (a
= *ap
; a
; a
= a
->next
)
3254 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3255 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3257 gfc_error("Keyword argument requires explicit interface "
3258 "for procedure pointer component '%s' at %L",
3259 comp
->name
, &a
->expr
->where
);
3267 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3268 comp
->attr
.elemental
, where
))
3271 check_intents (comp
->ts
.interface
->formal
, *ap
);
3272 if (gfc_option
.warn_aliasing
)
3273 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3277 /* Try if an actual argument list matches the formal list of a symbol,
3278 respecting the symbol's attributes like ELEMENTAL. This is used for
3279 GENERIC resolution. */
3282 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3284 gfc_formal_arglist
*dummy_args
;
3287 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3289 dummy_args
= gfc_sym_get_dummy_args (sym
);
3291 r
= !sym
->attr
.elemental
;
3292 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3294 check_intents (dummy_args
, *args
);
3295 if (gfc_option
.warn_aliasing
)
3296 check_some_aliasing (dummy_args
, *args
);
3304 /* Given an interface pointer and an actual argument list, search for
3305 a formal argument list that matches the actual. If found, returns
3306 a pointer to the symbol of the correct interface. Returns NULL if
3310 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3311 gfc_actual_arglist
**ap
)
3313 gfc_symbol
*elem_sym
= NULL
;
3314 gfc_symbol
*null_sym
= NULL
;
3315 locus null_expr_loc
;
3316 gfc_actual_arglist
*a
;
3317 bool has_null_arg
= false;
3319 for (a
= *ap
; a
; a
= a
->next
)
3320 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3321 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3323 has_null_arg
= true;
3324 null_expr_loc
= a
->expr
->where
;
3328 for (; intr
; intr
= intr
->next
)
3330 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3332 if (sub_flag
&& intr
->sym
->attr
.function
)
3334 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3337 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3339 if (has_null_arg
&& null_sym
)
3341 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3342 "between specific functions %s and %s",
3343 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3346 else if (has_null_arg
)
3348 null_sym
= intr
->sym
;
3352 /* Satisfy 12.4.4.1 such that an elemental match has lower
3353 weight than a non-elemental match. */
3354 if (intr
->sym
->attr
.elemental
)
3356 elem_sym
= intr
->sym
;
3366 return elem_sym
? elem_sym
: NULL
;
3370 /* Do a brute force recursive search for a symbol. */
3372 static gfc_symtree
*
3373 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3377 if (root
->n
.sym
== sym
)
3382 st
= find_symtree0 (root
->left
, sym
);
3383 if (root
->right
&& ! st
)
3384 st
= find_symtree0 (root
->right
, sym
);
3389 /* Find a symtree for a symbol. */
3392 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3397 /* First try to find it by name. */
3398 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3399 if (st
&& st
->n
.sym
== sym
)
3402 /* If it's been renamed, resort to a brute-force search. */
3403 /* TODO: avoid having to do this search. If the symbol doesn't exist
3404 in the symtree for the current namespace, it should probably be added. */
3405 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3407 st
= find_symtree0 (ns
->sym_root
, sym
);
3411 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3416 /* See if the arglist to an operator-call contains a derived-type argument
3417 with a matching type-bound operator. If so, return the matching specific
3418 procedure defined as operator-target as well as the base-object to use
3419 (which is the found derived-type argument with operator). The generic
3420 name, if any, is transmitted to the final expression via 'gname'. */
3422 static gfc_typebound_proc
*
3423 matching_typebound_op (gfc_expr
** tb_base
,
3424 gfc_actual_arglist
* args
,
3425 gfc_intrinsic_op op
, const char* uop
,
3426 const char ** gname
)
3428 gfc_actual_arglist
* base
;
3430 for (base
= args
; base
; base
= base
->next
)
3431 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3433 gfc_typebound_proc
* tb
;
3434 gfc_symbol
* derived
;
3437 while (base
->expr
->expr_type
== EXPR_OP
3438 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3439 base
->expr
= base
->expr
->value
.op
.op1
;
3441 if (base
->expr
->ts
.type
== BT_CLASS
)
3443 if (CLASS_DATA (base
->expr
) == NULL
3444 || !gfc_expr_attr (base
->expr
).class_ok
)
3446 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3449 derived
= base
->expr
->ts
.u
.derived
;
3451 if (op
== INTRINSIC_USER
)
3453 gfc_symtree
* tb_uop
;
3456 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3465 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3468 /* This means we hit a PRIVATE operator which is use-associated and
3469 should thus not be seen. */
3473 /* Look through the super-type hierarchy for a matching specific
3475 for (; tb
; tb
= tb
->overridden
)
3479 gcc_assert (tb
->is_generic
);
3480 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3483 gfc_actual_arglist
* argcopy
;
3486 gcc_assert (g
->specific
);
3487 if (g
->specific
->error
)
3490 target
= g
->specific
->u
.specific
->n
.sym
;
3492 /* Check if this arglist matches the formal. */
3493 argcopy
= gfc_copy_actual_arglist (args
);
3494 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3495 gfc_free_actual_arglist (argcopy
);
3497 /* Return if we found a match. */
3500 *tb_base
= base
->expr
;
3501 *gname
= g
->specific_st
->name
;
3512 /* For the 'actual arglist' of an operator call and a specific typebound
3513 procedure that has been found the target of a type-bound operator, build the
3514 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3515 type-bound procedures rather than resolving type-bound operators 'directly'
3516 so that we can reuse the existing logic. */
3519 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3520 gfc_expr
* base
, gfc_typebound_proc
* target
,
3523 e
->expr_type
= EXPR_COMPCALL
;
3524 e
->value
.compcall
.tbp
= target
;
3525 e
->value
.compcall
.name
= gname
? gname
: "$op";
3526 e
->value
.compcall
.actual
= actual
;
3527 e
->value
.compcall
.base_object
= base
;
3528 e
->value
.compcall
.ignore_pass
= 1;
3529 e
->value
.compcall
.assign
= 0;
3530 if (e
->ts
.type
== BT_UNKNOWN
3531 && target
->function
)
3533 if (target
->is_generic
)
3534 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3536 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3541 /* This subroutine is called when an expression is being resolved.
3542 The expression node in question is either a user defined operator
3543 or an intrinsic operator with arguments that aren't compatible
3544 with the operator. This subroutine builds an actual argument list
3545 corresponding to the operands, then searches for a compatible
3546 interface. If one is found, the expression node is replaced with
3547 the appropriate function call. We use the 'match' enum to specify
3548 whether a replacement has been made or not, or if an error occurred. */
3551 gfc_extend_expr (gfc_expr
*e
)
3553 gfc_actual_arglist
*actual
;
3562 actual
= gfc_get_actual_arglist ();
3563 actual
->expr
= e
->value
.op
.op1
;
3567 if (e
->value
.op
.op2
!= NULL
)
3569 actual
->next
= gfc_get_actual_arglist ();
3570 actual
->next
->expr
= e
->value
.op
.op2
;
3573 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3575 if (i
== INTRINSIC_USER
)
3577 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3579 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3583 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3590 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3592 /* Due to the distinction between '==' and '.eq.' and friends, one has
3593 to check if either is defined. */
3596 #define CHECK_OS_COMPARISON(comp) \
3597 case INTRINSIC_##comp: \
3598 case INTRINSIC_##comp##_OS: \
3599 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3601 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3603 CHECK_OS_COMPARISON(EQ
)
3604 CHECK_OS_COMPARISON(NE
)
3605 CHECK_OS_COMPARISON(GT
)
3606 CHECK_OS_COMPARISON(GE
)
3607 CHECK_OS_COMPARISON(LT
)
3608 CHECK_OS_COMPARISON(LE
)
3609 #undef CHECK_OS_COMPARISON
3612 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3620 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3621 found rather than just taking the first one and not checking further. */
3625 gfc_typebound_proc
* tbo
;
3628 /* See if we find a matching type-bound operator. */
3629 if (i
== INTRINSIC_USER
)
3630 tbo
= matching_typebound_op (&tb_base
, actual
,
3631 i
, e
->value
.op
.uop
->name
, &gname
);
3635 #define CHECK_OS_COMPARISON(comp) \
3636 case INTRINSIC_##comp: \
3637 case INTRINSIC_##comp##_OS: \
3638 tbo = matching_typebound_op (&tb_base, actual, \
3639 INTRINSIC_##comp, NULL, &gname); \
3641 tbo = matching_typebound_op (&tb_base, actual, \
3642 INTRINSIC_##comp##_OS, NULL, &gname); \
3644 CHECK_OS_COMPARISON(EQ
)
3645 CHECK_OS_COMPARISON(NE
)
3646 CHECK_OS_COMPARISON(GT
)
3647 CHECK_OS_COMPARISON(GE
)
3648 CHECK_OS_COMPARISON(LT
)
3649 CHECK_OS_COMPARISON(LE
)
3650 #undef CHECK_OS_COMPARISON
3653 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3657 /* If there is a matching typebound-operator, replace the expression with
3658 a call to it and succeed. */
3663 gcc_assert (tb_base
);
3664 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3666 result
= gfc_resolve_expr (e
);
3673 /* Don't use gfc_free_actual_arglist(). */
3674 free (actual
->next
);
3680 /* Change the expression node to a function call. */
3681 e
->expr_type
= EXPR_FUNCTION
;
3682 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3683 e
->value
.function
.actual
= actual
;
3684 e
->value
.function
.esym
= NULL
;
3685 e
->value
.function
.isym
= NULL
;
3686 e
->value
.function
.name
= NULL
;
3687 e
->user_operator
= 1;
3689 if (!gfc_resolve_expr (e
))
3696 /* Tries to replace an assignment code node with a subroutine call to
3697 the subroutine associated with the assignment operator. Return
3698 true if the node was replaced. On false, no error is
3702 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3704 gfc_actual_arglist
*actual
;
3705 gfc_expr
*lhs
, *rhs
;
3714 /* Don't allow an intrinsic assignment to be replaced. */
3715 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3716 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3717 && (lhs
->ts
.type
== rhs
->ts
.type
3718 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3721 actual
= gfc_get_actual_arglist ();
3724 actual
->next
= gfc_get_actual_arglist ();
3725 actual
->next
->expr
= rhs
;
3729 for (; ns
; ns
= ns
->parent
)
3731 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3736 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3740 gfc_typebound_proc
* tbo
;
3743 /* See if we find a matching type-bound assignment. */
3744 tbo
= matching_typebound_op (&tb_base
, actual
,
3745 INTRINSIC_ASSIGN
, NULL
, &gname
);
3747 /* If there is one, replace the expression with a call to it and
3751 gcc_assert (tb_base
);
3752 c
->expr1
= gfc_get_expr ();
3753 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3754 c
->expr1
->value
.compcall
.assign
= 1;
3755 c
->expr1
->where
= c
->loc
;
3757 c
->op
= EXEC_COMPCALL
;
3759 /* c is resolved from the caller, so no need to do it here. */
3764 free (actual
->next
);
3769 /* Replace the assignment with the call. */
3770 c
->op
= EXEC_ASSIGN_CALL
;
3771 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3774 c
->ext
.actual
= actual
;
3780 /* Make sure that the interface just parsed is not already present in
3781 the given interface list. Ambiguity isn't checked yet since module
3782 procedures can be present without interfaces. */
3785 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3789 for (ip
= base
; ip
; ip
= ip
->next
)
3791 if (ip
->sym
== new_sym
)
3793 gfc_error ("Entity '%s' at %L is already present in the interface",
3794 new_sym
->name
, &loc
);
3803 /* Add a symbol to the current interface. */
3806 gfc_add_interface (gfc_symbol
*new_sym
)
3808 gfc_interface
**head
, *intr
;
3812 switch (current_interface
.type
)
3814 case INTERFACE_NAMELESS
:
3815 case INTERFACE_ABSTRACT
:
3818 case INTERFACE_INTRINSIC_OP
:
3819 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3820 switch (current_interface
.op
)
3823 case INTRINSIC_EQ_OS
:
3824 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3826 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
3827 new_sym
, gfc_current_locus
))
3832 case INTRINSIC_NE_OS
:
3833 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3835 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
3836 new_sym
, gfc_current_locus
))
3841 case INTRINSIC_GT_OS
:
3842 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
3843 new_sym
, gfc_current_locus
)
3844 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
3845 new_sym
, gfc_current_locus
))
3850 case INTRINSIC_GE_OS
:
3851 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
3852 new_sym
, gfc_current_locus
)
3853 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
3854 new_sym
, gfc_current_locus
))
3859 case INTRINSIC_LT_OS
:
3860 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
3861 new_sym
, gfc_current_locus
)
3862 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
3863 new_sym
, gfc_current_locus
))
3868 case INTRINSIC_LE_OS
:
3869 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
3870 new_sym
, gfc_current_locus
)
3871 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
3872 new_sym
, gfc_current_locus
))
3877 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
3878 new_sym
, gfc_current_locus
))
3882 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3885 case INTERFACE_GENERIC
:
3886 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3888 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3892 if (!gfc_check_new_interface (sym
->generic
,
3893 new_sym
, gfc_current_locus
))
3897 head
= ¤t_interface
.sym
->generic
;
3900 case INTERFACE_USER_OP
:
3901 if (!gfc_check_new_interface (current_interface
.uop
->op
,
3902 new_sym
, gfc_current_locus
))
3905 head
= ¤t_interface
.uop
->op
;
3909 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3912 intr
= gfc_get_interface ();
3913 intr
->sym
= new_sym
;
3914 intr
->where
= gfc_current_locus
;
3924 gfc_current_interface_head (void)
3926 switch (current_interface
.type
)
3928 case INTERFACE_INTRINSIC_OP
:
3929 return current_interface
.ns
->op
[current_interface
.op
];
3932 case INTERFACE_GENERIC
:
3933 return current_interface
.sym
->generic
;
3936 case INTERFACE_USER_OP
:
3937 return current_interface
.uop
->op
;
3947 gfc_set_current_interface_head (gfc_interface
*i
)
3949 switch (current_interface
.type
)
3951 case INTERFACE_INTRINSIC_OP
:
3952 current_interface
.ns
->op
[current_interface
.op
] = i
;
3955 case INTERFACE_GENERIC
:
3956 current_interface
.sym
->generic
= i
;
3959 case INTERFACE_USER_OP
:
3960 current_interface
.uop
->op
= i
;
3969 /* Gets rid of a formal argument list. We do not free symbols.
3970 Symbols are freed when a namespace is freed. */
3973 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3975 gfc_formal_arglist
*q
;
3985 /* Check that it is ok for the type-bound procedure 'proc' to override the
3986 procedure 'old', cf. F08:4.5.7.3. */
3989 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
3992 gfc_symbol
*proc_target
, *old_target
;
3993 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
3994 gfc_formal_arglist
*proc_formal
, *old_formal
;
3998 /* This procedure should only be called for non-GENERIC proc. */
3999 gcc_assert (!proc
->n
.tb
->is_generic
);
4001 /* If the overwritten procedure is GENERIC, this is an error. */
4002 if (old
->n
.tb
->is_generic
)
4004 gfc_error ("Can't overwrite GENERIC '%s' at %L",
4005 old
->name
, &proc
->n
.tb
->where
);
4009 where
= proc
->n
.tb
->where
;
4010 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4011 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4013 /* Check that overridden binding is not NON_OVERRIDABLE. */
4014 if (old
->n
.tb
->non_overridable
)
4016 gfc_error ("'%s' at %L overrides a procedure binding declared"
4017 " NON_OVERRIDABLE", proc
->name
, &where
);
4021 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4022 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4024 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
4025 " non-DEFERRED binding", proc
->name
, &where
);
4029 /* If the overridden binding is PURE, the overriding must be, too. */
4030 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4032 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
4033 proc
->name
, &where
);
4037 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4038 is not, the overriding must not be either. */
4039 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4041 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
4042 " ELEMENTAL", proc
->name
, &where
);
4045 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4047 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
4048 " be ELEMENTAL, either", proc
->name
, &where
);
4052 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4054 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4056 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4057 " SUBROUTINE", proc
->name
, &where
);
4061 /* If the overridden binding is a FUNCTION, the overriding must also be a
4062 FUNCTION and have the same characteristics. */
4063 if (old_target
->attr
.function
)
4065 if (!proc_target
->attr
.function
)
4067 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4068 " FUNCTION", proc
->name
, &where
);
4072 if (!check_result_characteristics (proc_target
, old_target
, err
,
4075 gfc_error ("Result mismatch for the overriding procedure "
4076 "'%s' at %L: %s", proc
->name
, &where
, err
);
4081 /* If the overridden binding is PUBLIC, the overriding one must not be
4083 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4084 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4086 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4087 " PRIVATE", proc
->name
, &where
);
4091 /* Compare the formal argument lists of both procedures. This is also abused
4092 to find the position of the passed-object dummy arguments of both
4093 bindings as at least the overridden one might not yet be resolved and we
4094 need those positions in the check below. */
4095 proc_pass_arg
= old_pass_arg
= 0;
4096 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4098 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4101 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4102 old_formal
= gfc_sym_get_dummy_args (old_target
);
4103 for ( ; proc_formal
&& old_formal
;
4104 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4106 if (proc
->n
.tb
->pass_arg
4107 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4108 proc_pass_arg
= argpos
;
4109 if (old
->n
.tb
->pass_arg
4110 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4111 old_pass_arg
= argpos
;
4113 /* Check that the names correspond. */
4114 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4116 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4117 " to match the corresponding argument of the overridden"
4118 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4119 old_formal
->sym
->name
);
4123 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4124 if (!check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4125 check_type
, err
, sizeof(err
)))
4127 gfc_error ("Argument mismatch for the overriding procedure "
4128 "'%s' at %L: %s", proc
->name
, &where
, err
);
4134 if (proc_formal
|| old_formal
)
4136 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4137 " the overridden procedure", proc
->name
, &where
);
4141 /* If the overridden binding is NOPASS, the overriding one must also be
4143 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4145 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4146 " NOPASS", proc
->name
, &where
);
4150 /* If the overridden binding is PASS(x), the overriding one must also be
4151 PASS and the passed-object dummy arguments must correspond. */
4152 if (!old
->n
.tb
->nopass
)
4154 if (proc
->n
.tb
->nopass
)
4156 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4157 " PASS", proc
->name
, &where
);
4161 if (proc_pass_arg
!= old_pass_arg
)
4163 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4164 " the same position as the passed-object dummy argument of"
4165 " the overridden procedure", proc
->name
, &where
);