1 /* Deal with interfaces.
2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface
;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface
*intr
)
88 for (; intr
; intr
= next
)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op
)
104 case INTRINSIC_UPLUS
:
107 case INTRINSIC_UMINUS
:
108 op
= INTRINSIC_MINUS
;
118 /* Match a generic specification. Depending on which type of
119 interface is found, the 'name' or 'op' pointers may be set.
120 This subroutine doesn't return MATCH_NO. */
123 gfc_match_generic_spec (interface_type
*type
,
125 gfc_intrinsic_op
*op
)
127 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
131 if (gfc_match (" assignment ( = )") == MATCH_YES
)
133 *type
= INTERFACE_INTRINSIC_OP
;
134 *op
= INTRINSIC_ASSIGN
;
138 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
140 *type
= INTERFACE_INTRINSIC_OP
;
141 *op
= fold_unary_intrinsic (i
);
145 *op
= INTRINSIC_NONE
;
146 if (gfc_match (" operator ( ") == MATCH_YES
)
148 m
= gfc_match_defined_op_name (buffer
, 1);
154 m
= gfc_match_char (')');
160 strcpy (name
, buffer
);
161 *type
= INTERFACE_USER_OP
;
165 if (gfc_match_name (buffer
) == MATCH_YES
)
167 strcpy (name
, buffer
);
168 *type
= INTERFACE_GENERIC
;
172 *type
= INTERFACE_NAMELESS
;
176 gfc_error ("Syntax error in generic specification at %C");
181 /* Match one of the five F95 forms of an interface statement. The
182 matcher for the abstract interface follows. */
185 gfc_match_interface (void)
187 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
193 m
= gfc_match_space ();
195 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
198 /* If we're not looking at the end of the statement now, or if this
199 is not a nameless interface but we did not see a space, punt. */
200 if (gfc_match_eos () != MATCH_YES
201 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
203 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
208 current_interface
.type
= type
;
212 case INTERFACE_GENERIC
:
213 if (gfc_get_symbol (name
, NULL
, &sym
))
216 if (!sym
->attr
.generic
217 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
222 gfc_error ("Dummy procedure %qs at %C cannot have a "
223 "generic interface", sym
->name
);
227 current_interface
.sym
= gfc_new_block
= sym
;
230 case INTERFACE_USER_OP
:
231 current_interface
.uop
= gfc_get_uop (name
);
234 case INTERFACE_INTRINSIC_OP
:
235 current_interface
.op
= op
;
238 case INTERFACE_NAMELESS
:
239 case INTERFACE_ABSTRACT
:
248 /* Match a F2003 abstract interface. */
251 gfc_match_abstract_interface (void)
255 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT INTERFACE at %C"))
258 m
= gfc_match_eos ();
262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
266 current_interface
.type
= INTERFACE_ABSTRACT
;
272 /* Match the different sort of generic-specs that can be present after
273 the END INTERFACE itself. */
276 gfc_match_end_interface (void)
278 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
283 m
= gfc_match_space ();
285 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
288 /* If we're not looking at the end of the statement now, or if this
289 is not a nameless interface but we did not see a space, punt. */
290 if (gfc_match_eos () != MATCH_YES
291 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
300 switch (current_interface
.type
)
302 case INTERFACE_NAMELESS
:
303 case INTERFACE_ABSTRACT
:
304 if (type
!= INTERFACE_NAMELESS
)
306 gfc_error ("Expected a nameless interface at %C");
312 case INTERFACE_INTRINSIC_OP
:
313 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
316 if (current_interface
.op
== INTRINSIC_ASSIGN
)
319 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
324 s1
= gfc_op2string (current_interface
.op
);
325 s2
= gfc_op2string (op
);
327 /* The following if-statements are used to enforce C1202
329 if ((strcmp(s1
, "==") == 0 && strcmp (s2
, ".eq.") == 0)
330 || (strcmp(s1
, ".eq.") == 0 && strcmp (s2
, "==") == 0))
332 if ((strcmp(s1
, "/=") == 0 && strcmp (s2
, ".ne.") == 0)
333 || (strcmp(s1
, ".ne.") == 0 && strcmp (s2
, "/=") == 0))
335 if ((strcmp(s1
, "<=") == 0 && strcmp (s2
, ".le.") == 0)
336 || (strcmp(s1
, ".le.") == 0 && strcmp (s2
, "<=") == 0))
338 if ((strcmp(s1
, "<") == 0 && strcmp (s2
, ".lt.") == 0)
339 || (strcmp(s1
, ".lt.") == 0 && strcmp (s2
, "<") == 0))
341 if ((strcmp(s1
, ">=") == 0 && strcmp (s2
, ".ge.") == 0)
342 || (strcmp(s1
, ".ge.") == 0 && strcmp (s2
, ">=") == 0))
344 if ((strcmp(s1
, ">") == 0 && strcmp (s2
, ".gt.") == 0)
345 || (strcmp(s1
, ".gt.") == 0 && strcmp (s2
, ">") == 0))
349 if (strcmp(s2
, "none") == 0)
350 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
353 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
354 "but got %s", s1
, s2
);
361 case INTERFACE_USER_OP
:
362 /* Comparing the symbol node names is OK because only use-associated
363 symbols can be renamed. */
364 if (type
!= current_interface
.type
365 || strcmp (current_interface
.uop
->name
, name
) != 0)
367 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
368 current_interface
.uop
->name
);
374 case INTERFACE_GENERIC
:
375 if (type
!= current_interface
.type
376 || strcmp (current_interface
.sym
->name
, name
) != 0)
378 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
379 current_interface
.sym
->name
);
390 /* Compare two derived types using the criteria in 4.4.2 of the standard,
391 recursing through gfc_compare_types for the components. */
394 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
396 gfc_component
*dt1
, *dt2
;
398 if (derived1
== derived2
)
401 gcc_assert (derived1
&& derived2
);
403 /* Special case for comparing derived types across namespaces. If the
404 true names and module names are the same and the module name is
405 nonnull, then they are equal. */
406 if (strcmp (derived1
->name
, derived2
->name
) == 0
407 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
408 && strcmp (derived1
->module
, derived2
->module
) == 0)
411 /* Compare type via the rules of the standard. Both types must have
412 the SEQUENCE or BIND(C) attribute to be equal. */
414 if (strcmp (derived1
->name
, derived2
->name
))
417 if (derived1
->component_access
== ACCESS_PRIVATE
418 || derived2
->component_access
== ACCESS_PRIVATE
)
421 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
422 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
))
425 dt1
= derived1
->components
;
426 dt2
= derived2
->components
;
428 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
429 simple test can speed things up. Otherwise, lots of things have to
433 if (strcmp (dt1
->name
, dt2
->name
) != 0)
436 if (dt1
->attr
.access
!= dt2
->attr
.access
)
439 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
442 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
445 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
448 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
451 /* Make sure that link lists do not put this function into an
452 endless recursive loop! */
453 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
454 && !(dt2
->ts
.type
== BT_DERIVED
&& derived2
== dt2
->ts
.u
.derived
)
455 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
458 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
459 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
462 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
463 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
469 if (dt1
== NULL
&& dt2
== NULL
)
471 if (dt1
== NULL
|| dt2
== NULL
)
479 /* Compare two typespecs, recursively if necessary. */
482 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
484 /* See if one of the typespecs is a BT_VOID, which is what is being used
485 to allow the funcs like c_f_pointer to accept any pointer type.
486 TODO: Possibly should narrow this to just the one typespec coming in
487 that is for the formal arg, but oh well. */
488 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
491 /* The _data component is not always present, therefore check for its
492 presence before assuming, that its derived->attr is available.
493 When the _data component is not present, then nevertheless the
494 unlimited_polymorphic flag may be set in the derived type's attr. */
495 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
496 && ((ts1
->u
.derived
->attr
.is_class
497 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
498 .unlimited_polymorphic
)
499 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
503 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
504 && ts2
->u
.derived
->components
505 && ((ts2
->u
.derived
->attr
.is_class
506 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
507 .unlimited_polymorphic
)
508 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
509 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
512 if (ts1
->type
!= ts2
->type
513 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
514 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
516 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
517 return (ts1
->kind
== ts2
->kind
);
519 /* Compare derived types. */
520 if (gfc_type_compatible (ts1
, ts2
))
523 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
528 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
530 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
533 /* TYPE and CLASS of the same declared type are type compatible,
534 but have different characteristics. */
535 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
536 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
539 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
544 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
546 gfc_array_spec
*as1
, *as2
;
549 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
552 as1
= (s1
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s1
)->as
: s1
->as
;
553 as2
= (s2
->ts
.type
== BT_CLASS
) ? CLASS_DATA (s2
)->as
: s2
->as
;
555 r1
= as1
? as1
->rank
: 0;
556 r2
= as2
? as2
->rank
: 0;
558 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
559 return 0; /* Ranks differ. */
565 /* Given two symbols that are formal arguments, compare their ranks
566 and types. Returns nonzero if they have the same rank and type,
570 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
572 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
576 /* Given two symbols that are formal arguments, compare their types
577 and rank and their formal interfaces if they are both dummy
578 procedures. Returns nonzero if the same, zero if different. */
581 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
583 if (s1
== NULL
|| s2
== NULL
)
584 return s1
== s2
? 1 : 0;
589 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
590 return compare_type_rank (s1
, s2
);
592 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
595 /* At this point, both symbols are procedures. It can happen that
596 external procedures are compared, where one is identified by usage
597 to be a function or subroutine but the other is not. Check TKR
598 nonetheless for these cases. */
599 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
600 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
602 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
603 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
605 /* Now the type of procedure has been identified. */
606 if (s1
->attr
.function
!= s2
->attr
.function
607 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
610 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
613 /* Originally, gfortran recursed here to check the interfaces of passed
614 procedures. This is explicitly not required by the standard. */
619 /* Given a formal argument list and a keyword name, search the list
620 for that keyword. Returns the correct symbol node if found, NULL
624 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
626 for (; f
; f
= f
->next
)
627 if (strcmp (f
->sym
->name
, name
) == 0)
634 /******** Interface checking subroutines **********/
637 /* Given an operator interface and the operator, make sure that all
638 interfaces for that operator are legal. */
641 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
644 gfc_formal_arglist
*formal
;
647 int args
, r1
, r2
, k1
, k2
;
652 t1
= t2
= BT_UNKNOWN
;
653 i1
= i2
= INTENT_UNKNOWN
;
657 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
659 gfc_symbol
*fsym
= formal
->sym
;
662 gfc_error ("Alternate return cannot appear in operator "
663 "interface at %L", &sym
->declared_at
);
669 i1
= fsym
->attr
.intent
;
670 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
676 i2
= fsym
->attr
.intent
;
677 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
683 /* Only +, - and .not. can be unary operators.
684 .not. cannot be a binary operator. */
685 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
686 && op
!= INTRINSIC_MINUS
687 && op
!= INTRINSIC_NOT
)
688 || (args
== 2 && op
== INTRINSIC_NOT
))
690 if (op
== INTRINSIC_ASSIGN
)
691 gfc_error ("Assignment operator interface at %L must have "
692 "two arguments", &sym
->declared_at
);
694 gfc_error ("Operator interface at %L has the wrong number of arguments",
699 /* Check that intrinsics are mapped to functions, except
700 INTRINSIC_ASSIGN which should map to a subroutine. */
701 if (op
== INTRINSIC_ASSIGN
)
703 gfc_formal_arglist
*dummy_args
;
705 if (!sym
->attr
.subroutine
)
707 gfc_error ("Assignment operator interface at %L must be "
708 "a SUBROUTINE", &sym
->declared_at
);
712 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
713 - First argument an array with different rank than second,
714 - First argument is a scalar and second an array,
715 - Types and kinds do not conform, or
716 - First argument is of derived type. */
717 dummy_args
= gfc_sym_get_dummy_args (sym
);
718 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
719 && dummy_args
->sym
->ts
.type
!= BT_CLASS
720 && (r2
== 0 || r1
== r2
)
721 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
722 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
723 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
725 gfc_error ("Assignment operator interface at %L must not redefine "
726 "an INTRINSIC type assignment", &sym
->declared_at
);
732 if (!sym
->attr
.function
)
734 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
740 /* Check intents on operator interfaces. */
741 if (op
== INTRINSIC_ASSIGN
)
743 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
745 gfc_error ("First argument of defined assignment at %L must be "
746 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
752 gfc_error ("Second argument of defined assignment at %L must be "
753 "INTENT(IN)", &sym
->declared_at
);
761 gfc_error ("First argument of operator interface at %L must be "
762 "INTENT(IN)", &sym
->declared_at
);
766 if (args
== 2 && i2
!= INTENT_IN
)
768 gfc_error ("Second argument of operator interface at %L must be "
769 "INTENT(IN)", &sym
->declared_at
);
774 /* From now on, all we have to do is check that the operator definition
775 doesn't conflict with an intrinsic operator. The rules for this
776 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
777 as well as 12.3.2.1.1 of Fortran 2003:
779 "If the operator is an intrinsic-operator (R310), the number of
780 function arguments shall be consistent with the intrinsic uses of
781 that operator, and the types, kind type parameters, or ranks of the
782 dummy arguments shall differ from those required for the intrinsic
783 operation (7.1.2)." */
785 #define IS_NUMERIC_TYPE(t) \
786 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
788 /* Unary ops are easy, do them first. */
789 if (op
== INTRINSIC_NOT
)
791 if (t1
== BT_LOGICAL
)
797 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
799 if (IS_NUMERIC_TYPE (t1
))
805 /* Character intrinsic operators have same character kind, thus
806 operator definitions with operands of different character kinds
808 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
811 /* Intrinsic operators always perform on arguments of same rank,
812 so different ranks is also always safe. (rank == 0) is an exception
813 to that, because all intrinsic operators are elemental. */
814 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
820 case INTRINSIC_EQ_OS
:
822 case INTRINSIC_NE_OS
:
823 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
828 case INTRINSIC_MINUS
:
829 case INTRINSIC_TIMES
:
830 case INTRINSIC_DIVIDE
:
831 case INTRINSIC_POWER
:
832 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
837 case INTRINSIC_GT_OS
:
839 case INTRINSIC_GE_OS
:
841 case INTRINSIC_LT_OS
:
843 case INTRINSIC_LE_OS
:
844 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
846 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
847 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
851 case INTRINSIC_CONCAT
:
852 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
860 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
870 #undef IS_NUMERIC_TYPE
873 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
879 /* Given a pair of formal argument lists, we see if the two lists can
880 be distinguished by counting the number of nonoptional arguments of
881 a given type/rank in f1 and seeing if there are less then that
882 number of those arguments in f2 (including optional arguments).
883 Since this test is asymmetric, it has to be called twice to make it
884 symmetric. Returns nonzero if the argument lists are incompatible
885 by this test. This subroutine implements rule 1 of section F03:16.2.3.
886 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
889 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
890 const char *p1
, const char *p2
)
892 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
893 gfc_formal_arglist
*f
;
906 for (f
= f1
; f
; f
= f
->next
)
909 /* Build an array of integers that gives the same integer to
910 arguments of the same type/rank. */
911 arg
= XCNEWVEC (arginfo
, n1
);
914 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
922 for (i
= 0; i
< n1
; i
++)
924 if (arg
[i
].flag
!= -1)
927 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
928 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
929 continue; /* Skip OPTIONAL and PASS arguments. */
933 /* Find other non-optional, non-pass arguments of the same type/rank. */
934 for (j
= i
+ 1; j
< n1
; j
++)
935 if ((arg
[j
].sym
== NULL
936 || !(arg
[j
].sym
->attr
.optional
937 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
938 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
939 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
945 /* Now loop over each distinct type found in f1. */
949 for (i
= 0; i
< n1
; i
++)
951 if (arg
[i
].flag
!= k
)
955 for (j
= i
+ 1; j
< n1
; j
++)
956 if (arg
[j
].flag
== k
)
959 /* Count the number of non-pass arguments in f2 with that type,
960 including those that are optional. */
963 for (f
= f2
; f
; f
= f
->next
)
964 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
965 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
966 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
984 /* Perform the correspondence test in rule (3) of F08:C1215.
985 Returns zero if no argument is found that satisfies this rule,
986 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
989 This test is also not symmetric in f1 and f2 and must be called
990 twice. This test finds problems caused by sorting the actual
991 argument list with keywords. For example:
995 INTEGER :: A ; REAL :: B
999 INTEGER :: A ; REAL :: B
1003 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1006 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1007 const char *p1
, const char *p2
)
1009 gfc_formal_arglist
*f2_save
, *g
;
1016 if (f1
->sym
->attr
.optional
)
1019 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1021 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1024 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1025 || compare_type_rank (f2
->sym
, f1
->sym
))
1026 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1027 && ((f1
->sym
->attr
.allocatable
&& f2
->sym
->attr
.pointer
)
1028 || (f2
->sym
->attr
.allocatable
&& f1
->sym
->attr
.pointer
))))
1031 /* Now search for a disambiguating keyword argument starting at
1032 the current non-match. */
1033 for (g
= f1
; g
; g
= g
->next
)
1035 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1038 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1039 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1040 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1041 && ((sym
->attr
.allocatable
&& g
->sym
->attr
.pointer
)
1042 || (sym
->attr
.pointer
&& g
->sym
->attr
.allocatable
))))
1058 symbol_rank (gfc_symbol
*sym
)
1061 as
= (sym
->ts
.type
== BT_CLASS
) ? CLASS_DATA (sym
)->as
: sym
->as
;
1062 return as
? as
->rank
: 0;
1066 /* Check if the characteristics of two dummy arguments match,
1070 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1071 bool type_must_agree
, char *errmsg
, int err_len
)
1073 if (s1
== NULL
|| s2
== NULL
)
1074 return s1
== s2
? true : false;
1076 /* Check type and rank. */
1077 if (type_must_agree
)
1079 if (!compare_type (s1
, s2
) || !compare_type (s2
, s1
))
1081 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1082 s1
->name
, gfc_typename (&s1
->ts
), gfc_typename (&s2
->ts
));
1085 if (!compare_rank (s1
, s2
))
1087 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1088 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1094 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1096 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1101 /* Check OPTIONAL attribute. */
1102 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1104 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1109 /* Check ALLOCATABLE attribute. */
1110 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1112 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1117 /* Check POINTER attribute. */
1118 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1120 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1125 /* Check TARGET attribute. */
1126 if (s1
->attr
.target
!= s2
->attr
.target
)
1128 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1133 /* Check ASYNCHRONOUS attribute. */
1134 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1136 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1141 /* Check CONTIGUOUS attribute. */
1142 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1144 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1149 /* Check VALUE attribute. */
1150 if (s1
->attr
.value
!= s2
->attr
.value
)
1152 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1157 /* Check VOLATILE attribute. */
1158 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1160 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1165 /* Check interface of dummy procedures. */
1166 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1169 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1172 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1173 "'%s': %s", s1
->name
, err
);
1178 /* Check string length. */
1179 if (s1
->ts
.type
== BT_CHARACTER
1180 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1181 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1183 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1184 s2
->ts
.u
.cl
->length
);
1190 snprintf (errmsg
, err_len
, "Character length mismatch "
1191 "in argument '%s'", s1
->name
);
1195 /* FIXME: Implement a warning for this case.
1196 gfc_warning (0, "Possible character length mismatch in argument %qs",
1204 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1205 "%i of gfc_dep_compare_expr", compval
);
1210 /* Check array shape. */
1211 if (s1
->as
&& s2
->as
)
1214 gfc_expr
*shape1
, *shape2
;
1216 if (s1
->as
->type
!= s2
->as
->type
)
1218 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1223 if (s1
->as
->corank
!= s2
->as
->corank
)
1225 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1226 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1230 if (s1
->as
->type
== AS_EXPLICIT
)
1231 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1233 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1234 gfc_copy_expr (s1
->as
->lower
[i
]));
1235 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1236 gfc_copy_expr (s2
->as
->lower
[i
]));
1237 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1238 gfc_free_expr (shape1
);
1239 gfc_free_expr (shape2
);
1245 if (i
< s1
->as
->rank
)
1246 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1247 " argument '%s'", i
+ 1, s1
->name
);
1249 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1250 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1254 /* FIXME: Implement a warning for this case.
1255 gfc_warning (0, "Possible shape mismatch in argument %qs",
1263 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1264 "result %i of gfc_dep_compare_expr",
1275 /* Check if the characteristics of two function results match,
1279 check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1280 char *errmsg
, int err_len
)
1282 gfc_symbol
*r1
, *r2
;
1284 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1285 r1
= s1
->ts
.interface
->result
;
1287 r1
= s1
->result
? s1
->result
: s1
;
1289 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1290 r2
= s2
->ts
.interface
->result
;
1292 r2
= s2
->result
? s2
->result
: s2
;
1294 if (r1
->ts
.type
== BT_UNKNOWN
)
1297 /* Check type and rank. */
1298 if (!compare_type (r1
, r2
))
1300 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1301 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1304 if (!compare_rank (r1
, r2
))
1306 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1307 symbol_rank (r1
), symbol_rank (r2
));
1311 /* Check ALLOCATABLE attribute. */
1312 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1314 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1319 /* Check POINTER attribute. */
1320 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1322 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1327 /* Check CONTIGUOUS attribute. */
1328 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1330 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1335 /* Check PROCEDURE POINTER attribute. */
1336 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1338 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1343 /* Check string length. */
1344 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1346 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1348 snprintf (errmsg
, err_len
, "Character length mismatch "
1349 "in function result");
1353 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1355 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1356 r2
->ts
.u
.cl
->length
);
1362 snprintf (errmsg
, err_len
, "Character length mismatch "
1363 "in function result");
1367 /* FIXME: Implement a warning for this case.
1368 snprintf (errmsg, err_len, "Possible character length mismatch "
1369 "in function result");*/
1376 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1377 "result %i of gfc_dep_compare_expr", compval
);
1383 /* Check array shape. */
1384 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1387 gfc_expr
*shape1
, *shape2
;
1389 if (r1
->as
->type
!= r2
->as
->type
)
1391 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1395 if (r1
->as
->type
== AS_EXPLICIT
)
1396 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1398 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1399 gfc_copy_expr (r1
->as
->lower
[i
]));
1400 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1401 gfc_copy_expr (r2
->as
->lower
[i
]));
1402 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1403 gfc_free_expr (shape1
);
1404 gfc_free_expr (shape2
);
1410 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1411 "function result", i
+ 1);
1415 /* FIXME: Implement a warning for this case.
1416 gfc_warning (0, "Possible shape mismatch in return value");*/
1423 gfc_internal_error ("check_result_characteristics (2): "
1424 "Unexpected result %i of "
1425 "gfc_dep_compare_expr", compval
);
1435 /* 'Compare' two formal interfaces associated with a pair of symbols.
1436 We return nonzero if there exists an actual argument list that
1437 would be ambiguous between the two interfaces, zero otherwise.
1438 'strict_flag' specifies whether all the characteristics are
1439 required to match, which is not the case for ambiguity checks.
1440 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1443 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1444 int generic_flag
, int strict_flag
,
1445 char *errmsg
, int err_len
,
1446 const char *p1
, const char *p2
)
1448 gfc_formal_arglist
*f1
, *f2
;
1450 gcc_assert (name2
!= NULL
);
1452 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1453 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1454 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1457 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1461 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1464 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1468 /* Do strict checks on all characteristics
1469 (for dummy procedures and procedure pointer assignments). */
1470 if (!generic_flag
&& strict_flag
)
1472 if (s1
->attr
.function
&& s2
->attr
.function
)
1474 /* If both are functions, check result characteristics. */
1475 if (!check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1476 || !check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1480 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1482 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1485 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1487 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1492 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1493 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1496 f1
= gfc_sym_get_dummy_args (s1
);
1497 f2
= gfc_sym_get_dummy_args (s2
);
1499 if (f1
== NULL
&& f2
== NULL
)
1500 return 1; /* Special case: No arguments. */
1504 if (count_types_test (f1
, f2
, p1
, p2
)
1505 || count_types_test (f2
, f1
, p2
, p1
))
1507 if (generic_correspondence (f1
, f2
, p1
, p2
)
1508 || generic_correspondence (f2
, f1
, p2
, p1
))
1512 /* Perform the abbreviated correspondence test for operators (the
1513 arguments cannot be optional and are always ordered correctly).
1514 This is also done when comparing interfaces for dummy procedures and in
1515 procedure pointer assignments. */
1519 /* Check existence. */
1520 if (f1
== NULL
&& f2
== NULL
)
1522 if (f1
== NULL
|| f2
== NULL
)
1525 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1526 "arguments", name2
);
1530 if (UNLIMITED_POLY (f1
->sym
))
1535 /* Check all characteristics. */
1536 if (!check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1542 /* Only check type and rank. */
1543 if (!compare_type (f2
->sym
, f1
->sym
))
1546 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1547 "(%s/%s)", f1
->sym
->name
,
1548 gfc_typename (&f1
->sym
->ts
),
1549 gfc_typename (&f2
->sym
->ts
));
1552 if (!compare_rank (f2
->sym
, f1
->sym
))
1555 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' "
1556 "(%i/%i)", f1
->sym
->name
, symbol_rank (f1
->sym
),
1557 symbol_rank (f2
->sym
));
1570 /* Given a pointer to an interface pointer, remove duplicate
1571 interfaces and make sure that all symbols are either functions
1572 or subroutines, and all of the same kind. Returns nonzero if
1573 something goes wrong. */
1576 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1578 gfc_interface
*psave
, *q
, *qlast
;
1581 for (; p
; p
= p
->next
)
1583 /* Make sure all symbols in the interface have been defined as
1584 functions or subroutines. */
1585 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1586 || !p
->sym
->attr
.if_source
)
1587 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1589 if (p
->sym
->attr
.external
)
1590 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1591 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1593 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1594 "subroutine", p
->sym
->name
, interface_name
,
1595 &p
->sym
->declared_at
);
1599 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1600 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1601 && p
->sym
->attr
.flavor
!= FL_DERIVED
)
1602 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1604 if (p
->sym
->attr
.flavor
!= FL_DERIVED
)
1605 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1606 " or all FUNCTIONs", interface_name
,
1607 &p
->sym
->declared_at
);
1609 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1610 "generic name is also the name of a derived type",
1611 interface_name
, &p
->sym
->declared_at
);
1615 /* F2003, C1207. F2008, C1207. */
1616 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1617 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1618 "%qs in %s at %L", p
->sym
->name
,
1619 interface_name
, &p
->sym
->declared_at
))
1624 /* Remove duplicate interfaces in this interface list. */
1625 for (; p
; p
= p
->next
)
1629 for (q
= p
->next
; q
;)
1631 if (p
->sym
!= q
->sym
)
1638 /* Duplicate interface. */
1639 qlast
->next
= q
->next
;
1650 /* Check lists of interfaces to make sure that no two interfaces are
1651 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1654 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1655 int generic_flag
, const char *interface_name
,
1659 for (; p
; p
= p
->next
)
1660 for (q
= q0
; q
; q
= q
->next
)
1662 if (p
->sym
== q
->sym
)
1663 continue; /* Duplicates OK here. */
1665 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1668 if (p
->sym
->attr
.flavor
!= FL_DERIVED
1669 && q
->sym
->attr
.flavor
!= FL_DERIVED
1670 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1671 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1674 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1675 p
->sym
->name
, q
->sym
->name
, interface_name
,
1677 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1678 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
1679 p
->sym
->name
, q
->sym
->name
, interface_name
,
1682 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1683 "interfaces at %L", interface_name
, &p
->where
);
1691 /* Check the generic and operator interfaces of symbols to make sure
1692 that none of the interfaces conflict. The check has to be done
1693 after all of the symbols are actually loaded. */
1696 check_sym_interfaces (gfc_symbol
*sym
)
1698 char interface_name
[100];
1701 if (sym
->ns
!= gfc_current_ns
)
1704 if (sym
->generic
!= NULL
)
1706 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1707 if (check_interface0 (sym
->generic
, interface_name
))
1710 for (p
= sym
->generic
; p
; p
= p
->next
)
1712 if (p
->sym
->attr
.mod_proc
1713 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1714 || p
->sym
->attr
.procedure
))
1716 gfc_error ("%qs at %L is not a module procedure",
1717 p
->sym
->name
, &p
->where
);
1722 /* Originally, this test was applied to host interfaces too;
1723 this is incorrect since host associated symbols, from any
1724 source, cannot be ambiguous with local symbols. */
1725 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1726 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1732 check_uop_interfaces (gfc_user_op
*uop
)
1734 char interface_name
[100];
1738 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1739 if (check_interface0 (uop
->op
, interface_name
))
1742 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1744 uop2
= gfc_find_uop (uop
->name
, ns
);
1748 check_interface1 (uop
->op
, uop2
->op
, 0,
1749 interface_name
, true);
1753 /* Given an intrinsic op, return an equivalent op if one exists,
1754 or INTRINSIC_NONE otherwise. */
1757 gfc_equivalent_op (gfc_intrinsic_op op
)
1762 return INTRINSIC_EQ_OS
;
1764 case INTRINSIC_EQ_OS
:
1765 return INTRINSIC_EQ
;
1768 return INTRINSIC_NE_OS
;
1770 case INTRINSIC_NE_OS
:
1771 return INTRINSIC_NE
;
1774 return INTRINSIC_GT_OS
;
1776 case INTRINSIC_GT_OS
:
1777 return INTRINSIC_GT
;
1780 return INTRINSIC_GE_OS
;
1782 case INTRINSIC_GE_OS
:
1783 return INTRINSIC_GE
;
1786 return INTRINSIC_LT_OS
;
1788 case INTRINSIC_LT_OS
:
1789 return INTRINSIC_LT
;
1792 return INTRINSIC_LE_OS
;
1794 case INTRINSIC_LE_OS
:
1795 return INTRINSIC_LE
;
1798 return INTRINSIC_NONE
;
1802 /* For the namespace, check generic, user operator and intrinsic
1803 operator interfaces for consistency and to remove duplicate
1804 interfaces. We traverse the whole namespace, counting on the fact
1805 that most symbols will not have generic or operator interfaces. */
1808 gfc_check_interfaces (gfc_namespace
*ns
)
1810 gfc_namespace
*old_ns
, *ns2
;
1811 char interface_name
[100];
1814 old_ns
= gfc_current_ns
;
1815 gfc_current_ns
= ns
;
1817 gfc_traverse_ns (ns
, check_sym_interfaces
);
1819 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1821 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1823 if (i
== INTRINSIC_USER
)
1826 if (i
== INTRINSIC_ASSIGN
)
1827 strcpy (interface_name
, "intrinsic assignment operator");
1829 sprintf (interface_name
, "intrinsic '%s' operator",
1830 gfc_op2string ((gfc_intrinsic_op
) i
));
1832 if (check_interface0 (ns
->op
[i
], interface_name
))
1836 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1839 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1841 gfc_intrinsic_op other_op
;
1843 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1844 interface_name
, true))
1847 /* i should be gfc_intrinsic_op, but has to be int with this cast
1848 here for stupid C++ compatibility rules. */
1849 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1850 if (other_op
!= INTRINSIC_NONE
1851 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1852 0, interface_name
, true))
1858 gfc_current_ns
= old_ns
;
1862 /* Given a symbol of a formal argument list and an expression, if the
1863 formal argument is allocatable, check that the actual argument is
1864 allocatable. Returns nonzero if compatible, zero if not compatible. */
1867 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1869 symbol_attribute attr
;
1871 if (formal
->attr
.allocatable
1872 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1874 attr
= gfc_expr_attr (actual
);
1875 if (!attr
.allocatable
)
1883 /* Given a symbol of a formal argument list and an expression, if the
1884 formal argument is a pointer, see if the actual argument is a
1885 pointer. Returns nonzero if compatible, zero if not compatible. */
1888 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1890 symbol_attribute attr
;
1892 if (formal
->attr
.pointer
1893 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
1894 && CLASS_DATA (formal
)->attr
.class_pointer
))
1896 attr
= gfc_expr_attr (actual
);
1898 /* Fortran 2008 allows non-pointer actual arguments. */
1899 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1910 /* Emit clear error messages for rank mismatch. */
1913 argument_rank_mismatch (const char *name
, locus
*where
,
1914 int rank1
, int rank2
)
1917 /* TS 29113, C407b. */
1920 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1921 " %qs has assumed-rank", where
, name
);
1923 else if (rank1
== 0)
1925 gfc_error ("Rank mismatch in argument %qs at %L "
1926 "(scalar and rank-%d)", name
, where
, rank2
);
1928 else if (rank2
== 0)
1930 gfc_error ("Rank mismatch in argument %qs at %L "
1931 "(rank-%d and scalar)", name
, where
, rank1
);
1935 gfc_error ("Rank mismatch in argument %qs at %L "
1936 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1941 /* Given a symbol of a formal argument list and an expression, see if
1942 the two are compatible as arguments. Returns nonzero if
1943 compatible, zero if not compatible. */
1946 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1947 int ranks_must_agree
, int is_elemental
, locus
*where
)
1950 bool rank_check
, is_pointer
;
1954 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1955 procs c_f_pointer or c_f_procpointer, and we need to accept most
1956 pointers the user could give us. This should allow that. */
1957 if (formal
->ts
.type
== BT_VOID
)
1960 if (formal
->ts
.type
== BT_DERIVED
1961 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1962 && actual
->ts
.type
== BT_DERIVED
1963 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1966 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1967 /* Make sure the vtab symbol is present when
1968 the module variables are generated. */
1969 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1971 if (actual
->ts
.type
== BT_PROCEDURE
)
1973 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1975 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1978 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1982 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1983 sizeof(err
), NULL
, NULL
))
1986 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
1987 formal
->name
, &actual
->where
, err
);
1991 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1993 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1994 &act_sym
->declared_at
);
1995 if (act_sym
->ts
.type
== BT_UNKNOWN
1996 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
1999 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2000 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2001 &act_sym
->declared_at
);
2006 ppc
= gfc_get_proc_ptr_comp (actual
);
2009 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2010 err
, sizeof(err
), NULL
, NULL
))
2013 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2014 formal
->name
, &actual
->where
, err
);
2020 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2021 && !gfc_is_simply_contiguous (actual
, true))
2024 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2025 "must be simply contiguous", formal
->name
, &actual
->where
);
2029 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2030 && actual
->ts
.type
!= BT_HOLLERITH
2031 && formal
->ts
.type
!= BT_ASSUMED
2032 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2033 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2034 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2035 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2036 CLASS_DATA (actual
)->ts
.u
.derived
)))
2039 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2040 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
2041 gfc_typename (&formal
->ts
));
2045 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2048 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2049 "argument %qs is of assumed type", &actual
->where
,
2054 /* F2008, 12.5.2.5; IR F08/0073. */
2055 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2056 && actual
->expr_type
!= EXPR_NULL
2057 && ((CLASS_DATA (formal
)->attr
.class_pointer
2058 && formal
->attr
.intent
!= INTENT_IN
)
2059 || CLASS_DATA (formal
)->attr
.allocatable
))
2061 if (actual
->ts
.type
!= BT_CLASS
)
2064 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2065 formal
->name
, &actual
->where
);
2069 if (!gfc_expr_attr (actual
).class_ok
)
2072 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2073 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2074 CLASS_DATA (formal
)->ts
.u
.derived
))
2077 gfc_error ("Actual argument to %qs at %L must have the same "
2078 "declared type", formal
->name
, &actual
->where
);
2083 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2084 is necessary also for F03, so retain error for both.
2085 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2086 compatible, no attempt has been made to channel to this one. */
2087 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2088 && (CLASS_DATA (formal
)->attr
.allocatable
2089 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2092 gfc_error ("Actual argument to %qs at %L must be unlimited "
2093 "polymorphic since the formal argument is a "
2094 "pointer or allocatable unlimited polymorphic "
2095 "entity [F2008: 12.5.2.5]", formal
->name
,
2100 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
2103 gfc_error ("Actual argument to %qs at %L must be a coarray",
2104 formal
->name
, &actual
->where
);
2108 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
2110 gfc_ref
*last
= NULL
;
2112 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2113 if (ref
->type
== REF_COMPONENT
)
2116 /* F2008, 12.5.2.6. */
2117 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2119 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2122 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2123 formal
->name
, &actual
->where
, formal
->as
->corank
,
2124 last
? last
->u
.c
.component
->as
->corank
2125 : actual
->symtree
->n
.sym
->as
->corank
);
2130 if (formal
->attr
.codimension
)
2132 /* F2008, 12.5.2.8. */
2133 if (formal
->attr
.dimension
2134 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2135 && gfc_expr_attr (actual
).dimension
2136 && !gfc_is_simply_contiguous (actual
, true))
2139 gfc_error ("Actual argument to %qs at %L must be simply "
2140 "contiguous", formal
->name
, &actual
->where
);
2144 /* F2008, C1303 and C1304. */
2145 if (formal
->attr
.intent
!= INTENT_INOUT
2146 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2147 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2148 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2149 || formal
->attr
.lock_comp
))
2153 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2154 "which is LOCK_TYPE or has a LOCK_TYPE component",
2155 formal
->name
, &actual
->where
);
2160 /* F2008, C1239/C1240. */
2161 if (actual
->expr_type
== EXPR_VARIABLE
2162 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2163 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2164 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2165 && actual
->rank
&& formal
->as
&& !gfc_is_simply_contiguous (actual
, true)
2166 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2167 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2168 || formal
->attr
.contiguous
))
2171 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2172 "assumed-rank array without CONTIGUOUS attribute - as actual"
2173 " argument at %L is not simply contiguous and both are "
2174 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2178 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
2179 && gfc_expr_attr (actual
).codimension
)
2181 if (formal
->attr
.intent
== INTENT_OUT
)
2184 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2185 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2189 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2190 gfc_warning (OPT_Wsurprising
,
2191 "Passing coarray at %L to allocatable, noncoarray dummy "
2192 "argument %qs, which is invalid if the allocation status"
2193 " is modified", &actual
->where
, formal
->name
);
2196 /* If the rank is the same or the formal argument has assumed-rank. */
2197 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2200 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2201 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2202 || formal
->as
->type
== AS_DEFERRED
)
2203 && actual
->expr_type
!= EXPR_NULL
;
2205 /* Skip rank checks for NO_ARG_CHECK. */
2206 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2209 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2210 if (rank_check
|| ranks_must_agree
2211 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2212 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2213 || (actual
->rank
== 0
2214 && ((formal
->ts
.type
== BT_CLASS
2215 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2216 || (formal
->ts
.type
!= BT_CLASS
2217 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2218 && actual
->expr_type
!= EXPR_NULL
)
2219 || (actual
->rank
== 0 && formal
->attr
.dimension
2220 && gfc_is_coindexed (actual
)))
2223 argument_rank_mismatch (formal
->name
, &actual
->where
,
2224 symbol_rank (formal
), actual
->rank
);
2227 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2230 /* At this point, we are considering a scalar passed to an array. This
2231 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2232 - if the actual argument is (a substring of) an element of a
2233 non-assumed-shape/non-pointer/non-polymorphic array; or
2234 - (F2003) if the actual argument is of type character of default/c_char
2237 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2238 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2240 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2242 if (ref
->type
== REF_COMPONENT
)
2243 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2244 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2245 && ref
->u
.ar
.dimen
> 0
2247 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2251 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2254 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2255 "at %L", formal
->name
, &actual
->where
);
2259 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2260 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2263 gfc_error ("Element of assumed-shaped or pointer "
2264 "array passed to array dummy argument %qs at %L",
2265 formal
->name
, &actual
->where
);
2269 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2270 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2272 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2275 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2276 "CHARACTER actual argument with array dummy argument "
2277 "%qs at %L", formal
->name
, &actual
->where
);
2281 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2283 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2284 "array dummy argument %qs at %L",
2285 formal
->name
, &actual
->where
);
2288 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2294 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2297 argument_rank_mismatch (formal
->name
, &actual
->where
,
2298 symbol_rank (formal
), actual
->rank
);
2306 /* Returns the storage size of a symbol (formal argument) or
2307 zero if it cannot be determined. */
2309 static unsigned long
2310 get_sym_storage_size (gfc_symbol
*sym
)
2313 unsigned long strlen
, elements
;
2315 if (sym
->ts
.type
== BT_CHARACTER
)
2317 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2318 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2319 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2326 if (symbol_rank (sym
) == 0)
2330 if (sym
->as
->type
!= AS_EXPLICIT
)
2332 for (i
= 0; i
< sym
->as
->rank
; i
++)
2334 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2335 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2338 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2339 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2342 return strlen
*elements
;
2346 /* Returns the storage size of an expression (actual argument) or
2347 zero if it cannot be determined. For an array element, it returns
2348 the remaining size as the element sequence consists of all storage
2349 units of the actual argument up to the end of the array. */
2351 static unsigned long
2352 get_expr_storage_size (gfc_expr
*e
)
2355 long int strlen
, elements
;
2356 long int substrlen
= 0;
2357 bool is_str_storage
= false;
2363 if (e
->ts
.type
== BT_CHARACTER
)
2365 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2366 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2367 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2368 else if (e
->expr_type
== EXPR_CONSTANT
2369 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2370 strlen
= e
->value
.character
.length
;
2375 strlen
= 1; /* Length per element. */
2377 if (e
->rank
== 0 && !e
->ref
)
2385 for (i
= 0; i
< e
->rank
; i
++)
2386 elements
*= mpz_get_si (e
->shape
[i
]);
2387 return elements
*strlen
;
2390 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2392 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2393 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2397 /* The string length is the substring length.
2398 Set now to full string length. */
2399 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2400 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2403 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2405 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2409 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2410 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2412 long int start
, end
, stride
;
2415 if (ref
->u
.ar
.stride
[i
])
2417 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2418 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2423 if (ref
->u
.ar
.start
[i
])
2425 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2426 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2430 else if (ref
->u
.ar
.as
->lower
[i
]
2431 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2432 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2436 if (ref
->u
.ar
.end
[i
])
2438 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2439 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2443 else if (ref
->u
.ar
.as
->upper
[i
]
2444 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2445 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2449 elements
*= (end
- start
)/stride
+ 1L;
2451 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2452 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2454 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2455 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2456 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2457 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2458 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2463 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2464 && e
->expr_type
== EXPR_VARIABLE
)
2466 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2467 || e
->symtree
->n
.sym
->attr
.pointer
)
2473 /* Determine the number of remaining elements in the element
2474 sequence for array element designators. */
2475 is_str_storage
= true;
2476 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2478 if (ref
->u
.ar
.start
[i
] == NULL
2479 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2480 || ref
->u
.ar
.as
->upper
[i
] == NULL
2481 || ref
->u
.ar
.as
->lower
[i
] == NULL
2482 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2483 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2488 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2489 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2491 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2492 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2495 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2496 && ref
->u
.c
.component
->attr
.proc_pointer
2497 && ref
->u
.c
.component
->attr
.dimension
)
2499 /* Array-valued procedure-pointer components. */
2500 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2501 for (i
= 0; i
< as
->rank
; i
++)
2503 if (!as
->upper
[i
] || !as
->lower
[i
]
2504 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2505 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2509 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2510 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2516 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2519 return elements
*strlen
;
2523 /* Given an expression, check whether it is an array section
2524 which has a vector subscript. If it has, one is returned,
2528 gfc_has_vector_subscript (gfc_expr
*e
)
2533 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2536 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2537 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2538 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2539 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2547 is_procptr_result (gfc_expr
*expr
)
2549 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2551 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2553 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
2554 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
2558 /* Given formal and actual argument lists, see if they are compatible.
2559 If they are compatible, the actual argument list is sorted to
2560 correspond with the formal list, and elements for missing optional
2561 arguments are inserted. If WHERE pointer is nonnull, then we issue
2562 errors when things don't match instead of just returning the status
2566 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2567 int ranks_must_agree
, int is_elemental
, locus
*where
)
2569 gfc_actual_arglist
**new_arg
, *a
, *actual
;
2570 gfc_formal_arglist
*f
;
2572 unsigned long actual_size
, formal_size
;
2573 bool full_array
= false;
2577 if (actual
== NULL
&& formal
== NULL
)
2581 for (f
= formal
; f
; f
= f
->next
)
2584 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2586 for (i
= 0; i
< n
; i
++)
2593 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2595 /* Look for keywords but ignore g77 extensions like %VAL. */
2596 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2599 for (f
= formal
; f
; f
= f
->next
, i
++)
2603 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2610 gfc_error ("Keyword argument %qs at %L is not in "
2611 "the procedure", a
->name
, &a
->expr
->where
);
2615 if (new_arg
[i
] != NULL
)
2618 gfc_error ("Keyword argument %qs at %L is already associated "
2619 "with another actual argument", a
->name
,
2628 gfc_error ("More actual than formal arguments in procedure "
2629 "call at %L", where
);
2634 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2640 gfc_error ("Missing alternate return spec in subroutine call "
2645 if (a
->expr
== NULL
)
2648 gfc_error ("Unexpected alternate return spec in subroutine "
2649 "call at %L", where
);
2653 /* Make sure that intrinsic vtables exist for calls to unlimited
2654 polymorphic formal arguments. */
2655 if (UNLIMITED_POLY (f
->sym
)
2656 && a
->expr
->ts
.type
!= BT_DERIVED
2657 && a
->expr
->ts
.type
!= BT_CLASS
)
2658 gfc_find_vtab (&a
->expr
->ts
);
2660 if (a
->expr
->expr_type
== EXPR_NULL
2661 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
2662 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2663 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2664 || (f
->sym
->ts
.type
== BT_CLASS
2665 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
2666 && (CLASS_DATA (f
->sym
)->attr
.allocatable
2667 || !f
->sym
->attr
.optional
2668 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
2671 && (!f
->sym
->attr
.optional
2672 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
2673 || (f
->sym
->ts
.type
== BT_CLASS
2674 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2675 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2676 where
, f
->sym
->name
);
2678 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2679 "dummy %qs", where
, f
->sym
->name
);
2684 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2685 is_elemental
, where
))
2688 /* TS 29113, 6.3p2. */
2689 if (f
->sym
->ts
.type
== BT_ASSUMED
2690 && (a
->expr
->ts
.type
== BT_DERIVED
2691 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
2693 gfc_namespace
*f2k_derived
;
2695 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
2696 ? a
->expr
->ts
.u
.derived
->f2k_derived
2697 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
2700 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
2702 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2703 "derived type with type-bound or FINAL procedures",
2709 /* Special case for character arguments. For allocatable, pointer
2710 and assumed-shape dummies, the string length needs to match
2712 if (a
->expr
->ts
.type
== BT_CHARACTER
2713 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2714 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2715 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2716 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2717 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2718 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2719 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2720 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2722 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2724 "Character length mismatch (%ld/%ld) between actual "
2725 "argument and pointer or allocatable dummy argument "
2727 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2728 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2729 f
->sym
->name
, &a
->expr
->where
);
2732 "Character length mismatch (%ld/%ld) between actual "
2733 "argument and assumed-shape dummy argument %qs "
2735 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2736 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2737 f
->sym
->name
, &a
->expr
->where
);
2741 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2742 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2743 && a
->expr
->ts
.type
== BT_CHARACTER
)
2746 gfc_error ("Actual argument at %L to allocatable or "
2747 "pointer dummy argument %qs must have a deferred "
2748 "length type parameter if and only if the dummy has one",
2749 &a
->expr
->where
, f
->sym
->name
);
2753 if (f
->sym
->ts
.type
== BT_CLASS
)
2754 goto skip_size_check
;
2756 actual_size
= get_expr_storage_size (a
->expr
);
2757 formal_size
= get_sym_storage_size (f
->sym
);
2758 if (actual_size
!= 0 && actual_size
< formal_size
2759 && a
->expr
->ts
.type
!= BT_PROCEDURE
2760 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2762 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2763 gfc_warning (0, "Character length of actual argument shorter "
2764 "than of dummy argument %qs (%lu/%lu) at %L",
2765 f
->sym
->name
, actual_size
, formal_size
,
2768 gfc_warning (0, "Actual argument contains too few "
2769 "elements for dummy argument %qs (%lu/%lu) at %L",
2770 f
->sym
->name
, actual_size
, formal_size
,
2777 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2778 argument is provided for a procedure pointer formal argument. */
2779 if (f
->sym
->attr
.proc_pointer
2780 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2781 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2782 || gfc_is_proc_ptr_comp (a
->expr
)))
2783 || (a
->expr
->expr_type
== EXPR_FUNCTION
2784 && is_procptr_result (a
->expr
))))
2787 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2788 f
->sym
->name
, &a
->expr
->where
);
2792 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2793 provided for a procedure formal argument. */
2794 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
2795 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2796 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2797 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2798 || gfc_is_proc_ptr_comp (a
->expr
)))
2799 || (a
->expr
->expr_type
== EXPR_FUNCTION
2800 && is_procptr_result (a
->expr
))))
2803 gfc_error ("Expected a procedure for argument %qs at %L",
2804 f
->sym
->name
, &a
->expr
->where
);
2808 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2809 && a
->expr
->expr_type
== EXPR_VARIABLE
2810 && a
->expr
->symtree
->n
.sym
->as
2811 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2812 && (a
->expr
->ref
== NULL
2813 || (a
->expr
->ref
->type
== REF_ARRAY
2814 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2817 gfc_error ("Actual argument for %qs cannot be an assumed-size"
2818 " array at %L", f
->sym
->name
, where
);
2822 if (a
->expr
->expr_type
!= EXPR_NULL
2823 && compare_pointer (f
->sym
, a
->expr
) == 0)
2826 gfc_error ("Actual argument for %qs must be a pointer at %L",
2827 f
->sym
->name
, &a
->expr
->where
);
2831 if (a
->expr
->expr_type
!= EXPR_NULL
2832 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2833 && compare_pointer (f
->sym
, a
->expr
) == 2)
2836 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2837 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
2842 /* Fortran 2008, C1242. */
2843 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2846 gfc_error ("Coindexed actual argument at %L to pointer "
2848 &a
->expr
->where
, f
->sym
->name
);
2852 /* Fortran 2008, 12.5.2.5 (no constraint). */
2853 if (a
->expr
->expr_type
== EXPR_VARIABLE
2854 && f
->sym
->attr
.intent
!= INTENT_IN
2855 && f
->sym
->attr
.allocatable
2856 && gfc_is_coindexed (a
->expr
))
2859 gfc_error ("Coindexed actual argument at %L to allocatable "
2860 "dummy %qs requires INTENT(IN)",
2861 &a
->expr
->where
, f
->sym
->name
);
2865 /* Fortran 2008, C1237. */
2866 if (a
->expr
->expr_type
== EXPR_VARIABLE
2867 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2868 && gfc_is_coindexed (a
->expr
)
2869 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2870 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2873 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2874 "%L requires that dummy %qs has neither "
2875 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2880 /* Fortran 2008, 12.5.2.4 (no constraint). */
2881 if (a
->expr
->expr_type
== EXPR_VARIABLE
2882 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2883 && gfc_is_coindexed (a
->expr
)
2884 && gfc_has_ultimate_allocatable (a
->expr
))
2887 gfc_error ("Coindexed actual argument at %L with allocatable "
2888 "ultimate component to dummy %qs requires either VALUE "
2889 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2893 if (f
->sym
->ts
.type
== BT_CLASS
2894 && CLASS_DATA (f
->sym
)->attr
.allocatable
2895 && gfc_is_class_array_ref (a
->expr
, &full_array
)
2899 gfc_error ("Actual CLASS array argument for %qs must be a full "
2900 "array at %L", f
->sym
->name
, &a
->expr
->where
);
2905 if (a
->expr
->expr_type
!= EXPR_NULL
2906 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2909 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
2910 f
->sym
->name
, &a
->expr
->where
);
2914 /* Check intent = OUT/INOUT for definable actual argument. */
2915 if ((f
->sym
->attr
.intent
== INTENT_OUT
2916 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2918 const char* context
= (where
2919 ? _("actual argument to INTENT = OUT/INOUT")
2922 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
2923 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
2924 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
2925 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
2927 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
2931 if ((f
->sym
->attr
.intent
== INTENT_OUT
2932 || f
->sym
->attr
.intent
== INTENT_INOUT
2933 || f
->sym
->attr
.volatile_
2934 || f
->sym
->attr
.asynchronous
)
2935 && gfc_has_vector_subscript (a
->expr
))
2938 gfc_error ("Array-section actual argument with vector "
2939 "subscripts at %L is incompatible with INTENT(OUT), "
2940 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2941 "of the dummy argument %qs",
2942 &a
->expr
->where
, f
->sym
->name
);
2946 /* C1232 (R1221) For an actual argument which is an array section or
2947 an assumed-shape array, the dummy argument shall be an assumed-
2948 shape array, if the dummy argument has the VOLATILE attribute. */
2950 if (f
->sym
->attr
.volatile_
2951 && a
->expr
->symtree
->n
.sym
->as
2952 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2953 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2956 gfc_error ("Assumed-shape actual argument at %L is "
2957 "incompatible with the non-assumed-shape "
2958 "dummy argument %qs due to VOLATILE attribute",
2959 &a
->expr
->where
,f
->sym
->name
);
2963 if (f
->sym
->attr
.volatile_
2964 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2965 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2968 gfc_error ("Array-section actual argument at %L is "
2969 "incompatible with the non-assumed-shape "
2970 "dummy argument %qs due to VOLATILE attribute",
2971 &a
->expr
->where
,f
->sym
->name
);
2975 /* C1233 (R1221) For an actual argument which is a pointer array, the
2976 dummy argument shall be an assumed-shape or pointer array, if the
2977 dummy argument has the VOLATILE attribute. */
2979 if (f
->sym
->attr
.volatile_
2980 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2981 && a
->expr
->symtree
->n
.sym
->as
2983 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2984 || f
->sym
->attr
.pointer
)))
2987 gfc_error ("Pointer-array actual argument at %L requires "
2988 "an assumed-shape or pointer-array dummy "
2989 "argument %qs due to VOLATILE attribute",
2990 &a
->expr
->where
,f
->sym
->name
);
3001 /* Make sure missing actual arguments are optional. */
3003 for (f
= formal
; f
; f
= f
->next
, i
++)
3005 if (new_arg
[i
] != NULL
)
3010 gfc_error ("Missing alternate return spec in subroutine call "
3014 if (!f
->sym
->attr
.optional
)
3017 gfc_error ("Missing actual argument for argument %qs at %L",
3018 f
->sym
->name
, where
);
3023 /* The argument lists are compatible. We now relink a new actual
3024 argument list with null arguments in the right places. The head
3025 of the list remains the head. */
3026 for (i
= 0; i
< n
; i
++)
3027 if (new_arg
[i
] == NULL
)
3028 new_arg
[i
] = gfc_get_actual_arglist ();
3032 std::swap (*new_arg
[0], *actual
);
3033 std::swap (new_arg
[0], new_arg
[na
]);
3036 for (i
= 0; i
< n
- 1; i
++)
3037 new_arg
[i
]->next
= new_arg
[i
+ 1];
3039 new_arg
[i
]->next
= NULL
;
3041 if (*ap
== NULL
&& n
> 0)
3044 /* Note the types of omitted optional arguments. */
3045 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3046 if (a
->expr
== NULL
&& a
->label
== NULL
)
3047 a
->missing_arg_type
= f
->sym
->ts
.type
;
3055 gfc_formal_arglist
*f
;
3056 gfc_actual_arglist
*a
;
3060 /* qsort comparison function for argument pairs, with the following
3062 - p->a->expr == NULL
3063 - p->a->expr->expr_type != EXPR_VARIABLE
3064 - growing p->a->expr->symbol. */
3067 pair_cmp (const void *p1
, const void *p2
)
3069 const gfc_actual_arglist
*a1
, *a2
;
3071 /* *p1 and *p2 are elements of the to-be-sorted array. */
3072 a1
= ((const argpair
*) p1
)->a
;
3073 a2
= ((const argpair
*) p2
)->a
;
3082 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3084 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3088 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3090 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3094 /* Given two expressions from some actual arguments, test whether they
3095 refer to the same expression. The analysis is conservative.
3096 Returning false will produce no warning. */
3099 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3101 const gfc_ref
*r1
, *r2
;
3104 || e1
->expr_type
!= EXPR_VARIABLE
3105 || e2
->expr_type
!= EXPR_VARIABLE
3106 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3109 /* TODO: improve comparison, see expr.c:show_ref(). */
3110 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3112 if (r1
->type
!= r2
->type
)
3117 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3119 /* TODO: At the moment, consider only full arrays;
3120 we could do better. */
3121 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3126 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3134 gfc_internal_error ("compare_actual_expr(): Bad component code");
3143 /* Given formal and actual argument lists that correspond to one
3144 another, check that identical actual arguments aren't not
3145 associated with some incompatible INTENTs. */
3148 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3150 sym_intent f1_intent
, f2_intent
;
3151 gfc_formal_arglist
*f1
;
3152 gfc_actual_arglist
*a1
;
3158 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3160 if (f1
== NULL
&& a1
== NULL
)
3162 if (f1
== NULL
|| a1
== NULL
)
3163 gfc_internal_error ("check_some_aliasing(): List mismatch");
3168 p
= XALLOCAVEC (argpair
, n
);
3170 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3176 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3178 for (i
= 0; i
< n
; i
++)
3181 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3182 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3184 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3185 for (j
= i
+ 1; j
< n
; j
++)
3187 /* Expected order after the sort. */
3188 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3189 gfc_internal_error ("check_some_aliasing(): corrupted data");
3191 /* Are the expression the same? */
3192 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3194 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3195 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3196 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3197 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3199 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3200 "argument %qs and INTENT(%s) argument %qs at %L",
3201 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3202 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3203 &p
[i
].a
->expr
->where
);
3213 /* Given formal and actual argument lists that correspond to one
3214 another, check that they are compatible in the sense that intents
3215 are not mismatched. */
3218 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3220 sym_intent f_intent
;
3222 for (;; f
= f
->next
, a
= a
->next
)
3226 if (f
== NULL
&& a
== NULL
)
3228 if (f
== NULL
|| a
== NULL
)
3229 gfc_internal_error ("check_intents(): List mismatch");
3231 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3232 && a
->expr
->value
.function
.isym
3233 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3234 expr
= a
->expr
->value
.function
.actual
->expr
;
3238 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3241 f_intent
= f
->sym
->attr
.intent
;
3243 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3245 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3246 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3247 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3249 gfc_error ("Procedure argument at %L is local to a PURE "
3250 "procedure and has the POINTER attribute",
3256 /* Fortran 2008, C1283. */
3257 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3259 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3261 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3262 "is passed to an INTENT(%s) argument",
3263 &expr
->where
, gfc_intent_string (f_intent
));
3267 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3268 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3269 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3271 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3272 "is passed to a POINTER dummy argument",
3278 /* F2008, Section 12.5.2.4. */
3279 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3280 && gfc_is_coindexed (expr
))
3282 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3283 "polymorphic dummy argument %qs",
3284 &expr
->where
, f
->sym
->name
);
3293 /* Check how a procedure is used against its interface. If all goes
3294 well, the actual argument list will also end up being properly
3298 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3300 gfc_formal_arglist
*dummy_args
;
3302 /* Warn about calls with an implicit interface. Special case
3303 for calling a ISO_C_BINDING because c_loc and c_funloc
3304 are pseudo-unknown. Additionally, warn about procedures not
3305 explicitly declared at all if requested. */
3306 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3308 if (sym
->ns
->has_implicit_none_export
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3310 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3314 if (warn_implicit_interface
)
3315 gfc_warning (OPT_Wimplicit_interface
,
3316 "Procedure %qs called with an implicit interface at %L",
3318 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3319 gfc_warning (OPT_Wimplicit_procedure
,
3320 "Procedure %qs called at %L is not explicitly declared",
3324 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3326 gfc_actual_arglist
*a
;
3328 if (sym
->attr
.pointer
)
3330 gfc_error ("The pointer object %qs at %L must have an explicit "
3331 "function interface or be declared as array",
3336 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3338 gfc_error ("The allocatable object %qs at %L must have an explicit "
3339 "function interface or be declared as array",
3344 if (sym
->attr
.allocatable
)
3346 gfc_error ("Allocatable function %qs at %L must have an explicit "
3347 "function interface", sym
->name
, where
);
3351 for (a
= *ap
; a
; a
= a
->next
)
3353 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3354 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3356 gfc_error ("Keyword argument requires explicit interface "
3357 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3361 /* TS 29113, 6.2. */
3362 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3363 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3365 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3366 "interface", a
->expr
->symtree
->n
.sym
->name
,
3371 /* F2008, C1303 and C1304. */
3373 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3374 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3375 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3376 || gfc_expr_attr (a
->expr
).lock_comp
))
3378 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3379 "component at %L requires an explicit interface for "
3380 "procedure %qs", &a
->expr
->where
, sym
->name
);
3384 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3385 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3387 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
3391 /* TS 29113, C407b. */
3392 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3393 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3395 gfc_error ("Assumed-rank argument requires an explicit interface "
3396 "at %L", &a
->expr
->where
);
3404 dummy_args
= gfc_sym_get_dummy_args (sym
);
3406 if (!compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
, where
))
3409 if (!check_intents (dummy_args
, *ap
))
3413 check_some_aliasing (dummy_args
, *ap
);
3419 /* Check how a procedure pointer component is used against its interface.
3420 If all goes well, the actual argument list will also end up being properly
3421 sorted. Completely analogous to gfc_procedure_use. */
3424 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
3426 /* Warn about calls with an implicit interface. Special case
3427 for calling a ISO_C_BINDING because c_loc and c_funloc
3428 are pseudo-unknown. */
3429 if (warn_implicit_interface
3430 && comp
->attr
.if_source
== IFSRC_UNKNOWN
3431 && !comp
->attr
.is_iso_c
)
3432 gfc_warning (OPT_Wimplicit_interface
,
3433 "Procedure pointer component %qs called with an implicit "
3434 "interface at %L", comp
->name
, where
);
3436 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
3438 gfc_actual_arglist
*a
;
3439 for (a
= *ap
; a
; a
= a
->next
)
3441 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3442 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3444 gfc_error ("Keyword argument requires explicit interface "
3445 "for procedure pointer component %qs at %L",
3446 comp
->name
, &a
->expr
->where
);
3454 if (!compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
3455 comp
->attr
.elemental
, where
))
3458 check_intents (comp
->ts
.interface
->formal
, *ap
);
3460 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
3464 /* Try if an actual argument list matches the formal list of a symbol,
3465 respecting the symbol's attributes like ELEMENTAL. This is used for
3466 GENERIC resolution. */
3469 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
3471 gfc_formal_arglist
*dummy_args
;
3474 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
3476 dummy_args
= gfc_sym_get_dummy_args (sym
);
3478 r
= !sym
->attr
.elemental
;
3479 if (compare_actual_formal (args
, dummy_args
, r
, !r
, NULL
))
3481 check_intents (dummy_args
, *args
);
3483 check_some_aliasing (dummy_args
, *args
);
3491 /* Given an interface pointer and an actual argument list, search for
3492 a formal argument list that matches the actual. If found, returns
3493 a pointer to the symbol of the correct interface. Returns NULL if
3497 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3498 gfc_actual_arglist
**ap
)
3500 gfc_symbol
*elem_sym
= NULL
;
3501 gfc_symbol
*null_sym
= NULL
;
3502 locus null_expr_loc
;
3503 gfc_actual_arglist
*a
;
3504 bool has_null_arg
= false;
3506 for (a
= *ap
; a
; a
= a
->next
)
3507 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3508 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3510 has_null_arg
= true;
3511 null_expr_loc
= a
->expr
->where
;
3515 for (; intr
; intr
= intr
->next
)
3517 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
3519 if (sub_flag
&& intr
->sym
->attr
.function
)
3521 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3524 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3526 if (has_null_arg
&& null_sym
)
3528 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3529 "between specific functions %s and %s",
3530 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3533 else if (has_null_arg
)
3535 null_sym
= intr
->sym
;
3539 /* Satisfy 12.4.4.1 such that an elemental match has lower
3540 weight than a non-elemental match. */
3541 if (intr
->sym
->attr
.elemental
)
3543 elem_sym
= intr
->sym
;
3553 return elem_sym
? elem_sym
: NULL
;
3557 /* Do a brute force recursive search for a symbol. */
3559 static gfc_symtree
*
3560 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3564 if (root
->n
.sym
== sym
)
3569 st
= find_symtree0 (root
->left
, sym
);
3570 if (root
->right
&& ! st
)
3571 st
= find_symtree0 (root
->right
, sym
);
3576 /* Find a symtree for a symbol. */
3579 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3584 /* First try to find it by name. */
3585 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3586 if (st
&& st
->n
.sym
== sym
)
3589 /* If it's been renamed, resort to a brute-force search. */
3590 /* TODO: avoid having to do this search. If the symbol doesn't exist
3591 in the symtree for the current namespace, it should probably be added. */
3592 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3594 st
= find_symtree0 (ns
->sym_root
, sym
);
3598 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
3603 /* See if the arglist to an operator-call contains a derived-type argument
3604 with a matching type-bound operator. If so, return the matching specific
3605 procedure defined as operator-target as well as the base-object to use
3606 (which is the found derived-type argument with operator). The generic
3607 name, if any, is transmitted to the final expression via 'gname'. */
3609 static gfc_typebound_proc
*
3610 matching_typebound_op (gfc_expr
** tb_base
,
3611 gfc_actual_arglist
* args
,
3612 gfc_intrinsic_op op
, const char* uop
,
3613 const char ** gname
)
3615 gfc_actual_arglist
* base
;
3617 for (base
= args
; base
; base
= base
->next
)
3618 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3620 gfc_typebound_proc
* tb
;
3621 gfc_symbol
* derived
;
3624 while (base
->expr
->expr_type
== EXPR_OP
3625 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
3626 base
->expr
= base
->expr
->value
.op
.op1
;
3628 if (base
->expr
->ts
.type
== BT_CLASS
)
3630 if (CLASS_DATA (base
->expr
) == NULL
3631 || !gfc_expr_attr (base
->expr
).class_ok
)
3633 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3636 derived
= base
->expr
->ts
.u
.derived
;
3638 if (op
== INTRINSIC_USER
)
3640 gfc_symtree
* tb_uop
;
3643 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3652 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3655 /* This means we hit a PRIVATE operator which is use-associated and
3656 should thus not be seen. */
3660 /* Look through the super-type hierarchy for a matching specific
3662 for (; tb
; tb
= tb
->overridden
)
3666 gcc_assert (tb
->is_generic
);
3667 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3670 gfc_actual_arglist
* argcopy
;
3673 gcc_assert (g
->specific
);
3674 if (g
->specific
->error
)
3677 target
= g
->specific
->u
.specific
->n
.sym
;
3679 /* Check if this arglist matches the formal. */
3680 argcopy
= gfc_copy_actual_arglist (args
);
3681 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3682 gfc_free_actual_arglist (argcopy
);
3684 /* Return if we found a match. */
3687 *tb_base
= base
->expr
;
3688 *gname
= g
->specific_st
->name
;
3699 /* For the 'actual arglist' of an operator call and a specific typebound
3700 procedure that has been found the target of a type-bound operator, build the
3701 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3702 type-bound procedures rather than resolving type-bound operators 'directly'
3703 so that we can reuse the existing logic. */
3706 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3707 gfc_expr
* base
, gfc_typebound_proc
* target
,
3710 e
->expr_type
= EXPR_COMPCALL
;
3711 e
->value
.compcall
.tbp
= target
;
3712 e
->value
.compcall
.name
= gname
? gname
: "$op";
3713 e
->value
.compcall
.actual
= actual
;
3714 e
->value
.compcall
.base_object
= base
;
3715 e
->value
.compcall
.ignore_pass
= 1;
3716 e
->value
.compcall
.assign
= 0;
3717 if (e
->ts
.type
== BT_UNKNOWN
3718 && target
->function
)
3720 if (target
->is_generic
)
3721 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
3723 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
3728 /* This subroutine is called when an expression is being resolved.
3729 The expression node in question is either a user defined operator
3730 or an intrinsic operator with arguments that aren't compatible
3731 with the operator. This subroutine builds an actual argument list
3732 corresponding to the operands, then searches for a compatible
3733 interface. If one is found, the expression node is replaced with
3734 the appropriate function call. We use the 'match' enum to specify
3735 whether a replacement has been made or not, or if an error occurred. */
3738 gfc_extend_expr (gfc_expr
*e
)
3740 gfc_actual_arglist
*actual
;
3746 gfc_typebound_proc
* tbo
;
3751 actual
= gfc_get_actual_arglist ();
3752 actual
->expr
= e
->value
.op
.op1
;
3756 if (e
->value
.op
.op2
!= NULL
)
3758 actual
->next
= gfc_get_actual_arglist ();
3759 actual
->next
->expr
= e
->value
.op
.op2
;
3762 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3764 /* See if we find a matching type-bound operator. */
3765 if (i
== INTRINSIC_USER
)
3766 tbo
= matching_typebound_op (&tb_base
, actual
,
3767 i
, e
->value
.op
.uop
->name
, &gname
);
3771 #define CHECK_OS_COMPARISON(comp) \
3772 case INTRINSIC_##comp: \
3773 case INTRINSIC_##comp##_OS: \
3774 tbo = matching_typebound_op (&tb_base, actual, \
3775 INTRINSIC_##comp, NULL, &gname); \
3777 tbo = matching_typebound_op (&tb_base, actual, \
3778 INTRINSIC_##comp##_OS, NULL, &gname); \
3780 CHECK_OS_COMPARISON(EQ
)
3781 CHECK_OS_COMPARISON(NE
)
3782 CHECK_OS_COMPARISON(GT
)
3783 CHECK_OS_COMPARISON(GE
)
3784 CHECK_OS_COMPARISON(LT
)
3785 CHECK_OS_COMPARISON(LE
)
3786 #undef CHECK_OS_COMPARISON
3789 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3793 /* If there is a matching typebound-operator, replace the expression with
3794 a call to it and succeed. */
3797 gcc_assert (tb_base
);
3798 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3800 if (!gfc_resolve_expr (e
))
3806 if (i
== INTRINSIC_USER
)
3808 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3810 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3814 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3821 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3823 /* Due to the distinction between '==' and '.eq.' and friends, one has
3824 to check if either is defined. */
3827 #define CHECK_OS_COMPARISON(comp) \
3828 case INTRINSIC_##comp: \
3829 case INTRINSIC_##comp##_OS: \
3830 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3832 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3834 CHECK_OS_COMPARISON(EQ
)
3835 CHECK_OS_COMPARISON(NE
)
3836 CHECK_OS_COMPARISON(GT
)
3837 CHECK_OS_COMPARISON(GE
)
3838 CHECK_OS_COMPARISON(LT
)
3839 CHECK_OS_COMPARISON(LE
)
3840 #undef CHECK_OS_COMPARISON
3843 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3851 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3852 found rather than just taking the first one and not checking further. */
3856 /* Don't use gfc_free_actual_arglist(). */
3857 free (actual
->next
);
3862 /* Change the expression node to a function call. */
3863 e
->expr_type
= EXPR_FUNCTION
;
3864 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3865 e
->value
.function
.actual
= actual
;
3866 e
->value
.function
.esym
= NULL
;
3867 e
->value
.function
.isym
= NULL
;
3868 e
->value
.function
.name
= NULL
;
3869 e
->user_operator
= 1;
3871 if (!gfc_resolve_expr (e
))
3878 /* Tries to replace an assignment code node with a subroutine call to the
3879 subroutine associated with the assignment operator. Return true if the node
3880 was replaced. On false, no error is generated. */
3883 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3885 gfc_actual_arglist
*actual
;
3886 gfc_expr
*lhs
, *rhs
, *tb_base
;
3887 gfc_symbol
*sym
= NULL
;
3888 const char *gname
= NULL
;
3889 gfc_typebound_proc
* tbo
;
3894 /* Don't allow an intrinsic assignment to be replaced. */
3895 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3896 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3897 && (lhs
->ts
.type
== rhs
->ts
.type
3898 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3901 actual
= gfc_get_actual_arglist ();
3904 actual
->next
= gfc_get_actual_arglist ();
3905 actual
->next
->expr
= rhs
;
3907 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3909 /* See if we find a matching type-bound assignment. */
3910 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
3915 /* Success: Replace the expression with a type-bound call. */
3916 gcc_assert (tb_base
);
3917 c
->expr1
= gfc_get_expr ();
3918 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3919 c
->expr1
->value
.compcall
.assign
= 1;
3920 c
->expr1
->where
= c
->loc
;
3922 c
->op
= EXEC_COMPCALL
;
3926 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
3927 for (; ns
; ns
= ns
->parent
)
3929 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3936 /* Success: Replace the assignment with the call. */
3937 c
->op
= EXEC_ASSIGN_CALL
;
3938 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3941 c
->ext
.actual
= actual
;
3945 /* Failure: No assignment procedure found. */
3946 free (actual
->next
);
3952 /* Make sure that the interface just parsed is not already present in
3953 the given interface list. Ambiguity isn't checked yet since module
3954 procedures can be present without interfaces. */
3957 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
3961 for (ip
= base
; ip
; ip
= ip
->next
)
3963 if (ip
->sym
== new_sym
)
3965 gfc_error ("Entity %qs at %L is already present in the interface",
3966 new_sym
->name
, &loc
);
3975 /* Add a symbol to the current interface. */
3978 gfc_add_interface (gfc_symbol
*new_sym
)
3980 gfc_interface
**head
, *intr
;
3984 switch (current_interface
.type
)
3986 case INTERFACE_NAMELESS
:
3987 case INTERFACE_ABSTRACT
:
3990 case INTERFACE_INTRINSIC_OP
:
3991 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3992 switch (current_interface
.op
)
3995 case INTRINSIC_EQ_OS
:
3996 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
3998 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
3999 new_sym
, gfc_current_locus
))
4004 case INTRINSIC_NE_OS
:
4005 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4007 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4008 new_sym
, gfc_current_locus
))
4013 case INTRINSIC_GT_OS
:
4014 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4015 new_sym
, gfc_current_locus
)
4016 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4017 new_sym
, gfc_current_locus
))
4022 case INTRINSIC_GE_OS
:
4023 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4024 new_sym
, gfc_current_locus
)
4025 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4026 new_sym
, gfc_current_locus
))
4031 case INTRINSIC_LT_OS
:
4032 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4033 new_sym
, gfc_current_locus
)
4034 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4035 new_sym
, gfc_current_locus
))
4040 case INTRINSIC_LE_OS
:
4041 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4042 new_sym
, gfc_current_locus
)
4043 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4044 new_sym
, gfc_current_locus
))
4049 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4050 new_sym
, gfc_current_locus
))
4054 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4057 case INTERFACE_GENERIC
:
4058 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4060 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4064 if (!gfc_check_new_interface (sym
->generic
,
4065 new_sym
, gfc_current_locus
))
4069 head
= ¤t_interface
.sym
->generic
;
4072 case INTERFACE_USER_OP
:
4073 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4074 new_sym
, gfc_current_locus
))
4077 head
= ¤t_interface
.uop
->op
;
4081 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4084 intr
= gfc_get_interface ();
4085 intr
->sym
= new_sym
;
4086 intr
->where
= gfc_current_locus
;
4096 gfc_current_interface_head (void)
4098 switch (current_interface
.type
)
4100 case INTERFACE_INTRINSIC_OP
:
4101 return current_interface
.ns
->op
[current_interface
.op
];
4104 case INTERFACE_GENERIC
:
4105 return current_interface
.sym
->generic
;
4108 case INTERFACE_USER_OP
:
4109 return current_interface
.uop
->op
;
4119 gfc_set_current_interface_head (gfc_interface
*i
)
4121 switch (current_interface
.type
)
4123 case INTERFACE_INTRINSIC_OP
:
4124 current_interface
.ns
->op
[current_interface
.op
] = i
;
4127 case INTERFACE_GENERIC
:
4128 current_interface
.sym
->generic
= i
;
4131 case INTERFACE_USER_OP
:
4132 current_interface
.uop
->op
= i
;
4141 /* Gets rid of a formal argument list. We do not free symbols.
4142 Symbols are freed when a namespace is freed. */
4145 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4147 gfc_formal_arglist
*q
;
4157 /* Check that it is ok for the type-bound procedure 'proc' to override the
4158 procedure 'old', cf. F08:4.5.7.3. */
4161 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4164 gfc_symbol
*proc_target
, *old_target
;
4165 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4166 gfc_formal_arglist
*proc_formal
, *old_formal
;
4170 /* This procedure should only be called for non-GENERIC proc. */
4171 gcc_assert (!proc
->n
.tb
->is_generic
);
4173 /* If the overwritten procedure is GENERIC, this is an error. */
4174 if (old
->n
.tb
->is_generic
)
4176 gfc_error ("Can't overwrite GENERIC %qs at %L",
4177 old
->name
, &proc
->n
.tb
->where
);
4181 where
= proc
->n
.tb
->where
;
4182 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4183 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4185 /* Check that overridden binding is not NON_OVERRIDABLE. */
4186 if (old
->n
.tb
->non_overridable
)
4188 gfc_error ("%qs at %L overrides a procedure binding declared"
4189 " NON_OVERRIDABLE", proc
->name
, &where
);
4193 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4194 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4196 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4197 " non-DEFERRED binding", proc
->name
, &where
);
4201 /* If the overridden binding is PURE, the overriding must be, too. */
4202 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4204 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4205 proc
->name
, &where
);
4209 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4210 is not, the overriding must not be either. */
4211 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4213 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4214 " ELEMENTAL", proc
->name
, &where
);
4217 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4219 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4220 " be ELEMENTAL, either", proc
->name
, &where
);
4224 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4226 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4228 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4229 " SUBROUTINE", proc
->name
, &where
);
4233 /* If the overridden binding is a FUNCTION, the overriding must also be a
4234 FUNCTION and have the same characteristics. */
4235 if (old_target
->attr
.function
)
4237 if (!proc_target
->attr
.function
)
4239 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4240 " FUNCTION", proc
->name
, &where
);
4244 if (!check_result_characteristics (proc_target
, old_target
, err
,
4247 gfc_error ("Result mismatch for the overriding procedure "
4248 "%qs at %L: %s", proc
->name
, &where
, err
);
4253 /* If the overridden binding is PUBLIC, the overriding one must not be
4255 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4256 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4258 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4259 " PRIVATE", proc
->name
, &where
);
4263 /* Compare the formal argument lists of both procedures. This is also abused
4264 to find the position of the passed-object dummy arguments of both
4265 bindings as at least the overridden one might not yet be resolved and we
4266 need those positions in the check below. */
4267 proc_pass_arg
= old_pass_arg
= 0;
4268 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4270 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4273 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4274 old_formal
= gfc_sym_get_dummy_args (old_target
);
4275 for ( ; proc_formal
&& old_formal
;
4276 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4278 if (proc
->n
.tb
->pass_arg
4279 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4280 proc_pass_arg
= argpos
;
4281 if (old
->n
.tb
->pass_arg
4282 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4283 old_pass_arg
= argpos
;
4285 /* Check that the names correspond. */
4286 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4288 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4289 " to match the corresponding argument of the overridden"
4290 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4291 old_formal
->sym
->name
);
4295 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4296 if (!check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4297 check_type
, err
, sizeof(err
)))
4299 gfc_error ("Argument mismatch for the overriding procedure "
4300 "%qs at %L: %s", proc
->name
, &where
, err
);
4306 if (proc_formal
|| old_formal
)
4308 gfc_error ("%qs at %L must have the same number of formal arguments as"
4309 " the overridden procedure", proc
->name
, &where
);
4313 /* If the overridden binding is NOPASS, the overriding one must also be
4315 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4317 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4318 " NOPASS", proc
->name
, &where
);
4322 /* If the overridden binding is PASS(x), the overriding one must also be
4323 PASS and the passed-object dummy arguments must correspond. */
4324 if (!old
->n
.tb
->nopass
)
4326 if (proc
->n
.tb
->nopass
)
4328 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4329 " PASS", proc
->name
, &where
);
4333 if (proc_pass_arg
!= old_pass_arg
)
4335 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4336 " the same position as the passed-object dummy argument of"
4337 " the overridden procedure", proc
->name
, &where
);