1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Deal with interfaces. An explicit interface is represented as a
25 singly linked list of formal argument structures attached to the
26 relevant symbols. For an implicit interface, the arguments don't
27 point to symbols. Explicit interfaces point to namespaces that
28 contain the symbols within that interface.
30 Implicit interfaces are linked together in a singly linked list
31 along the next_if member of symbol nodes. Since a particular
32 symbol can only have a single explicit interface, the symbol cannot
33 be part of multiple lists and a single next-member suffices.
35 This is not the case for general classes, though. An operator
36 definition is independent of just about all other uses and has it's
40 Nameless interfaces create symbols with explicit interfaces within
41 the current namespace. They are otherwise unlinked.
44 The generic name points to a linked list of symbols. Each symbol
45 has an explicit interface. Each explicit interface has its own
46 namespace containing the arguments. Module procedures are symbols in
47 which the interface is added later when the module procedure is parsed.
50 User-defined operators are stored in a their own set of symtrees
51 separate from regular symbols. The symtrees point to gfc_user_op
52 structures which in turn head up a list of relevant interfaces.
54 Extended intrinsics and assignment:
55 The head of these interface lists are stored in the containing namespace.
58 An implicit interface is represented as a singly linked list of
59 formal argument list structures that don't point to any symbol
60 nodes -- they just contain types.
63 When a subprogram is defined, the program unit's name points to an
64 interface as usual, but the link to the namespace is NULL and the
65 formal argument list points to symbols within the same namespace as
66 the program unit name. */
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
) == FAILURE
)
222 gfc_error ("Dummy procedure '%s' 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
, "Fortran 2003: ABSTRACT INTERFACE at %C")
259 m
= gfc_match_eos ();
263 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
267 current_interface
.type
= INTERFACE_ABSTRACT
;
273 /* Match the different sort of generic-specs that can be present after
274 the END INTERFACE itself. */
277 gfc_match_end_interface (void)
279 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
284 m
= gfc_match_space ();
286 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
289 /* If we're not looking at the end of the statement now, or if this
290 is not a nameless interface but we did not see a space, punt. */
291 if (gfc_match_eos () != MATCH_YES
292 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
294 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
301 switch (current_interface
.type
)
303 case INTERFACE_NAMELESS
:
304 case INTERFACE_ABSTRACT
:
305 if (type
!= INTERFACE_NAMELESS
)
307 gfc_error ("Expected a nameless interface at %C");
313 case INTERFACE_INTRINSIC_OP
:
314 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
317 if (current_interface
.op
== INTRINSIC_ASSIGN
)
320 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
325 s1
= gfc_op2string (current_interface
.op
);
326 s2
= gfc_op2string (op
);
328 /* The following if-statements are used to enforce C1202
330 if ((strcmp(s1
, "==") == 0 && strcmp(s2
, ".eq.") == 0)
331 || (strcmp(s1
, ".eq.") == 0 && strcmp(s2
, "==") == 0))
333 if ((strcmp(s1
, "/=") == 0 && strcmp(s2
, ".ne.") == 0)
334 || (strcmp(s1
, ".ne.") == 0 && strcmp(s2
, "/=") == 0))
336 if ((strcmp(s1
, "<=") == 0 && strcmp(s2
, ".le.") == 0)
337 || (strcmp(s1
, ".le.") == 0 && strcmp(s2
, "<=") == 0))
339 if ((strcmp(s1
, "<") == 0 && strcmp(s2
, ".lt.") == 0)
340 || (strcmp(s1
, ".lt.") == 0 && strcmp(s2
, "<") == 0))
342 if ((strcmp(s1
, ">=") == 0 && strcmp(s2
, ".ge.") == 0)
343 || (strcmp(s1
, ".ge.") == 0 && strcmp(s2
, ">=") == 0))
345 if ((strcmp(s1
, ">") == 0 && strcmp(s2
, ".gt.") == 0)
346 || (strcmp(s1
, ".gt.") == 0 && strcmp(s2
, ">") == 0))
350 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
351 "but got %s", s1
, s2
);
358 case INTERFACE_USER_OP
:
359 /* Comparing the symbol node names is OK because only use-associated
360 symbols can be renamed. */
361 if (type
!= current_interface
.type
362 || strcmp (current_interface
.uop
->name
, name
) != 0)
364 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
365 current_interface
.uop
->name
);
371 case INTERFACE_GENERIC
:
372 if (type
!= current_interface
.type
373 || strcmp (current_interface
.sym
->name
, name
) != 0)
375 gfc_error ("Expecting 'END INTERFACE %s' at %C",
376 current_interface
.sym
->name
);
387 /* Compare two derived types using the criteria in 4.4.2 of the standard,
388 recursing through gfc_compare_types for the components. */
391 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
393 gfc_component
*dt1
, *dt2
;
395 if (derived1
== derived2
)
398 /* Special case for comparing derived types across namespaces. If the
399 true names and module names are the same and the module name is
400 nonnull, then they are equal. */
401 if (derived1
!= NULL
&& derived2
!= NULL
402 && strcmp (derived1
->name
, derived2
->name
) == 0
403 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
404 && strcmp (derived1
->module
, derived2
->module
) == 0)
407 /* Compare type via the rules of the standard. Both types must have
408 the SEQUENCE attribute to be equal. */
410 if (strcmp (derived1
->name
, derived2
->name
))
413 if (derived1
->component_access
== ACCESS_PRIVATE
414 || derived2
->component_access
== ACCESS_PRIVATE
)
417 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
420 dt1
= derived1
->components
;
421 dt2
= derived2
->components
;
423 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
424 simple test can speed things up. Otherwise, lots of things have to
428 if (strcmp (dt1
->name
, dt2
->name
) != 0)
431 if (dt1
->attr
.access
!= dt2
->attr
.access
)
434 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
437 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
440 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
443 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
446 /* Make sure that link lists do not put this function into an
447 endless recursive loop! */
448 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
449 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
450 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
453 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
454 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
457 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
458 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
464 if (dt1
== NULL
&& dt2
== NULL
)
466 if (dt1
== NULL
|| dt2
== NULL
)
474 /* Compare two typespecs, recursively if necessary. */
477 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
479 /* See if one of the typespecs is a BT_VOID, which is what is being used
480 to allow the funcs like c_f_pointer to accept any pointer type.
481 TODO: Possibly should narrow this to just the one typespec coming in
482 that is for the formal arg, but oh well. */
483 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
486 if (ts1
->type
!= ts2
->type
487 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
488 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
490 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
491 return (ts1
->kind
== ts2
->kind
);
493 /* Compare derived types. */
494 if (gfc_type_compatible (ts1
, ts2
))
497 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
501 /* Given two symbols that are formal arguments, compare their ranks
502 and types. Returns nonzero if they have the same rank and type,
506 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
510 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
511 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
514 return 0; /* Ranks differ. */
516 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
520 /* Given two symbols that are formal arguments, compare their types
521 and rank and their formal interfaces if they are both dummy
522 procedures. Returns nonzero if the same, zero if different. */
525 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
527 if (s1
== NULL
|| s2
== NULL
)
528 return s1
== s2
? 1 : 0;
533 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
534 return compare_type_rank (s1
, s2
);
536 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
539 /* At this point, both symbols are procedures. It can happen that
540 external procedures are compared, where one is identified by usage
541 to be a function or subroutine but the other is not. Check TKR
542 nonetheless for these cases. */
543 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
544 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
546 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
547 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
549 /* Now the type of procedure has been identified. */
550 if (s1
->attr
.function
!= s2
->attr
.function
551 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
554 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
557 /* Originally, gfortran recursed here to check the interfaces of passed
558 procedures. This is explicitly not required by the standard. */
563 /* Given a formal argument list and a keyword name, search the list
564 for that keyword. Returns the correct symbol node if found, NULL
568 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
570 for (; f
; f
= f
->next
)
571 if (strcmp (f
->sym
->name
, name
) == 0)
578 /******** Interface checking subroutines **********/
581 /* Given an operator interface and the operator, make sure that all
582 interfaces for that operator are legal. */
585 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
588 gfc_formal_arglist
*formal
;
591 int args
, r1
, r2
, k1
, k2
;
596 t1
= t2
= BT_UNKNOWN
;
597 i1
= i2
= INTENT_UNKNOWN
;
601 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
603 gfc_symbol
*fsym
= formal
->sym
;
606 gfc_error ("Alternate return cannot appear in operator "
607 "interface at %L", &sym
->declared_at
);
613 i1
= fsym
->attr
.intent
;
614 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
620 i2
= fsym
->attr
.intent
;
621 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
627 /* Only +, - and .not. can be unary operators.
628 .not. cannot be a binary operator. */
629 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
630 && op
!= INTRINSIC_MINUS
631 && op
!= INTRINSIC_NOT
)
632 || (args
== 2 && op
== INTRINSIC_NOT
))
634 gfc_error ("Operator interface at %L has the wrong number of arguments",
639 /* Check that intrinsics are mapped to functions, except
640 INTRINSIC_ASSIGN which should map to a subroutine. */
641 if (op
== INTRINSIC_ASSIGN
)
643 if (!sym
->attr
.subroutine
)
645 gfc_error ("Assignment operator interface at %L must be "
646 "a SUBROUTINE", &sym
->declared_at
);
651 gfc_error ("Assignment operator interface at %L must have "
652 "two arguments", &sym
->declared_at
);
656 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
657 - First argument an array with different rank than second,
658 - First argument is a scalar and second an array,
659 - Types and kinds do not conform, or
660 - First argument is of derived type. */
661 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
662 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
663 && (r2
== 0 || r1
== r2
)
664 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
665 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
666 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
668 gfc_error ("Assignment operator interface at %L must not redefine "
669 "an INTRINSIC type assignment", &sym
->declared_at
);
675 if (!sym
->attr
.function
)
677 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
683 /* Check intents on operator interfaces. */
684 if (op
== INTRINSIC_ASSIGN
)
686 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
688 gfc_error ("First argument of defined assignment at %L must be "
689 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
695 gfc_error ("Second argument of defined assignment at %L must be "
696 "INTENT(IN)", &sym
->declared_at
);
704 gfc_error ("First argument of operator interface at %L must be "
705 "INTENT(IN)", &sym
->declared_at
);
709 if (args
== 2 && i2
!= INTENT_IN
)
711 gfc_error ("Second argument of operator interface at %L must be "
712 "INTENT(IN)", &sym
->declared_at
);
717 /* From now on, all we have to do is check that the operator definition
718 doesn't conflict with an intrinsic operator. The rules for this
719 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
720 as well as 12.3.2.1.1 of Fortran 2003:
722 "If the operator is an intrinsic-operator (R310), the number of
723 function arguments shall be consistent with the intrinsic uses of
724 that operator, and the types, kind type parameters, or ranks of the
725 dummy arguments shall differ from those required for the intrinsic
726 operation (7.1.2)." */
728 #define IS_NUMERIC_TYPE(t) \
729 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
731 /* Unary ops are easy, do them first. */
732 if (op
== INTRINSIC_NOT
)
734 if (t1
== BT_LOGICAL
)
740 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
742 if (IS_NUMERIC_TYPE (t1
))
748 /* Character intrinsic operators have same character kind, thus
749 operator definitions with operands of different character kinds
751 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
754 /* Intrinsic operators always perform on arguments of same rank,
755 so different ranks is also always safe. (rank == 0) is an exception
756 to that, because all intrinsic operators are elemental. */
757 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
763 case INTRINSIC_EQ_OS
:
765 case INTRINSIC_NE_OS
:
766 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
771 case INTRINSIC_MINUS
:
772 case INTRINSIC_TIMES
:
773 case INTRINSIC_DIVIDE
:
774 case INTRINSIC_POWER
:
775 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
780 case INTRINSIC_GT_OS
:
782 case INTRINSIC_GE_OS
:
784 case INTRINSIC_LT_OS
:
786 case INTRINSIC_LE_OS
:
787 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
789 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
790 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
794 case INTRINSIC_CONCAT
:
795 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
803 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
813 #undef IS_NUMERIC_TYPE
816 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
822 /* Given a pair of formal argument lists, we see if the two lists can
823 be distinguished by counting the number of nonoptional arguments of
824 a given type/rank in f1 and seeing if there are less then that
825 number of those arguments in f2 (including optional arguments).
826 Since this test is asymmetric, it has to be called twice to make it
827 symmetric. Returns nonzero if the argument lists are incompatible
828 by this test. This subroutine implements rule 1 of section
829 14.1.2.3 in the Fortran 95 standard. */
832 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
834 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
835 gfc_formal_arglist
*f
;
848 for (f
= f1
; f
; f
= f
->next
)
851 /* Build an array of integers that gives the same integer to
852 arguments of the same type/rank. */
853 arg
= XCNEWVEC (arginfo
, n1
);
856 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
864 for (i
= 0; i
< n1
; i
++)
866 if (arg
[i
].flag
!= -1)
869 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
870 continue; /* Skip optional arguments. */
874 /* Find other nonoptional arguments of the same type/rank. */
875 for (j
= i
+ 1; j
< n1
; j
++)
876 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
877 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
878 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
884 /* Now loop over each distinct type found in f1. */
888 for (i
= 0; i
< n1
; i
++)
890 if (arg
[i
].flag
!= k
)
894 for (j
= i
+ 1; j
< n1
; j
++)
895 if (arg
[j
].flag
== k
)
898 /* Count the number of arguments in f2 with that type, including
899 those that are optional. */
902 for (f
= f2
; f
; f
= f
->next
)
903 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
904 || compare_type_rank_if (f
->sym
, arg
[i
].sym
))
922 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
923 Returns zero if no argument is found that satisfies rule 2, nonzero
926 This test is also not symmetric in f1 and f2 and must be called
927 twice. This test finds problems caused by sorting the actual
928 argument list with keywords. For example:
932 INTEGER :: A ; REAL :: B
936 INTEGER :: A ; REAL :: B
940 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
943 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
945 gfc_formal_arglist
*f2_save
, *g
;
952 if (f1
->sym
->attr
.optional
)
955 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
956 || compare_type_rank (f2
->sym
, f1
->sym
)))
959 /* Now search for a disambiguating keyword argument starting at
960 the current non-match. */
961 for (g
= f1
; g
; g
= g
->next
)
963 if (g
->sym
->attr
.optional
)
966 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
967 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
981 /* Check if the characteristics of two dummy arguments match,
985 check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
986 bool type_must_agree
, char *errmsg
, int err_len
)
988 /* Check type and rank. */
989 if (type_must_agree
&& !compare_type_rank (s2
, s1
))
992 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
998 if (s1
->attr
.intent
!= s2
->attr
.intent
)
1000 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1005 /* Check OPTIONAL attribute. */
1006 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1008 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1013 /* Check ALLOCATABLE attribute. */
1014 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1016 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1021 /* Check POINTER attribute. */
1022 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1024 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1029 /* Check TARGET attribute. */
1030 if (s1
->attr
.target
!= s2
->attr
.target
)
1032 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1037 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1038 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1040 /* Check string length. */
1041 if (s1
->ts
.type
== BT_CHARACTER
1042 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1043 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1045 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1046 s2
->ts
.u
.cl
->length
);
1052 snprintf (errmsg
, err_len
, "Character length mismatch "
1053 "in argument '%s'", s1
->name
);
1057 /* FIXME: Implement a warning for this case.
1058 gfc_warning ("Possible character length mismatch in argument '%s'",
1066 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1067 "%i of gfc_dep_compare_expr", compval
);
1072 /* Check array shape. */
1073 if (s1
->as
&& s2
->as
)
1076 gfc_expr
*shape1
, *shape2
;
1078 if (s1
->as
->type
!= s2
->as
->type
)
1080 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1085 if (s1
->as
->type
== AS_EXPLICIT
)
1086 for (i
= 0; i
< s1
->as
->rank
+ s1
->as
->corank
; i
++)
1088 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1089 gfc_copy_expr (s1
->as
->lower
[i
]));
1090 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1091 gfc_copy_expr (s2
->as
->lower
[i
]));
1092 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1093 gfc_free_expr (shape1
);
1094 gfc_free_expr (shape2
);
1100 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1101 "argument '%s'", i
, s1
->name
);
1105 /* FIXME: Implement a warning for this case.
1106 gfc_warning ("Possible shape mismatch in argument '%s'",
1114 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1115 "result %i of gfc_dep_compare_expr",
1126 /* 'Compare' two formal interfaces associated with a pair of symbols.
1127 We return nonzero if there exists an actual argument list that
1128 would be ambiguous between the two interfaces, zero otherwise.
1129 'strict_flag' specifies whether all the characteristics are
1130 required to match, which is not the case for ambiguity checks.*/
1133 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1134 int generic_flag
, int strict_flag
,
1135 char *errmsg
, int err_len
)
1137 gfc_formal_arglist
*f1
, *f2
;
1139 gcc_assert (name2
!= NULL
);
1141 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1142 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1143 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1146 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1150 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1153 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1157 /* Do strict checks on all characteristics
1158 (for dummy procedures and procedure pointer assignments). */
1159 if (!generic_flag
&& strict_flag
)
1161 if (s1
->attr
.function
&& s2
->attr
.function
)
1163 /* If both are functions, check result type. */
1164 if (s1
->ts
.type
== BT_UNKNOWN
)
1166 if (!compare_type_rank (s1
,s2
))
1169 snprintf (errmsg
, err_len
, "Type/rank mismatch in return value "
1174 /* FIXME: Check array bounds and string length of result. */
1177 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1179 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1182 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1184 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1189 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1190 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1196 if (f1
== NULL
&& f2
== NULL
)
1197 return 1; /* Special case: No arguments. */
1201 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1203 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
1207 /* Perform the abbreviated correspondence test for operators (the
1208 arguments cannot be optional and are always ordered correctly).
1209 This is also done when comparing interfaces for dummy procedures and in
1210 procedure pointer assignments. */
1214 /* Check existence. */
1215 if (f1
== NULL
&& f2
== NULL
)
1217 if (f1
== NULL
|| f2
== NULL
)
1220 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1221 "arguments", name2
);
1227 /* Check all characteristics. */
1228 if (check_dummy_characteristics (f1
->sym
, f2
->sym
,
1229 true, errmsg
, err_len
) == FAILURE
)
1232 else if (!compare_type_rank (f2
->sym
, f1
->sym
))
1234 /* Only check type and rank. */
1236 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1249 /* Given a pointer to an interface pointer, remove duplicate
1250 interfaces and make sure that all symbols are either functions
1251 or subroutines, and all of the same kind. Returns nonzero if
1252 something goes wrong. */
1255 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1257 gfc_interface
*psave
, *q
, *qlast
;
1260 for (; p
; p
= p
->next
)
1262 /* Make sure all symbols in the interface have been defined as
1263 functions or subroutines. */
1264 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1265 || !p
->sym
->attr
.if_source
)
1267 if (p
->sym
->attr
.external
)
1268 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1269 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1271 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1272 "subroutine", p
->sym
->name
, interface_name
,
1273 &p
->sym
->declared_at
);
1277 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1278 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
)
1279 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1281 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1282 " or all FUNCTIONs", interface_name
, &p
->sym
->declared_at
);
1286 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1287 && gfc_notify_std (GFC_STD_GNU
, "Extension: Internal procedure '%s' "
1288 "in %s at %L", p
->sym
->name
, interface_name
,
1289 &p
->sym
->declared_at
) == FAILURE
)
1294 /* Remove duplicate interfaces in this interface list. */
1295 for (; p
; p
= p
->next
)
1299 for (q
= p
->next
; q
;)
1301 if (p
->sym
!= q
->sym
)
1308 /* Duplicate interface. */
1309 qlast
->next
= q
->next
;
1320 /* Check lists of interfaces to make sure that no two interfaces are
1321 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1324 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1325 int generic_flag
, const char *interface_name
,
1329 for (; p
; p
= p
->next
)
1330 for (q
= q0
; q
; q
= q
->next
)
1332 if (p
->sym
== q
->sym
)
1333 continue; /* Duplicates OK here. */
1335 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1338 if (gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
, generic_flag
,
1342 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1343 p
->sym
->name
, q
->sym
->name
, interface_name
,
1345 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1346 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1347 p
->sym
->name
, q
->sym
->name
, interface_name
,
1350 gfc_warning ("Although not referenced, '%s' has ambiguous "
1351 "interfaces at %L", interface_name
, &p
->where
);
1359 /* Check the generic and operator interfaces of symbols to make sure
1360 that none of the interfaces conflict. The check has to be done
1361 after all of the symbols are actually loaded. */
1364 check_sym_interfaces (gfc_symbol
*sym
)
1366 char interface_name
[100];
1369 if (sym
->ns
!= gfc_current_ns
)
1372 if (sym
->generic
!= NULL
)
1374 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1375 if (check_interface0 (sym
->generic
, interface_name
))
1378 for (p
= sym
->generic
; p
; p
= p
->next
)
1380 if (p
->sym
->attr
.mod_proc
1381 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1382 || p
->sym
->attr
.procedure
))
1384 gfc_error ("'%s' at %L is not a module procedure",
1385 p
->sym
->name
, &p
->where
);
1390 /* Originally, this test was applied to host interfaces too;
1391 this is incorrect since host associated symbols, from any
1392 source, cannot be ambiguous with local symbols. */
1393 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1394 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1400 check_uop_interfaces (gfc_user_op
*uop
)
1402 char interface_name
[100];
1406 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1407 if (check_interface0 (uop
->op
, interface_name
))
1410 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1412 uop2
= gfc_find_uop (uop
->name
, ns
);
1416 check_interface1 (uop
->op
, uop2
->op
, 0,
1417 interface_name
, true);
1421 /* Given an intrinsic op, return an equivalent op if one exists,
1422 or INTRINSIC_NONE otherwise. */
1425 gfc_equivalent_op (gfc_intrinsic_op op
)
1430 return INTRINSIC_EQ_OS
;
1432 case INTRINSIC_EQ_OS
:
1433 return INTRINSIC_EQ
;
1436 return INTRINSIC_NE_OS
;
1438 case INTRINSIC_NE_OS
:
1439 return INTRINSIC_NE
;
1442 return INTRINSIC_GT_OS
;
1444 case INTRINSIC_GT_OS
:
1445 return INTRINSIC_GT
;
1448 return INTRINSIC_GE_OS
;
1450 case INTRINSIC_GE_OS
:
1451 return INTRINSIC_GE
;
1454 return INTRINSIC_LT_OS
;
1456 case INTRINSIC_LT_OS
:
1457 return INTRINSIC_LT
;
1460 return INTRINSIC_LE_OS
;
1462 case INTRINSIC_LE_OS
:
1463 return INTRINSIC_LE
;
1466 return INTRINSIC_NONE
;
1470 /* For the namespace, check generic, user operator and intrinsic
1471 operator interfaces for consistency and to remove duplicate
1472 interfaces. We traverse the whole namespace, counting on the fact
1473 that most symbols will not have generic or operator interfaces. */
1476 gfc_check_interfaces (gfc_namespace
*ns
)
1478 gfc_namespace
*old_ns
, *ns2
;
1479 char interface_name
[100];
1482 old_ns
= gfc_current_ns
;
1483 gfc_current_ns
= ns
;
1485 gfc_traverse_ns (ns
, check_sym_interfaces
);
1487 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1489 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1491 if (i
== INTRINSIC_USER
)
1494 if (i
== INTRINSIC_ASSIGN
)
1495 strcpy (interface_name
, "intrinsic assignment operator");
1497 sprintf (interface_name
, "intrinsic '%s' operator",
1498 gfc_op2string ((gfc_intrinsic_op
) i
));
1500 if (check_interface0 (ns
->op
[i
], interface_name
))
1504 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1507 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1509 gfc_intrinsic_op other_op
;
1511 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1512 interface_name
, true))
1515 /* i should be gfc_intrinsic_op, but has to be int with this cast
1516 here for stupid C++ compatibility rules. */
1517 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
1518 if (other_op
!= INTRINSIC_NONE
1519 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
1520 0, interface_name
, true))
1526 gfc_current_ns
= old_ns
;
1531 symbol_rank (gfc_symbol
*sym
)
1533 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1537 /* Given a symbol of a formal argument list and an expression, if the
1538 formal argument is allocatable, check that the actual argument is
1539 allocatable. Returns nonzero if compatible, zero if not compatible. */
1542 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1544 symbol_attribute attr
;
1546 if (formal
->attr
.allocatable
1547 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1549 attr
= gfc_expr_attr (actual
);
1550 if (!attr
.allocatable
)
1558 /* Given a symbol of a formal argument list and an expression, if the
1559 formal argument is a pointer, see if the actual argument is a
1560 pointer. Returns nonzero if compatible, zero if not compatible. */
1563 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1565 symbol_attribute attr
;
1567 if (formal
->attr
.pointer
)
1569 attr
= gfc_expr_attr (actual
);
1571 /* Fortran 2008 allows non-pointer actual arguments. */
1572 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1583 /* Emit clear error messages for rank mismatch. */
1586 argument_rank_mismatch (const char *name
, locus
*where
,
1587 int rank1
, int rank2
)
1591 gfc_error ("Rank mismatch in argument '%s' at %L "
1592 "(scalar and rank-%d)", name
, where
, rank2
);
1594 else if (rank2
== 0)
1596 gfc_error ("Rank mismatch in argument '%s' at %L "
1597 "(rank-%d and scalar)", name
, where
, rank1
);
1601 gfc_error ("Rank mismatch in argument '%s' at %L "
1602 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1607 /* Given a symbol of a formal argument list and an expression, see if
1608 the two are compatible as arguments. Returns nonzero if
1609 compatible, zero if not compatible. */
1612 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1613 int ranks_must_agree
, int is_elemental
, locus
*where
)
1616 bool rank_check
, is_pointer
;
1618 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1619 procs c_f_pointer or c_f_procpointer, and we need to accept most
1620 pointers the user could give us. This should allow that. */
1621 if (formal
->ts
.type
== BT_VOID
)
1624 if (formal
->ts
.type
== BT_DERIVED
1625 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1626 && actual
->ts
.type
== BT_DERIVED
1627 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1630 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1631 /* Make sure the vtab symbol is present when
1632 the module variables are generated. */
1633 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1635 if (actual
->ts
.type
== BT_PROCEDURE
)
1638 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1640 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1643 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1647 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1651 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1652 formal
->name
, &actual
->where
, err
);
1656 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1658 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1659 &act_sym
->declared_at
);
1660 if (act_sym
->ts
.type
== BT_UNKNOWN
1661 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1664 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1665 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1666 &act_sym
->declared_at
);
1672 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1673 && !gfc_is_simply_contiguous (actual
, true))
1676 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1677 "must be simply contigous", formal
->name
, &actual
->where
);
1681 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1682 && actual
->ts
.type
!= BT_HOLLERITH
1683 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1686 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1687 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1688 gfc_typename (&formal
->ts
));
1692 /* F2003, 12.5.2.5. */
1693 if (formal
->ts
.type
== BT_CLASS
1694 && (CLASS_DATA (formal
)->attr
.class_pointer
1695 || CLASS_DATA (formal
)->attr
.allocatable
))
1697 if (actual
->ts
.type
!= BT_CLASS
)
1700 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1701 formal
->name
, &actual
->where
);
1704 if (CLASS_DATA (actual
)->ts
.u
.derived
1705 != CLASS_DATA (formal
)->ts
.u
.derived
)
1708 gfc_error ("Actual argument to '%s' at %L must have the same "
1709 "declared type", formal
->name
, &actual
->where
);
1714 if (formal
->attr
.codimension
&& !gfc_is_coarray (actual
))
1717 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1718 formal
->name
, &actual
->where
);
1722 if (formal
->attr
.codimension
&& formal
->attr
.allocatable
)
1724 gfc_ref
*last
= NULL
;
1726 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1727 if (ref
->type
== REF_COMPONENT
)
1730 /* F2008, 12.5.2.6. */
1731 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1733 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
1736 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1737 formal
->name
, &actual
->where
, formal
->as
->corank
,
1738 last
? last
->u
.c
.component
->as
->corank
1739 : actual
->symtree
->n
.sym
->as
->corank
);
1744 if (formal
->attr
.codimension
)
1746 /* F2008, 12.5.2.8. */
1747 if (formal
->attr
.dimension
1748 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1749 && gfc_expr_attr (actual
).dimension
1750 && !gfc_is_simply_contiguous (actual
, true))
1753 gfc_error ("Actual argument to '%s' at %L must be simply "
1754 "contiguous", formal
->name
, &actual
->where
);
1758 /* F2008, C1303 and C1304. */
1759 if (formal
->attr
.intent
!= INTENT_INOUT
1760 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
1761 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1762 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
1763 || formal
->attr
.lock_comp
))
1767 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1768 "which is LOCK_TYPE or has a LOCK_TYPE component",
1769 formal
->name
, &actual
->where
);
1774 /* F2008, C1239/C1240. */
1775 if (actual
->expr_type
== EXPR_VARIABLE
1776 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1777 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1778 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1779 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1780 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1781 || formal
->attr
.contiguous
))
1784 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1785 "array without CONTIGUOUS attribute - as actual argument at"
1786 " %L is not simply contiguous and both are ASYNCHRONOUS "
1787 "or VOLATILE", formal
->name
, &actual
->where
);
1791 if (formal
->attr
.allocatable
&& !formal
->attr
.codimension
1792 && gfc_expr_attr (actual
).codimension
)
1794 if (formal
->attr
.intent
== INTENT_OUT
)
1797 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
1798 "INTENT(OUT) dummy argument '%s'", &actual
->where
,
1802 else if (gfc_option
.warn_surprising
&& where
1803 && formal
->attr
.intent
!= INTENT_IN
)
1804 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
1805 "argument '%s', which is invalid if the allocation status"
1806 " is modified", &actual
->where
, formal
->name
);
1809 if (symbol_rank (formal
) == actual
->rank
)
1812 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1813 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1814 || formal
->as
->type
== AS_DEFERRED
)
1815 && actual
->expr_type
!= EXPR_NULL
;
1817 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1818 if (rank_check
|| ranks_must_agree
1819 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
1820 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1821 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
1822 && actual
->expr_type
!= EXPR_NULL
)
1823 || (actual
->rank
== 0 && formal
->attr
.dimension
1824 && gfc_is_coindexed (actual
)))
1827 argument_rank_mismatch (formal
->name
, &actual
->where
,
1828 symbol_rank (formal
), actual
->rank
);
1831 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1834 /* At this point, we are considering a scalar passed to an array. This
1835 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1836 - if the actual argument is (a substring of) an element of a
1837 non-assumed-shape/non-pointer/non-polymorphic array; or
1838 - (F2003) if the actual argument is of type character of default/c_char
1841 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
1842 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
1844 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1846 if (ref
->type
== REF_COMPONENT
)
1847 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
1848 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1849 && ref
->u
.ar
.dimen
> 0
1851 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
1855 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
1858 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1859 "at %L", formal
->name
, &actual
->where
);
1863 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
1864 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
1867 gfc_error ("Element of assumed-shaped or pointer "
1868 "array passed to array dummy argument '%s' at %L",
1869 formal
->name
, &actual
->where
);
1873 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
1874 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
1876 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
1879 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1880 "CHARACTER actual argument with array dummy argument "
1881 "'%s' at %L", formal
->name
, &actual
->where
);
1885 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1887 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1888 "array dummy argument '%s' at %L",
1889 formal
->name
, &actual
->where
);
1892 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1898 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
1901 argument_rank_mismatch (formal
->name
, &actual
->where
,
1902 symbol_rank (formal
), actual
->rank
);
1910 /* Returns the storage size of a symbol (formal argument) or
1911 zero if it cannot be determined. */
1913 static unsigned long
1914 get_sym_storage_size (gfc_symbol
*sym
)
1917 unsigned long strlen
, elements
;
1919 if (sym
->ts
.type
== BT_CHARACTER
)
1921 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1922 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1923 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
1930 if (symbol_rank (sym
) == 0)
1934 if (sym
->as
->type
!= AS_EXPLICIT
)
1936 for (i
= 0; i
< sym
->as
->rank
; i
++)
1938 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1939 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1942 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
1943 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1946 return strlen
*elements
;
1950 /* Returns the storage size of an expression (actual argument) or
1951 zero if it cannot be determined. For an array element, it returns
1952 the remaining size as the element sequence consists of all storage
1953 units of the actual argument up to the end of the array. */
1955 static unsigned long
1956 get_expr_storage_size (gfc_expr
*e
)
1959 long int strlen
, elements
;
1960 long int substrlen
= 0;
1961 bool is_str_storage
= false;
1967 if (e
->ts
.type
== BT_CHARACTER
)
1969 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1970 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1971 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
1972 else if (e
->expr_type
== EXPR_CONSTANT
1973 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
1974 strlen
= e
->value
.character
.length
;
1979 strlen
= 1; /* Length per element. */
1981 if (e
->rank
== 0 && !e
->ref
)
1989 for (i
= 0; i
< e
->rank
; i
++)
1990 elements
*= mpz_get_si (e
->shape
[i
]);
1991 return elements
*strlen
;
1994 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1996 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1997 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2001 /* The string length is the substring length.
2002 Set now to full string length. */
2003 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2004 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2007 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2009 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2013 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
2014 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
2015 && ref
->u
.ar
.as
->upper
)
2016 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2018 long int start
, end
, stride
;
2021 if (ref
->u
.ar
.stride
[i
])
2023 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2024 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2029 if (ref
->u
.ar
.start
[i
])
2031 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2032 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2036 else if (ref
->u
.ar
.as
->lower
[i
]
2037 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2038 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2042 if (ref
->u
.ar
.end
[i
])
2044 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2045 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2049 else if (ref
->u
.ar
.as
->upper
[i
]
2050 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2051 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2055 elements
*= (end
- start
)/stride
+ 1L;
2057 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
2058 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
2059 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2061 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2062 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2063 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2064 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2065 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2070 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2071 && e
->expr_type
== EXPR_VARIABLE
)
2073 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2074 || e
->symtree
->n
.sym
->attr
.pointer
)
2080 /* Determine the number of remaining elements in the element
2081 sequence for array element designators. */
2082 is_str_storage
= true;
2083 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2085 if (ref
->u
.ar
.start
[i
] == NULL
2086 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2087 || ref
->u
.ar
.as
->upper
[i
] == NULL
2088 || ref
->u
.ar
.as
->lower
[i
] == NULL
2089 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2090 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2095 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2096 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2098 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2099 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2105 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2108 return elements
*strlen
;
2112 /* Given an expression, check whether it is an array section
2113 which has a vector subscript. If it has, one is returned,
2117 gfc_has_vector_subscript (gfc_expr
*e
)
2122 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2125 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2126 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2127 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2128 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2135 /* Given formal and actual argument lists, see if they are compatible.
2136 If they are compatible, the actual argument list is sorted to
2137 correspond with the formal list, and elements for missing optional
2138 arguments are inserted. If WHERE pointer is nonnull, then we issue
2139 errors when things don't match instead of just returning the status
2143 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
2144 int ranks_must_agree
, int is_elemental
, locus
*where
)
2146 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
2147 gfc_formal_arglist
*f
;
2149 unsigned long actual_size
, formal_size
;
2153 if (actual
== NULL
&& formal
== NULL
)
2157 for (f
= formal
; f
; f
= f
->next
)
2160 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2162 for (i
= 0; i
< n
; i
++)
2169 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2171 /* Look for keywords but ignore g77 extensions like %VAL. */
2172 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2175 for (f
= formal
; f
; f
= f
->next
, i
++)
2179 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2186 gfc_error ("Keyword argument '%s' at %L is not in "
2187 "the procedure", a
->name
, &a
->expr
->where
);
2191 if (new_arg
[i
] != NULL
)
2194 gfc_error ("Keyword argument '%s' at %L is already associated "
2195 "with another actual argument", a
->name
,
2204 gfc_error ("More actual than formal arguments in procedure "
2205 "call at %L", where
);
2210 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2216 gfc_error ("Missing alternate return spec in subroutine call "
2221 if (a
->expr
== NULL
)
2224 gfc_error ("Unexpected alternate return spec in subroutine "
2225 "call at %L", where
);
2229 if (a
->expr
->expr_type
== EXPR_NULL
&& !f
->sym
->attr
.pointer
2230 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2231 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2233 if (where
&& (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
))
2234 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2235 where
, f
->sym
->name
);
2237 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2238 "dummy '%s'", where
, f
->sym
->name
);
2243 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2244 is_elemental
, where
))
2247 /* Special case for character arguments. For allocatable, pointer
2248 and assumed-shape dummies, the string length needs to match
2250 if (a
->expr
->ts
.type
== BT_CHARACTER
2251 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2252 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2253 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2254 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2255 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2256 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2257 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2258 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2260 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2261 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2262 "argument and pointer or allocatable dummy argument "
2264 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2265 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2266 f
->sym
->name
, &a
->expr
->where
);
2268 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2269 "argument and assumed-shape dummy argument '%s' "
2271 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2272 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2273 f
->sym
->name
, &a
->expr
->where
);
2277 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2278 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2279 && a
->expr
->ts
.type
== BT_CHARACTER
)
2282 gfc_error ("Actual argument argument at %L to allocatable or "
2283 "pointer dummy argument '%s' must have a deferred "
2284 "length type parameter if and only if the dummy has one",
2285 &a
->expr
->where
, f
->sym
->name
);
2289 actual_size
= get_expr_storage_size (a
->expr
);
2290 formal_size
= get_sym_storage_size (f
->sym
);
2291 if (actual_size
!= 0 && actual_size
< formal_size
2292 && a
->expr
->ts
.type
!= BT_PROCEDURE
2293 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
2295 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2296 gfc_warning ("Character length of actual argument shorter "
2297 "than of dummy argument '%s' (%lu/%lu) at %L",
2298 f
->sym
->name
, actual_size
, formal_size
,
2301 gfc_warning ("Actual argument contains too few "
2302 "elements for dummy argument '%s' (%lu/%lu) at %L",
2303 f
->sym
->name
, actual_size
, formal_size
,
2308 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2309 is provided for a procedure pointer formal argument. */
2310 if (f
->sym
->attr
.proc_pointer
2311 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2312 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2313 || (a
->expr
->expr_type
== EXPR_FUNCTION
2314 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2315 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
2318 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2319 f
->sym
->name
, &a
->expr
->where
);
2323 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2324 provided for a procedure formal argument. */
2325 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
2326 && a
->expr
->expr_type
== EXPR_VARIABLE
2327 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2330 gfc_error ("Expected a procedure for argument '%s' at %L",
2331 f
->sym
->name
, &a
->expr
->where
);
2335 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2336 && a
->expr
->expr_type
== EXPR_VARIABLE
2337 && a
->expr
->symtree
->n
.sym
->as
2338 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2339 && (a
->expr
->ref
== NULL
2340 || (a
->expr
->ref
->type
== REF_ARRAY
2341 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2344 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2345 " array at %L", f
->sym
->name
, where
);
2349 if (a
->expr
->expr_type
!= EXPR_NULL
2350 && compare_pointer (f
->sym
, a
->expr
) == 0)
2353 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2354 f
->sym
->name
, &a
->expr
->where
);
2358 if (a
->expr
->expr_type
!= EXPR_NULL
2359 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2360 && compare_pointer (f
->sym
, a
->expr
) == 2)
2363 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2364 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2369 /* Fortran 2008, C1242. */
2370 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2373 gfc_error ("Coindexed actual argument at %L to pointer "
2375 &a
->expr
->where
, f
->sym
->name
);
2379 /* Fortran 2008, 12.5.2.5 (no constraint). */
2380 if (a
->expr
->expr_type
== EXPR_VARIABLE
2381 && f
->sym
->attr
.intent
!= INTENT_IN
2382 && f
->sym
->attr
.allocatable
2383 && gfc_is_coindexed (a
->expr
))
2386 gfc_error ("Coindexed actual argument at %L to allocatable "
2387 "dummy '%s' requires INTENT(IN)",
2388 &a
->expr
->where
, f
->sym
->name
);
2392 /* Fortran 2008, C1237. */
2393 if (a
->expr
->expr_type
== EXPR_VARIABLE
2394 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2395 && gfc_is_coindexed (a
->expr
)
2396 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2397 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2400 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2401 "at %L requires that dummy %s' has neither "
2402 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2407 /* Fortran 2008, 12.5.2.4 (no constraint). */
2408 if (a
->expr
->expr_type
== EXPR_VARIABLE
2409 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2410 && gfc_is_coindexed (a
->expr
)
2411 && gfc_has_ultimate_allocatable (a
->expr
))
2414 gfc_error ("Coindexed actual argument at %L with allocatable "
2415 "ultimate component to dummy '%s' requires either VALUE "
2416 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2420 if (a
->expr
->expr_type
!= EXPR_NULL
2421 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2424 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2425 f
->sym
->name
, &a
->expr
->where
);
2429 /* Check intent = OUT/INOUT for definable actual argument. */
2430 if ((f
->sym
->attr
.intent
== INTENT_OUT
2431 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2433 const char* context
= (where
2434 ? _("actual argument to INTENT = OUT/INOUT")
2437 if (f
->sym
->attr
.pointer
2438 && gfc_check_vardef_context (a
->expr
, true, false, context
)
2441 if (gfc_check_vardef_context (a
->expr
, false, false, context
)
2446 if ((f
->sym
->attr
.intent
== INTENT_OUT
2447 || f
->sym
->attr
.intent
== INTENT_INOUT
2448 || f
->sym
->attr
.volatile_
2449 || f
->sym
->attr
.asynchronous
)
2450 && gfc_has_vector_subscript (a
->expr
))
2453 gfc_error ("Array-section actual argument with vector "
2454 "subscripts at %L is incompatible with INTENT(OUT), "
2455 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2456 "of the dummy argument '%s'",
2457 &a
->expr
->where
, f
->sym
->name
);
2461 /* C1232 (R1221) For an actual argument which is an array section or
2462 an assumed-shape array, the dummy argument shall be an assumed-
2463 shape array, if the dummy argument has the VOLATILE attribute. */
2465 if (f
->sym
->attr
.volatile_
2466 && a
->expr
->symtree
->n
.sym
->as
2467 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2468 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2471 gfc_error ("Assumed-shape actual argument at %L is "
2472 "incompatible with the non-assumed-shape "
2473 "dummy argument '%s' due to VOLATILE attribute",
2474 &a
->expr
->where
,f
->sym
->name
);
2478 if (f
->sym
->attr
.volatile_
2479 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2480 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2483 gfc_error ("Array-section actual argument at %L is "
2484 "incompatible with the non-assumed-shape "
2485 "dummy argument '%s' due to VOLATILE attribute",
2486 &a
->expr
->where
,f
->sym
->name
);
2490 /* C1233 (R1221) For an actual argument which is a pointer array, the
2491 dummy argument shall be an assumed-shape or pointer array, if the
2492 dummy argument has the VOLATILE attribute. */
2494 if (f
->sym
->attr
.volatile_
2495 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2496 && a
->expr
->symtree
->n
.sym
->as
2498 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2499 || f
->sym
->attr
.pointer
)))
2502 gfc_error ("Pointer-array actual argument at %L requires "
2503 "an assumed-shape or pointer-array dummy "
2504 "argument '%s' due to VOLATILE attribute",
2505 &a
->expr
->where
,f
->sym
->name
);
2516 /* Make sure missing actual arguments are optional. */
2518 for (f
= formal
; f
; f
= f
->next
, i
++)
2520 if (new_arg
[i
] != NULL
)
2525 gfc_error ("Missing alternate return spec in subroutine call "
2529 if (!f
->sym
->attr
.optional
)
2532 gfc_error ("Missing actual argument for argument '%s' at %L",
2533 f
->sym
->name
, where
);
2538 /* The argument lists are compatible. We now relink a new actual
2539 argument list with null arguments in the right places. The head
2540 of the list remains the head. */
2541 for (i
= 0; i
< n
; i
++)
2542 if (new_arg
[i
] == NULL
)
2543 new_arg
[i
] = gfc_get_actual_arglist ();
2548 *new_arg
[0] = *actual
;
2552 new_arg
[0] = new_arg
[na
];
2556 for (i
= 0; i
< n
- 1; i
++)
2557 new_arg
[i
]->next
= new_arg
[i
+ 1];
2559 new_arg
[i
]->next
= NULL
;
2561 if (*ap
== NULL
&& n
> 0)
2564 /* Note the types of omitted optional arguments. */
2565 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2566 if (a
->expr
== NULL
&& a
->label
== NULL
)
2567 a
->missing_arg_type
= f
->sym
->ts
.type
;
2575 gfc_formal_arglist
*f
;
2576 gfc_actual_arglist
*a
;
2580 /* qsort comparison function for argument pairs, with the following
2582 - p->a->expr == NULL
2583 - p->a->expr->expr_type != EXPR_VARIABLE
2584 - growing p->a->expr->symbol. */
2587 pair_cmp (const void *p1
, const void *p2
)
2589 const gfc_actual_arglist
*a1
, *a2
;
2591 /* *p1 and *p2 are elements of the to-be-sorted array. */
2592 a1
= ((const argpair
*) p1
)->a
;
2593 a2
= ((const argpair
*) p2
)->a
;
2602 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2604 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2608 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2610 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2614 /* Given two expressions from some actual arguments, test whether they
2615 refer to the same expression. The analysis is conservative.
2616 Returning FAILURE will produce no warning. */
2619 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2621 const gfc_ref
*r1
, *r2
;
2624 || e1
->expr_type
!= EXPR_VARIABLE
2625 || e2
->expr_type
!= EXPR_VARIABLE
2626 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2629 /* TODO: improve comparison, see expr.c:show_ref(). */
2630 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2632 if (r1
->type
!= r2
->type
)
2637 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2639 /* TODO: At the moment, consider only full arrays;
2640 we could do better. */
2641 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2646 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2654 gfc_internal_error ("compare_actual_expr(): Bad component code");
2663 /* Given formal and actual argument lists that correspond to one
2664 another, check that identical actual arguments aren't not
2665 associated with some incompatible INTENTs. */
2668 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2670 sym_intent f1_intent
, f2_intent
;
2671 gfc_formal_arglist
*f1
;
2672 gfc_actual_arglist
*a1
;
2675 gfc_try t
= SUCCESS
;
2678 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2680 if (f1
== NULL
&& a1
== NULL
)
2682 if (f1
== NULL
|| a1
== NULL
)
2683 gfc_internal_error ("check_some_aliasing(): List mismatch");
2688 p
= XALLOCAVEC (argpair
, n
);
2690 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2696 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2698 for (i
= 0; i
< n
; i
++)
2701 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2702 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2704 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2705 for (j
= i
+ 1; j
< n
; j
++)
2707 /* Expected order after the sort. */
2708 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2709 gfc_internal_error ("check_some_aliasing(): corrupted data");
2711 /* Are the expression the same? */
2712 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2714 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2715 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2716 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2718 gfc_warning ("Same actual argument associated with INTENT(%s) "
2719 "argument '%s' and INTENT(%s) argument '%s' at %L",
2720 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2721 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2722 &p
[i
].a
->expr
->where
);
2732 /* Given a symbol of a formal argument list and an expression,
2733 return nonzero if their intents are compatible, zero otherwise. */
2736 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2738 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2741 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2744 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2751 /* Given formal and actual argument lists that correspond to one
2752 another, check that they are compatible in the sense that intents
2753 are not mismatched. */
2756 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2758 sym_intent f_intent
;
2760 for (;; f
= f
->next
, a
= a
->next
)
2762 if (f
== NULL
&& a
== NULL
)
2764 if (f
== NULL
|| a
== NULL
)
2765 gfc_internal_error ("check_intents(): List mismatch");
2767 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2770 f_intent
= f
->sym
->attr
.intent
;
2772 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2774 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2775 "specifies INTENT(%s)", &a
->expr
->where
,
2776 gfc_intent_string (f_intent
));
2780 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2782 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2784 gfc_error ("Procedure argument at %L is local to a PURE "
2785 "procedure and is passed to an INTENT(%s) argument",
2786 &a
->expr
->where
, gfc_intent_string (f_intent
));
2790 if (f
->sym
->attr
.pointer
)
2792 gfc_error ("Procedure argument at %L is local to a PURE "
2793 "procedure and has the POINTER attribute",
2799 /* Fortran 2008, C1283. */
2800 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
2802 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2804 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2805 "is passed to an INTENT(%s) argument",
2806 &a
->expr
->where
, gfc_intent_string (f_intent
));
2810 if (f
->sym
->attr
.pointer
)
2812 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2813 "is passed to a POINTER dummy argument",
2819 /* F2008, Section 12.5.2.4. */
2820 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
2821 && gfc_is_coindexed (a
->expr
))
2823 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2824 "polymorphic dummy argument '%s'",
2825 &a
->expr
->where
, f
->sym
->name
);
2834 /* Check how a procedure is used against its interface. If all goes
2835 well, the actual argument list will also end up being properly
2839 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2842 /* Warn about calls with an implicit interface. Special case
2843 for calling a ISO_C_BINDING becase c_loc and c_funloc
2844 are pseudo-unknown. Additionally, warn about procedures not
2845 explicitly declared at all if requested. */
2846 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2848 if (gfc_option
.warn_implicit_interface
)
2849 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2851 else if (gfc_option
.warn_implicit_procedure
2852 && sym
->attr
.proc
== PROC_UNKNOWN
)
2853 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2857 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2859 gfc_actual_arglist
*a
;
2861 if (sym
->attr
.pointer
)
2863 gfc_error("The pointer object '%s' at %L must have an explicit "
2864 "function interface or be declared as array",
2869 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
2871 gfc_error("The allocatable object '%s' at %L must have an explicit "
2872 "function interface or be declared as array",
2877 if (sym
->attr
.allocatable
)
2879 gfc_error("Allocatable function '%s' at %L must have an explicit "
2880 "function interface", sym
->name
, where
);
2884 for (a
= *ap
; a
; a
= a
->next
)
2886 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2887 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2889 gfc_error("Keyword argument requires explicit interface "
2890 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2894 /* F2008, C1303 and C1304. */
2896 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
2897 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2898 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2899 || gfc_expr_attr (a
->expr
).lock_comp
))
2901 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
2902 "component at %L requires an explicit interface for "
2903 "procedure '%s'", &a
->expr
->where
, sym
->name
);
2907 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
2908 && a
->expr
->ts
.type
== BT_UNKNOWN
)
2910 gfc_error ("MOLD argument to NULL required at %L", &a
->expr
->where
);
2918 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2921 check_intents (sym
->formal
, *ap
);
2922 if (gfc_option
.warn_aliasing
)
2923 check_some_aliasing (sym
->formal
, *ap
);
2927 /* Check how a procedure pointer component is used against its interface.
2928 If all goes well, the actual argument list will also end up being properly
2929 sorted. Completely analogous to gfc_procedure_use. */
2932 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2935 /* Warn about calls with an implicit interface. Special case
2936 for calling a ISO_C_BINDING becase c_loc and c_funloc
2937 are pseudo-unknown. */
2938 if (gfc_option
.warn_implicit_interface
2939 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2940 && !comp
->attr
.is_iso_c
)
2941 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2942 "interface at %L", comp
->name
, where
);
2944 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2946 gfc_actual_arglist
*a
;
2947 for (a
= *ap
; a
; a
= a
->next
)
2949 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2950 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2952 gfc_error("Keyword argument requires explicit interface "
2953 "for procedure pointer component '%s' at %L",
2954 comp
->name
, &a
->expr
->where
);
2962 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2965 check_intents (comp
->formal
, *ap
);
2966 if (gfc_option
.warn_aliasing
)
2967 check_some_aliasing (comp
->formal
, *ap
);
2971 /* Try if an actual argument list matches the formal list of a symbol,
2972 respecting the symbol's attributes like ELEMENTAL. This is used for
2973 GENERIC resolution. */
2976 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2980 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2982 r
= !sym
->attr
.elemental
;
2983 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2985 check_intents (sym
->formal
, *args
);
2986 if (gfc_option
.warn_aliasing
)
2987 check_some_aliasing (sym
->formal
, *args
);
2995 /* Given an interface pointer and an actual argument list, search for
2996 a formal argument list that matches the actual. If found, returns
2997 a pointer to the symbol of the correct interface. Returns NULL if
3001 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
3002 gfc_actual_arglist
**ap
)
3004 gfc_symbol
*elem_sym
= NULL
;
3005 gfc_symbol
*null_sym
= NULL
;
3006 locus null_expr_loc
;
3007 gfc_actual_arglist
*a
;
3008 bool has_null_arg
= false;
3010 for (a
= *ap
; a
; a
= a
->next
)
3011 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3012 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3014 has_null_arg
= true;
3015 null_expr_loc
= a
->expr
->where
;
3019 for (; intr
; intr
= intr
->next
)
3021 if (sub_flag
&& intr
->sym
->attr
.function
)
3023 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
3026 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
3028 if (has_null_arg
&& null_sym
)
3030 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3031 "between specific functions %s and %s",
3032 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
3035 else if (has_null_arg
)
3037 null_sym
= intr
->sym
;
3041 /* Satisfy 12.4.4.1 such that an elemental match has lower
3042 weight than a non-elemental match. */
3043 if (intr
->sym
->attr
.elemental
)
3045 elem_sym
= intr
->sym
;
3055 return elem_sym
? elem_sym
: NULL
;
3059 /* Do a brute force recursive search for a symbol. */
3061 static gfc_symtree
*
3062 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
3066 if (root
->n
.sym
== sym
)
3071 st
= find_symtree0 (root
->left
, sym
);
3072 if (root
->right
&& ! st
)
3073 st
= find_symtree0 (root
->right
, sym
);
3078 /* Find a symtree for a symbol. */
3081 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
3086 /* First try to find it by name. */
3087 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
3088 if (st
&& st
->n
.sym
== sym
)
3091 /* If it's been renamed, resort to a brute-force search. */
3092 /* TODO: avoid having to do this search. If the symbol doesn't exist
3093 in the symtree for the current namespace, it should probably be added. */
3094 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3096 st
= find_symtree0 (ns
->sym_root
, sym
);
3100 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
3105 /* See if the arglist to an operator-call contains a derived-type argument
3106 with a matching type-bound operator. If so, return the matching specific
3107 procedure defined as operator-target as well as the base-object to use
3108 (which is the found derived-type argument with operator). The generic
3109 name, if any, is transmitted to the final expression via 'gname'. */
3111 static gfc_typebound_proc
*
3112 matching_typebound_op (gfc_expr
** tb_base
,
3113 gfc_actual_arglist
* args
,
3114 gfc_intrinsic_op op
, const char* uop
,
3115 const char ** gname
)
3117 gfc_actual_arglist
* base
;
3119 for (base
= args
; base
; base
= base
->next
)
3120 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
3122 gfc_typebound_proc
* tb
;
3123 gfc_symbol
* derived
;
3126 if (base
->expr
->ts
.type
== BT_CLASS
)
3128 if (!gfc_expr_attr (base
->expr
).class_ok
)
3130 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
3133 derived
= base
->expr
->ts
.u
.derived
;
3135 if (op
== INTRINSIC_USER
)
3137 gfc_symtree
* tb_uop
;
3140 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
3149 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
3152 /* This means we hit a PRIVATE operator which is use-associated and
3153 should thus not be seen. */
3154 if (result
== FAILURE
)
3157 /* Look through the super-type hierarchy for a matching specific
3159 for (; tb
; tb
= tb
->overridden
)
3163 gcc_assert (tb
->is_generic
);
3164 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
3167 gfc_actual_arglist
* argcopy
;
3170 gcc_assert (g
->specific
);
3171 if (g
->specific
->error
)
3174 target
= g
->specific
->u
.specific
->n
.sym
;
3176 /* Check if this arglist matches the formal. */
3177 argcopy
= gfc_copy_actual_arglist (args
);
3178 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
3179 gfc_free_actual_arglist (argcopy
);
3181 /* Return if we found a match. */
3184 *tb_base
= base
->expr
;
3185 *gname
= g
->specific_st
->name
;
3196 /* For the 'actual arglist' of an operator call and a specific typebound
3197 procedure that has been found the target of a type-bound operator, build the
3198 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3199 type-bound procedures rather than resolving type-bound operators 'directly'
3200 so that we can reuse the existing logic. */
3203 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3204 gfc_expr
* base
, gfc_typebound_proc
* target
,
3207 e
->expr_type
= EXPR_COMPCALL
;
3208 e
->value
.compcall
.tbp
= target
;
3209 e
->value
.compcall
.name
= gname
? gname
: "$op";
3210 e
->value
.compcall
.actual
= actual
;
3211 e
->value
.compcall
.base_object
= base
;
3212 e
->value
.compcall
.ignore_pass
= 1;
3213 e
->value
.compcall
.assign
= 0;
3217 /* This subroutine is called when an expression is being resolved.
3218 The expression node in question is either a user defined operator
3219 or an intrinsic operator with arguments that aren't compatible
3220 with the operator. This subroutine builds an actual argument list
3221 corresponding to the operands, then searches for a compatible
3222 interface. If one is found, the expression node is replaced with
3223 the appropriate function call.
3224 real_error is an additional output argument that specifies if FAILURE
3225 is because of some real error and not because no match was found. */
3228 gfc_extend_expr (gfc_expr
*e
, bool *real_error
)
3230 gfc_actual_arglist
*actual
;
3239 actual
= gfc_get_actual_arglist ();
3240 actual
->expr
= e
->value
.op
.op1
;
3242 *real_error
= false;
3245 if (e
->value
.op
.op2
!= NULL
)
3247 actual
->next
= gfc_get_actual_arglist ();
3248 actual
->next
->expr
= e
->value
.op
.op2
;
3251 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3253 if (i
== INTRINSIC_USER
)
3255 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3257 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3261 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3268 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3270 /* Due to the distinction between '==' and '.eq.' and friends, one has
3271 to check if either is defined. */
3274 #define CHECK_OS_COMPARISON(comp) \
3275 case INTRINSIC_##comp: \
3276 case INTRINSIC_##comp##_OS: \
3277 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3279 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3281 CHECK_OS_COMPARISON(EQ
)
3282 CHECK_OS_COMPARISON(NE
)
3283 CHECK_OS_COMPARISON(GT
)
3284 CHECK_OS_COMPARISON(GE
)
3285 CHECK_OS_COMPARISON(LT
)
3286 CHECK_OS_COMPARISON(LE
)
3287 #undef CHECK_OS_COMPARISON
3290 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3298 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3299 found rather than just taking the first one and not checking further. */
3303 gfc_typebound_proc
* tbo
;
3306 /* See if we find a matching type-bound operator. */
3307 if (i
== INTRINSIC_USER
)
3308 tbo
= matching_typebound_op (&tb_base
, actual
,
3309 i
, e
->value
.op
.uop
->name
, &gname
);
3313 #define CHECK_OS_COMPARISON(comp) \
3314 case INTRINSIC_##comp: \
3315 case INTRINSIC_##comp##_OS: \
3316 tbo = matching_typebound_op (&tb_base, actual, \
3317 INTRINSIC_##comp, NULL, &gname); \
3319 tbo = matching_typebound_op (&tb_base, actual, \
3320 INTRINSIC_##comp##_OS, NULL, &gname); \
3322 CHECK_OS_COMPARISON(EQ
)
3323 CHECK_OS_COMPARISON(NE
)
3324 CHECK_OS_COMPARISON(GT
)
3325 CHECK_OS_COMPARISON(GE
)
3326 CHECK_OS_COMPARISON(LT
)
3327 CHECK_OS_COMPARISON(LE
)
3328 #undef CHECK_OS_COMPARISON
3331 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3335 /* If there is a matching typebound-operator, replace the expression with
3336 a call to it and succeed. */
3341 gcc_assert (tb_base
);
3342 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3344 result
= gfc_resolve_expr (e
);
3345 if (result
== FAILURE
)
3351 /* Don't use gfc_free_actual_arglist(). */
3352 free (actual
->next
);
3358 /* Change the expression node to a function call. */
3359 e
->expr_type
= EXPR_FUNCTION
;
3360 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3361 e
->value
.function
.actual
= actual
;
3362 e
->value
.function
.esym
= NULL
;
3363 e
->value
.function
.isym
= NULL
;
3364 e
->value
.function
.name
= NULL
;
3365 e
->user_operator
= 1;
3367 if (gfc_resolve_expr (e
) == FAILURE
)
3377 /* Tries to replace an assignment code node with a subroutine call to
3378 the subroutine associated with the assignment operator. Return
3379 SUCCESS if the node was replaced. On FAILURE, no error is
3383 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3385 gfc_actual_arglist
*actual
;
3386 gfc_expr
*lhs
, *rhs
;
3395 /* Don't allow an intrinsic assignment to be replaced. */
3396 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3397 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3398 && (lhs
->ts
.type
== rhs
->ts
.type
3399 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3402 actual
= gfc_get_actual_arglist ();
3405 actual
->next
= gfc_get_actual_arglist ();
3406 actual
->next
->expr
= rhs
;
3410 for (; ns
; ns
= ns
->parent
)
3412 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3417 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3421 gfc_typebound_proc
* tbo
;
3424 /* See if we find a matching type-bound assignment. */
3425 tbo
= matching_typebound_op (&tb_base
, actual
,
3426 INTRINSIC_ASSIGN
, NULL
, &gname
);
3428 /* If there is one, replace the expression with a call to it and
3432 gcc_assert (tb_base
);
3433 c
->expr1
= gfc_get_expr ();
3434 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3435 c
->expr1
->value
.compcall
.assign
= 1;
3436 c
->expr1
->where
= c
->loc
;
3438 c
->op
= EXEC_COMPCALL
;
3440 /* c is resolved from the caller, so no need to do it here. */
3445 free (actual
->next
);
3450 /* Replace the assignment with the call. */
3451 c
->op
= EXEC_ASSIGN_CALL
;
3452 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3455 c
->ext
.actual
= actual
;
3461 /* Make sure that the interface just parsed is not already present in
3462 the given interface list. Ambiguity isn't checked yet since module
3463 procedures can be present without interfaces. */
3466 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
3470 for (ip
= base
; ip
; ip
= ip
->next
)
3472 if (ip
->sym
== new_sym
)
3474 gfc_error ("Entity '%s' at %C is already present in the interface",
3484 /* Add a symbol to the current interface. */
3487 gfc_add_interface (gfc_symbol
*new_sym
)
3489 gfc_interface
**head
, *intr
;
3493 switch (current_interface
.type
)
3495 case INTERFACE_NAMELESS
:
3496 case INTERFACE_ABSTRACT
:
3499 case INTERFACE_INTRINSIC_OP
:
3500 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3501 switch (current_interface
.op
)
3504 case INTRINSIC_EQ_OS
:
3505 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
3506 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
3511 case INTRINSIC_NE_OS
:
3512 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
3513 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
3518 case INTRINSIC_GT_OS
:
3519 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
3520 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
3525 case INTRINSIC_GE_OS
:
3526 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
3527 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
3532 case INTRINSIC_LT_OS
:
3533 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
3534 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
3539 case INTRINSIC_LE_OS
:
3540 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
3541 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
3546 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
3550 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3553 case INTERFACE_GENERIC
:
3554 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3556 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3560 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
3564 head
= ¤t_interface
.sym
->generic
;
3567 case INTERFACE_USER_OP
:
3568 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
3572 head
= ¤t_interface
.uop
->op
;
3576 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3579 intr
= gfc_get_interface ();
3580 intr
->sym
= new_sym
;
3581 intr
->where
= gfc_current_locus
;
3591 gfc_current_interface_head (void)
3593 switch (current_interface
.type
)
3595 case INTERFACE_INTRINSIC_OP
:
3596 return current_interface
.ns
->op
[current_interface
.op
];
3599 case INTERFACE_GENERIC
:
3600 return current_interface
.sym
->generic
;
3603 case INTERFACE_USER_OP
:
3604 return current_interface
.uop
->op
;
3614 gfc_set_current_interface_head (gfc_interface
*i
)
3616 switch (current_interface
.type
)
3618 case INTERFACE_INTRINSIC_OP
:
3619 current_interface
.ns
->op
[current_interface
.op
] = i
;
3622 case INTERFACE_GENERIC
:
3623 current_interface
.sym
->generic
= i
;
3626 case INTERFACE_USER_OP
:
3627 current_interface
.uop
->op
= i
;
3636 /* Gets rid of a formal argument list. We do not free symbols.
3637 Symbols are freed when a namespace is freed. */
3640 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3642 gfc_formal_arglist
*q
;
3652 /* Check that it is ok for the type-bound procedure 'proc' to override the
3653 procedure 'old', cf. F08:4.5.7.3. */
3656 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
3659 const gfc_symbol
*proc_target
, *old_target
;
3660 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
3661 gfc_formal_arglist
*proc_formal
, *old_formal
;
3665 /* This procedure should only be called for non-GENERIC proc. */
3666 gcc_assert (!proc
->n
.tb
->is_generic
);
3668 /* If the overwritten procedure is GENERIC, this is an error. */
3669 if (old
->n
.tb
->is_generic
)
3671 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3672 old
->name
, &proc
->n
.tb
->where
);
3676 where
= proc
->n
.tb
->where
;
3677 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
3678 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
3680 /* Check that overridden binding is not NON_OVERRIDABLE. */
3681 if (old
->n
.tb
->non_overridable
)
3683 gfc_error ("'%s' at %L overrides a procedure binding declared"
3684 " NON_OVERRIDABLE", proc
->name
, &where
);
3688 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3689 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
3691 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3692 " non-DEFERRED binding", proc
->name
, &where
);
3696 /* If the overridden binding is PURE, the overriding must be, too. */
3697 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
3699 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3700 proc
->name
, &where
);
3704 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3705 is not, the overriding must not be either. */
3706 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
3708 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3709 " ELEMENTAL", proc
->name
, &where
);
3712 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
3714 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3715 " be ELEMENTAL, either", proc
->name
, &where
);
3719 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3721 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
3723 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3724 " SUBROUTINE", proc
->name
, &where
);
3728 /* If the overridden binding is a FUNCTION, the overriding must also be a
3729 FUNCTION and have the same characteristics. */
3730 if (old_target
->attr
.function
)
3732 if (!proc_target
->attr
.function
)
3734 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
3735 " FUNCTION", proc
->name
, &where
);
3739 /* FIXME: Do more comprehensive checking (including, for instance, the
3741 gcc_assert (proc_target
->result
&& old_target
->result
);
3742 if (!compare_type_rank (proc_target
->result
, old_target
->result
))
3744 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
3745 " matching result types and ranks", proc
->name
, &where
);
3749 /* Check string length. */
3750 if (proc_target
->result
->ts
.type
== BT_CHARACTER
3751 && proc_target
->result
->ts
.u
.cl
&& old_target
->result
->ts
.u
.cl
)
3753 int compval
= gfc_dep_compare_expr (proc_target
->result
->ts
.u
.cl
->length
,
3754 old_target
->result
->ts
.u
.cl
->length
);
3760 gfc_error ("Character length mismatch between '%s' at '%L' and "
3761 "overridden FUNCTION", proc
->name
, &where
);
3765 gfc_warning ("Possible character length mismatch between '%s' at"
3766 " '%L' and overridden FUNCTION", proc
->name
, &where
);
3773 gfc_internal_error ("gfc_check_typebound_override: Unexpected "
3774 "result %i of gfc_dep_compare_expr", compval
);
3780 /* If the overridden binding is PUBLIC, the overriding one must not be
3782 if (old
->n
.tb
->access
== ACCESS_PUBLIC
3783 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
3785 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
3786 " PRIVATE", proc
->name
, &where
);
3790 /* Compare the formal argument lists of both procedures. This is also abused
3791 to find the position of the passed-object dummy arguments of both
3792 bindings as at least the overridden one might not yet be resolved and we
3793 need those positions in the check below. */
3794 proc_pass_arg
= old_pass_arg
= 0;
3795 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
3797 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
3800 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
3801 proc_formal
&& old_formal
;
3802 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
3804 if (proc
->n
.tb
->pass_arg
3805 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
3806 proc_pass_arg
= argpos
;
3807 if (old
->n
.tb
->pass_arg
3808 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
3809 old_pass_arg
= argpos
;
3811 /* Check that the names correspond. */
3812 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
3814 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
3815 " to match the corresponding argument of the overridden"
3816 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
3817 old_formal
->sym
->name
);
3821 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
3822 if (check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
3823 check_type
, err
, sizeof(err
)) == FAILURE
)
3825 gfc_error ("Argument mismatch for the overriding procedure "
3826 "'%s' at %L: %s", proc
->name
, &where
, err
);
3832 if (proc_formal
|| old_formal
)
3834 gfc_error ("'%s' at %L must have the same number of formal arguments as"
3835 " the overridden procedure", proc
->name
, &where
);
3839 /* If the overridden binding is NOPASS, the overriding one must also be
3841 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
3843 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
3844 " NOPASS", proc
->name
, &where
);
3848 /* If the overridden binding is PASS(x), the overriding one must also be
3849 PASS and the passed-object dummy arguments must correspond. */
3850 if (!old
->n
.tb
->nopass
)
3852 if (proc
->n
.tb
->nopass
)
3854 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
3855 " PASS", proc
->name
, &where
);
3859 if (proc_pass_arg
!= old_pass_arg
)
3861 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
3862 " the same position as the passed-object dummy argument of"
3863 " the overridden procedure", proc
->name
, &where
);