1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Deal with interfaces. An explicit interface is represented as a
25 singly linked list of formal argument structures attached to the
26 relevant symbols. For an implicit interface, the arguments don't
27 point to symbols. Explicit interfaces point to namespaces that
28 contain the symbols within that interface.
30 Implicit interfaces are linked together in a singly linked list
31 along the next_if member of symbol nodes. Since a particular
32 symbol can only have a single explicit interface, the symbol cannot
33 be part of multiple lists and a single next-member suffices.
35 This is not the case for general classes, though. An operator
36 definition is independent of just about all other uses and has it's
40 Nameless interfaces create symbols with explicit interfaces within
41 the current namespace. They are otherwise unlinked.
44 The generic name points to a linked list of symbols. Each symbol
45 has an explicit interface. Each explicit interface has its own
46 namespace containing the arguments. Module procedures are symbols in
47 which the interface is added later when the module procedure is parsed.
50 User-defined operators are stored in a their own set of symtrees
51 separate from regular symbols. The symtrees point to gfc_user_op
52 structures which in turn head up a list of relevant interfaces.
54 Extended intrinsics and assignment:
55 The head of these interface lists are stored in the containing namespace.
58 An implicit interface is represented as a singly linked list of
59 formal argument list structures that don't point to any symbol
60 nodes -- they just contain types.
63 When a subprogram is defined, the program unit's name points to an
64 interface as usual, but the link to the namespace is NULL and the
65 formal argument list points to symbols within the same namespace as
66 the program unit name. */
70 #include "coretypes.h"
75 /* The current_interface structure holds information about the
76 interface currently being parsed. This structure is saved and
77 restored during recursive interfaces. */
79 gfc_interface_info current_interface
;
82 /* Free a singly linked list of gfc_interface structures. */
85 gfc_free_interface (gfc_interface
*intr
)
89 for (; intr
; intr
= next
)
97 /* Change the operators unary plus and minus into binary plus and
98 minus respectively, leaving the rest unchanged. */
100 static gfc_intrinsic_op
101 fold_unary_intrinsic (gfc_intrinsic_op op
)
105 case INTRINSIC_UPLUS
:
108 case INTRINSIC_UMINUS
:
109 op
= INTRINSIC_MINUS
;
119 /* Match a generic specification. Depending on which type of
120 interface is found, the 'name' or 'op' pointers may be set.
121 This subroutine doesn't return MATCH_NO. */
124 gfc_match_generic_spec (interface_type
*type
,
126 gfc_intrinsic_op
*op
)
128 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
132 if (gfc_match (" assignment ( = )") == MATCH_YES
)
134 *type
= INTERFACE_INTRINSIC_OP
;
135 *op
= INTRINSIC_ASSIGN
;
139 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
141 *type
= INTERFACE_INTRINSIC_OP
;
142 *op
= fold_unary_intrinsic (i
);
146 *op
= INTRINSIC_NONE
;
147 if (gfc_match (" operator ( ") == MATCH_YES
)
149 m
= gfc_match_defined_op_name (buffer
, 1);
155 m
= gfc_match_char (')');
161 strcpy (name
, buffer
);
162 *type
= INTERFACE_USER_OP
;
166 if (gfc_match_name (buffer
) == MATCH_YES
)
168 strcpy (name
, buffer
);
169 *type
= INTERFACE_GENERIC
;
173 *type
= INTERFACE_NAMELESS
;
177 gfc_error ("Syntax error in generic specification at %C");
182 /* Match one of the five F95 forms of an interface statement. The
183 matcher for the abstract interface follows. */
186 gfc_match_interface (void)
188 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
194 m
= gfc_match_space ();
196 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
199 /* If we're not looking at the end of the statement now, or if this
200 is not a nameless interface but we did not see a space, punt. */
201 if (gfc_match_eos () != MATCH_YES
202 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
204 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
209 current_interface
.type
= type
;
213 case INTERFACE_GENERIC
:
214 if (gfc_get_symbol (name
, NULL
, &sym
))
217 if (!sym
->attr
.generic
218 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
223 gfc_error ("Dummy procedure '%s' at %C cannot have a "
224 "generic interface", sym
->name
);
228 current_interface
.sym
= gfc_new_block
= sym
;
231 case INTERFACE_USER_OP
:
232 current_interface
.uop
= gfc_get_uop (name
);
235 case INTERFACE_INTRINSIC_OP
:
236 current_interface
.op
= op
;
239 case INTERFACE_NAMELESS
:
240 case INTERFACE_ABSTRACT
:
249 /* Match a F2003 abstract interface. */
252 gfc_match_abstract_interface (void)
256 if (gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C")
260 m
= gfc_match_eos ();
264 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
268 current_interface
.type
= INTERFACE_ABSTRACT
;
274 /* Match the different sort of generic-specs that can be present after
275 the END INTERFACE itself. */
278 gfc_match_end_interface (void)
280 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
285 m
= gfc_match_space ();
287 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
290 /* If we're not looking at the end of the statement now, or if this
291 is not a nameless interface but we did not see a space, punt. */
292 if (gfc_match_eos () != MATCH_YES
293 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
295 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
302 switch (current_interface
.type
)
304 case INTERFACE_NAMELESS
:
305 case INTERFACE_ABSTRACT
:
306 if (type
!= INTERFACE_NAMELESS
)
308 gfc_error ("Expected a nameless interface at %C");
314 case INTERFACE_INTRINSIC_OP
:
315 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
318 if (current_interface
.op
== INTRINSIC_ASSIGN
)
321 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
326 s1
= gfc_op2string (current_interface
.op
);
327 s2
= gfc_op2string (op
);
329 /* The following if-statements are used to enforce C1202
331 if ((strcmp(s1
, "==") == 0 && strcmp(s2
, ".eq.") == 0)
332 || (strcmp(s1
, ".eq.") == 0 && strcmp(s2
, "==") == 0))
334 if ((strcmp(s1
, "/=") == 0 && strcmp(s2
, ".ne.") == 0)
335 || (strcmp(s1
, ".ne.") == 0 && strcmp(s2
, "/=") == 0))
337 if ((strcmp(s1
, "<=") == 0 && strcmp(s2
, ".le.") == 0)
338 || (strcmp(s1
, ".le.") == 0 && strcmp(s2
, "<=") == 0))
340 if ((strcmp(s1
, "<") == 0 && strcmp(s2
, ".lt.") == 0)
341 || (strcmp(s1
, ".lt.") == 0 && strcmp(s2
, "<") == 0))
343 if ((strcmp(s1
, ">=") == 0 && strcmp(s2
, ".ge.") == 0)
344 || (strcmp(s1
, ".ge.") == 0 && strcmp(s2
, ">=") == 0))
346 if ((strcmp(s1
, ">") == 0 && strcmp(s2
, ".gt.") == 0)
347 || (strcmp(s1
, ".gt.") == 0 && strcmp(s2
, ">") == 0))
351 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
352 "but got %s", s1
, s2
);
359 case INTERFACE_USER_OP
:
360 /* Comparing the symbol node names is OK because only use-associated
361 symbols can be renamed. */
362 if (type
!= current_interface
.type
363 || strcmp (current_interface
.uop
->name
, name
) != 0)
365 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
366 current_interface
.uop
->name
);
372 case INTERFACE_GENERIC
:
373 if (type
!= current_interface
.type
374 || strcmp (current_interface
.sym
->name
, name
) != 0)
376 gfc_error ("Expecting 'END INTERFACE %s' at %C",
377 current_interface
.sym
->name
);
388 /* Compare two derived types using the criteria in 4.4.2 of the standard,
389 recursing through gfc_compare_types for the components. */
392 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
394 gfc_component
*dt1
, *dt2
;
396 if (derived1
== derived2
)
399 gcc_assert (derived1
&& derived2
);
401 /* Special case for comparing derived types across namespaces. If the
402 true names and module names are the same and the module name is
403 nonnull, then they are equal. */
404 if (strcmp (derived1
->name
, derived2
->name
) == 0
405 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
406 && strcmp (derived1
->module
, derived2
->module
) == 0)
409 /* Compare type via the rules of the standard. Both types must have
410 the SEQUENCE or BIND(C) attribute to be equal. */
412 if (strcmp (derived1
->name
, derived2
->name
))
415 if (derived1
->component_access
== ACCESS_PRIVATE
416 || derived2
->component_access
== ACCESS_PRIVATE
)
419 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
420 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
423 dt1
= derived1
->components
;
424 dt2
= derived2
->components
;
426 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
427 simple test can speed things up. Otherwise, lots of things have to
431 if (strcmp (dt1
->name
, dt2
->name
) != 0)
434 if (dt1
->attr
.access
!= dt2
->attr
.access
)
437 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
440 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
443 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
446 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
449 /* Make sure that link lists do not put this function into an
450 endless recursive loop! */
451 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
452 && !(dt2
->ts
.type
== BT_DERIVED
&& derived2
== dt2
->ts
.u
.derived
)
453 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
456 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
457 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
460 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
461 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
467 if (dt1
== NULL
&& dt2
== NULL
)
469 if (dt1
== NULL
|| dt2
== NULL
)
477 /* Compare two typespecs, recursively if necessary. */
480 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
482 /* See if one of the typespecs is a BT_VOID, which is what is being used
483 to allow the funcs like c_f_pointer to accept any pointer type.
484 TODO: Possibly should narrow this to just the one typespec coming in
485 that is for the formal arg, but oh well. */
486 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
489 if (ts1
->type
!= ts2
->type
490 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
491 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
493 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
494 return (ts1
->kind
== ts2
->kind
);
496 /* Compare derived types. */
497 if (gfc_type_compatible (ts1
, ts2
))
500 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
504 /* Given two symbols that are formal arguments, compare their ranks
505 and types. Returns nonzero if they have the same rank and type,
509 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
511 gfc_array_spec
*as1
, *as2
;
514 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
515 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
517 r1
= as1
? as1
->rank
: 0;
518 r2
= as2
? as2
->rank
: 0;
521 && (!as1
|| as1
->type
!= AS_ASSUMED_RANK
)
522 && (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
523 return 0; /* Ranks differ. */
525 return gfc_compare_types (&s1
->ts
, &s2
->ts
)
526 || s1
->ts
.type
== BT_ASSUMED
|| s2
->ts
.type
== BT_ASSUMED
;
530 /* Given two symbols that are formal arguments, compare their types
531 and rank and their formal interfaces if they are both dummy
532 procedures. Returns nonzero if the same, zero if different. */
535 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
537 if (s1
== NULL
|| s2
== NULL
)
538 return s1
== s2
? 1 : 0;
543 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
544 return compare_type_rank (s1
, s2
);
546 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
549 /* At this point, both symbols are procedures. It can happen that
550 external procedures are compared, where one is identified by usage
551 to be a function or subroutine but the other is not. Check TKR
552 nonetheless for these cases. */
553 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
554 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
556 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
557 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
559 /* Now the type of procedure has been identified. */
560 if (s1
->attr
.function
!= s2
->attr
.function
561 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
564 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
567 /* Originally, gfortran recursed here to check the interfaces of passed
568 procedures. This is explicitly not required by the standard. */
573 /* Given a formal argument list and a keyword name, search the list
574 for that keyword. Returns the correct symbol node if found, NULL
578 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
580 for (; f
; f
= f
->next
)
581 if (strcmp (f
->sym
->name
, name
) == 0)
588 /******** Interface checking subroutines **********/
591 /* Given an operator interface and the operator, make sure that all
592 interfaces for that operator are legal. */
595 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
598 gfc_formal_arglist
*formal
;
601 int args
, r1
, r2
, k1
, k2
;
606 t1
= t2
= BT_UNKNOWN
;
607 i1
= i2
= INTENT_UNKNOWN
;
611 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
613 gfc_symbol
*fsym
= formal
->sym
;
616 gfc_error ("Alternate return cannot appear in operator "
617 "interface at %L", &sym
->declared_at
);
623 i1
= fsym
->attr
.intent
;
624 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
630 i2
= fsym
->attr
.intent
;
631 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
637 /* Only +, - and .not. can be unary operators.
638 .not. cannot be a binary operator. */
639 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
640 && op
!= INTRINSIC_MINUS
641 && op
!= INTRINSIC_NOT
)
642 || (args
== 2 && op
== INTRINSIC_NOT
))
644 if (op
== INTRINSIC_ASSIGN
)
645 gfc_error ("Assignment operator interface at %L must have "
646 "two arguments", &sym
->declared_at
);
648 gfc_error ("Operator interface at %L has the wrong number of arguments",
653 /* Check that intrinsics are mapped to functions, except
654 INTRINSIC_ASSIGN which should map to a subroutine. */
655 if (op
== INTRINSIC_ASSIGN
)
657 if (!sym
->attr
.subroutine
)
659 gfc_error ("Assignment operator interface at %L must be "
660 "a SUBROUTINE", &sym
->declared_at
);
664 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
665 - First argument an array with different rank than second,
666 - First argument is a scalar and second an array,
667 - Types and kinds do not conform, or
668 - First argument is of derived type. */
669 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
670 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
671 && (r2
== 0 || r1
== r2
)
672 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
673 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
674 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
676 gfc_error ("Assignment operator interface at %L must not redefine "
677 "an INTRINSIC type assignment", &sym
->declared_at
);
683 if (!sym
->attr
.function
)
685 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
691 /* Check intents on operator interfaces. */
692 if (op
== INTRINSIC_ASSIGN
)
694 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
696 gfc_error ("First argument of defined assignment at %L must be "
697 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
703 gfc_error ("Second argument of defined assignment at %L must be "
704 "INTENT(IN)", &sym
->declared_at
);
712 gfc_error ("First argument of operator interface at %L must be "
713 "INTENT(IN)", &sym
->declared_at
);
717 if (args
== 2 && i2
!= INTENT_IN
)
719 gfc_error ("Second argument of operator interface at %L must be "
720 "INTENT(IN)", &sym
->declared_at
);
725 /* From now on, all we have to do is check that the operator definition
726 doesn't conflict with an intrinsic operator. The rules for this
727 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
728 as well as 12.3.2.1.1 of Fortran 2003:
730 "If the operator is an intrinsic-operator (R310), the number of
731 function arguments shall be consistent with the intrinsic uses of
732 that operator, and the types, kind type parameters, or ranks of the
733 dummy arguments shall differ from those required for the intrinsic
734 operation (7.1.2)." */
736 #define IS_NUMERIC_TYPE(t) \
737 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
739 /* Unary ops are easy, do them first. */
740 if (op
== INTRINSIC_NOT
)
742 if (t1
== BT_LOGICAL
)
748 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
750 if (IS_NUMERIC_TYPE (t1
))
756 /* Character intrinsic operators have same character kind, thus
757 operator definitions with operands of different character kinds
759 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
762 /* Intrinsic operators always perform on arguments of same rank,
763 so different ranks is also always safe. (rank == 0) is an exception
764 to that, because all intrinsic operators are elemental. */
765 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
771 case INTRINSIC_EQ_OS
:
773 case INTRINSIC_NE_OS
:
774 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
779 case INTRINSIC_MINUS
:
780 case INTRINSIC_TIMES
:
781 case INTRINSIC_DIVIDE
:
782 case INTRINSIC_POWER
:
783 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
788 case INTRINSIC_GT_OS
:
790 case INTRINSIC_GE_OS
:
792 case INTRINSIC_LT_OS
:
794 case INTRINSIC_LE_OS
:
795 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
797 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
798 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
802 case INTRINSIC_CONCAT
:
803 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
811 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
821 #undef IS_NUMERIC_TYPE
824 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
830 /* Given a pair of formal argument lists, we see if the two lists can
831 be distinguished by counting the number of nonoptional arguments of
832 a given type/rank in f1 and seeing if there are less then that
833 number of those arguments in f2 (including optional arguments).
834 Since this test is asymmetric, it has to be called twice to make it
835 symmetric. Returns nonzero if the argument lists are incompatible
836 by this test. This subroutine implements rule 1 of section F03:16.2.3.
837 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
840 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
841 const char *p1
, const char *p2
)
843 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
844 gfc_formal_arglist
*f
;
857 for (f
= f1
; f
; f
= f
->next
)
860 /* Build an array of integers that gives the same integer to
861 arguments of the same type/rank. */
862 arg
= XCNEWVEC (arginfo
, n1
);
865 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
873 for (i
= 0; i
< n1
; i
++)
875 if (arg
[i
].flag
!= -1)
878 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
879 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
880 continue; /* Skip OPTIONAL and PASS arguments. */
884 /* Find other non-optional, non-pass arguments of the same type/rank. */
885 for (j
= i
+ 1; j
< n1
; j
++)
886 if ((arg
[j
].sym
== NULL
887 || !(arg
[j
].sym
->attr
.optional
888 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
889 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
890 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
896 /* Now loop over each distinct type found in f1. */
900 for (i
= 0; i
< n1
; i
++)
902 if (arg
[i
].flag
!= k
)
906 for (j
= i
+ 1; j
< n1
; j
++)
907 if (arg
[j
].flag
== k
)
910 /* Count the number of non-pass arguments in f2 with that type,
911 including those that are optional. */
914 for (f
= f2
; f
; f
= f
->next
)
915 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
916 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
917 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
935 /* Perform the correspondence test in rule 3 of section F03:16.2.3.
936 Returns zero if no argument is found that satisfies rule 3, nonzero
937 otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
940 This test is also not symmetric in f1 and f2 and must be called
941 twice. This test finds problems caused by sorting the actual
942 argument list with keywords. For example:
946 INTEGER :: A ; REAL :: B
950 INTEGER :: A ; REAL :: B
954 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
957 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
958 const char *p1
, const char *p2
)
960 gfc_formal_arglist
*f2_save
, *g
;
967 if (f1
->sym
->attr
.optional
)
970 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
972 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
975 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
976 || compare_type_rank (f2
->sym
, f1
->sym
)))
979 /* Now search for a disambiguating keyword argument starting at
980 the current non-match. */
981 for (g
= f1
; g
; g
= g
->next
)
983 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
986 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
987 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
1002 /* Check if the characteristics of two dummy arguments match,
1006 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1007 bool type_must_agree
, char *errmsg
, int err_len
)
1009 /* Check type and rank. */
1010 if (type_must_agree
&& !compare_type_rank (s2
, s1
))
1012 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1018 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1020 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1025 /* Check OPTIONAL attribute. */
1026 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1028 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1033 /* Check ALLOCATABLE attribute. */
1034 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1036 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1041 /* Check POINTER attribute. */
1042 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1044 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1049 /* Check TARGET attribute. */
1050 if (s1
->attr
.target
!= s2
->attr
.target
)
1052 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1057 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1058 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1060 /* Check string length. */
1061 if (s1
->ts
.type
== BT_CHARACTER
1062 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1063 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1065 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1066 s2
->ts
.u
.cl
->length
);
1072 snprintf (errmsg
, err_len
, "Character length mismatch "
1073 "in argument '%s'", s1
->name
);
1077 /* FIXME: Implement a warning for this case.
1078 gfc_warning ("Possible character length mismatch in argument '%s'",
1086 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1087 "%i of gfc_dep_compare_expr", compval
);
1092 /* Check array shape. */
1093 if (s1
->as
&& s2
->as
)
1096 gfc_expr
*shape1
, *shape2
;
1098 if (s1
->as
->type
!= s2
->as
->type
)
1100 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1105 if (s1
->as
->type
== AS_EXPLICIT
)
1106 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1108 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1109 gfc_copy_expr (s1
->as
->lower
[i
]));
1110 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1111 gfc_copy_expr (s2
->as
->lower
[i
]));
1112 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1113 gfc_free_expr (shape1
);
1114 gfc_free_expr (shape2
);
1120 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1121 "argument '%s'", i
+ 1, s1
->name
);
1125 /* FIXME: Implement a warning for this case.
1126 gfc_warning ("Possible shape mismatch in argument '%s'",
1134 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1135 "result %i of gfc_dep_compare_expr",
1146 /* Check if the characteristics of two function results match,
1150 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1151 char *errmsg
, int err_len
)
1153 gfc_symbol
*r1
, *r2
;
1155 r1
= s1
->result
? s1
->result
: s1
;
1156 r2
= s2
->result
? s2
->result
: s2
;
1158 if (r1
->ts
.type
== BT_UNKNOWN
)
1161 /* Check type and rank. */
1162 if (!compare_type_rank (r1
, r2
))
1164 snprintf (errmsg
, err_len
, "Type/rank mismatch in function result");
1168 /* Check ALLOCATABLE attribute. */
1169 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1171 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1176 /* Check POINTER attribute. */
1177 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1179 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1184 /* Check CONTIGUOUS attribute. */
1185 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1187 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1192 /* Check PROCEDURE POINTER attribute. */
1193 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1195 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1200 /* Check string length. */
1201 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1203 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1205 snprintf (errmsg
, err_len
, "Character length mismatch "
1206 "in function result");
1210 if (r1
->ts
.u
.cl
->length
)
1212 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1213 r2
->ts
.u
.cl
->length
);
1219 snprintf (errmsg
, err_len
, "Character length mismatch "
1220 "in function result");
1224 /* FIXME: Implement a warning for this case.
1225 snprintf (errmsg, err_len, "Possible character length mismatch "
1226 "in function result");*/
1233 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1234 "result %i of gfc_dep_compare_expr", compval
);
1240 /* Check array shape. */
1241 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1244 gfc_expr
*shape1
, *shape2
;
1246 if (r1
->as
->type
!= r2
->as
->type
)
1248 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1252 if (r1
->as
->type
== AS_EXPLICIT
)
1253 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1255 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1256 gfc_copy_expr (r1
->as
->lower
[i
]));
1257 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1258 gfc_copy_expr (r2
->as
->lower
[i
]));
1259 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1260 gfc_free_expr (shape1
);
1261 gfc_free_expr (shape2
);
1267 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1268 "function result", i
+ 1);
1272 /* FIXME: Implement a warning for this case.
1273 gfc_warning ("Possible shape mismatch in return value");*/
1280 gfc_internal_error ("check_result_characteristics (2): "
1281 "Unexpected result %i of "
1282 "gfc_dep_compare_expr", compval
);
1292 /* 'Compare' two formal interfaces associated with a pair of symbols.
1293 We return nonzero if there exists an actual argument list that
1294 would be ambiguous between the two interfaces, zero otherwise.
1295 'strict_flag' specifies whether all the characteristics are
1296 required to match, which is not the case for ambiguity checks.
1297 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1300 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1301 int generic_flag
, int strict_flag
,
1302 char *errmsg
, int err_len
,
1303 const char *p1
, const char *p2
)
1305 gfc_formal_arglist
*f1
, *f2
;
1307 gcc_assert (name2
!= NULL
);
1309 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1310 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1311 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1314 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1318 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1321 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1325 /* Do strict checks on all characteristics
1326 (for dummy procedures and procedure pointer assignments). */
1327 if (!generic_flag
&& strict_flag
)
1329 if (s1
->attr
.function
&& s2
->attr
.function
)
1331 /* If both are functions, check result characteristics. */
1332 if (check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1337 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1339 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1342 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1344 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1349 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1350 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1356 if (f1
== NULL
&& f2
== NULL
)
1357 return 1; /* Special case: No arguments. */
1361 if (count_types_test (f1
, f2
, p1
, p2
)
1362 || count_types_test (f2
, f1
, p2
, p1
))
1364 if (generic_correspondence (f1
, f2
, p1
, p2
)
1365 || generic_correspondence (f2
, f1
, p2
, p1
))
1369 /* Perform the abbreviated correspondence test for operators (the
1370 arguments cannot be optional and are always ordered correctly).
1371 This is also done when comparing interfaces for dummy procedures and in
1372 procedure pointer assignments. */
1376 /* Check existence. */
1377 if (f1
== NULL
&& f2
== NULL
)
1379 if (f1
== NULL
|| f2
== NULL
)
1382 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1383 "arguments", name2
);
1389 /* Check all characteristics. */
1390 if (check_dummy_characteristics (f1
->sym
, f2
->sym
,
1391 true, errmsg
, err_len
) == FAILURE
)
1394 else if (!compare_type_rank (f2
->sym
, f1
->sym
))
1396 /* Only check type and rank. */
1398 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1411 /* Given a pointer to an interface pointer, remove duplicate
1412 interfaces and make sure that all symbols are either functions
1413 or subroutines, and all of the same kind. Returns nonzero if
1414 something goes wrong. */
1417 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1419 gfc_interface
*psave
, *q
, *qlast
;
1422 for (; p
; p
= p
->next
)
1424 /* Make sure all symbols in the interface have been defined as
1425 functions or subroutines. */
1426 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1427 || !p
->sym
->attr
.if_source
)
1428 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1430 if (p
->sym
->attr
.external
)
1431 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1432 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1434 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1435 "subroutine", p
->sym
->name
, interface_name
,
1436 &p
->sym
->declared_at
);
1440 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1441 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1442 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1443 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1445 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1446 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1447 " or all FUNCTIONs", interface_name
,
1448 &p
->sym
->declared_at
);
1450 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1451 "generic name is also the name of a derived type",
1452 interface_name
, &p
->sym
->declared_at
);
1456 /* F2003, C1207. F2008, C1207. */
1457 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1458 && gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1459 "'%s' in %s at %L", p
->sym
->name
, interface_name
,
1460 &p
->sym
->declared_at
) == FAILURE
)
1465 /* Remove duplicate interfaces in this interface list. */
1466 for (; p
; p
= p
->next
)
1470 for (q
= p
->next
; q
;)
1472 if (p
->sym
!= q
->sym
)
1479 /* Duplicate interface. */
1480 qlast
->next
= q
->next
;
1491 /* Check lists of interfaces to make sure that no two interfaces are
1492 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1495 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1496 int generic_flag
, const char *interface_name
,
1500 for (; p
; p
= p
->next
)
1501 for (q
= q0
; q
; q
= q
->next
)
1503 if (p
->sym
== q
->sym
)
1504 continue; /* Duplicates OK here. */
1506 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1509 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1510 && q
->sym
->attr
.flavor
!= FL_DERIVED
1511 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1512 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1515 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1516 p
->sym
->name
, q
->sym
->name
, interface_name
,
1518 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1519 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1520 p
->sym
->name
, q
->sym
->name
, interface_name
,
1523 gfc_warning ("Although not referenced, '%s' has ambiguous "
1524 "interfaces at %L", interface_name
, &p
->where
);
1532 /* Check the generic and operator interfaces of symbols to make sure
1533 that none of the interfaces conflict. The check has to be done
1534 after all of the symbols are actually loaded. */
1537 check_sym_interfaces (gfc_symbol
*sym
)
1539 char interface_name
[100];
1542 if (sym
->ns
!= gfc_current_ns
)
1545 if (sym
->generic
!= NULL
)
1547 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1548 if (check_interface0 (sym
->generic
, interface_name
))
1551 for (p
= sym
->generic
; p
; p
= p
->next
)
1553 if (sym
->attr
.access
!= ACCESS_PRIVATE
)
1554 p
->sym
->attr
.public_used
= 1;
1556 if (p
->sym
->attr
.mod_proc
1557 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1558 || p
->sym
->attr
.procedure
))
1560 gfc_error ("'%s' at %L is not a module procedure",
1561 p
->sym
->name
, &p
->where
);
1566 /* Originally, this test was applied to host interfaces too;
1567 this is incorrect since host associated symbols, from any
1568 source, cannot be ambiguous with local symbols. */
1569 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1570 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1576 check_uop_interfaces (gfc_user_op
*uop
)
1578 char interface_name
[100];
1583 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1584 if (check_interface0 (uop
->op
, interface_name
))
1587 if (uop
->access
!= ACCESS_PRIVATE
)
1588 for (p
= uop
->op
; p
; p
= p
->next
)
1589 p
->sym
->attr
.public_used
= 1;
1591 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1593 uop2
= gfc_find_uop (uop
->name
, ns
);
1597 check_interface1 (uop
->op
, uop2
->op
, 0,
1598 interface_name
, true);
1602 /* Given an intrinsic op, return an equivalent op if one exists,
1603 or INTRINSIC_NONE otherwise. */
1606 gfc_equivalent_op (gfc_intrinsic_op op
)
1611 return INTRINSIC_EQ_OS
;
1613 case INTRINSIC_EQ_OS
:
1614 return INTRINSIC_EQ
;
1617 return INTRINSIC_NE_OS
;
1619 case INTRINSIC_NE_OS
:
1620 return INTRINSIC_NE
;
1623 return INTRINSIC_GT_OS
;
1625 case INTRINSIC_GT_OS
:
1626 return INTRINSIC_GT
;
1629 return INTRINSIC_GE_OS
;
1631 case INTRINSIC_GE_OS
:
1632 return INTRINSIC_GE
;
1635 return INTRINSIC_LT_OS
;
1637 case INTRINSIC_LT_OS
:
1638 return INTRINSIC_LT
;
1641 return INTRINSIC_LE_OS
;
1643 case INTRINSIC_LE_OS
:
1644 return INTRINSIC_LE
;
1647 return INTRINSIC_NONE
;
1651 /* For the namespace, check generic, user operator and intrinsic
1652 operator interfaces for consistency and to remove duplicate
1653 interfaces. We traverse the whole namespace, counting on the fact
1654 that most symbols will not have generic or operator interfaces. */
1657 gfc_check_interfaces (gfc_namespace
*ns
)
1659 gfc_namespace
*old_ns
, *ns2
;
1661 char interface_name
[100];
1664 old_ns
= gfc_current_ns
;
1665 gfc_current_ns
= ns
;
1667 gfc_traverse_ns (ns
, check_sym_interfaces
);
1669 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1671 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1673 if (i
== INTRINSIC_USER
)
1676 if (i
== INTRINSIC_ASSIGN
)
1677 strcpy (interface_name
, "intrinsic assignment operator");
1679 sprintf (interface_name
, "intrinsic '%s' operator",
1680 gfc_op2string ((gfc_intrinsic_op
) i
));
1682 if (check_interface0 (ns
->op
[i
], interface_name
))
1685 for (p
= ns
->op
[i
]; p
; p
= p
->next
)
1686 p
->sym
->attr
.public_used
= 1;
1690 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1693 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1695 gfc_intrinsic_op other_op
;
1697 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1698 interface_name
, true))
1701 /* i should be gfc_intrinsic_op, but has to be int with this cast
1702 here for stupid C++ compatibility rules. */
1703 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1704 if (other_op
!= INTRINSIC_NONE
1705 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1706 0, interface_name
, true))
1712 gfc_current_ns
= old_ns
;
1717 symbol_rank (gfc_symbol
*sym
)
1719 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
1720 return CLASS_DATA (sym
)->as
->rank
;
1722 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1726 /* Given a symbol of a formal argument list and an expression, if the
1727 formal argument is allocatable, check that the actual argument is
1728 allocatable. Returns nonzero if compatible, zero if not compatible. */
1731 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1733 symbol_attribute attr
;
1735 if (formal
->attr
.allocatable
1736 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1738 attr
= gfc_expr_attr (actual
);
1739 if (!attr
.allocatable
)
1747 /* Given a symbol of a formal argument list and an expression, if the
1748 formal argument is a pointer, see if the actual argument is a
1749 pointer. Returns nonzero if compatible, zero if not compatible. */
1752 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1754 symbol_attribute attr
;
1756 if (formal
->attr
.pointer
1757 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1758 && CLASS_DATA (formal
)->attr
.class_pointer
))
1760 attr
= gfc_expr_attr (actual
);
1762 /* Fortran 2008 allows non-pointer actual arguments. */
1763 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1774 /* Emit clear error messages for rank mismatch. */
1777 argument_rank_mismatch (const char *name
, locus
*where
,
1778 int rank1
, int rank2
)
1781 /* TS 29113, C407b. */
1784 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1785 " '%s' has assumed-rank", where
, name
);
1787 else if (rank1
== 0)
1789 gfc_error ("Rank mismatch in argument '%s' at %L "
1790 "(scalar and rank-%d)", name
, where
, rank2
);
1792 else if (rank2
== 0)
1794 gfc_error ("Rank mismatch in argument '%s' at %L "
1795 "(rank-%d and scalar)", name
, where
, rank1
);
1799 gfc_error ("Rank mismatch in argument '%s' at %L "
1800 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1805 /* Given a symbol of a formal argument list and an expression, see if
1806 the two are compatible as arguments. Returns nonzero if
1807 compatible, zero if not compatible. */
1810 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1811 int ranks_must_agree
, int is_elemental
, locus
*where
)
1814 bool rank_check
, is_pointer
;
1816 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1817 procs c_f_pointer or c_f_procpointer, and we need to accept most
1818 pointers the user could give us. This should allow that. */
1819 if (formal
->ts
.type
== BT_VOID
)
1822 if (formal
->ts
.type
== BT_DERIVED
1823 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1824 && actual
->ts
.type
== BT_DERIVED
1825 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1828 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1829 /* Make sure the vtab symbol is present when
1830 the module variables are generated. */
1831 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1833 if (actual
->ts
.type
== BT_PROCEDURE
)
1836 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1838 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1841 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1845 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1846 sizeof(err
), NULL
, NULL
))
1849 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1850 formal
->name
, &actual
->where
, err
);
1854 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1856 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1857 &act_sym
->declared_at
);
1858 if (act_sym
->ts
.type
== BT_UNKNOWN
1859 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1862 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1863 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1864 &act_sym
->declared_at
);
1870 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1871 && !gfc_is_simply_contiguous (actual
, true))
1874 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1875 "must be simply contiguous", formal
->name
, &actual
->where
);
1879 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1880 && actual
->ts
.type
!= BT_HOLLERITH
1881 && formal
->ts
.type
!= BT_ASSUMED
1882 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
1883 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
1884 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
1885 CLASS_DATA (actual
)->ts
.u
.derived
)))
1888 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1889 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1890 gfc_typename (&formal
->ts
));
1894 /* F2008, 12.5.2.5; IR F08/0073. */
1895 if (formal
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
1896 && ((CLASS_DATA (formal
)->attr
.class_pointer
1897 && !formal
->attr
.intent
== INTENT_IN
)
1898 || CLASS_DATA (formal
)->attr
.allocatable
))
1900 if (actual
->ts
.type
!= BT_CLASS
)
1903 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1904 formal
->name
, &actual
->where
);
1907 if (!gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
1908 CLASS_DATA (formal
)->ts
.u
.derived
))
1911 gfc_error ("Actual argument to '%s' at %L must have the same "
1912 "declared type", formal
->name
, &actual
->where
);
1917 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
1920 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1921 formal
->name
, &actual
->where
);
1925 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
1927 gfc_ref
*last
= NULL
;
1929 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1930 if (ref
->type
== REF_COMPONENT
)
1933 /* F2008, 12.5.2.6. */
1934 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1936 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
1939 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1940 formal
->name
, &actual
->where
, formal
->as
->corank
,
1941 last
? last
->u
.c
.component
->as
->corank
1942 : actual
->symtree
->n
.sym
->as
->corank
);
1947 if (formal
->attr
.codimension
)
1949 /* F2008, 12.5.2.8. */
1950 if (formal
->attr
.dimension
1951 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1952 && gfc_expr_attr (actual
).dimension
1953 && !gfc_is_simply_contiguous (actual
, true))
1956 gfc_error ("Actual argument to '%s' at %L must be simply "
1957 "contiguous", formal
->name
, &actual
->where
);
1961 /* F2008, C1303 and C1304. */
1962 if (formal
->attr
.intent
!= INTENT_INOUT
1963 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
1964 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1965 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
1966 || formal
->attr
.lock_comp
))
1970 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1971 "which is LOCK_TYPE or has a LOCK_TYPE component",
1972 formal
->name
, &actual
->where
);
1977 /* F2008, C1239/C1240. */
1978 if (actual
->expr_type
== EXPR_VARIABLE
1979 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1980 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1981 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1982 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1983 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1984 || formal
->attr
.contiguous
))
1987 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1988 "array without CONTIGUOUS attribute - as actual argument at"
1989 " %L is not simply contiguous and both are ASYNCHRONOUS "
1990 "or VOLATILE", formal
->name
, &actual
->where
);
1994 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
1995 && gfc_expr_attr (actual
).codimension
)
1997 if (formal
->attr
.intent
== INTENT_OUT
)
2000 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2001 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
2005 else if (gfc_option
.warn_surprising
&& where
2006 && formal
->attr
.intent
!= INTENT_IN
)
2007 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2008 "argument '%s', which is invalid if the allocation status"
2009 " is modified", &actual
->where
, formal
->name
);
2012 /* If the rank is the same or the formal argument has assumed-rank. */
2013 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2016 if (actual
->ts
.type
== BT_CLASS
&& CLASS_DATA (actual
)->as
2017 && CLASS_DATA (actual
)->as
->rank
== symbol_rank (formal
))
2020 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2021 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2022 || formal
->as
->type
== AS_DEFERRED
)
2023 && actual
->expr_type
!= EXPR_NULL
;
2025 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2026 if (rank_check
|| ranks_must_agree
2027 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2028 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2029 || (actual
->rank
== 0
2030 && ((formal
->ts
.type
== BT_CLASS
2031 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2032 || (formal
->ts
.type
!= BT_CLASS
2033 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2034 && actual
->expr_type
!= EXPR_NULL
)
2035 || (actual
->rank
== 0 && formal
->attr
.dimension
2036 && gfc_is_coindexed (actual
)))
2039 argument_rank_mismatch (formal
->name
, &actual
->where
,
2040 symbol_rank (formal
), actual
->rank
);
2043 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2046 /* At this point, we are considering a scalar passed to an array. This
2047 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2048 - if the actual argument is (a substring of) an element of a
2049 non-assumed-shape/non-pointer/non-polymorphic array; or
2050 - (F2003) if the actual argument is of type character of default/c_char
2053 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2054 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2056 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2058 if (ref
->type
== REF_COMPONENT
)
2059 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2060 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2061 && ref
->u
.ar
.dimen
> 0
2063 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2067 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2070 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2071 "at %L", formal
->name
, &actual
->where
);
2075 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2076 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2079 gfc_error ("Element of assumed-shaped or pointer "
2080 "array passed to array dummy argument '%s' at %L",
2081 formal
->name
, &actual
->where
);
2085 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2086 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2088 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2091 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2092 "CHARACTER actual argument with array dummy argument "
2093 "'%s' at %L", formal
->name
, &actual
->where
);
2097 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2099 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2100 "array dummy argument '%s' at %L",
2101 formal
->name
, &actual
->where
);
2104 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2110 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2113 argument_rank_mismatch (formal
->name
, &actual
->where
,
2114 symbol_rank (formal
), actual
->rank
);
2122 /* Returns the storage size of a symbol (formal argument) or
2123 zero if it cannot be determined. */
2125 static unsigned long
2126 get_sym_storage_size (gfc_symbol
*sym
)
2129 unsigned long strlen
, elements
;
2131 if (sym
->ts
.type
== BT_CHARACTER
)
2133 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2134 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2135 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2142 if (symbol_rank (sym
) == 0)
2146 if (sym
->as
->type
!= AS_EXPLICIT
)
2148 for (i
= 0; i
< sym
->as
->rank
; i
++)
2150 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2151 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2154 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2155 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2158 return strlen
*elements
;
2162 /* Returns the storage size of an expression (actual argument) or
2163 zero if it cannot be determined. For an array element, it returns
2164 the remaining size as the element sequence consists of all storage
2165 units of the actual argument up to the end of the array. */
2167 static unsigned long
2168 get_expr_storage_size (gfc_expr
*e
)
2171 long int strlen
, elements
;
2172 long int substrlen
= 0;
2173 bool is_str_storage
= false;
2179 if (e
->ts
.type
== BT_CHARACTER
)
2181 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2182 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2183 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2184 else if (e
->expr_type
== EXPR_CONSTANT
2185 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2186 strlen
= e
->value
.character
.length
;
2191 strlen
= 1; /* Length per element. */
2193 if (e
->rank
== 0 && !e
->ref
)
2201 for (i
= 0; i
< e
->rank
; i
++)
2202 elements
*= mpz_get_si (e
->shape
[i
]);
2203 return elements
*strlen
;
2206 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2208 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2209 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2213 /* The string length is the substring length.
2214 Set now to full string length. */
2215 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2216 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2219 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2221 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2225 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2226 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2228 long int start
, end
, stride
;
2231 if (ref
->u
.ar
.stride
[i
])
2233 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2234 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2239 if (ref
->u
.ar
.start
[i
])
2241 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2242 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2246 else if (ref
->u
.ar
.as
->lower
[i
]
2247 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2248 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2252 if (ref
->u
.ar
.end
[i
])
2254 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2255 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2259 else if (ref
->u
.ar
.as
->upper
[i
]
2260 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2261 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2265 elements
*= (end
- start
)/stride
+ 1L;
2267 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2268 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2270 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2271 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2272 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2273 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2274 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2279 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2280 && e
->expr_type
== EXPR_VARIABLE
)
2282 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2283 || e
->symtree
->n
.sym
->attr
.pointer
)
2289 /* Determine the number of remaining elements in the element
2290 sequence for array element designators. */
2291 is_str_storage
= true;
2292 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2294 if (ref
->u
.ar
.start
[i
] == NULL
2295 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2296 || ref
->u
.ar
.as
->upper
[i
] == NULL
2297 || ref
->u
.ar
.as
->lower
[i
] == NULL
2298 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2299 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2304 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2305 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2307 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2308 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2314 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2317 return elements
*strlen
;
2321 /* Given an expression, check whether it is an array section
2322 which has a vector subscript. If it has, one is returned,
2326 gfc_has_vector_subscript (gfc_expr
*e
)
2331 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2334 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2335 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2336 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2337 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2344 /* Given formal and actual argument lists, see if they are compatible.
2345 If they are compatible, the actual argument list is sorted to
2346 correspond with the formal list, and elements for missing optional
2347 arguments are inserted. If WHERE pointer is nonnull, then we issue
2348 errors when things don't match instead of just returning the status
2352 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2353 int ranks_must_agree
, int is_elemental
, locus
*where
)
2355 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2356 gfc_formal_arglist
*f
;
2358 unsigned long actual_size
, formal_size
;
2359 bool full_array
= false;
2363 if (actual
== NULL
&& formal
== NULL
)
2367 for (f
= formal
; f
; f
= f
->next
)
2370 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2372 for (i
= 0; i
< n
; i
++)
2379 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2381 /* Look for keywords but ignore g77 extensions like %VAL. */
2382 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2385 for (f
= formal
; f
; f
= f
->next
, i
++)
2389 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2396 gfc_error ("Keyword argument '%s' at %L is not in "
2397 "the procedure", a
->name
, &a
->expr
->where
);
2401 if (new_arg
[i
] != NULL
)
2404 gfc_error ("Keyword argument '%s' at %L is already associated "
2405 "with another actual argument", a
->name
,
2414 gfc_error ("More actual than formal arguments in procedure "
2415 "call at %L", where
);
2420 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2426 gfc_error ("Missing alternate return spec in subroutine call "
2431 if (a
->expr
== NULL
)
2434 gfc_error ("Unexpected alternate return spec in subroutine "
2435 "call at %L", where
);
2439 if (a
->expr
->expr_type
== EXPR_NULL
2440 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2441 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2442 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2443 || (f
->sym
->ts
.type
== BT_CLASS
2444 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2445 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2446 || !f
->sym
->attr
.optional
2447 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2450 && (!f
->sym
->attr
.optional
2451 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2452 || (f
->sym
->ts
.type
== BT_CLASS
2453 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2454 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2455 where
, f
->sym
->name
);
2457 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2458 "dummy '%s'", where
, f
->sym
->name
);
2463 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2464 is_elemental
, where
))
2467 /* TS 29113, 6.3p2. */
2468 if (f
->sym
->ts
.type
== BT_ASSUMED
2469 && (a
->expr
->ts
.type
== BT_DERIVED
2470 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2472 gfc_namespace
*f2k_derived
;
2474 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2475 ? a
->expr
->ts
.u
.derived
->f2k_derived
2476 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2479 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2481 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2482 "derived type with type-bound or FINAL procedures",
2488 /* Special case for character arguments. For allocatable, pointer
2489 and assumed-shape dummies, the string length needs to match
2491 if (a
->expr
->ts
.type
== BT_CHARACTER
2492 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2493 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2494 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2495 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2496 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2497 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2498 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2499 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2501 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2502 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2503 "argument and pointer or allocatable dummy argument "
2505 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2506 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2507 f
->sym
->name
, &a
->expr
->where
);
2509 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2510 "argument and assumed-shape dummy argument '%s' "
2512 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2513 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2514 f
->sym
->name
, &a
->expr
->where
);
2518 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2519 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2520 && a
->expr
->ts
.type
== BT_CHARACTER
)
2523 gfc_error ("Actual argument at %L to allocatable or "
2524 "pointer dummy argument '%s' must have a deferred "
2525 "length type parameter if and only if the dummy has one",
2526 &a
->expr
->where
, f
->sym
->name
);
2530 if (f
->sym
->ts
.type
== BT_CLASS
)
2531 goto skip_size_check
;
2533 actual_size
= get_expr_storage_size (a
->expr
);
2534 formal_size
= get_sym_storage_size (f
->sym
);
2535 if (actual_size
!= 0 && actual_size
< formal_size
2536 && a
->expr
->ts
.type
!= BT_PROCEDURE
2537 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2539 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2540 gfc_warning ("Character length of actual argument shorter "
2541 "than of dummy argument '%s' (%lu/%lu) at %L",
2542 f
->sym
->name
, actual_size
, formal_size
,
2545 gfc_warning ("Actual argument contains too few "
2546 "elements for dummy argument '%s' (%lu/%lu) at %L",
2547 f
->sym
->name
, actual_size
, formal_size
,
2554 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2555 is provided for a procedure pointer formal argument. */
2556 if (f
->sym
->attr
.proc_pointer
2557 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2558 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2559 || (a
->expr
->expr_type
== EXPR_FUNCTION
2560 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2561 || gfc_is_proc_ptr_comp (a
->expr
)))
2564 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2565 f
->sym
->name
, &a
->expr
->where
);
2569 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2570 provided for a procedure formal argument. */
2571 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
)
2572 && a
->expr
->expr_type
== EXPR_VARIABLE
2573 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2576 gfc_error ("Expected a procedure for argument '%s' at %L",
2577 f
->sym
->name
, &a
->expr
->where
);
2581 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2582 && a
->expr
->expr_type
== EXPR_VARIABLE
2583 && a
->expr
->symtree
->n
.sym
->as
2584 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2585 && (a
->expr
->ref
== NULL
2586 || (a
->expr
->ref
->type
== REF_ARRAY
2587 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2590 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2591 " array at %L", f
->sym
->name
, where
);
2595 if (a
->expr
->expr_type
!= EXPR_NULL
2596 && compare_pointer (f
->sym
, a
->expr
) == 0)
2599 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2600 f
->sym
->name
, &a
->expr
->where
);
2604 if (a
->expr
->expr_type
!= EXPR_NULL
2605 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2606 && compare_pointer (f
->sym
, a
->expr
) == 2)
2609 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2610 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2615 /* Fortran 2008, C1242. */
2616 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2619 gfc_error ("Coindexed actual argument at %L to pointer "
2621 &a
->expr
->where
, f
->sym
->name
);
2625 /* Fortran 2008, 12.5.2.5 (no constraint). */
2626 if (a
->expr
->expr_type
== EXPR_VARIABLE
2627 && f
->sym
->attr
.intent
!= INTENT_IN
2628 && f
->sym
->attr
.allocatable
2629 && gfc_is_coindexed (a
->expr
))
2632 gfc_error ("Coindexed actual argument at %L to allocatable "
2633 "dummy '%s' requires INTENT(IN)",
2634 &a
->expr
->where
, f
->sym
->name
);
2638 /* Fortran 2008, C1237. */
2639 if (a
->expr
->expr_type
== EXPR_VARIABLE
2640 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2641 && gfc_is_coindexed (a
->expr
)
2642 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2643 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2646 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2647 "%L requires that dummy '%s' has neither "
2648 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2653 /* Fortran 2008, 12.5.2.4 (no constraint). */
2654 if (a
->expr
->expr_type
== EXPR_VARIABLE
2655 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2656 && gfc_is_coindexed (a
->expr
)
2657 && gfc_has_ultimate_allocatable (a
->expr
))
2660 gfc_error ("Coindexed actual argument at %L with allocatable "
2661 "ultimate component to dummy '%s' requires either VALUE "
2662 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2666 if (f
->sym
->ts
.type
== BT_CLASS
2667 && CLASS_DATA (f
->sym
)->attr
.allocatable
2668 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2672 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2673 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2678 if (a
->expr
->expr_type
!= EXPR_NULL
2679 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2682 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2683 f
->sym
->name
, &a
->expr
->where
);
2687 /* Check intent = OUT/INOUT for definable actual argument. */
2688 if ((f
->sym
->attr
.intent
== INTENT_OUT
2689 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2691 const char* context
= (where
2692 ? _("actual argument to INTENT = OUT/INOUT")
2695 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2696 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2697 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2698 && gfc_check_vardef_context (a
->expr
, true, false, context
)
2701 if (gfc_check_vardef_context (a
->expr
, false, false, context
)
2706 if ((f
->sym
->attr
.intent
== INTENT_OUT
2707 || f
->sym
->attr
.intent
== INTENT_INOUT
2708 || f
->sym
->attr
.volatile_
2709 || f
->sym
->attr
.asynchronous
)
2710 && gfc_has_vector_subscript (a
->expr
))
2713 gfc_error ("Array-section actual argument with vector "
2714 "subscripts at %L is incompatible with INTENT(OUT), "
2715 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2716 "of the dummy argument '%s'",
2717 &a
->expr
->where
, f
->sym
->name
);
2721 /* C1232 (R1221) For an actual argument which is an array section or
2722 an assumed-shape array, the dummy argument shall be an assumed-
2723 shape array, if the dummy argument has the VOLATILE attribute. */
2725 if (f
->sym
->attr
.volatile_
2726 && a
->expr
->symtree
->n
.sym
->as
2727 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2728 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2731 gfc_error ("Assumed-shape actual argument at %L is "
2732 "incompatible with the non-assumed-shape "
2733 "dummy argument '%s' due to VOLATILE attribute",
2734 &a
->expr
->where
,f
->sym
->name
);
2738 if (f
->sym
->attr
.volatile_
2739 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2740 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2743 gfc_error ("Array-section actual argument at %L is "
2744 "incompatible with the non-assumed-shape "
2745 "dummy argument '%s' due to VOLATILE attribute",
2746 &a
->expr
->where
,f
->sym
->name
);
2750 /* C1233 (R1221) For an actual argument which is a pointer array, the
2751 dummy argument shall be an assumed-shape or pointer array, if the
2752 dummy argument has the VOLATILE attribute. */
2754 if (f
->sym
->attr
.volatile_
2755 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2756 && a
->expr
->symtree
->n
.sym
->as
2758 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2759 || f
->sym
->attr
.pointer
)))
2762 gfc_error ("Pointer-array actual argument at %L requires "
2763 "an assumed-shape or pointer-array dummy "
2764 "argument '%s' due to VOLATILE attribute",
2765 &a
->expr
->where
,f
->sym
->name
);
2776 /* Make sure missing actual arguments are optional. */
2778 for (f
= formal
; f
; f
= f
->next
, i
++)
2780 if (new_arg
[i
] != NULL
)
2785 gfc_error ("Missing alternate return spec in subroutine call "
2789 if (!f
->sym
->attr
.optional
)
2792 gfc_error ("Missing actual argument for argument '%s' at %L",
2793 f
->sym
->name
, where
);
2798 /* The argument lists are compatible. We now relink a new actual
2799 argument list with null arguments in the right places. The head
2800 of the list remains the head. */
2801 for (i
= 0; i
< n
; i
++)
2802 if (new_arg
[i
] == NULL
)
2803 new_arg
[i
] = gfc_get_actual_arglist ();
2808 *new_arg
[0] = *actual
;
2812 new_arg
[0] = new_arg
[na
];
2816 for (i
= 0; i
< n
- 1; i
++)
2817 new_arg
[i
]->next
= new_arg
[i
+ 1];
2819 new_arg
[i
]->next
= NULL
;
2821 if (*ap
== NULL
&& n
> 0)
2824 /* Note the types of omitted optional arguments. */
2825 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2826 if (a
->expr
== NULL
&& a
->label
== NULL
)
2827 a
->missing_arg_type
= f
->sym
->ts
.type
;
2835 gfc_formal_arglist
*f
;
2836 gfc_actual_arglist
*a
;
2840 /* qsort comparison function for argument pairs, with the following
2842 - p->a->expr == NULL
2843 - p->a->expr->expr_type != EXPR_VARIABLE
2844 - growing p->a->expr->symbol. */
2847 pair_cmp (const void *p1
, const void *p2
)
2849 const gfc_actual_arglist
*a1
, *a2
;
2851 /* *p1 and *p2 are elements of the to-be-sorted array. */
2852 a1
= ((const argpair
*) p1
)->a
;
2853 a2
= ((const argpair
*) p2
)->a
;
2862 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2864 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2868 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2870 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2874 /* Given two expressions from some actual arguments, test whether they
2875 refer to the same expression. The analysis is conservative.
2876 Returning FAILURE will produce no warning. */
2879 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2881 const gfc_ref
*r1
, *r2
;
2884 || e1
->expr_type
!= EXPR_VARIABLE
2885 || e2
->expr_type
!= EXPR_VARIABLE
2886 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2889 /* TODO: improve comparison, see expr.c:show_ref(). */
2890 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2892 if (r1
->type
!= r2
->type
)
2897 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2899 /* TODO: At the moment, consider only full arrays;
2900 we could do better. */
2901 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2906 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2914 gfc_internal_error ("compare_actual_expr(): Bad component code");
2923 /* Given formal and actual argument lists that correspond to one
2924 another, check that identical actual arguments aren't not
2925 associated with some incompatible INTENTs. */
2928 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2930 sym_intent f1_intent
, f2_intent
;
2931 gfc_formal_arglist
*f1
;
2932 gfc_actual_arglist
*a1
;
2935 gfc_try t
= SUCCESS
;
2938 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2940 if (f1
== NULL
&& a1
== NULL
)
2942 if (f1
== NULL
|| a1
== NULL
)
2943 gfc_internal_error ("check_some_aliasing(): List mismatch");
2948 p
= XALLOCAVEC (argpair
, n
);
2950 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2956 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2958 for (i
= 0; i
< n
; i
++)
2961 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2962 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2964 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2965 for (j
= i
+ 1; j
< n
; j
++)
2967 /* Expected order after the sort. */
2968 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2969 gfc_internal_error ("check_some_aliasing(): corrupted data");
2971 /* Are the expression the same? */
2972 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2974 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2975 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2976 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2978 gfc_warning ("Same actual argument associated with INTENT(%s) "
2979 "argument '%s' and INTENT(%s) argument '%s' at %L",
2980 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2981 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2982 &p
[i
].a
->expr
->where
);
2992 /* Given formal and actual argument lists that correspond to one
2993 another, check that they are compatible in the sense that intents
2994 are not mismatched. */
2997 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2999 sym_intent f_intent
;
3001 for (;; f
= f
->next
, a
= a
->next
)
3003 if (f
== NULL
&& a
== NULL
)
3005 if (f
== NULL
|| a
== NULL
)
3006 gfc_internal_error ("check_intents(): List mismatch");
3008 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
3011 f_intent
= f
->sym
->attr
.intent
;
3013 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
3015 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3016 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3017 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3019 gfc_error ("Procedure argument at %L is local to a PURE "
3020 "procedure and has the POINTER attribute",
3026 /* Fortran 2008, C1283. */
3027 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
3029 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3031 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3032 "is passed to an INTENT(%s) argument",
3033 &a
->expr
->where
, gfc_intent_string (f_intent
));
3037 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3038 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3039 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3041 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3042 "is passed to a POINTER dummy argument",
3048 /* F2008, Section 12.5.2.4. */
3049 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3050 && gfc_is_coindexed (a
->expr
))
3052 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3053 "polymorphic dummy argument '%s'",
3054 &a
->expr
->where
, f
->sym
->name
);
3063 /* Check how a procedure is used against its interface. If all goes
3064 well, the actual argument list will also end up being properly
3068 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3070 /* Warn about calls with an implicit interface. Special case
3071 for calling a ISO_C_BINDING becase c_loc and c_funloc
3072 are pseudo-unknown. Additionally, warn about procedures not
3073 explicitly declared at all if requested. */
3074 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
3076 if (gfc_option
.warn_implicit_interface
)
3077 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3079 else if (gfc_option
.warn_implicit_procedure
3080 && sym
->attr
.proc
== PROC_UNKNOWN
)
3081 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3085 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3087 gfc_actual_arglist
*a
;
3089 if (sym
->attr
.pointer
)
3091 gfc_error("The pointer object '%s' at %L must have an explicit "
3092 "function interface or be declared as array",
3097 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3099 gfc_error("The allocatable object '%s' at %L must have an explicit "
3100 "function interface or be declared as array",
3105 if (sym
->attr
.allocatable
)
3107 gfc_error("Allocatable function '%s' at %L must have an explicit "
3108 "function interface", sym
->name
, where
);
3112 for (a
= *ap
; a
; a
= a
->next
)
3114 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3115 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3117 gfc_error("Keyword argument requires explicit interface "
3118 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
3122 /* TS 29113, 6.2. */
3123 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3124 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3126 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3127 "interface", a
->expr
->symtree
->n
.sym
->name
,
3132 /* F2008, C1303 and C1304. */
3134 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3135 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3136 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3137 || gfc_expr_attr (a
->expr
).lock_comp
))
3139 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3140 "component at %L requires an explicit interface for "
3141 "procedure '%s'", &a
->expr
->where
, sym
->name
);
3145 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3146 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3148 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3152 /* TS 29113, C407b. */
3153 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3154 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3156 gfc_error ("Assumed-rank argument requires an explicit interface "
3157 "at %L", &a
->expr
->where
);
3165 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
3168 if (check_intents (sym
->formal
, *ap
) == FAILURE
)
3171 if (gfc_option
.warn_aliasing
)
3172 check_some_aliasing (sym
->formal
, *ap
);
3178 /* Check how a procedure pointer component is used against its interface.
3179 If all goes well, the actual argument list will also end up being properly
3180 sorted. Completely analogous to gfc_procedure_use. */
3183 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3186 /* Warn about calls with an implicit interface. Special case
3187 for calling a ISO_C_BINDING becase c_loc and c_funloc
3188 are pseudo-unknown. */
3189 if (gfc_option
.warn_implicit_interface
3190 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3191 && !comp
->attr
.is_iso_c
)
3192 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3193 "interface at %L", comp
->name
, where
);
3195 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3197 gfc_actual_arglist
*a
;
3198 for (a
= *ap
; a
; a
= a
->next
)
3200 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3201 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3203 gfc_error("Keyword argument requires explicit interface "
3204 "for procedure pointer component '%s' at %L",
3205 comp
->name
, &a
->expr
->where
);
3213 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
3216 check_intents (comp
->formal
, *ap
);
3217 if (gfc_option
.warn_aliasing
)
3218 check_some_aliasing (comp
->formal
, *ap
);
3222 /* Try if an actual argument list matches the formal list of a symbol,
3223 respecting the symbol's attributes like ELEMENTAL. This is used for
3224 GENERIC resolution. */
3227 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3231 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3233 r
= !sym
->attr
.elemental
;
3234 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
3236 check_intents (sym
->formal
, *args
);
3237 if (gfc_option
.warn_aliasing
)
3238 check_some_aliasing (sym
->formal
, *args
);
3246 /* Given an interface pointer and an actual argument list, search for
3247 a formal argument list that matches the actual. If found, returns
3248 a pointer to the symbol of the correct interface. Returns NULL if
3252 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3253 gfc_actual_arglist
**ap
)
3255 gfc_symbol
*elem_sym
= NULL
;
3256 gfc_symbol
*null_sym
= NULL
;
3257 locus null_expr_loc
;
3258 gfc_actual_arglist
*a
;
3259 bool has_null_arg
= false;
3261 for (a
= *ap
; a
; a
= a
->next
)
3262 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3263 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3265 has_null_arg
= true;
3266 null_expr_loc
= a
->expr
->where
;
3270 for (; intr
; intr
= intr
->next
)
3272 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3274 if (sub_flag
&& intr
->sym
->attr
.function
)
3276 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3279 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3281 if (has_null_arg
&& null_sym
)
3283 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3284 "between specific functions %s and %s",
3285 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3288 else if (has_null_arg
)
3290 null_sym
= intr
->sym
;
3294 /* Satisfy 12.4.4.1 such that an elemental match has lower
3295 weight than a non-elemental match. */
3296 if (intr
->sym
->attr
.elemental
)
3298 elem_sym
= intr
->sym
;
3308 return elem_sym
? elem_sym
: NULL
;
3312 /* Do a brute force recursive search for a symbol. */
3314 static gfc_symtree
*
3315 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3319 if (root
->n
.sym
== sym
)
3324 st
= find_symtree0 (root
->left
, sym
);
3325 if (root
->right
&& ! st
)
3326 st
= find_symtree0 (root
->right
, sym
);
3331 /* Find a symtree for a symbol. */
3334 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3339 /* First try to find it by name. */
3340 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3341 if (st
&& st
->n
.sym
== sym
)
3344 /* If it's been renamed, resort to a brute-force search. */
3345 /* TODO: avoid having to do this search. If the symbol doesn't exist
3346 in the symtree for the current namespace, it should probably be added. */
3347 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3349 st
= find_symtree0 (ns
->sym_root
, sym
);
3353 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3358 /* See if the arglist to an operator-call contains a derived-type argument
3359 with a matching type-bound operator. If so, return the matching specific
3360 procedure defined as operator-target as well as the base-object to use
3361 (which is the found derived-type argument with operator). The generic
3362 name, if any, is transmitted to the final expression via 'gname'. */
3364 static gfc_typebound_proc
*
3365 matching_typebound_op (gfc_expr
** tb_base
,
3366 gfc_actual_arglist
* args
,
3367 gfc_intrinsic_op op
, const char* uop
,
3368 const char ** gname
)
3370 gfc_actual_arglist
* base
;
3372 for (base
= args
; base
; base
= base
->next
)
3373 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3375 gfc_typebound_proc
* tb
;
3376 gfc_symbol
* derived
;
3379 while (base
->expr
->expr_type
== EXPR_OP
3380 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3381 base
->expr
= base
->expr
->value
.op
.op1
;
3383 if (base
->expr
->ts
.type
== BT_CLASS
)
3385 if (CLASS_DATA (base
->expr
) == NULL
3386 || !gfc_expr_attr (base
->expr
).class_ok
)
3388 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3391 derived
= base
->expr
->ts
.u
.derived
;
3393 if (op
== INTRINSIC_USER
)
3395 gfc_symtree
* tb_uop
;
3398 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3407 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3410 /* This means we hit a PRIVATE operator which is use-associated and
3411 should thus not be seen. */
3412 if (result
== FAILURE
)
3415 /* Look through the super-type hierarchy for a matching specific
3417 for (; tb
; tb
= tb
->overridden
)
3421 gcc_assert (tb
->is_generic
);
3422 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3425 gfc_actual_arglist
* argcopy
;
3428 gcc_assert (g
->specific
);
3429 if (g
->specific
->error
)
3432 target
= g
->specific
->u
.specific
->n
.sym
;
3434 /* Check if this arglist matches the formal. */
3435 argcopy
= gfc_copy_actual_arglist (args
);
3436 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3437 gfc_free_actual_arglist (argcopy
);
3439 /* Return if we found a match. */
3442 *tb_base
= base
->expr
;
3443 *gname
= g
->specific_st
->name
;
3454 /* For the 'actual arglist' of an operator call and a specific typebound
3455 procedure that has been found the target of a type-bound operator, build the
3456 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3457 type-bound procedures rather than resolving type-bound operators 'directly'
3458 so that we can reuse the existing logic. */
3461 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3462 gfc_expr
* base
, gfc_typebound_proc
* target
,
3465 e
->expr_type
= EXPR_COMPCALL
;
3466 e
->value
.compcall
.tbp
= target
;
3467 e
->value
.compcall
.name
= gname
? gname
: "$op";
3468 e
->value
.compcall
.actual
= actual
;
3469 e
->value
.compcall
.base_object
= base
;
3470 e
->value
.compcall
.ignore_pass
= 1;
3471 e
->value
.compcall
.assign
= 0;
3472 if (e
->ts
.type
== BT_UNKNOWN
3473 && target
->function
)
3475 if (target
->is_generic
)
3476 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3478 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3483 /* This subroutine is called when an expression is being resolved.
3484 The expression node in question is either a user defined operator
3485 or an intrinsic operator with arguments that aren't compatible
3486 with the operator. This subroutine builds an actual argument list
3487 corresponding to the operands, then searches for a compatible
3488 interface. If one is found, the expression node is replaced with
3489 the appropriate function call. We use the 'match' enum to specify
3490 whether a replacement has been made or not, or if an error occurred. */
3493 gfc_extend_expr (gfc_expr
*e
)
3495 gfc_actual_arglist
*actual
;
3504 actual
= gfc_get_actual_arglist ();
3505 actual
->expr
= e
->value
.op
.op1
;
3509 if (e
->value
.op
.op2
!= NULL
)
3511 actual
->next
= gfc_get_actual_arglist ();
3512 actual
->next
->expr
= e
->value
.op
.op2
;
3515 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3517 if (i
== INTRINSIC_USER
)
3519 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3521 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3525 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3532 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3534 /* Due to the distinction between '==' and '.eq.' and friends, one has
3535 to check if either is defined. */
3538 #define CHECK_OS_COMPARISON(comp) \
3539 case INTRINSIC_##comp: \
3540 case INTRINSIC_##comp##_OS: \
3541 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3543 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3545 CHECK_OS_COMPARISON(EQ
)
3546 CHECK_OS_COMPARISON(NE
)
3547 CHECK_OS_COMPARISON(GT
)
3548 CHECK_OS_COMPARISON(GE
)
3549 CHECK_OS_COMPARISON(LT
)
3550 CHECK_OS_COMPARISON(LE
)
3551 #undef CHECK_OS_COMPARISON
3554 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3562 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3563 found rather than just taking the first one and not checking further. */
3567 gfc_typebound_proc
* tbo
;
3570 /* See if we find a matching type-bound operator. */
3571 if (i
== INTRINSIC_USER
)
3572 tbo
= matching_typebound_op (&tb_base
, actual
,
3573 i
, e
->value
.op
.uop
->name
, &gname
);
3577 #define CHECK_OS_COMPARISON(comp) \
3578 case INTRINSIC_##comp: \
3579 case INTRINSIC_##comp##_OS: \
3580 tbo = matching_typebound_op (&tb_base, actual, \
3581 INTRINSIC_##comp, NULL, &gname); \
3583 tbo = matching_typebound_op (&tb_base, actual, \
3584 INTRINSIC_##comp##_OS, NULL, &gname); \
3586 CHECK_OS_COMPARISON(EQ
)
3587 CHECK_OS_COMPARISON(NE
)
3588 CHECK_OS_COMPARISON(GT
)
3589 CHECK_OS_COMPARISON(GE
)
3590 CHECK_OS_COMPARISON(LT
)
3591 CHECK_OS_COMPARISON(LE
)
3592 #undef CHECK_OS_COMPARISON
3595 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3599 /* If there is a matching typebound-operator, replace the expression with
3600 a call to it and succeed. */
3605 gcc_assert (tb_base
);
3606 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3608 result
= gfc_resolve_expr (e
);
3609 if (result
== FAILURE
)
3615 /* Don't use gfc_free_actual_arglist(). */
3616 free (actual
->next
);
3622 /* Change the expression node to a function call. */
3623 e
->expr_type
= EXPR_FUNCTION
;
3624 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3625 e
->value
.function
.actual
= actual
;
3626 e
->value
.function
.esym
= NULL
;
3627 e
->value
.function
.isym
= NULL
;
3628 e
->value
.function
.name
= NULL
;
3629 e
->user_operator
= 1;
3631 if (gfc_resolve_expr (e
) == FAILURE
)
3638 /* Tries to replace an assignment code node with a subroutine call to
3639 the subroutine associated with the assignment operator. Return
3640 SUCCESS if the node was replaced. On FAILURE, no error is
3644 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3646 gfc_actual_arglist
*actual
;
3647 gfc_expr
*lhs
, *rhs
;
3656 /* Don't allow an intrinsic assignment to be replaced. */
3657 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3658 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3659 && (lhs
->ts
.type
== rhs
->ts
.type
3660 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3663 actual
= gfc_get_actual_arglist ();
3666 actual
->next
= gfc_get_actual_arglist ();
3667 actual
->next
->expr
= rhs
;
3671 for (; ns
; ns
= ns
->parent
)
3673 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3678 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3682 gfc_typebound_proc
* tbo
;
3685 /* See if we find a matching type-bound assignment. */
3686 tbo
= matching_typebound_op (&tb_base
, actual
,
3687 INTRINSIC_ASSIGN
, NULL
, &gname
);
3689 /* If there is one, replace the expression with a call to it and
3693 gcc_assert (tb_base
);
3694 c
->expr1
= gfc_get_expr ();
3695 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3696 c
->expr1
->value
.compcall
.assign
= 1;
3697 c
->expr1
->where
= c
->loc
;
3699 c
->op
= EXEC_COMPCALL
;
3701 /* c is resolved from the caller, so no need to do it here. */
3706 free (actual
->next
);
3711 /* Replace the assignment with the call. */
3712 c
->op
= EXEC_ASSIGN_CALL
;
3713 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3716 c
->ext
.actual
= actual
;
3722 /* Make sure that the interface just parsed is not already present in
3723 the given interface list. Ambiguity isn't checked yet since module
3724 procedures can be present without interfaces. */
3727 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3731 for (ip
= base
; ip
; ip
= ip
->next
)
3733 if (ip
->sym
== new_sym
)
3735 gfc_error ("Entity '%s' at %L is already present in the interface",
3736 new_sym
->name
, &loc
);
3745 /* Add a symbol to the current interface. */
3748 gfc_add_interface (gfc_symbol
*new_sym
)
3750 gfc_interface
**head
, *intr
;
3754 switch (current_interface
.type
)
3756 case INTERFACE_NAMELESS
:
3757 case INTERFACE_ABSTRACT
:
3760 case INTERFACE_INTRINSIC_OP
:
3761 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3762 switch (current_interface
.op
)
3765 case INTRINSIC_EQ_OS
:
3766 if (gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3767 gfc_current_locus
) == FAILURE
3768 || gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
,
3769 gfc_current_locus
) == FAILURE
)
3774 case INTRINSIC_NE_OS
:
3775 if (gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3776 gfc_current_locus
) == FAILURE
3777 || gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
,
3778 gfc_current_locus
) == FAILURE
)
3783 case INTRINSIC_GT_OS
:
3784 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
,
3785 gfc_current_locus
) == FAILURE
3786 || gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
,
3787 gfc_current_locus
) == FAILURE
)
3792 case INTRINSIC_GE_OS
:
3793 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
,
3794 gfc_current_locus
) == FAILURE
3795 || gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
,
3796 gfc_current_locus
) == FAILURE
)
3801 case INTRINSIC_LT_OS
:
3802 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
,
3803 gfc_current_locus
) == FAILURE
3804 || gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
,
3805 gfc_current_locus
) == FAILURE
)
3810 case INTRINSIC_LE_OS
:
3811 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
,
3812 gfc_current_locus
) == FAILURE
3813 || gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
,
3814 gfc_current_locus
) == FAILURE
)
3819 if (gfc_check_new_interface (ns
->op
[current_interface
.op
], new_sym
,
3820 gfc_current_locus
) == FAILURE
)
3824 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3827 case INTERFACE_GENERIC
:
3828 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3830 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3834 if (gfc_check_new_interface (sym
->generic
, new_sym
, gfc_current_locus
)
3839 head
= ¤t_interface
.sym
->generic
;
3842 case INTERFACE_USER_OP
:
3843 if (gfc_check_new_interface (current_interface
.uop
->op
, new_sym
,
3844 gfc_current_locus
) == FAILURE
)
3847 head
= ¤t_interface
.uop
->op
;
3851 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3854 intr
= gfc_get_interface ();
3855 intr
->sym
= new_sym
;
3856 intr
->where
= gfc_current_locus
;
3866 gfc_current_interface_head (void)
3868 switch (current_interface
.type
)
3870 case INTERFACE_INTRINSIC_OP
:
3871 return current_interface
.ns
->op
[current_interface
.op
];
3874 case INTERFACE_GENERIC
:
3875 return current_interface
.sym
->generic
;
3878 case INTERFACE_USER_OP
:
3879 return current_interface
.uop
->op
;
3889 gfc_set_current_interface_head (gfc_interface
*i
)
3891 switch (current_interface
.type
)
3893 case INTERFACE_INTRINSIC_OP
:
3894 current_interface
.ns
->op
[current_interface
.op
] = i
;
3897 case INTERFACE_GENERIC
:
3898 current_interface
.sym
->generic
= i
;
3901 case INTERFACE_USER_OP
:
3902 current_interface
.uop
->op
= i
;
3911 /* Gets rid of a formal argument list. We do not free symbols.
3912 Symbols are freed when a namespace is freed. */
3915 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3917 gfc_formal_arglist
*q
;
3927 /* Check that it is ok for the type-bound procedure 'proc' to override the
3928 procedure 'old', cf. F08:4.5.7.3. */
3931 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
3934 gfc_symbol
*proc_target
, *old_target
;
3935 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
3936 gfc_formal_arglist
*proc_formal
, *old_formal
;
3940 /* This procedure should only be called for non-GENERIC proc. */
3941 gcc_assert (!proc
->n
.tb
->is_generic
);
3943 /* If the overwritten procedure is GENERIC, this is an error. */
3944 if (old
->n
.tb
->is_generic
)
3946 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3947 old
->name
, &proc
->n
.tb
->where
);
3951 where
= proc
->n
.tb
->where
;
3952 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
3953 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
3955 /* Check that overridden binding is not NON_OVERRIDABLE. */
3956 if (old
->n
.tb
->non_overridable
)
3958 gfc_error ("'%s' at %L overrides a procedure binding declared"
3959 " NON_OVERRIDABLE", proc
->name
, &where
);
3963 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3964 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
3966 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3967 " non-DEFERRED binding", proc
->name
, &where
);
3971 /* If the overridden binding is PURE, the overriding must be, too. */
3972 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
3974 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3975 proc
->name
, &where
);
3979 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3980 is not, the overriding must not be either. */
3981 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
3983 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3984 " ELEMENTAL", proc
->name
, &where
);
3987 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
3989 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3990 " be ELEMENTAL, either", proc
->name
, &where
);
3994 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3996 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
3998 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3999 " SUBROUTINE", proc
->name
, &where
);
4003 /* If the overridden binding is a FUNCTION, the overriding must also be a
4004 FUNCTION and have the same characteristics. */
4005 if (old_target
->attr
.function
)
4007 if (!proc_target
->attr
.function
)
4009 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4010 " FUNCTION", proc
->name
, &where
);
4014 if (check_result_characteristics (proc_target
, old_target
,
4015 err
, sizeof(err
)) == FAILURE
)
4017 gfc_error ("Result mismatch for the overriding procedure "
4018 "'%s' at %L: %s", proc
->name
, &where
, err
);
4023 /* If the overridden binding is PUBLIC, the overriding one must not be
4025 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4026 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4028 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4029 " PRIVATE", proc
->name
, &where
);
4033 /* Compare the formal argument lists of both procedures. This is also abused
4034 to find the position of the passed-object dummy arguments of both
4035 bindings as at least the overridden one might not yet be resolved and we
4036 need those positions in the check below. */
4037 proc_pass_arg
= old_pass_arg
= 0;
4038 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4040 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4043 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
4044 proc_formal
&& old_formal
;
4045 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4047 if (proc
->n
.tb
->pass_arg
4048 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4049 proc_pass_arg
= argpos
;
4050 if (old
->n
.tb
->pass_arg
4051 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4052 old_pass_arg
= argpos
;
4054 /* Check that the names correspond. */
4055 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4057 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4058 " to match the corresponding argument of the overridden"
4059 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4060 old_formal
->sym
->name
);
4064 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4065 if (check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4066 check_type
, err
, sizeof(err
)) == FAILURE
)
4068 gfc_error ("Argument mismatch for the overriding procedure "
4069 "'%s' at %L: %s", proc
->name
, &where
, err
);
4075 if (proc_formal
|| old_formal
)
4077 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4078 " the overridden procedure", proc
->name
, &where
);
4082 /* If the overridden binding is NOPASS, the overriding one must also be
4084 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4086 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4087 " NOPASS", proc
->name
, &where
);
4091 /* If the overridden binding is PASS(x), the overriding one must also be
4092 PASS and the passed-object dummy arguments must correspond. */
4093 if (!old
->n
.tb
->nopass
)
4095 if (proc
->n
.tb
->nopass
)
4097 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4098 " PASS", proc
->name
, &where
);
4102 if (proc_pass_arg
!= old_pass_arg
)
4104 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4105 " the same position as the passed-object dummy argument of"
4106 " the overridden procedure", proc
->name
, &where
);