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 F08:C1215.
936 Returns zero if no argument is found that satisfies this rule,
937 nonzero 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
))
977 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
978 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
979 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
982 /* Now search for a disambiguating keyword argument starting at
983 the current non-match. */
984 for (g
= f1
; g
; g
= g
->next
)
986 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
989 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
990 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
991 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
992 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
993 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1008 /* Check if the characteristics of two dummy arguments match,
1012 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1013 bool type_must_agree
, char *errmsg
, int err_len
)
1015 /* Check type and rank. */
1016 if (type_must_agree
&& !compare_type_rank (s2
, s1
))
1018 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1024 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1026 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1031 /* Check OPTIONAL attribute. */
1032 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1034 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1039 /* Check ALLOCATABLE attribute. */
1040 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1042 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1047 /* Check POINTER attribute. */
1048 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1050 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1055 /* Check TARGET attribute. */
1056 if (s1
->attr
.target
!= s2
->attr
.target
)
1058 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1063 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1064 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1066 /* Check string length. */
1067 if (s1
->ts
.type
== BT_CHARACTER
1068 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1069 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1071 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1072 s2
->ts
.u
.cl
->length
);
1078 snprintf (errmsg
, err_len
, "Character length mismatch "
1079 "in argument '%s'", s1
->name
);
1083 /* FIXME: Implement a warning for this case.
1084 gfc_warning ("Possible character length mismatch in argument '%s'",
1092 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1093 "%i of gfc_dep_compare_expr", compval
);
1098 /* Check array shape. */
1099 if (s1
->as
&& s2
->as
)
1102 gfc_expr
*shape1
, *shape2
;
1104 if (s1
->as
->type
!= s2
->as
->type
)
1106 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1111 if (s1
->as
->type
== AS_EXPLICIT
)
1112 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1114 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1115 gfc_copy_expr (s1
->as
->lower
[i
]));
1116 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1117 gfc_copy_expr (s2
->as
->lower
[i
]));
1118 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1119 gfc_free_expr (shape1
);
1120 gfc_free_expr (shape2
);
1126 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1127 "argument '%s'", i
+ 1, s1
->name
);
1131 /* FIXME: Implement a warning for this case.
1132 gfc_warning ("Possible shape mismatch in argument '%s'",
1140 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1141 "result %i of gfc_dep_compare_expr",
1152 /* Check if the characteristics of two function results match,
1156 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1157 char *errmsg
, int err_len
)
1159 gfc_symbol
*r1
, *r2
;
1161 r1
= s1
->result
? s1
->result
: s1
;
1162 r2
= s2
->result
? s2
->result
: s2
;
1164 if (r1
->ts
.type
== BT_UNKNOWN
)
1167 /* Check type and rank. */
1168 if (!compare_type_rank (r1
, r2
))
1170 snprintf (errmsg
, err_len
, "Type/rank mismatch in function result");
1174 /* Check ALLOCATABLE attribute. */
1175 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1177 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1182 /* Check POINTER attribute. */
1183 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1185 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1190 /* Check CONTIGUOUS attribute. */
1191 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1193 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1198 /* Check PROCEDURE POINTER attribute. */
1199 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1201 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1206 /* Check string length. */
1207 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1209 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1211 snprintf (errmsg
, err_len
, "Character length mismatch "
1212 "in function result");
1216 if (r1
->ts
.u
.cl
->length
)
1218 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1219 r2
->ts
.u
.cl
->length
);
1225 snprintf (errmsg
, err_len
, "Character length mismatch "
1226 "in function result");
1230 /* FIXME: Implement a warning for this case.
1231 snprintf (errmsg, err_len, "Possible character length mismatch "
1232 "in function result");*/
1239 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1240 "result %i of gfc_dep_compare_expr", compval
);
1246 /* Check array shape. */
1247 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1250 gfc_expr
*shape1
, *shape2
;
1252 if (r1
->as
->type
!= r2
->as
->type
)
1254 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1258 if (r1
->as
->type
== AS_EXPLICIT
)
1259 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1261 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1262 gfc_copy_expr (r1
->as
->lower
[i
]));
1263 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1264 gfc_copy_expr (r2
->as
->lower
[i
]));
1265 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1266 gfc_free_expr (shape1
);
1267 gfc_free_expr (shape2
);
1273 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1274 "function result", i
+ 1);
1278 /* FIXME: Implement a warning for this case.
1279 gfc_warning ("Possible shape mismatch in return value");*/
1286 gfc_internal_error ("check_result_characteristics (2): "
1287 "Unexpected result %i of "
1288 "gfc_dep_compare_expr", compval
);
1298 /* 'Compare' two formal interfaces associated with a pair of symbols.
1299 We return nonzero if there exists an actual argument list that
1300 would be ambiguous between the two interfaces, zero otherwise.
1301 'strict_flag' specifies whether all the characteristics are
1302 required to match, which is not the case for ambiguity checks.
1303 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1306 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1307 int generic_flag
, int strict_flag
,
1308 char *errmsg
, int err_len
,
1309 const char *p1
, const char *p2
)
1311 gfc_formal_arglist
*f1
, *f2
;
1313 gcc_assert (name2
!= NULL
);
1315 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1316 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1317 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1320 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1324 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1327 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1331 /* Do strict checks on all characteristics
1332 (for dummy procedures and procedure pointer assignments). */
1333 if (!generic_flag
&& strict_flag
)
1335 if (s1
->attr
.function
&& s2
->attr
.function
)
1337 /* If both are functions, check result characteristics. */
1338 if (check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1343 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1345 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1348 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1350 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1355 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1356 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1362 if (f1
== NULL
&& f2
== NULL
)
1363 return 1; /* Special case: No arguments. */
1367 if (count_types_test (f1
, f2
, p1
, p2
)
1368 || count_types_test (f2
, f1
, p2
, p1
))
1370 if (generic_correspondence (f1
, f2
, p1
, p2
)
1371 || generic_correspondence (f2
, f1
, p2
, p1
))
1375 /* Perform the abbreviated correspondence test for operators (the
1376 arguments cannot be optional and are always ordered correctly).
1377 This is also done when comparing interfaces for dummy procedures and in
1378 procedure pointer assignments. */
1382 /* Check existence. */
1383 if (f1
== NULL
&& f2
== NULL
)
1385 if (f1
== NULL
|| f2
== NULL
)
1388 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1389 "arguments", name2
);
1395 /* Check all characteristics. */
1396 if (check_dummy_characteristics (f1
->sym
, f2
->sym
,
1397 true, errmsg
, err_len
) == FAILURE
)
1400 else if (!compare_type_rank (f2
->sym
, f1
->sym
))
1402 /* Only check type and rank. */
1404 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1417 /* Given a pointer to an interface pointer, remove duplicate
1418 interfaces and make sure that all symbols are either functions
1419 or subroutines, and all of the same kind. Returns nonzero if
1420 something goes wrong. */
1423 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1425 gfc_interface
*psave
, *q
, *qlast
;
1428 for (; p
; p
= p
->next
)
1430 /* Make sure all symbols in the interface have been defined as
1431 functions or subroutines. */
1432 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1433 || !p
->sym
->attr
.if_source
)
1434 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1436 if (p
->sym
->attr
.external
)
1437 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1438 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1440 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1441 "subroutine", p
->sym
->name
, interface_name
,
1442 &p
->sym
->declared_at
);
1446 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1447 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1448 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1449 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1451 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1452 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1453 " or all FUNCTIONs", interface_name
,
1454 &p
->sym
->declared_at
);
1456 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1457 "generic name is also the name of a derived type",
1458 interface_name
, &p
->sym
->declared_at
);
1462 /* F2003, C1207. F2008, C1207. */
1463 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1464 && gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1465 "'%s' in %s at %L", p
->sym
->name
, interface_name
,
1466 &p
->sym
->declared_at
) == FAILURE
)
1471 /* Remove duplicate interfaces in this interface list. */
1472 for (; p
; p
= p
->next
)
1476 for (q
= p
->next
; q
;)
1478 if (p
->sym
!= q
->sym
)
1485 /* Duplicate interface. */
1486 qlast
->next
= q
->next
;
1497 /* Check lists of interfaces to make sure that no two interfaces are
1498 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1501 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1502 int generic_flag
, const char *interface_name
,
1506 for (; p
; p
= p
->next
)
1507 for (q
= q0
; q
; q
= q
->next
)
1509 if (p
->sym
== q
->sym
)
1510 continue; /* Duplicates OK here. */
1512 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1515 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1516 && q
->sym
->attr
.flavor
!= FL_DERIVED
1517 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1518 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1521 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1522 p
->sym
->name
, q
->sym
->name
, interface_name
,
1524 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1525 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1526 p
->sym
->name
, q
->sym
->name
, interface_name
,
1529 gfc_warning ("Although not referenced, '%s' has ambiguous "
1530 "interfaces at %L", interface_name
, &p
->where
);
1538 /* Check the generic and operator interfaces of symbols to make sure
1539 that none of the interfaces conflict. The check has to be done
1540 after all of the symbols are actually loaded. */
1543 check_sym_interfaces (gfc_symbol
*sym
)
1545 char interface_name
[100];
1548 if (sym
->ns
!= gfc_current_ns
)
1551 if (sym
->generic
!= NULL
)
1553 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1554 if (check_interface0 (sym
->generic
, interface_name
))
1557 for (p
= sym
->generic
; p
; p
= p
->next
)
1559 if (sym
->attr
.access
!= ACCESS_PRIVATE
)
1560 p
->sym
->attr
.public_used
= 1;
1562 if (p
->sym
->attr
.mod_proc
1563 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1564 || p
->sym
->attr
.procedure
))
1566 gfc_error ("'%s' at %L is not a module procedure",
1567 p
->sym
->name
, &p
->where
);
1572 /* Originally, this test was applied to host interfaces too;
1573 this is incorrect since host associated symbols, from any
1574 source, cannot be ambiguous with local symbols. */
1575 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1576 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1582 check_uop_interfaces (gfc_user_op
*uop
)
1584 char interface_name
[100];
1589 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1590 if (check_interface0 (uop
->op
, interface_name
))
1593 if (uop
->access
!= ACCESS_PRIVATE
)
1594 for (p
= uop
->op
; p
; p
= p
->next
)
1595 p
->sym
->attr
.public_used
= 1;
1597 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1599 uop2
= gfc_find_uop (uop
->name
, ns
);
1603 check_interface1 (uop
->op
, uop2
->op
, 0,
1604 interface_name
, true);
1608 /* Given an intrinsic op, return an equivalent op if one exists,
1609 or INTRINSIC_NONE otherwise. */
1612 gfc_equivalent_op (gfc_intrinsic_op op
)
1617 return INTRINSIC_EQ_OS
;
1619 case INTRINSIC_EQ_OS
:
1620 return INTRINSIC_EQ
;
1623 return INTRINSIC_NE_OS
;
1625 case INTRINSIC_NE_OS
:
1626 return INTRINSIC_NE
;
1629 return INTRINSIC_GT_OS
;
1631 case INTRINSIC_GT_OS
:
1632 return INTRINSIC_GT
;
1635 return INTRINSIC_GE_OS
;
1637 case INTRINSIC_GE_OS
:
1638 return INTRINSIC_GE
;
1641 return INTRINSIC_LT_OS
;
1643 case INTRINSIC_LT_OS
:
1644 return INTRINSIC_LT
;
1647 return INTRINSIC_LE_OS
;
1649 case INTRINSIC_LE_OS
:
1650 return INTRINSIC_LE
;
1653 return INTRINSIC_NONE
;
1657 /* For the namespace, check generic, user operator and intrinsic
1658 operator interfaces for consistency and to remove duplicate
1659 interfaces. We traverse the whole namespace, counting on the fact
1660 that most symbols will not have generic or operator interfaces. */
1663 gfc_check_interfaces (gfc_namespace
*ns
)
1665 gfc_namespace
*old_ns
, *ns2
;
1667 char interface_name
[100];
1670 old_ns
= gfc_current_ns
;
1671 gfc_current_ns
= ns
;
1673 gfc_traverse_ns (ns
, check_sym_interfaces
);
1675 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1677 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1679 if (i
== INTRINSIC_USER
)
1682 if (i
== INTRINSIC_ASSIGN
)
1683 strcpy (interface_name
, "intrinsic assignment operator");
1685 sprintf (interface_name
, "intrinsic '%s' operator",
1686 gfc_op2string ((gfc_intrinsic_op
) i
));
1688 if (check_interface0 (ns
->op
[i
], interface_name
))
1691 for (p
= ns
->op
[i
]; p
; p
= p
->next
)
1692 p
->sym
->attr
.public_used
= 1;
1696 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1699 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1701 gfc_intrinsic_op other_op
;
1703 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1704 interface_name
, true))
1707 /* i should be gfc_intrinsic_op, but has to be int with this cast
1708 here for stupid C++ compatibility rules. */
1709 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1710 if (other_op
!= INTRINSIC_NONE
1711 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1712 0, interface_name
, true))
1718 gfc_current_ns
= old_ns
;
1723 symbol_rank (gfc_symbol
*sym
)
1725 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
1726 return CLASS_DATA (sym
)->as
->rank
;
1728 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1732 /* Given a symbol of a formal argument list and an expression, if the
1733 formal argument is allocatable, check that the actual argument is
1734 allocatable. Returns nonzero if compatible, zero if not compatible. */
1737 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1739 symbol_attribute attr
;
1741 if (formal
->attr
.allocatable
1742 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1744 attr
= gfc_expr_attr (actual
);
1745 if (!attr
.allocatable
)
1753 /* Given a symbol of a formal argument list and an expression, if the
1754 formal argument is a pointer, see if the actual argument is a
1755 pointer. Returns nonzero if compatible, zero if not compatible. */
1758 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1760 symbol_attribute attr
;
1762 if (formal
->attr
.pointer
1763 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1764 && CLASS_DATA (formal
)->attr
.class_pointer
))
1766 attr
= gfc_expr_attr (actual
);
1768 /* Fortran 2008 allows non-pointer actual arguments. */
1769 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1780 /* Emit clear error messages for rank mismatch. */
1783 argument_rank_mismatch (const char *name
, locus
*where
,
1784 int rank1
, int rank2
)
1787 /* TS 29113, C407b. */
1790 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1791 " '%s' has assumed-rank", where
, name
);
1793 else if (rank1
== 0)
1795 gfc_error ("Rank mismatch in argument '%s' at %L "
1796 "(scalar and rank-%d)", name
, where
, rank2
);
1798 else if (rank2
== 0)
1800 gfc_error ("Rank mismatch in argument '%s' at %L "
1801 "(rank-%d and scalar)", name
, where
, rank1
);
1805 gfc_error ("Rank mismatch in argument '%s' at %L "
1806 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1811 /* Given a symbol of a formal argument list and an expression, see if
1812 the two are compatible as arguments. Returns nonzero if
1813 compatible, zero if not compatible. */
1816 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1817 int ranks_must_agree
, int is_elemental
, locus
*where
)
1820 bool rank_check
, is_pointer
;
1822 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1823 procs c_f_pointer or c_f_procpointer, and we need to accept most
1824 pointers the user could give us. This should allow that. */
1825 if (formal
->ts
.type
== BT_VOID
)
1828 if (formal
->ts
.type
== BT_DERIVED
1829 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1830 && actual
->ts
.type
== BT_DERIVED
1831 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1834 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1835 /* Make sure the vtab symbol is present when
1836 the module variables are generated. */
1837 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1839 if (actual
->ts
.type
== BT_PROCEDURE
)
1842 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1844 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1847 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1851 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1852 sizeof(err
), NULL
, NULL
))
1855 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1856 formal
->name
, &actual
->where
, err
);
1860 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1862 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1863 &act_sym
->declared_at
);
1864 if (act_sym
->ts
.type
== BT_UNKNOWN
1865 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1868 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1869 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1870 &act_sym
->declared_at
);
1876 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1877 && !gfc_is_simply_contiguous (actual
, true))
1880 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1881 "must be simply contiguous", formal
->name
, &actual
->where
);
1885 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1886 && actual
->ts
.type
!= BT_HOLLERITH
1887 && formal
->ts
.type
!= BT_ASSUMED
1888 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
1889 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
1890 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
1891 CLASS_DATA (actual
)->ts
.u
.derived
)))
1894 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1895 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1896 gfc_typename (&formal
->ts
));
1900 /* F2008, 12.5.2.5; IR F08/0073. */
1901 if (formal
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
1902 && ((CLASS_DATA (formal
)->attr
.class_pointer
1903 && !formal
->attr
.intent
== INTENT_IN
)
1904 || CLASS_DATA (formal
)->attr
.allocatable
))
1906 if (actual
->ts
.type
!= BT_CLASS
)
1909 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1910 formal
->name
, &actual
->where
);
1913 if (!gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
1914 CLASS_DATA (formal
)->ts
.u
.derived
))
1917 gfc_error ("Actual argument to '%s' at %L must have the same "
1918 "declared type", formal
->name
, &actual
->where
);
1923 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
1926 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1927 formal
->name
, &actual
->where
);
1931 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
1933 gfc_ref
*last
= NULL
;
1935 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1936 if (ref
->type
== REF_COMPONENT
)
1939 /* F2008, 12.5.2.6. */
1940 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1942 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
1945 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1946 formal
->name
, &actual
->where
, formal
->as
->corank
,
1947 last
? last
->u
.c
.component
->as
->corank
1948 : actual
->symtree
->n
.sym
->as
->corank
);
1953 if (formal
->attr
.codimension
)
1955 /* F2008, 12.5.2.8. */
1956 if (formal
->attr
.dimension
1957 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1958 && gfc_expr_attr (actual
).dimension
1959 && !gfc_is_simply_contiguous (actual
, true))
1962 gfc_error ("Actual argument to '%s' at %L must be simply "
1963 "contiguous", formal
->name
, &actual
->where
);
1967 /* F2008, C1303 and C1304. */
1968 if (formal
->attr
.intent
!= INTENT_INOUT
1969 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
1970 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1971 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
1972 || formal
->attr
.lock_comp
))
1976 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1977 "which is LOCK_TYPE or has a LOCK_TYPE component",
1978 formal
->name
, &actual
->where
);
1983 /* F2008, C1239/C1240. */
1984 if (actual
->expr_type
== EXPR_VARIABLE
1985 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1986 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1987 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1988 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1989 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1990 || formal
->attr
.contiguous
))
1993 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1994 "array without CONTIGUOUS attribute - as actual argument at"
1995 " %L is not simply contiguous and both are ASYNCHRONOUS "
1996 "or VOLATILE", formal
->name
, &actual
->where
);
2000 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2001 && gfc_expr_attr (actual
).codimension
)
2003 if (formal
->attr
.intent
== INTENT_OUT
)
2006 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2007 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
2011 else if (gfc_option
.warn_surprising
&& where
2012 && formal
->attr
.intent
!= INTENT_IN
)
2013 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2014 "argument '%s', which is invalid if the allocation status"
2015 " is modified", &actual
->where
, formal
->name
);
2018 /* If the rank is the same or the formal argument has assumed-rank. */
2019 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2022 if (actual
->ts
.type
== BT_CLASS
&& CLASS_DATA (actual
)->as
2023 && CLASS_DATA (actual
)->as
->rank
== symbol_rank (formal
))
2026 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2027 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2028 || formal
->as
->type
== AS_DEFERRED
)
2029 && actual
->expr_type
!= EXPR_NULL
;
2031 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2032 if (rank_check
|| ranks_must_agree
2033 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2034 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2035 || (actual
->rank
== 0
2036 && ((formal
->ts
.type
== BT_CLASS
2037 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2038 || (formal
->ts
.type
!= BT_CLASS
2039 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2040 && actual
->expr_type
!= EXPR_NULL
)
2041 || (actual
->rank
== 0 && formal
->attr
.dimension
2042 && gfc_is_coindexed (actual
)))
2045 argument_rank_mismatch (formal
->name
, &actual
->where
,
2046 symbol_rank (formal
), actual
->rank
);
2049 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2052 /* At this point, we are considering a scalar passed to an array. This
2053 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2054 - if the actual argument is (a substring of) an element of a
2055 non-assumed-shape/non-pointer/non-polymorphic array; or
2056 - (F2003) if the actual argument is of type character of default/c_char
2059 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2060 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2062 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2064 if (ref
->type
== REF_COMPONENT
)
2065 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2066 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2067 && ref
->u
.ar
.dimen
> 0
2069 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2073 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2076 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2077 "at %L", formal
->name
, &actual
->where
);
2081 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2082 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2085 gfc_error ("Element of assumed-shaped or pointer "
2086 "array passed to array dummy argument '%s' at %L",
2087 formal
->name
, &actual
->where
);
2091 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2092 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2094 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2097 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2098 "CHARACTER actual argument with array dummy argument "
2099 "'%s' at %L", formal
->name
, &actual
->where
);
2103 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2105 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2106 "array dummy argument '%s' at %L",
2107 formal
->name
, &actual
->where
);
2110 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2116 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2119 argument_rank_mismatch (formal
->name
, &actual
->where
,
2120 symbol_rank (formal
), actual
->rank
);
2128 /* Returns the storage size of a symbol (formal argument) or
2129 zero if it cannot be determined. */
2131 static unsigned long
2132 get_sym_storage_size (gfc_symbol
*sym
)
2135 unsigned long strlen
, elements
;
2137 if (sym
->ts
.type
== BT_CHARACTER
)
2139 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2140 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2141 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2148 if (symbol_rank (sym
) == 0)
2152 if (sym
->as
->type
!= AS_EXPLICIT
)
2154 for (i
= 0; i
< sym
->as
->rank
; i
++)
2156 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2157 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2160 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2161 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2164 return strlen
*elements
;
2168 /* Returns the storage size of an expression (actual argument) or
2169 zero if it cannot be determined. For an array element, it returns
2170 the remaining size as the element sequence consists of all storage
2171 units of the actual argument up to the end of the array. */
2173 static unsigned long
2174 get_expr_storage_size (gfc_expr
*e
)
2177 long int strlen
, elements
;
2178 long int substrlen
= 0;
2179 bool is_str_storage
= false;
2185 if (e
->ts
.type
== BT_CHARACTER
)
2187 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2188 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2189 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2190 else if (e
->expr_type
== EXPR_CONSTANT
2191 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2192 strlen
= e
->value
.character
.length
;
2197 strlen
= 1; /* Length per element. */
2199 if (e
->rank
== 0 && !e
->ref
)
2207 for (i
= 0; i
< e
->rank
; i
++)
2208 elements
*= mpz_get_si (e
->shape
[i
]);
2209 return elements
*strlen
;
2212 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2214 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2215 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2219 /* The string length is the substring length.
2220 Set now to full string length. */
2221 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2222 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2225 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2227 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2231 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2232 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2234 long int start
, end
, stride
;
2237 if (ref
->u
.ar
.stride
[i
])
2239 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2240 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2245 if (ref
->u
.ar
.start
[i
])
2247 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2248 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2252 else if (ref
->u
.ar
.as
->lower
[i
]
2253 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2254 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2258 if (ref
->u
.ar
.end
[i
])
2260 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2261 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2265 else if (ref
->u
.ar
.as
->upper
[i
]
2266 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2267 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2271 elements
*= (end
- start
)/stride
+ 1L;
2273 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2274 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2276 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2277 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2278 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2279 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2280 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2285 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2286 && e
->expr_type
== EXPR_VARIABLE
)
2288 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2289 || e
->symtree
->n
.sym
->attr
.pointer
)
2295 /* Determine the number of remaining elements in the element
2296 sequence for array element designators. */
2297 is_str_storage
= true;
2298 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2300 if (ref
->u
.ar
.start
[i
] == NULL
2301 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2302 || ref
->u
.ar
.as
->upper
[i
] == NULL
2303 || ref
->u
.ar
.as
->lower
[i
] == NULL
2304 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2305 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2310 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2311 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2313 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2314 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2320 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2323 return elements
*strlen
;
2327 /* Given an expression, check whether it is an array section
2328 which has a vector subscript. If it has, one is returned,
2332 gfc_has_vector_subscript (gfc_expr
*e
)
2337 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2340 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2341 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2342 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2343 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2350 /* Given formal and actual argument lists, see if they are compatible.
2351 If they are compatible, the actual argument list is sorted to
2352 correspond with the formal list, and elements for missing optional
2353 arguments are inserted. If WHERE pointer is nonnull, then we issue
2354 errors when things don't match instead of just returning the status
2358 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2359 int ranks_must_agree
, int is_elemental
, locus
*where
)
2361 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2362 gfc_formal_arglist
*f
;
2364 unsigned long actual_size
, formal_size
;
2365 bool full_array
= false;
2369 if (actual
== NULL
&& formal
== NULL
)
2373 for (f
= formal
; f
; f
= f
->next
)
2376 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2378 for (i
= 0; i
< n
; i
++)
2385 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2387 /* Look for keywords but ignore g77 extensions like %VAL. */
2388 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2391 for (f
= formal
; f
; f
= f
->next
, i
++)
2395 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2402 gfc_error ("Keyword argument '%s' at %L is not in "
2403 "the procedure", a
->name
, &a
->expr
->where
);
2407 if (new_arg
[i
] != NULL
)
2410 gfc_error ("Keyword argument '%s' at %L is already associated "
2411 "with another actual argument", a
->name
,
2420 gfc_error ("More actual than formal arguments in procedure "
2421 "call at %L", where
);
2426 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2432 gfc_error ("Missing alternate return spec in subroutine call "
2437 if (a
->expr
== NULL
)
2440 gfc_error ("Unexpected alternate return spec in subroutine "
2441 "call at %L", where
);
2445 if (a
->expr
->expr_type
== EXPR_NULL
2446 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2447 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2448 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2449 || (f
->sym
->ts
.type
== BT_CLASS
2450 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2451 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2452 || !f
->sym
->attr
.optional
2453 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2456 && (!f
->sym
->attr
.optional
2457 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2458 || (f
->sym
->ts
.type
== BT_CLASS
2459 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2460 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2461 where
, f
->sym
->name
);
2463 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2464 "dummy '%s'", where
, f
->sym
->name
);
2469 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2470 is_elemental
, where
))
2473 /* TS 29113, 6.3p2. */
2474 if (f
->sym
->ts
.type
== BT_ASSUMED
2475 && (a
->expr
->ts
.type
== BT_DERIVED
2476 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2478 gfc_namespace
*f2k_derived
;
2480 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2481 ? a
->expr
->ts
.u
.derived
->f2k_derived
2482 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2485 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2487 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2488 "derived type with type-bound or FINAL procedures",
2494 /* Special case for character arguments. For allocatable, pointer
2495 and assumed-shape dummies, the string length needs to match
2497 if (a
->expr
->ts
.type
== BT_CHARACTER
2498 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2499 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2500 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2501 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2502 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2503 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2504 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2505 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2507 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2508 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2509 "argument and pointer or allocatable dummy argument "
2511 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2512 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2513 f
->sym
->name
, &a
->expr
->where
);
2515 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2516 "argument and assumed-shape dummy argument '%s' "
2518 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2519 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2520 f
->sym
->name
, &a
->expr
->where
);
2524 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2525 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2526 && a
->expr
->ts
.type
== BT_CHARACTER
)
2529 gfc_error ("Actual argument at %L to allocatable or "
2530 "pointer dummy argument '%s' must have a deferred "
2531 "length type parameter if and only if the dummy has one",
2532 &a
->expr
->where
, f
->sym
->name
);
2536 if (f
->sym
->ts
.type
== BT_CLASS
)
2537 goto skip_size_check
;
2539 actual_size
= get_expr_storage_size (a
->expr
);
2540 formal_size
= get_sym_storage_size (f
->sym
);
2541 if (actual_size
!= 0 && actual_size
< formal_size
2542 && a
->expr
->ts
.type
!= BT_PROCEDURE
2543 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2545 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2546 gfc_warning ("Character length of actual argument shorter "
2547 "than of dummy argument '%s' (%lu/%lu) at %L",
2548 f
->sym
->name
, actual_size
, formal_size
,
2551 gfc_warning ("Actual argument contains too few "
2552 "elements for dummy argument '%s' (%lu/%lu) at %L",
2553 f
->sym
->name
, actual_size
, formal_size
,
2560 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2561 argument is provided for a procedure pointer formal argument. */
2562 if (f
->sym
->attr
.proc_pointer
2563 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2564 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2565 || (a
->expr
->expr_type
== EXPR_FUNCTION
2566 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2567 || gfc_is_proc_ptr_comp (a
->expr
)))
2570 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2571 f
->sym
->name
, &a
->expr
->where
);
2575 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2576 provided for a procedure formal argument. */
2577 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2578 && gfc_expr_attr (a
->expr
).flavor
!= FL_PROCEDURE
)
2581 gfc_error ("Expected a procedure for argument '%s' at %L",
2582 f
->sym
->name
, &a
->expr
->where
);
2586 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2587 && a
->expr
->expr_type
== EXPR_VARIABLE
2588 && a
->expr
->symtree
->n
.sym
->as
2589 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2590 && (a
->expr
->ref
== NULL
2591 || (a
->expr
->ref
->type
== REF_ARRAY
2592 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2595 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2596 " array at %L", f
->sym
->name
, where
);
2600 if (a
->expr
->expr_type
!= EXPR_NULL
2601 && compare_pointer (f
->sym
, a
->expr
) == 0)
2604 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2605 f
->sym
->name
, &a
->expr
->where
);
2609 if (a
->expr
->expr_type
!= EXPR_NULL
2610 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2611 && compare_pointer (f
->sym
, a
->expr
) == 2)
2614 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2615 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2620 /* Fortran 2008, C1242. */
2621 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2624 gfc_error ("Coindexed actual argument at %L to pointer "
2626 &a
->expr
->where
, f
->sym
->name
);
2630 /* Fortran 2008, 12.5.2.5 (no constraint). */
2631 if (a
->expr
->expr_type
== EXPR_VARIABLE
2632 && f
->sym
->attr
.intent
!= INTENT_IN
2633 && f
->sym
->attr
.allocatable
2634 && gfc_is_coindexed (a
->expr
))
2637 gfc_error ("Coindexed actual argument at %L to allocatable "
2638 "dummy '%s' requires INTENT(IN)",
2639 &a
->expr
->where
, f
->sym
->name
);
2643 /* Fortran 2008, C1237. */
2644 if (a
->expr
->expr_type
== EXPR_VARIABLE
2645 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2646 && gfc_is_coindexed (a
->expr
)
2647 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2648 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2651 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2652 "%L requires that dummy '%s' has neither "
2653 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2658 /* Fortran 2008, 12.5.2.4 (no constraint). */
2659 if (a
->expr
->expr_type
== EXPR_VARIABLE
2660 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2661 && gfc_is_coindexed (a
->expr
)
2662 && gfc_has_ultimate_allocatable (a
->expr
))
2665 gfc_error ("Coindexed actual argument at %L with allocatable "
2666 "ultimate component to dummy '%s' requires either VALUE "
2667 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2671 if (f
->sym
->ts
.type
== BT_CLASS
2672 && CLASS_DATA (f
->sym
)->attr
.allocatable
2673 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2677 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2678 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2683 if (a
->expr
->expr_type
!= EXPR_NULL
2684 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2687 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2688 f
->sym
->name
, &a
->expr
->where
);
2692 /* Check intent = OUT/INOUT for definable actual argument. */
2693 if ((f
->sym
->attr
.intent
== INTENT_OUT
2694 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2696 const char* context
= (where
2697 ? _("actual argument to INTENT = OUT/INOUT")
2700 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2701 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2702 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2703 && gfc_check_vardef_context (a
->expr
, true, false, context
)
2706 if (gfc_check_vardef_context (a
->expr
, false, false, context
)
2711 if ((f
->sym
->attr
.intent
== INTENT_OUT
2712 || f
->sym
->attr
.intent
== INTENT_INOUT
2713 || f
->sym
->attr
.volatile_
2714 || f
->sym
->attr
.asynchronous
)
2715 && gfc_has_vector_subscript (a
->expr
))
2718 gfc_error ("Array-section actual argument with vector "
2719 "subscripts at %L is incompatible with INTENT(OUT), "
2720 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2721 "of the dummy argument '%s'",
2722 &a
->expr
->where
, f
->sym
->name
);
2726 /* C1232 (R1221) For an actual argument which is an array section or
2727 an assumed-shape array, the dummy argument shall be an assumed-
2728 shape array, if the dummy argument has the VOLATILE attribute. */
2730 if (f
->sym
->attr
.volatile_
2731 && a
->expr
->symtree
->n
.sym
->as
2732 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2733 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2736 gfc_error ("Assumed-shape actual argument at %L is "
2737 "incompatible with the non-assumed-shape "
2738 "dummy argument '%s' due to VOLATILE attribute",
2739 &a
->expr
->where
,f
->sym
->name
);
2743 if (f
->sym
->attr
.volatile_
2744 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2745 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2748 gfc_error ("Array-section actual argument at %L is "
2749 "incompatible with the non-assumed-shape "
2750 "dummy argument '%s' due to VOLATILE attribute",
2751 &a
->expr
->where
,f
->sym
->name
);
2755 /* C1233 (R1221) For an actual argument which is a pointer array, the
2756 dummy argument shall be an assumed-shape or pointer array, if the
2757 dummy argument has the VOLATILE attribute. */
2759 if (f
->sym
->attr
.volatile_
2760 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2761 && a
->expr
->symtree
->n
.sym
->as
2763 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2764 || f
->sym
->attr
.pointer
)))
2767 gfc_error ("Pointer-array actual argument at %L requires "
2768 "an assumed-shape or pointer-array dummy "
2769 "argument '%s' due to VOLATILE attribute",
2770 &a
->expr
->where
,f
->sym
->name
);
2781 /* Make sure missing actual arguments are optional. */
2783 for (f
= formal
; f
; f
= f
->next
, i
++)
2785 if (new_arg
[i
] != NULL
)
2790 gfc_error ("Missing alternate return spec in subroutine call "
2794 if (!f
->sym
->attr
.optional
)
2797 gfc_error ("Missing actual argument for argument '%s' at %L",
2798 f
->sym
->name
, where
);
2803 /* The argument lists are compatible. We now relink a new actual
2804 argument list with null arguments in the right places. The head
2805 of the list remains the head. */
2806 for (i
= 0; i
< n
; i
++)
2807 if (new_arg
[i
] == NULL
)
2808 new_arg
[i
] = gfc_get_actual_arglist ();
2813 *new_arg
[0] = *actual
;
2817 new_arg
[0] = new_arg
[na
];
2821 for (i
= 0; i
< n
- 1; i
++)
2822 new_arg
[i
]->next
= new_arg
[i
+ 1];
2824 new_arg
[i
]->next
= NULL
;
2826 if (*ap
== NULL
&& n
> 0)
2829 /* Note the types of omitted optional arguments. */
2830 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2831 if (a
->expr
== NULL
&& a
->label
== NULL
)
2832 a
->missing_arg_type
= f
->sym
->ts
.type
;
2840 gfc_formal_arglist
*f
;
2841 gfc_actual_arglist
*a
;
2845 /* qsort comparison function for argument pairs, with the following
2847 - p->a->expr == NULL
2848 - p->a->expr->expr_type != EXPR_VARIABLE
2849 - growing p->a->expr->symbol. */
2852 pair_cmp (const void *p1
, const void *p2
)
2854 const gfc_actual_arglist
*a1
, *a2
;
2856 /* *p1 and *p2 are elements of the to-be-sorted array. */
2857 a1
= ((const argpair
*) p1
)->a
;
2858 a2
= ((const argpair
*) p2
)->a
;
2867 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2869 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2873 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2875 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2879 /* Given two expressions from some actual arguments, test whether they
2880 refer to the same expression. The analysis is conservative.
2881 Returning FAILURE will produce no warning. */
2884 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2886 const gfc_ref
*r1
, *r2
;
2889 || e1
->expr_type
!= EXPR_VARIABLE
2890 || e2
->expr_type
!= EXPR_VARIABLE
2891 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2894 /* TODO: improve comparison, see expr.c:show_ref(). */
2895 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2897 if (r1
->type
!= r2
->type
)
2902 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2904 /* TODO: At the moment, consider only full arrays;
2905 we could do better. */
2906 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2911 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2919 gfc_internal_error ("compare_actual_expr(): Bad component code");
2928 /* Given formal and actual argument lists that correspond to one
2929 another, check that identical actual arguments aren't not
2930 associated with some incompatible INTENTs. */
2933 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2935 sym_intent f1_intent
, f2_intent
;
2936 gfc_formal_arglist
*f1
;
2937 gfc_actual_arglist
*a1
;
2940 gfc_try t
= SUCCESS
;
2943 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2945 if (f1
== NULL
&& a1
== NULL
)
2947 if (f1
== NULL
|| a1
== NULL
)
2948 gfc_internal_error ("check_some_aliasing(): List mismatch");
2953 p
= XALLOCAVEC (argpair
, n
);
2955 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2961 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2963 for (i
= 0; i
< n
; i
++)
2966 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2967 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2969 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2970 for (j
= i
+ 1; j
< n
; j
++)
2972 /* Expected order after the sort. */
2973 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2974 gfc_internal_error ("check_some_aliasing(): corrupted data");
2976 /* Are the expression the same? */
2977 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2979 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2980 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2981 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2983 gfc_warning ("Same actual argument associated with INTENT(%s) "
2984 "argument '%s' and INTENT(%s) argument '%s' at %L",
2985 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2986 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2987 &p
[i
].a
->expr
->where
);
2997 /* Given formal and actual argument lists that correspond to one
2998 another, check that they are compatible in the sense that intents
2999 are not mismatched. */
3002 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3004 sym_intent f_intent
;
3006 for (;; f
= f
->next
, a
= a
->next
)
3008 if (f
== NULL
&& a
== NULL
)
3010 if (f
== NULL
|| a
== NULL
)
3011 gfc_internal_error ("check_intents(): List mismatch");
3013 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
3016 f_intent
= f
->sym
->attr
.intent
;
3018 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
3020 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3021 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3022 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3024 gfc_error ("Procedure argument at %L is local to a PURE "
3025 "procedure and has the POINTER attribute",
3031 /* Fortran 2008, C1283. */
3032 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
3034 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3036 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3037 "is passed to an INTENT(%s) argument",
3038 &a
->expr
->where
, gfc_intent_string (f_intent
));
3042 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3043 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3044 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3046 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3047 "is passed to a POINTER dummy argument",
3053 /* F2008, Section 12.5.2.4. */
3054 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3055 && gfc_is_coindexed (a
->expr
))
3057 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3058 "polymorphic dummy argument '%s'",
3059 &a
->expr
->where
, f
->sym
->name
);
3068 /* Check how a procedure is used against its interface. If all goes
3069 well, the actual argument list will also end up being properly
3073 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3075 /* Warn about calls with an implicit interface. Special case
3076 for calling a ISO_C_BINDING becase c_loc and c_funloc
3077 are pseudo-unknown. Additionally, warn about procedures not
3078 explicitly declared at all if requested. */
3079 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
3081 if (gfc_option
.warn_implicit_interface
)
3082 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3084 else if (gfc_option
.warn_implicit_procedure
3085 && sym
->attr
.proc
== PROC_UNKNOWN
)
3086 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3090 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3092 gfc_actual_arglist
*a
;
3094 if (sym
->attr
.pointer
)
3096 gfc_error("The pointer object '%s' at %L must have an explicit "
3097 "function interface or be declared as array",
3102 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3104 gfc_error("The allocatable object '%s' at %L must have an explicit "
3105 "function interface or be declared as array",
3110 if (sym
->attr
.allocatable
)
3112 gfc_error("Allocatable function '%s' at %L must have an explicit "
3113 "function interface", sym
->name
, where
);
3117 for (a
= *ap
; a
; a
= a
->next
)
3119 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3120 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3122 gfc_error("Keyword argument requires explicit interface "
3123 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
3127 /* TS 29113, 6.2. */
3128 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3129 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3131 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3132 "interface", a
->expr
->symtree
->n
.sym
->name
,
3137 /* F2008, C1303 and C1304. */
3139 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3140 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3141 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3142 || gfc_expr_attr (a
->expr
).lock_comp
))
3144 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3145 "component at %L requires an explicit interface for "
3146 "procedure '%s'", &a
->expr
->where
, sym
->name
);
3150 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3151 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3153 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3157 /* TS 29113, C407b. */
3158 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3159 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3161 gfc_error ("Assumed-rank argument requires an explicit interface "
3162 "at %L", &a
->expr
->where
);
3170 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
3173 if (check_intents (sym
->formal
, *ap
) == FAILURE
)
3176 if (gfc_option
.warn_aliasing
)
3177 check_some_aliasing (sym
->formal
, *ap
);
3183 /* Check how a procedure pointer component is used against its interface.
3184 If all goes well, the actual argument list will also end up being properly
3185 sorted. Completely analogous to gfc_procedure_use. */
3188 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3191 /* Warn about calls with an implicit interface. Special case
3192 for calling a ISO_C_BINDING becase c_loc and c_funloc
3193 are pseudo-unknown. */
3194 if (gfc_option
.warn_implicit_interface
3195 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3196 && !comp
->attr
.is_iso_c
)
3197 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3198 "interface at %L", comp
->name
, where
);
3200 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3202 gfc_actual_arglist
*a
;
3203 for (a
= *ap
; a
; a
= a
->next
)
3205 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3206 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3208 gfc_error("Keyword argument requires explicit interface "
3209 "for procedure pointer component '%s' at %L",
3210 comp
->name
, &a
->expr
->where
);
3218 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
3221 check_intents (comp
->formal
, *ap
);
3222 if (gfc_option
.warn_aliasing
)
3223 check_some_aliasing (comp
->formal
, *ap
);
3227 /* Try if an actual argument list matches the formal list of a symbol,
3228 respecting the symbol's attributes like ELEMENTAL. This is used for
3229 GENERIC resolution. */
3232 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3236 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3238 r
= !sym
->attr
.elemental
;
3239 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
3241 check_intents (sym
->formal
, *args
);
3242 if (gfc_option
.warn_aliasing
)
3243 check_some_aliasing (sym
->formal
, *args
);
3251 /* Given an interface pointer and an actual argument list, search for
3252 a formal argument list that matches the actual. If found, returns
3253 a pointer to the symbol of the correct interface. Returns NULL if
3257 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3258 gfc_actual_arglist
**ap
)
3260 gfc_symbol
*elem_sym
= NULL
;
3261 gfc_symbol
*null_sym
= NULL
;
3262 locus null_expr_loc
;
3263 gfc_actual_arglist
*a
;
3264 bool has_null_arg
= false;
3266 for (a
= *ap
; a
; a
= a
->next
)
3267 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3268 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3270 has_null_arg
= true;
3271 null_expr_loc
= a
->expr
->where
;
3275 for (; intr
; intr
= intr
->next
)
3277 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3279 if (sub_flag
&& intr
->sym
->attr
.function
)
3281 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3284 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3286 if (has_null_arg
&& null_sym
)
3288 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3289 "between specific functions %s and %s",
3290 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3293 else if (has_null_arg
)
3295 null_sym
= intr
->sym
;
3299 /* Satisfy 12.4.4.1 such that an elemental match has lower
3300 weight than a non-elemental match. */
3301 if (intr
->sym
->attr
.elemental
)
3303 elem_sym
= intr
->sym
;
3313 return elem_sym
? elem_sym
: NULL
;
3317 /* Do a brute force recursive search for a symbol. */
3319 static gfc_symtree
*
3320 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3324 if (root
->n
.sym
== sym
)
3329 st
= find_symtree0 (root
->left
, sym
);
3330 if (root
->right
&& ! st
)
3331 st
= find_symtree0 (root
->right
, sym
);
3336 /* Find a symtree for a symbol. */
3339 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3344 /* First try to find it by name. */
3345 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3346 if (st
&& st
->n
.sym
== sym
)
3349 /* If it's been renamed, resort to a brute-force search. */
3350 /* TODO: avoid having to do this search. If the symbol doesn't exist
3351 in the symtree for the current namespace, it should probably be added. */
3352 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3354 st
= find_symtree0 (ns
->sym_root
, sym
);
3358 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3363 /* See if the arglist to an operator-call contains a derived-type argument
3364 with a matching type-bound operator. If so, return the matching specific
3365 procedure defined as operator-target as well as the base-object to use
3366 (which is the found derived-type argument with operator). The generic
3367 name, if any, is transmitted to the final expression via 'gname'. */
3369 static gfc_typebound_proc
*
3370 matching_typebound_op (gfc_expr
** tb_base
,
3371 gfc_actual_arglist
* args
,
3372 gfc_intrinsic_op op
, const char* uop
,
3373 const char ** gname
)
3375 gfc_actual_arglist
* base
;
3377 for (base
= args
; base
; base
= base
->next
)
3378 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3380 gfc_typebound_proc
* tb
;
3381 gfc_symbol
* derived
;
3384 while (base
->expr
->expr_type
== EXPR_OP
3385 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3386 base
->expr
= base
->expr
->value
.op
.op1
;
3388 if (base
->expr
->ts
.type
== BT_CLASS
)
3390 if (CLASS_DATA (base
->expr
) == NULL
3391 || !gfc_expr_attr (base
->expr
).class_ok
)
3393 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3396 derived
= base
->expr
->ts
.u
.derived
;
3398 if (op
== INTRINSIC_USER
)
3400 gfc_symtree
* tb_uop
;
3403 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3412 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3415 /* This means we hit a PRIVATE operator which is use-associated and
3416 should thus not be seen. */
3417 if (result
== FAILURE
)
3420 /* Look through the super-type hierarchy for a matching specific
3422 for (; tb
; tb
= tb
->overridden
)
3426 gcc_assert (tb
->is_generic
);
3427 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3430 gfc_actual_arglist
* argcopy
;
3433 gcc_assert (g
->specific
);
3434 if (g
->specific
->error
)
3437 target
= g
->specific
->u
.specific
->n
.sym
;
3439 /* Check if this arglist matches the formal. */
3440 argcopy
= gfc_copy_actual_arglist (args
);
3441 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3442 gfc_free_actual_arglist (argcopy
);
3444 /* Return if we found a match. */
3447 *tb_base
= base
->expr
;
3448 *gname
= g
->specific_st
->name
;
3459 /* For the 'actual arglist' of an operator call and a specific typebound
3460 procedure that has been found the target of a type-bound operator, build the
3461 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3462 type-bound procedures rather than resolving type-bound operators 'directly'
3463 so that we can reuse the existing logic. */
3466 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3467 gfc_expr
* base
, gfc_typebound_proc
* target
,
3470 e
->expr_type
= EXPR_COMPCALL
;
3471 e
->value
.compcall
.tbp
= target
;
3472 e
->value
.compcall
.name
= gname
? gname
: "$op";
3473 e
->value
.compcall
.actual
= actual
;
3474 e
->value
.compcall
.base_object
= base
;
3475 e
->value
.compcall
.ignore_pass
= 1;
3476 e
->value
.compcall
.assign
= 0;
3477 if (e
->ts
.type
== BT_UNKNOWN
3478 && target
->function
)
3480 if (target
->is_generic
)
3481 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3483 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3488 /* This subroutine is called when an expression is being resolved.
3489 The expression node in question is either a user defined operator
3490 or an intrinsic operator with arguments that aren't compatible
3491 with the operator. This subroutine builds an actual argument list
3492 corresponding to the operands, then searches for a compatible
3493 interface. If one is found, the expression node is replaced with
3494 the appropriate function call. We use the 'match' enum to specify
3495 whether a replacement has been made or not, or if an error occurred. */
3498 gfc_extend_expr (gfc_expr
*e
)
3500 gfc_actual_arglist
*actual
;
3509 actual
= gfc_get_actual_arglist ();
3510 actual
->expr
= e
->value
.op
.op1
;
3514 if (e
->value
.op
.op2
!= NULL
)
3516 actual
->next
= gfc_get_actual_arglist ();
3517 actual
->next
->expr
= e
->value
.op
.op2
;
3520 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3522 if (i
== INTRINSIC_USER
)
3524 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3526 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3530 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3537 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3539 /* Due to the distinction between '==' and '.eq.' and friends, one has
3540 to check if either is defined. */
3543 #define CHECK_OS_COMPARISON(comp) \
3544 case INTRINSIC_##comp: \
3545 case INTRINSIC_##comp##_OS: \
3546 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3548 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3550 CHECK_OS_COMPARISON(EQ
)
3551 CHECK_OS_COMPARISON(NE
)
3552 CHECK_OS_COMPARISON(GT
)
3553 CHECK_OS_COMPARISON(GE
)
3554 CHECK_OS_COMPARISON(LT
)
3555 CHECK_OS_COMPARISON(LE
)
3556 #undef CHECK_OS_COMPARISON
3559 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3567 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3568 found rather than just taking the first one and not checking further. */
3572 gfc_typebound_proc
* tbo
;
3575 /* See if we find a matching type-bound operator. */
3576 if (i
== INTRINSIC_USER
)
3577 tbo
= matching_typebound_op (&tb_base
, actual
,
3578 i
, e
->value
.op
.uop
->name
, &gname
);
3582 #define CHECK_OS_COMPARISON(comp) \
3583 case INTRINSIC_##comp: \
3584 case INTRINSIC_##comp##_OS: \
3585 tbo = matching_typebound_op (&tb_base, actual, \
3586 INTRINSIC_##comp, NULL, &gname); \
3588 tbo = matching_typebound_op (&tb_base, actual, \
3589 INTRINSIC_##comp##_OS, NULL, &gname); \
3591 CHECK_OS_COMPARISON(EQ
)
3592 CHECK_OS_COMPARISON(NE
)
3593 CHECK_OS_COMPARISON(GT
)
3594 CHECK_OS_COMPARISON(GE
)
3595 CHECK_OS_COMPARISON(LT
)
3596 CHECK_OS_COMPARISON(LE
)
3597 #undef CHECK_OS_COMPARISON
3600 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3604 /* If there is a matching typebound-operator, replace the expression with
3605 a call to it and succeed. */
3610 gcc_assert (tb_base
);
3611 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3613 result
= gfc_resolve_expr (e
);
3614 if (result
== FAILURE
)
3620 /* Don't use gfc_free_actual_arglist(). */
3621 free (actual
->next
);
3627 /* Change the expression node to a function call. */
3628 e
->expr_type
= EXPR_FUNCTION
;
3629 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3630 e
->value
.function
.actual
= actual
;
3631 e
->value
.function
.esym
= NULL
;
3632 e
->value
.function
.isym
= NULL
;
3633 e
->value
.function
.name
= NULL
;
3634 e
->user_operator
= 1;
3636 if (gfc_resolve_expr (e
) == FAILURE
)
3643 /* Tries to replace an assignment code node with a subroutine call to
3644 the subroutine associated with the assignment operator. Return
3645 SUCCESS if the node was replaced. On FAILURE, no error is
3649 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3651 gfc_actual_arglist
*actual
;
3652 gfc_expr
*lhs
, *rhs
;
3661 /* Don't allow an intrinsic assignment to be replaced. */
3662 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3663 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3664 && (lhs
->ts
.type
== rhs
->ts
.type
3665 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3668 actual
= gfc_get_actual_arglist ();
3671 actual
->next
= gfc_get_actual_arglist ();
3672 actual
->next
->expr
= rhs
;
3676 for (; ns
; ns
= ns
->parent
)
3678 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3683 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3687 gfc_typebound_proc
* tbo
;
3690 /* See if we find a matching type-bound assignment. */
3691 tbo
= matching_typebound_op (&tb_base
, actual
,
3692 INTRINSIC_ASSIGN
, NULL
, &gname
);
3694 /* If there is one, replace the expression with a call to it and
3698 gcc_assert (tb_base
);
3699 c
->expr1
= gfc_get_expr ();
3700 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3701 c
->expr1
->value
.compcall
.assign
= 1;
3702 c
->expr1
->where
= c
->loc
;
3704 c
->op
= EXEC_COMPCALL
;
3706 /* c is resolved from the caller, so no need to do it here. */
3711 free (actual
->next
);
3716 /* Replace the assignment with the call. */
3717 c
->op
= EXEC_ASSIGN_CALL
;
3718 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3721 c
->ext
.actual
= actual
;
3727 /* Make sure that the interface just parsed is not already present in
3728 the given interface list. Ambiguity isn't checked yet since module
3729 procedures can be present without interfaces. */
3732 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3736 for (ip
= base
; ip
; ip
= ip
->next
)
3738 if (ip
->sym
== new_sym
)
3740 gfc_error ("Entity '%s' at %L is already present in the interface",
3741 new_sym
->name
, &loc
);
3750 /* Add a symbol to the current interface. */
3753 gfc_add_interface (gfc_symbol
*new_sym
)
3755 gfc_interface
**head
, *intr
;
3759 switch (current_interface
.type
)
3761 case INTERFACE_NAMELESS
:
3762 case INTERFACE_ABSTRACT
:
3765 case INTERFACE_INTRINSIC_OP
:
3766 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3767 switch (current_interface
.op
)
3770 case INTRINSIC_EQ_OS
:
3771 if (gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3772 gfc_current_locus
) == FAILURE
3773 || gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
,
3774 gfc_current_locus
) == FAILURE
)
3779 case INTRINSIC_NE_OS
:
3780 if (gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
3781 gfc_current_locus
) == FAILURE
3782 || gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
,
3783 gfc_current_locus
) == FAILURE
)
3788 case INTRINSIC_GT_OS
:
3789 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
,
3790 gfc_current_locus
) == FAILURE
3791 || gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
,
3792 gfc_current_locus
) == FAILURE
)
3797 case INTRINSIC_GE_OS
:
3798 if (gfc_check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
,
3799 gfc_current_locus
) == FAILURE
3800 || gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
,
3801 gfc_current_locus
) == FAILURE
)
3806 case INTRINSIC_LT_OS
:
3807 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
,
3808 gfc_current_locus
) == FAILURE
3809 || gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
,
3810 gfc_current_locus
) == FAILURE
)
3815 case INTRINSIC_LE_OS
:
3816 if (gfc_check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
,
3817 gfc_current_locus
) == FAILURE
3818 || gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
,
3819 gfc_current_locus
) == FAILURE
)
3824 if (gfc_check_new_interface (ns
->op
[current_interface
.op
], new_sym
,
3825 gfc_current_locus
) == FAILURE
)
3829 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3832 case INTERFACE_GENERIC
:
3833 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3835 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3839 if (gfc_check_new_interface (sym
->generic
, new_sym
, gfc_current_locus
)
3844 head
= ¤t_interface
.sym
->generic
;
3847 case INTERFACE_USER_OP
:
3848 if (gfc_check_new_interface (current_interface
.uop
->op
, new_sym
,
3849 gfc_current_locus
) == FAILURE
)
3852 head
= ¤t_interface
.uop
->op
;
3856 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3859 intr
= gfc_get_interface ();
3860 intr
->sym
= new_sym
;
3861 intr
->where
= gfc_current_locus
;
3871 gfc_current_interface_head (void)
3873 switch (current_interface
.type
)
3875 case INTERFACE_INTRINSIC_OP
:
3876 return current_interface
.ns
->op
[current_interface
.op
];
3879 case INTERFACE_GENERIC
:
3880 return current_interface
.sym
->generic
;
3883 case INTERFACE_USER_OP
:
3884 return current_interface
.uop
->op
;
3894 gfc_set_current_interface_head (gfc_interface
*i
)
3896 switch (current_interface
.type
)
3898 case INTERFACE_INTRINSIC_OP
:
3899 current_interface
.ns
->op
[current_interface
.op
] = i
;
3902 case INTERFACE_GENERIC
:
3903 current_interface
.sym
->generic
= i
;
3906 case INTERFACE_USER_OP
:
3907 current_interface
.uop
->op
= i
;
3916 /* Gets rid of a formal argument list. We do not free symbols.
3917 Symbols are freed when a namespace is freed. */
3920 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3922 gfc_formal_arglist
*q
;
3932 /* Check that it is ok for the type-bound procedure 'proc' to override the
3933 procedure 'old', cf. F08:4.5.7.3. */
3936 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
3939 gfc_symbol
*proc_target
, *old_target
;
3940 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
3941 gfc_formal_arglist
*proc_formal
, *old_formal
;
3945 /* This procedure should only be called for non-GENERIC proc. */
3946 gcc_assert (!proc
->n
.tb
->is_generic
);
3948 /* If the overwritten procedure is GENERIC, this is an error. */
3949 if (old
->n
.tb
->is_generic
)
3951 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3952 old
->name
, &proc
->n
.tb
->where
);
3956 where
= proc
->n
.tb
->where
;
3957 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
3958 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
3960 /* Check that overridden binding is not NON_OVERRIDABLE. */
3961 if (old
->n
.tb
->non_overridable
)
3963 gfc_error ("'%s' at %L overrides a procedure binding declared"
3964 " NON_OVERRIDABLE", proc
->name
, &where
);
3968 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3969 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
3971 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3972 " non-DEFERRED binding", proc
->name
, &where
);
3976 /* If the overridden binding is PURE, the overriding must be, too. */
3977 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
3979 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3980 proc
->name
, &where
);
3984 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3985 is not, the overriding must not be either. */
3986 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
3988 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3989 " ELEMENTAL", proc
->name
, &where
);
3992 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
3994 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3995 " be ELEMENTAL, either", proc
->name
, &where
);
3999 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4001 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4003 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4004 " SUBROUTINE", proc
->name
, &where
);
4008 /* If the overridden binding is a FUNCTION, the overriding must also be a
4009 FUNCTION and have the same characteristics. */
4010 if (old_target
->attr
.function
)
4012 if (!proc_target
->attr
.function
)
4014 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4015 " FUNCTION", proc
->name
, &where
);
4019 if (check_result_characteristics (proc_target
, old_target
,
4020 err
, sizeof(err
)) == FAILURE
)
4022 gfc_error ("Result mismatch for the overriding procedure "
4023 "'%s' at %L: %s", proc
->name
, &where
, err
);
4028 /* If the overridden binding is PUBLIC, the overriding one must not be
4030 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4031 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4033 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4034 " PRIVATE", proc
->name
, &where
);
4038 /* Compare the formal argument lists of both procedures. This is also abused
4039 to find the position of the passed-object dummy arguments of both
4040 bindings as at least the overridden one might not yet be resolved and we
4041 need those positions in the check below. */
4042 proc_pass_arg
= old_pass_arg
= 0;
4043 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4045 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4048 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
4049 proc_formal
&& old_formal
;
4050 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4052 if (proc
->n
.tb
->pass_arg
4053 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4054 proc_pass_arg
= argpos
;
4055 if (old
->n
.tb
->pass_arg
4056 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4057 old_pass_arg
= argpos
;
4059 /* Check that the names correspond. */
4060 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4062 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4063 " to match the corresponding argument of the overridden"
4064 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4065 old_formal
->sym
->name
);
4069 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4070 if (check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4071 check_type
, err
, sizeof(err
)) == FAILURE
)
4073 gfc_error ("Argument mismatch for the overriding procedure "
4074 "'%s' at %L: %s", proc
->name
, &where
, err
);
4080 if (proc_formal
|| old_formal
)
4082 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4083 " the overridden procedure", proc
->name
, &where
);
4087 /* If the overridden binding is NOPASS, the overriding one must also be
4089 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4091 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4092 " NOPASS", proc
->name
, &where
);
4096 /* If the overridden binding is PASS(x), the overriding one must also be
4097 PASS and the passed-object dummy arguments must correspond. */
4098 if (!old
->n
.tb
->nopass
)
4100 if (proc
->n
.tb
->nopass
)
4102 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4103 " PASS", proc
->name
, &where
);
4107 if (proc_pass_arg
!= old_pass_arg
)
4109 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4110 " the same position as the passed-object dummy argument of"
4111 " the overridden procedure", proc
->name
, &where
);