1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Deal with interfaces. An explicit interface is represented as a
24 singly linked list of formal argument structures attached to the
25 relevant symbols. For an implicit interface, the arguments don't
26 point to symbols. Explicit interfaces point to namespaces that
27 contain the symbols within that interface.
29 Implicit interfaces are linked together in a singly linked list
30 along the next_if member of symbol nodes. Since a particular
31 symbol can only have a single explicit interface, the symbol cannot
32 be part of multiple lists and a single next-member suffices.
34 This is not the case for general classes, though. An operator
35 definition is independent of just about all other uses and has it's
39 Nameless interfaces create symbols with explicit interfaces within
40 the current namespace. They are otherwise unlinked.
43 The generic name points to a linked list of symbols. Each symbol
44 has an explicit interface. Each explicit interface has its own
45 namespace containing the arguments. Module procedures are symbols in
46 which the interface is added later when the module procedure is parsed.
49 User-defined operators are stored in a their own set of symtrees
50 separate from regular symbols. The symtrees point to gfc_user_op
51 structures which in turn head up a list of relevant interfaces.
53 Extended intrinsics and assignment:
54 The head of these interface lists are stored in the containing namespace.
57 An implicit interface is represented as a singly linked list of
58 formal argument list structures that don't point to any symbol
59 nodes -- they just contain types.
62 When a subprogram is defined, the program unit's name points to an
63 interface as usual, but the link to the namespace is NULL and the
64 formal argument list points to symbols within the same namespace as
65 the program unit name. */
72 /* The current_interface structure holds information about the
73 interface currently being parsed. This structure is saved and
74 restored during recursive interfaces. */
76 gfc_interface_info current_interface
;
79 /* Free a singly linked list of gfc_interface structures. */
82 gfc_free_interface (gfc_interface
*intr
)
86 for (; intr
; intr
= next
)
94 /* Change the operators unary plus and minus into binary plus and
95 minus respectively, leaving the rest unchanged. */
97 static gfc_intrinsic_op
98 fold_unary_intrinsic (gfc_intrinsic_op op
)
102 case INTRINSIC_UPLUS
:
105 case INTRINSIC_UMINUS
:
106 op
= INTRINSIC_MINUS
;
116 /* Match a generic specification. Depending on which type of
117 interface is found, the 'name' or 'op' pointers may be set.
118 This subroutine doesn't return MATCH_NO. */
121 gfc_match_generic_spec (interface_type
*type
,
123 gfc_intrinsic_op
*op
)
125 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
129 if (gfc_match (" assignment ( = )") == MATCH_YES
)
131 *type
= INTERFACE_INTRINSIC_OP
;
132 *op
= INTRINSIC_ASSIGN
;
136 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
138 *type
= INTERFACE_INTRINSIC_OP
;
139 *op
= fold_unary_intrinsic (i
);
143 *op
= INTRINSIC_NONE
;
144 if (gfc_match (" operator ( ") == MATCH_YES
)
146 m
= gfc_match_defined_op_name (buffer
, 1);
152 m
= gfc_match_char (')');
158 strcpy (name
, buffer
);
159 *type
= INTERFACE_USER_OP
;
163 if (gfc_match_name (buffer
) == MATCH_YES
)
165 strcpy (name
, buffer
);
166 *type
= INTERFACE_GENERIC
;
170 *type
= INTERFACE_NAMELESS
;
174 gfc_error ("Syntax error in generic specification at %C");
179 /* Match one of the five F95 forms of an interface statement. The
180 matcher for the abstract interface follows. */
183 gfc_match_interface (void)
185 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
191 m
= gfc_match_space ();
193 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
196 /* If we're not looking at the end of the statement now, or if this
197 is not a nameless interface but we did not see a space, punt. */
198 if (gfc_match_eos () != MATCH_YES
199 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
201 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
206 current_interface
.type
= type
;
210 case INTERFACE_GENERIC
:
211 if (gfc_get_symbol (name
, NULL
, &sym
))
214 if (!sym
->attr
.generic
215 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
220 gfc_error ("Dummy procedure '%s' at %C cannot have a "
221 "generic interface", sym
->name
);
225 current_interface
.sym
= gfc_new_block
= sym
;
228 case INTERFACE_USER_OP
:
229 current_interface
.uop
= gfc_get_uop (name
);
232 case INTERFACE_INTRINSIC_OP
:
233 current_interface
.op
= op
;
236 case INTERFACE_NAMELESS
:
237 case INTERFACE_ABSTRACT
:
246 /* Match a F2003 abstract interface. */
249 gfc_match_abstract_interface (void)
253 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ABSTRACT INTERFACE at %C")
257 m
= gfc_match_eos ();
261 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
265 current_interface
.type
= INTERFACE_ABSTRACT
;
271 /* Match the different sort of generic-specs that can be present after
272 the END INTERFACE itself. */
275 gfc_match_end_interface (void)
277 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
282 m
= gfc_match_space ();
284 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
287 /* If we're not looking at the end of the statement now, or if this
288 is not a nameless interface but we did not see a space, punt. */
289 if (gfc_match_eos () != MATCH_YES
290 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
292 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
299 switch (current_interface
.type
)
301 case INTERFACE_NAMELESS
:
302 case INTERFACE_ABSTRACT
:
303 if (type
!= INTERFACE_NAMELESS
)
305 gfc_error ("Expected a nameless interface at %C");
311 case INTERFACE_INTRINSIC_OP
:
312 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
315 if (current_interface
.op
== INTRINSIC_ASSIGN
)
316 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
318 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
319 gfc_op2string (current_interface
.op
));
326 case INTERFACE_USER_OP
:
327 /* Comparing the symbol node names is OK because only use-associated
328 symbols can be renamed. */
329 if (type
!= current_interface
.type
330 || strcmp (current_interface
.uop
->name
, name
) != 0)
332 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
333 current_interface
.uop
->name
);
339 case INTERFACE_GENERIC
:
340 if (type
!= current_interface
.type
341 || strcmp (current_interface
.sym
->name
, name
) != 0)
343 gfc_error ("Expecting 'END INTERFACE %s' at %C",
344 current_interface
.sym
->name
);
355 /* Compare two derived types using the criteria in 4.4.2 of the standard,
356 recursing through gfc_compare_types for the components. */
359 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
361 gfc_component
*dt1
, *dt2
;
363 if (derived1
== derived2
)
366 /* Special case for comparing derived types across namespaces. If the
367 true names and module names are the same and the module name is
368 nonnull, then they are equal. */
369 if (derived1
!= NULL
&& derived2
!= NULL
370 && strcmp (derived1
->name
, derived2
->name
) == 0
371 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
372 && strcmp (derived1
->module
, derived2
->module
) == 0)
375 /* Compare type via the rules of the standard. Both types must have
376 the SEQUENCE attribute to be equal. */
378 if (strcmp (derived1
->name
, derived2
->name
))
381 if (derived1
->component_access
== ACCESS_PRIVATE
382 || derived2
->component_access
== ACCESS_PRIVATE
)
385 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
388 dt1
= derived1
->components
;
389 dt2
= derived2
->components
;
391 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
392 simple test can speed things up. Otherwise, lots of things have to
396 if (strcmp (dt1
->name
, dt2
->name
) != 0)
399 if (dt1
->attr
.access
!= dt2
->attr
.access
)
402 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
405 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
408 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
411 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
414 /* Make sure that link lists do not put this function into an
415 endless recursive loop! */
416 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
417 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
418 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
421 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
422 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
425 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
426 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
432 if (dt1
== NULL
&& dt2
== NULL
)
434 if (dt1
== NULL
|| dt2
== NULL
)
442 /* Compare two typespecs, recursively if necessary. */
445 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
447 /* See if one of the typespecs is a BT_VOID, which is what is being used
448 to allow the funcs like c_f_pointer to accept any pointer type.
449 TODO: Possibly should narrow this to just the one typespec coming in
450 that is for the formal arg, but oh well. */
451 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
454 if (ts1
->type
!= ts2
->type
455 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
456 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
458 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
459 return (ts1
->kind
== ts2
->kind
);
461 /* Compare derived types. */
462 if (gfc_type_compatible (ts1
, ts2
))
465 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
469 /* Given two symbols that are formal arguments, compare their ranks
470 and types. Returns nonzero if they have the same rank and type,
474 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
478 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
479 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
482 return 0; /* Ranks differ. */
484 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
488 /* Given two symbols that are formal arguments, compare their types
489 and rank and their formal interfaces if they are both dummy
490 procedures. Returns nonzero if the same, zero if different. */
493 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
495 if (s1
== NULL
|| s2
== NULL
)
496 return s1
== s2
? 1 : 0;
501 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
502 return compare_type_rank (s1
, s2
);
504 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
507 /* At this point, both symbols are procedures. It can happen that
508 external procedures are compared, where one is identified by usage
509 to be a function or subroutine but the other is not. Check TKR
510 nonetheless for these cases. */
511 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
512 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
514 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
515 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
517 /* Now the type of procedure has been identified. */
518 if (s1
->attr
.function
!= s2
->attr
.function
519 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
522 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
525 /* Originally, gfortran recursed here to check the interfaces of passed
526 procedures. This is explicitly not required by the standard. */
531 /* Given a formal argument list and a keyword name, search the list
532 for that keyword. Returns the correct symbol node if found, NULL
536 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
538 for (; f
; f
= f
->next
)
539 if (strcmp (f
->sym
->name
, name
) == 0)
546 /******** Interface checking subroutines **********/
549 /* Given an operator interface and the operator, make sure that all
550 interfaces for that operator are legal. */
553 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
556 gfc_formal_arglist
*formal
;
559 int args
, r1
, r2
, k1
, k2
;
564 t1
= t2
= BT_UNKNOWN
;
565 i1
= i2
= INTENT_UNKNOWN
;
569 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
571 gfc_symbol
*fsym
= formal
->sym
;
574 gfc_error ("Alternate return cannot appear in operator "
575 "interface at %L", &sym
->declared_at
);
581 i1
= fsym
->attr
.intent
;
582 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
588 i2
= fsym
->attr
.intent
;
589 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
595 /* Only +, - and .not. can be unary operators.
596 .not. cannot be a binary operator. */
597 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
598 && op
!= INTRINSIC_MINUS
599 && op
!= INTRINSIC_NOT
)
600 || (args
== 2 && op
== INTRINSIC_NOT
))
602 gfc_error ("Operator interface at %L has the wrong number of arguments",
607 /* Check that intrinsics are mapped to functions, except
608 INTRINSIC_ASSIGN which should map to a subroutine. */
609 if (op
== INTRINSIC_ASSIGN
)
611 if (!sym
->attr
.subroutine
)
613 gfc_error ("Assignment operator interface at %L must be "
614 "a SUBROUTINE", &sym
->declared_at
);
619 gfc_error ("Assignment operator interface at %L must have "
620 "two arguments", &sym
->declared_at
);
624 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
625 - First argument an array with different rank than second,
626 - Types and kinds do not conform, and
627 - First argument is of derived type. */
628 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
629 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
630 && (r1
== 0 || r1
== r2
)
631 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
632 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
633 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
635 gfc_error ("Assignment operator interface at %L must not redefine "
636 "an INTRINSIC type assignment", &sym
->declared_at
);
642 if (!sym
->attr
.function
)
644 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
650 /* Check intents on operator interfaces. */
651 if (op
== INTRINSIC_ASSIGN
)
653 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
655 gfc_error ("First argument of defined assignment at %L must be "
656 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
662 gfc_error ("Second argument of defined assignment at %L must be "
663 "INTENT(IN)", &sym
->declared_at
);
671 gfc_error ("First argument of operator interface at %L must be "
672 "INTENT(IN)", &sym
->declared_at
);
676 if (args
== 2 && i2
!= INTENT_IN
)
678 gfc_error ("Second argument of operator interface at %L must be "
679 "INTENT(IN)", &sym
->declared_at
);
684 /* From now on, all we have to do is check that the operator definition
685 doesn't conflict with an intrinsic operator. The rules for this
686 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
687 as well as 12.3.2.1.1 of Fortran 2003:
689 "If the operator is an intrinsic-operator (R310), the number of
690 function arguments shall be consistent with the intrinsic uses of
691 that operator, and the types, kind type parameters, or ranks of the
692 dummy arguments shall differ from those required for the intrinsic
693 operation (7.1.2)." */
695 #define IS_NUMERIC_TYPE(t) \
696 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
698 /* Unary ops are easy, do them first. */
699 if (op
== INTRINSIC_NOT
)
701 if (t1
== BT_LOGICAL
)
707 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
709 if (IS_NUMERIC_TYPE (t1
))
715 /* Character intrinsic operators have same character kind, thus
716 operator definitions with operands of different character kinds
718 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
721 /* Intrinsic operators always perform on arguments of same rank,
722 so different ranks is also always safe. (rank == 0) is an exception
723 to that, because all intrinsic operators are elemental. */
724 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
730 case INTRINSIC_EQ_OS
:
732 case INTRINSIC_NE_OS
:
733 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
738 case INTRINSIC_MINUS
:
739 case INTRINSIC_TIMES
:
740 case INTRINSIC_DIVIDE
:
741 case INTRINSIC_POWER
:
742 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
747 case INTRINSIC_GT_OS
:
749 case INTRINSIC_GE_OS
:
751 case INTRINSIC_LT_OS
:
753 case INTRINSIC_LE_OS
:
754 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
756 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
757 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
761 case INTRINSIC_CONCAT
:
762 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
770 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
780 #undef IS_NUMERIC_TYPE
783 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
789 /* Given a pair of formal argument lists, we see if the two lists can
790 be distinguished by counting the number of nonoptional arguments of
791 a given type/rank in f1 and seeing if there are less then that
792 number of those arguments in f2 (including optional arguments).
793 Since this test is asymmetric, it has to be called twice to make it
794 symmetric. Returns nonzero if the argument lists are incompatible
795 by this test. This subroutine implements rule 1 of section
796 14.1.2.3 in the Fortran 95 standard. */
799 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
801 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
802 gfc_formal_arglist
*f
;
815 for (f
= f1
; f
; f
= f
->next
)
818 /* Build an array of integers that gives the same integer to
819 arguments of the same type/rank. */
820 arg
= XCNEWVEC (arginfo
, n1
);
823 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
831 for (i
= 0; i
< n1
; i
++)
833 if (arg
[i
].flag
!= -1)
836 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
837 continue; /* Skip optional arguments. */
841 /* Find other nonoptional arguments of the same type/rank. */
842 for (j
= i
+ 1; j
< n1
; j
++)
843 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
844 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
850 /* Now loop over each distinct type found in f1. */
854 for (i
= 0; i
< n1
; i
++)
856 if (arg
[i
].flag
!= k
)
860 for (j
= i
+ 1; j
< n1
; j
++)
861 if (arg
[j
].flag
== k
)
864 /* Count the number of arguments in f2 with that type, including
865 those that are optional. */
868 for (f
= f2
; f
; f
= f
->next
)
869 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
887 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
888 Returns zero if no argument is found that satisfies rule 2, nonzero
891 This test is also not symmetric in f1 and f2 and must be called
892 twice. This test finds problems caused by sorting the actual
893 argument list with keywords. For example:
897 INTEGER :: A ; REAL :: B
901 INTEGER :: A ; REAL :: B
905 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
908 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
910 gfc_formal_arglist
*f2_save
, *g
;
917 if (f1
->sym
->attr
.optional
)
920 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
923 /* Now search for a disambiguating keyword argument starting at
924 the current non-match. */
925 for (g
= f1
; g
; g
= g
->next
)
927 if (g
->sym
->attr
.optional
)
930 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
931 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
945 /* 'Compare' two formal interfaces associated with a pair of symbols.
946 We return nonzero if there exists an actual argument list that
947 would be ambiguous between the two interfaces, zero otherwise.
948 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
949 required to match, which is not the case for ambiguity checks.*/
952 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
953 int generic_flag
, int intent_flag
,
954 char *errmsg
, int err_len
)
956 gfc_formal_arglist
*f1
, *f2
;
958 if (s1
->attr
.function
&& (s2
->attr
.subroutine
959 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
960 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
963 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
967 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
970 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
974 /* If the arguments are functions, check type and kind
975 (only for dummy procedures and procedure pointer assignments). */
976 if (!generic_flag
&& intent_flag
&& s1
->attr
.function
&& s2
->attr
.function
)
978 if (s1
->ts
.type
== BT_UNKNOWN
)
980 if ((s1
->ts
.type
!= s2
->ts
.type
) || (s1
->ts
.kind
!= s2
->ts
.kind
))
983 snprintf (errmsg
, err_len
, "Type/kind mismatch in return value "
989 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
990 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
996 if (f1
== NULL
&& f2
== NULL
)
997 return 1; /* Special case: No arguments. */
1001 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1003 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
1007 /* Perform the abbreviated correspondence test for operators (the
1008 arguments cannot be optional and are always ordered correctly).
1009 This is also done when comparing interfaces for dummy procedures and in
1010 procedure pointer assignments. */
1014 /* Check existence. */
1015 if (f1
== NULL
&& f2
== NULL
)
1017 if (f1
== NULL
|| f2
== NULL
)
1020 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1021 "arguments", name2
);
1025 /* Check type and rank. */
1026 if (!compare_type_rank (f1
->sym
, f2
->sym
))
1029 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1035 if (intent_flag
&& (f1
->sym
->attr
.intent
!= f2
->sym
->attr
.intent
))
1037 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1042 /* Check OPTIONAL. */
1043 if (intent_flag
&& (f1
->sym
->attr
.optional
!= f2
->sym
->attr
.optional
))
1045 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1058 /* Given a pointer to an interface pointer, remove duplicate
1059 interfaces and make sure that all symbols are either functions or
1060 subroutines. Returns nonzero if something goes wrong. */
1063 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1065 gfc_interface
*psave
, *q
, *qlast
;
1068 /* Make sure all symbols in the interface have been defined as
1069 functions or subroutines. */
1070 for (; p
; p
= p
->next
)
1071 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1072 || !p
->sym
->attr
.if_source
)
1074 if (p
->sym
->attr
.external
)
1075 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1076 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1078 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1079 "subroutine", p
->sym
->name
, interface_name
,
1080 &p
->sym
->declared_at
);
1085 /* Remove duplicate interfaces in this interface list. */
1086 for (; p
; p
= p
->next
)
1090 for (q
= p
->next
; q
;)
1092 if (p
->sym
!= q
->sym
)
1099 /* Duplicate interface. */
1100 qlast
->next
= q
->next
;
1111 /* Check lists of interfaces to make sure that no two interfaces are
1112 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1115 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1116 int generic_flag
, const char *interface_name
,
1120 for (; p
; p
= p
->next
)
1121 for (q
= q0
; q
; q
= q
->next
)
1123 if (p
->sym
== q
->sym
)
1124 continue; /* Duplicates OK here. */
1126 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1129 if (gfc_compare_interfaces (p
->sym
, q
->sym
, NULL
, generic_flag
, 0,
1134 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1135 p
->sym
->name
, q
->sym
->name
, interface_name
,
1139 if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1140 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1141 p
->sym
->name
, q
->sym
->name
, interface_name
,
1150 /* Check the generic and operator interfaces of symbols to make sure
1151 that none of the interfaces conflict. The check has to be done
1152 after all of the symbols are actually loaded. */
1155 check_sym_interfaces (gfc_symbol
*sym
)
1157 char interface_name
[100];
1161 if (sym
->ns
!= gfc_current_ns
)
1164 if (sym
->generic
!= NULL
)
1166 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1167 if (check_interface0 (sym
->generic
, interface_name
))
1170 for (p
= sym
->generic
; p
; p
= p
->next
)
1172 if (p
->sym
->attr
.mod_proc
1173 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1174 || p
->sym
->attr
.procedure
))
1176 gfc_error ("'%s' at %L is not a module procedure",
1177 p
->sym
->name
, &p
->where
);
1182 /* Originally, this test was applied to host interfaces too;
1183 this is incorrect since host associated symbols, from any
1184 source, cannot be ambiguous with local symbols. */
1185 k
= sym
->attr
.referenced
|| !sym
->attr
.use_assoc
;
1186 if (check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
, k
))
1187 sym
->attr
.ambiguous_interfaces
= 1;
1193 check_uop_interfaces (gfc_user_op
*uop
)
1195 char interface_name
[100];
1199 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1200 if (check_interface0 (uop
->op
, interface_name
))
1203 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1205 uop2
= gfc_find_uop (uop
->name
, ns
);
1209 check_interface1 (uop
->op
, uop2
->op
, 0,
1210 interface_name
, true);
1215 /* For the namespace, check generic, user operator and intrinsic
1216 operator interfaces for consistency and to remove duplicate
1217 interfaces. We traverse the whole namespace, counting on the fact
1218 that most symbols will not have generic or operator interfaces. */
1221 gfc_check_interfaces (gfc_namespace
*ns
)
1223 gfc_namespace
*old_ns
, *ns2
;
1224 char interface_name
[100];
1227 old_ns
= gfc_current_ns
;
1228 gfc_current_ns
= ns
;
1230 gfc_traverse_ns (ns
, check_sym_interfaces
);
1232 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1234 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1236 if (i
== INTRINSIC_USER
)
1239 if (i
== INTRINSIC_ASSIGN
)
1240 strcpy (interface_name
, "intrinsic assignment operator");
1242 sprintf (interface_name
, "intrinsic '%s' operator",
1243 gfc_op2string ((gfc_intrinsic_op
) i
));
1245 if (check_interface0 (ns
->op
[i
], interface_name
))
1249 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1252 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1254 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1255 interface_name
, true))
1261 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ_OS
],
1262 0, interface_name
, true)) goto done
;
1265 case INTRINSIC_EQ_OS
:
1266 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ
],
1267 0, interface_name
, true)) goto done
;
1271 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE_OS
],
1272 0, interface_name
, true)) goto done
;
1275 case INTRINSIC_NE_OS
:
1276 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE
],
1277 0, interface_name
, true)) goto done
;
1281 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT_OS
],
1282 0, interface_name
, true)) goto done
;
1285 case INTRINSIC_GT_OS
:
1286 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT
],
1287 0, interface_name
, true)) goto done
;
1291 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE_OS
],
1292 0, interface_name
, true)) goto done
;
1295 case INTRINSIC_GE_OS
:
1296 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE
],
1297 0, interface_name
, true)) goto done
;
1301 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT_OS
],
1302 0, interface_name
, true)) goto done
;
1305 case INTRINSIC_LT_OS
:
1306 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT
],
1307 0, interface_name
, true)) goto done
;
1311 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE_OS
],
1312 0, interface_name
, true)) goto done
;
1315 case INTRINSIC_LE_OS
:
1316 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE
],
1317 0, interface_name
, true)) goto done
;
1327 gfc_current_ns
= old_ns
;
1332 symbol_rank (gfc_symbol
*sym
)
1334 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1338 /* Given a symbol of a formal argument list and an expression, if the
1339 formal argument is allocatable, check that the actual argument is
1340 allocatable. Returns nonzero if compatible, zero if not compatible. */
1343 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1345 symbol_attribute attr
;
1347 if (formal
->attr
.allocatable
)
1349 attr
= gfc_expr_attr (actual
);
1350 if (!attr
.allocatable
)
1358 /* Given a symbol of a formal argument list and an expression, if the
1359 formal argument is a pointer, see if the actual argument is a
1360 pointer. Returns nonzero if compatible, zero if not compatible. */
1363 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1365 symbol_attribute attr
;
1367 if (formal
->attr
.pointer
)
1369 attr
= gfc_expr_attr (actual
);
1378 /* Given a symbol of a formal argument list and an expression, see if
1379 the two are compatible as arguments. Returns nonzero if
1380 compatible, zero if not compatible. */
1383 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1384 int ranks_must_agree
, int is_elemental
, locus
*where
)
1389 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1390 procs c_f_pointer or c_f_procpointer, and we need to accept most
1391 pointers the user could give us. This should allow that. */
1392 if (formal
->ts
.type
== BT_VOID
)
1395 if (formal
->ts
.type
== BT_DERIVED
1396 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1397 && actual
->ts
.type
== BT_DERIVED
1398 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1401 if (actual
->ts
.type
== BT_PROCEDURE
)
1404 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1406 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1409 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1413 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1417 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1418 formal
->name
, &actual
->where
, err
);
1422 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1424 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1425 &act_sym
->declared_at
);
1426 if (act_sym
->ts
.type
== BT_UNKNOWN
1427 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1430 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1431 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1432 &act_sym
->declared_at
);
1437 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1438 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1441 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1442 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1443 gfc_typename (&formal
->ts
));
1447 if (symbol_rank (formal
) == actual
->rank
)
1450 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1451 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1452 || formal
->as
->type
== AS_DEFERRED
);
1454 if (rank_check
|| ranks_must_agree
|| formal
->attr
.pointer
1455 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1456 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
1459 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1460 formal
->name
, &actual
->where
, symbol_rank (formal
),
1464 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1467 /* At this point, we are considering a scalar passed to an array. This
1468 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1469 - if the actual argument is (a substring of) an element of a
1470 non-assumed-shape/non-pointer array;
1471 - (F2003) if the actual argument is of type character. */
1473 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1474 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1477 /* Not an array element. */
1478 if (formal
->ts
.type
== BT_CHARACTER
1480 || (actual
->expr_type
== EXPR_VARIABLE
1481 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1482 || actual
->symtree
->n
.sym
->attr
.pointer
))))
1484 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1486 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1487 "array dummy argument '%s' at %L",
1488 formal
->name
, &actual
->where
);
1491 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1496 else if (ref
== NULL
)
1499 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1500 formal
->name
, &actual
->where
, symbol_rank (formal
),
1505 if (actual
->expr_type
== EXPR_VARIABLE
1506 && actual
->symtree
->n
.sym
->as
1507 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1508 || actual
->symtree
->n
.sym
->attr
.pointer
))
1511 gfc_error ("Element of assumed-shaped array passed to dummy "
1512 "argument '%s' at %L", formal
->name
, &actual
->where
);
1520 /* Given a symbol of a formal argument list and an expression, see if
1521 the two are compatible as arguments. Returns nonzero if
1522 compatible, zero if not compatible. */
1525 compare_parameter_protected (gfc_symbol
*formal
, gfc_expr
*actual
)
1527 if (actual
->expr_type
!= EXPR_VARIABLE
)
1530 if (!actual
->symtree
->n
.sym
->attr
.is_protected
)
1533 if (!actual
->symtree
->n
.sym
->attr
.use_assoc
)
1536 if (formal
->attr
.intent
== INTENT_IN
1537 || formal
->attr
.intent
== INTENT_UNKNOWN
)
1540 if (!actual
->symtree
->n
.sym
->attr
.pointer
)
1543 if (actual
->symtree
->n
.sym
->attr
.pointer
&& formal
->attr
.pointer
)
1550 /* Returns the storage size of a symbol (formal argument) or
1551 zero if it cannot be determined. */
1553 static unsigned long
1554 get_sym_storage_size (gfc_symbol
*sym
)
1557 unsigned long strlen
, elements
;
1559 if (sym
->ts
.type
== BT_CHARACTER
)
1561 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1562 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1563 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
1570 if (symbol_rank (sym
) == 0)
1574 if (sym
->as
->type
!= AS_EXPLICIT
)
1576 for (i
= 0; i
< sym
->as
->rank
; i
++)
1578 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1579 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1582 elements
*= mpz_get_ui (sym
->as
->upper
[i
]->value
.integer
)
1583 - mpz_get_ui (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1586 return strlen
*elements
;
1590 /* Returns the storage size of an expression (actual argument) or
1591 zero if it cannot be determined. For an array element, it returns
1592 the remaining size as the element sequence consists of all storage
1593 units of the actual argument up to the end of the array. */
1595 static unsigned long
1596 get_expr_storage_size (gfc_expr
*e
)
1599 long int strlen
, elements
;
1600 long int substrlen
= 0;
1601 bool is_str_storage
= false;
1607 if (e
->ts
.type
== BT_CHARACTER
)
1609 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1610 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1611 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
1612 else if (e
->expr_type
== EXPR_CONSTANT
1613 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
1614 strlen
= e
->value
.character
.length
;
1619 strlen
= 1; /* Length per element. */
1621 if (e
->rank
== 0 && !e
->ref
)
1629 for (i
= 0; i
< e
->rank
; i
++)
1630 elements
*= mpz_get_si (e
->shape
[i
]);
1631 return elements
*strlen
;
1634 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1636 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1637 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1641 /* The string length is the substring length.
1642 Set now to full string length. */
1643 if (ref
->u
.ss
.length
== NULL
1644 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1647 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1649 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1653 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1654 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1655 && ref
->u
.ar
.as
->upper
)
1656 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1658 long int start
, end
, stride
;
1661 if (ref
->u
.ar
.stride
[i
])
1663 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1664 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1669 if (ref
->u
.ar
.start
[i
])
1671 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1672 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1676 else if (ref
->u
.ar
.as
->lower
[i
]
1677 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1678 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1682 if (ref
->u
.ar
.end
[i
])
1684 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1685 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1689 else if (ref
->u
.ar
.as
->upper
[i
]
1690 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1691 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1695 elements
*= (end
- start
)/stride
+ 1L;
1697 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1698 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1699 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1701 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1702 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1703 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1704 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1705 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1710 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1711 && e
->expr_type
== EXPR_VARIABLE
)
1713 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1714 || e
->symtree
->n
.sym
->attr
.pointer
)
1720 /* Determine the number of remaining elements in the element
1721 sequence for array element designators. */
1722 is_str_storage
= true;
1723 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1725 if (ref
->u
.ar
.start
[i
] == NULL
1726 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1727 || ref
->u
.ar
.as
->upper
[i
] == NULL
1728 || ref
->u
.ar
.as
->lower
[i
] == NULL
1729 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1730 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1735 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1736 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1738 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1739 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1747 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1750 return elements
*strlen
;
1754 /* Given an expression, check whether it is an array section
1755 which has a vector subscript. If it has, one is returned,
1759 has_vector_subscript (gfc_expr
*e
)
1764 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1767 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1768 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1769 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1770 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1777 /* Given formal and actual argument lists, see if they are compatible.
1778 If they are compatible, the actual argument list is sorted to
1779 correspond with the formal list, and elements for missing optional
1780 arguments are inserted. If WHERE pointer is nonnull, then we issue
1781 errors when things don't match instead of just returning the status
1785 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1786 int ranks_must_agree
, int is_elemental
, locus
*where
)
1788 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
1789 gfc_formal_arglist
*f
;
1791 unsigned long actual_size
, formal_size
;
1795 if (actual
== NULL
&& formal
== NULL
)
1799 for (f
= formal
; f
; f
= f
->next
)
1802 new_arg
= (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1804 for (i
= 0; i
< n
; i
++)
1811 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1813 /* Look for keywords but ignore g77 extensions like %VAL. */
1814 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1817 for (f
= formal
; f
; f
= f
->next
, i
++)
1821 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1828 gfc_error ("Keyword argument '%s' at %L is not in "
1829 "the procedure", a
->name
, &a
->expr
->where
);
1833 if (new_arg
[i
] != NULL
)
1836 gfc_error ("Keyword argument '%s' at %L is already associated "
1837 "with another actual argument", a
->name
,
1846 gfc_error ("More actual than formal arguments in procedure "
1847 "call at %L", where
);
1852 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1858 gfc_error ("Missing alternate return spec in subroutine call "
1863 if (a
->expr
== NULL
)
1866 gfc_error ("Unexpected alternate return spec in subroutine "
1867 "call at %L", where
);
1871 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
1872 is_elemental
, where
))
1875 /* Special case for character arguments. For allocatable, pointer
1876 and assumed-shape dummies, the string length needs to match
1878 if (a
->expr
->ts
.type
== BT_CHARACTER
1879 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
1880 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1881 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
1882 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1883 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
1884 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1885 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
1886 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
1888 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
1889 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1890 "argument and pointer or allocatable dummy argument "
1892 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
1893 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
1894 f
->sym
->name
, &a
->expr
->where
);
1896 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1897 "argument and assumed-shape dummy argument '%s' "
1899 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
1900 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
1901 f
->sym
->name
, &a
->expr
->where
);
1905 actual_size
= get_expr_storage_size (a
->expr
);
1906 formal_size
= get_sym_storage_size (f
->sym
);
1907 if (actual_size
!= 0
1908 && actual_size
< formal_size
1909 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
1911 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
1912 gfc_warning ("Character length of actual argument shorter "
1913 "than of dummy argument '%s' (%lu/%lu) at %L",
1914 f
->sym
->name
, actual_size
, formal_size
,
1917 gfc_warning ("Actual argument contains too few "
1918 "elements for dummy argument '%s' (%lu/%lu) at %L",
1919 f
->sym
->name
, actual_size
, formal_size
,
1924 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1925 is provided for a procedure pointer formal argument. */
1926 if (f
->sym
->attr
.proc_pointer
1927 && !((a
->expr
->expr_type
== EXPR_VARIABLE
1928 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
1929 || (a
->expr
->expr_type
== EXPR_FUNCTION
1930 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
1931 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
1934 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1935 f
->sym
->name
, &a
->expr
->where
);
1939 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1940 provided for a procedure formal argument. */
1941 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
1942 && a
->expr
->expr_type
== EXPR_VARIABLE
1943 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1946 gfc_error ("Expected a procedure for argument '%s' at %L",
1947 f
->sym
->name
, &a
->expr
->where
);
1951 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
1952 && a
->expr
->ts
.type
== BT_PROCEDURE
1953 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
1956 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1957 f
->sym
->name
, &a
->expr
->where
);
1961 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1962 && a
->expr
->expr_type
== EXPR_VARIABLE
1963 && a
->expr
->symtree
->n
.sym
->as
1964 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
1965 && (a
->expr
->ref
== NULL
1966 || (a
->expr
->ref
->type
== REF_ARRAY
1967 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
1970 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1971 " array at %L", f
->sym
->name
, where
);
1975 if (a
->expr
->expr_type
!= EXPR_NULL
1976 && compare_pointer (f
->sym
, a
->expr
) == 0)
1979 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1980 f
->sym
->name
, &a
->expr
->where
);
1984 if (a
->expr
->expr_type
!= EXPR_NULL
1985 && compare_allocatable (f
->sym
, a
->expr
) == 0)
1988 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1989 f
->sym
->name
, &a
->expr
->where
);
1993 /* Check intent = OUT/INOUT for definable actual argument. */
1994 if ((a
->expr
->expr_type
!= EXPR_VARIABLE
1995 || (a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
1996 && a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
))
1997 && (f
->sym
->attr
.intent
== INTENT_OUT
1998 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2001 gfc_error ("Actual argument at %L must be definable as "
2002 "the dummy argument '%s' is INTENT = OUT/INOUT",
2003 &a
->expr
->where
, f
->sym
->name
);
2007 if (!compare_parameter_protected(f
->sym
, a
->expr
))
2010 gfc_error ("Actual argument at %L is use-associated with "
2011 "PROTECTED attribute and dummy argument '%s' is "
2012 "INTENT = OUT/INOUT",
2013 &a
->expr
->where
,f
->sym
->name
);
2017 if ((f
->sym
->attr
.intent
== INTENT_OUT
2018 || f
->sym
->attr
.intent
== INTENT_INOUT
2019 || f
->sym
->attr
.volatile_
)
2020 && has_vector_subscript (a
->expr
))
2023 gfc_error ("Array-section actual argument with vector subscripts "
2024 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2025 "or VOLATILE attribute of the dummy argument '%s'",
2026 &a
->expr
->where
, f
->sym
->name
);
2030 /* C1232 (R1221) For an actual argument which is an array section or
2031 an assumed-shape array, the dummy argument shall be an assumed-
2032 shape array, if the dummy argument has the VOLATILE attribute. */
2034 if (f
->sym
->attr
.volatile_
2035 && a
->expr
->symtree
->n
.sym
->as
2036 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2037 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2040 gfc_error ("Assumed-shape actual argument at %L is "
2041 "incompatible with the non-assumed-shape "
2042 "dummy argument '%s' due to VOLATILE attribute",
2043 &a
->expr
->where
,f
->sym
->name
);
2047 if (f
->sym
->attr
.volatile_
2048 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2049 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2052 gfc_error ("Array-section actual argument at %L is "
2053 "incompatible with the non-assumed-shape "
2054 "dummy argument '%s' due to VOLATILE attribute",
2055 &a
->expr
->where
,f
->sym
->name
);
2059 /* C1233 (R1221) For an actual argument which is a pointer array, the
2060 dummy argument shall be an assumed-shape or pointer array, if the
2061 dummy argument has the VOLATILE attribute. */
2063 if (f
->sym
->attr
.volatile_
2064 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2065 && a
->expr
->symtree
->n
.sym
->as
2067 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2068 || f
->sym
->attr
.pointer
)))
2071 gfc_error ("Pointer-array actual argument at %L requires "
2072 "an assumed-shape or pointer-array dummy "
2073 "argument '%s' due to VOLATILE attribute",
2074 &a
->expr
->where
,f
->sym
->name
);
2085 /* Make sure missing actual arguments are optional. */
2087 for (f
= formal
; f
; f
= f
->next
, i
++)
2089 if (new_arg
[i
] != NULL
)
2094 gfc_error ("Missing alternate return spec in subroutine call "
2098 if (!f
->sym
->attr
.optional
)
2101 gfc_error ("Missing actual argument for argument '%s' at %L",
2102 f
->sym
->name
, where
);
2107 /* The argument lists are compatible. We now relink a new actual
2108 argument list with null arguments in the right places. The head
2109 of the list remains the head. */
2110 for (i
= 0; i
< n
; i
++)
2111 if (new_arg
[i
] == NULL
)
2112 new_arg
[i
] = gfc_get_actual_arglist ();
2117 *new_arg
[0] = *actual
;
2121 new_arg
[0] = new_arg
[na
];
2125 for (i
= 0; i
< n
- 1; i
++)
2126 new_arg
[i
]->next
= new_arg
[i
+ 1];
2128 new_arg
[i
]->next
= NULL
;
2130 if (*ap
== NULL
&& n
> 0)
2133 /* Note the types of omitted optional arguments. */
2134 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2135 if (a
->expr
== NULL
&& a
->label
== NULL
)
2136 a
->missing_arg_type
= f
->sym
->ts
.type
;
2144 gfc_formal_arglist
*f
;
2145 gfc_actual_arglist
*a
;
2149 /* qsort comparison function for argument pairs, with the following
2151 - p->a->expr == NULL
2152 - p->a->expr->expr_type != EXPR_VARIABLE
2153 - growing p->a->expr->symbol. */
2156 pair_cmp (const void *p1
, const void *p2
)
2158 const gfc_actual_arglist
*a1
, *a2
;
2160 /* *p1 and *p2 are elements of the to-be-sorted array. */
2161 a1
= ((const argpair
*) p1
)->a
;
2162 a2
= ((const argpair
*) p2
)->a
;
2171 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2173 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2177 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2179 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2183 /* Given two expressions from some actual arguments, test whether they
2184 refer to the same expression. The analysis is conservative.
2185 Returning FAILURE will produce no warning. */
2188 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2190 const gfc_ref
*r1
, *r2
;
2193 || e1
->expr_type
!= EXPR_VARIABLE
2194 || e2
->expr_type
!= EXPR_VARIABLE
2195 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2198 /* TODO: improve comparison, see expr.c:show_ref(). */
2199 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2201 if (r1
->type
!= r2
->type
)
2206 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2208 /* TODO: At the moment, consider only full arrays;
2209 we could do better. */
2210 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2215 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2223 gfc_internal_error ("compare_actual_expr(): Bad component code");
2232 /* Given formal and actual argument lists that correspond to one
2233 another, check that identical actual arguments aren't not
2234 associated with some incompatible INTENTs. */
2237 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2239 sym_intent f1_intent
, f2_intent
;
2240 gfc_formal_arglist
*f1
;
2241 gfc_actual_arglist
*a1
;
2244 gfc_try t
= SUCCESS
;
2247 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2249 if (f1
== NULL
&& a1
== NULL
)
2251 if (f1
== NULL
|| a1
== NULL
)
2252 gfc_internal_error ("check_some_aliasing(): List mismatch");
2257 p
= (argpair
*) alloca (n
* sizeof (argpair
));
2259 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2265 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2267 for (i
= 0; i
< n
; i
++)
2270 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2271 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2273 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2274 for (j
= i
+ 1; j
< n
; j
++)
2276 /* Expected order after the sort. */
2277 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2278 gfc_internal_error ("check_some_aliasing(): corrupted data");
2280 /* Are the expression the same? */
2281 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2283 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2284 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2285 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2287 gfc_warning ("Same actual argument associated with INTENT(%s) "
2288 "argument '%s' and INTENT(%s) argument '%s' at %L",
2289 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2290 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2291 &p
[i
].a
->expr
->where
);
2301 /* Given a symbol of a formal argument list and an expression,
2302 return nonzero if their intents are compatible, zero otherwise. */
2305 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2307 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2310 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2313 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2320 /* Given formal and actual argument lists that correspond to one
2321 another, check that they are compatible in the sense that intents
2322 are not mismatched. */
2325 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2327 sym_intent f_intent
;
2329 for (;; f
= f
->next
, a
= a
->next
)
2331 if (f
== NULL
&& a
== NULL
)
2333 if (f
== NULL
|| a
== NULL
)
2334 gfc_internal_error ("check_intents(): List mismatch");
2336 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2339 f_intent
= f
->sym
->attr
.intent
;
2341 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2343 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2344 "specifies INTENT(%s)", &a
->expr
->where
,
2345 gfc_intent_string (f_intent
));
2349 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2351 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2353 gfc_error ("Procedure argument at %L is local to a PURE "
2354 "procedure and is passed to an INTENT(%s) argument",
2355 &a
->expr
->where
, gfc_intent_string (f_intent
));
2359 if (f
->sym
->attr
.pointer
)
2361 gfc_error ("Procedure argument at %L is local to a PURE "
2362 "procedure and has the POINTER attribute",
2373 /* Check how a procedure is used against its interface. If all goes
2374 well, the actual argument list will also end up being properly
2378 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2381 /* Warn about calls with an implicit interface. Special case
2382 for calling a ISO_C_BINDING becase c_loc and c_funloc
2383 are pseudo-unknown. Additionally, warn about procedures not
2384 explicitly declared at all if requested. */
2385 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2387 if (gfc_option
.warn_implicit_interface
)
2388 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2390 else if (gfc_option
.warn_implicit_procedure
2391 && sym
->attr
.proc
== PROC_UNKNOWN
)
2392 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2396 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2398 gfc_actual_arglist
*a
;
2399 for (a
= *ap
; a
; a
= a
->next
)
2401 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2402 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2404 gfc_error("Keyword argument requires explicit interface "
2405 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2413 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2416 check_intents (sym
->formal
, *ap
);
2417 if (gfc_option
.warn_aliasing
)
2418 check_some_aliasing (sym
->formal
, *ap
);
2422 /* Check how a procedure pointer component is used against its interface.
2423 If all goes well, the actual argument list will also end up being properly
2424 sorted. Completely analogous to gfc_procedure_use. */
2427 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2430 /* Warn about calls with an implicit interface. Special case
2431 for calling a ISO_C_BINDING becase c_loc and c_funloc
2432 are pseudo-unknown. */
2433 if (gfc_option
.warn_implicit_interface
2434 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2435 && !comp
->attr
.is_iso_c
)
2436 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2437 "interface at %L", comp
->name
, where
);
2439 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2441 gfc_actual_arglist
*a
;
2442 for (a
= *ap
; a
; a
= a
->next
)
2444 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2445 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2447 gfc_error("Keyword argument requires explicit interface "
2448 "for procedure pointer component '%s' at %L",
2449 comp
->name
, &a
->expr
->where
);
2457 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2460 check_intents (comp
->formal
, *ap
);
2461 if (gfc_option
.warn_aliasing
)
2462 check_some_aliasing (comp
->formal
, *ap
);
2466 /* Try if an actual argument list matches the formal list of a symbol,
2467 respecting the symbol's attributes like ELEMENTAL. This is used for
2468 GENERIC resolution. */
2471 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2475 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2477 r
= !sym
->attr
.elemental
;
2478 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2480 check_intents (sym
->formal
, *args
);
2481 if (gfc_option
.warn_aliasing
)
2482 check_some_aliasing (sym
->formal
, *args
);
2490 /* Given an interface pointer and an actual argument list, search for
2491 a formal argument list that matches the actual. If found, returns
2492 a pointer to the symbol of the correct interface. Returns NULL if
2496 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2497 gfc_actual_arglist
**ap
)
2499 gfc_symbol
*elem_sym
= NULL
;
2500 for (; intr
; intr
= intr
->next
)
2502 if (sub_flag
&& intr
->sym
->attr
.function
)
2504 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2507 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
2509 /* Satisfy 12.4.4.1 such that an elemental match has lower
2510 weight than a non-elemental match. */
2511 if (intr
->sym
->attr
.elemental
)
2513 elem_sym
= intr
->sym
;
2520 return elem_sym
? elem_sym
: NULL
;
2524 /* Do a brute force recursive search for a symbol. */
2526 static gfc_symtree
*
2527 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2531 if (root
->n
.sym
== sym
)
2536 st
= find_symtree0 (root
->left
, sym
);
2537 if (root
->right
&& ! st
)
2538 st
= find_symtree0 (root
->right
, sym
);
2543 /* Find a symtree for a symbol. */
2546 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
2551 /* First try to find it by name. */
2552 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2553 if (st
&& st
->n
.sym
== sym
)
2556 /* If it's been renamed, resort to a brute-force search. */
2557 /* TODO: avoid having to do this search. If the symbol doesn't exist
2558 in the symtree for the current namespace, it should probably be added. */
2559 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2561 st
= find_symtree0 (ns
->sym_root
, sym
);
2565 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2570 /* See if the arglist to an operator-call contains a derived-type argument
2571 with a matching type-bound operator. If so, return the matching specific
2572 procedure defined as operator-target as well as the base-object to use
2573 (which is the found derived-type argument with operator). */
2575 static gfc_typebound_proc
*
2576 matching_typebound_op (gfc_expr
** tb_base
,
2577 gfc_actual_arglist
* args
,
2578 gfc_intrinsic_op op
, const char* uop
)
2580 gfc_actual_arglist
* base
;
2582 for (base
= args
; base
; base
= base
->next
)
2583 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
2585 gfc_typebound_proc
* tb
;
2586 gfc_symbol
* derived
;
2589 if (base
->expr
->ts
.type
== BT_CLASS
)
2590 derived
= base
->expr
->ts
.u
.derived
->components
->ts
.u
.derived
;
2592 derived
= base
->expr
->ts
.u
.derived
;
2594 if (op
== INTRINSIC_USER
)
2596 gfc_symtree
* tb_uop
;
2599 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
2608 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
2611 /* This means we hit a PRIVATE operator which is use-associated and
2612 should thus not be seen. */
2613 if (result
== FAILURE
)
2616 /* Look through the super-type hierarchy for a matching specific
2618 for (; tb
; tb
= tb
->overridden
)
2622 gcc_assert (tb
->is_generic
);
2623 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
2626 gfc_actual_arglist
* argcopy
;
2629 gcc_assert (g
->specific
);
2630 if (g
->specific
->error
)
2633 target
= g
->specific
->u
.specific
->n
.sym
;
2635 /* Check if this arglist matches the formal. */
2636 argcopy
= gfc_copy_actual_arglist (args
);
2637 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
2638 gfc_free_actual_arglist (argcopy
);
2640 /* Return if we found a match. */
2643 *tb_base
= base
->expr
;
2654 /* For the 'actual arglist' of an operator call and a specific typebound
2655 procedure that has been found the target of a type-bound operator, build the
2656 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2657 type-bound procedures rather than resolving type-bound operators 'directly'
2658 so that we can reuse the existing logic. */
2661 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
2662 gfc_expr
* base
, gfc_typebound_proc
* target
)
2664 e
->expr_type
= EXPR_COMPCALL
;
2665 e
->value
.compcall
.tbp
= target
;
2666 e
->value
.compcall
.name
= "operator"; /* Should not matter. */
2667 e
->value
.compcall
.actual
= actual
;
2668 e
->value
.compcall
.base_object
= base
;
2669 e
->value
.compcall
.ignore_pass
= 1;
2670 e
->value
.compcall
.assign
= 0;
2674 /* This subroutine is called when an expression is being resolved.
2675 The expression node in question is either a user defined operator
2676 or an intrinsic operator with arguments that aren't compatible
2677 with the operator. This subroutine builds an actual argument list
2678 corresponding to the operands, then searches for a compatible
2679 interface. If one is found, the expression node is replaced with
2680 the appropriate function call.
2681 real_error is an additional output argument that specifies if FAILURE
2682 is because of some real error and not because no match was found. */
2685 gfc_extend_expr (gfc_expr
*e
, bool *real_error
)
2687 gfc_actual_arglist
*actual
;
2695 actual
= gfc_get_actual_arglist ();
2696 actual
->expr
= e
->value
.op
.op1
;
2698 *real_error
= false;
2700 if (e
->value
.op
.op2
!= NULL
)
2702 actual
->next
= gfc_get_actual_arglist ();
2703 actual
->next
->expr
= e
->value
.op
.op2
;
2706 i
= fold_unary_intrinsic (e
->value
.op
.op
);
2708 if (i
== INTRINSIC_USER
)
2710 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2712 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2716 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
2723 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2725 /* Due to the distinction between '==' and '.eq.' and friends, one has
2726 to check if either is defined. */
2729 #define CHECK_OS_COMPARISON(comp) \
2730 case INTRINSIC_##comp: \
2731 case INTRINSIC_##comp##_OS: \
2732 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2734 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2736 CHECK_OS_COMPARISON(EQ
)
2737 CHECK_OS_COMPARISON(NE
)
2738 CHECK_OS_COMPARISON(GT
)
2739 CHECK_OS_COMPARISON(GE
)
2740 CHECK_OS_COMPARISON(LT
)
2741 CHECK_OS_COMPARISON(LE
)
2742 #undef CHECK_OS_COMPARISON
2745 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
2753 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2754 found rather than just taking the first one and not checking further. */
2758 gfc_typebound_proc
* tbo
;
2761 /* See if we find a matching type-bound operator. */
2762 if (i
== INTRINSIC_USER
)
2763 tbo
= matching_typebound_op (&tb_base
, actual
,
2764 i
, e
->value
.op
.uop
->name
);
2768 #define CHECK_OS_COMPARISON(comp) \
2769 case INTRINSIC_##comp: \
2770 case INTRINSIC_##comp##_OS: \
2771 tbo = matching_typebound_op (&tb_base, actual, \
2772 INTRINSIC_##comp, NULL); \
2774 tbo = matching_typebound_op (&tb_base, actual, \
2775 INTRINSIC_##comp##_OS, NULL); \
2777 CHECK_OS_COMPARISON(EQ
)
2778 CHECK_OS_COMPARISON(NE
)
2779 CHECK_OS_COMPARISON(GT
)
2780 CHECK_OS_COMPARISON(GE
)
2781 CHECK_OS_COMPARISON(LT
)
2782 CHECK_OS_COMPARISON(LE
)
2783 #undef CHECK_OS_COMPARISON
2786 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
);
2790 /* If there is a matching typebound-operator, replace the expression with
2791 a call to it and succeed. */
2796 gcc_assert (tb_base
);
2797 build_compcall_for_operator (e
, actual
, tb_base
, tbo
);
2799 result
= gfc_resolve_expr (e
);
2800 if (result
== FAILURE
)
2806 /* Don't use gfc_free_actual_arglist(). */
2807 if (actual
->next
!= NULL
)
2808 gfc_free (actual
->next
);
2814 /* Change the expression node to a function call. */
2815 e
->expr_type
= EXPR_FUNCTION
;
2816 e
->symtree
= gfc_find_sym_in_symtree (sym
);
2817 e
->value
.function
.actual
= actual
;
2818 e
->value
.function
.esym
= NULL
;
2819 e
->value
.function
.isym
= NULL
;
2820 e
->value
.function
.name
= NULL
;
2821 e
->user_operator
= 1;
2823 if (gfc_resolve_expr (e
) == FAILURE
)
2833 /* Tries to replace an assignment code node with a subroutine call to
2834 the subroutine associated with the assignment operator. Return
2835 SUCCESS if the node was replaced. On FAILURE, no error is
2839 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
2841 gfc_actual_arglist
*actual
;
2842 gfc_expr
*lhs
, *rhs
;
2848 /* Don't allow an intrinsic assignment to be replaced. */
2849 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
2850 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
2851 && (lhs
->ts
.type
== rhs
->ts
.type
2852 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
2855 actual
= gfc_get_actual_arglist ();
2858 actual
->next
= gfc_get_actual_arglist ();
2859 actual
->next
->expr
= rhs
;
2863 for (; ns
; ns
= ns
->parent
)
2865 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
2870 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
2874 gfc_typebound_proc
* tbo
;
2877 /* See if we find a matching type-bound assignment. */
2878 tbo
= matching_typebound_op (&tb_base
, actual
,
2879 INTRINSIC_ASSIGN
, NULL
);
2881 /* If there is one, replace the expression with a call to it and
2885 gcc_assert (tb_base
);
2886 c
->expr1
= gfc_get_expr ();
2887 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
);
2888 c
->expr1
->value
.compcall
.assign
= 1;
2890 c
->op
= EXEC_COMPCALL
;
2892 /* c is resolved from the caller, so no need to do it here. */
2897 gfc_free (actual
->next
);
2902 /* Replace the assignment with the call. */
2903 c
->op
= EXEC_ASSIGN_CALL
;
2904 c
->symtree
= gfc_find_sym_in_symtree (sym
);
2907 c
->ext
.actual
= actual
;
2913 /* Make sure that the interface just parsed is not already present in
2914 the given interface list. Ambiguity isn't checked yet since module
2915 procedures can be present without interfaces. */
2918 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
2922 for (ip
= base
; ip
; ip
= ip
->next
)
2924 if (ip
->sym
== new_sym
)
2926 gfc_error ("Entity '%s' at %C is already present in the interface",
2936 /* Add a symbol to the current interface. */
2939 gfc_add_interface (gfc_symbol
*new_sym
)
2941 gfc_interface
**head
, *intr
;
2945 switch (current_interface
.type
)
2947 case INTERFACE_NAMELESS
:
2948 case INTERFACE_ABSTRACT
:
2951 case INTERFACE_INTRINSIC_OP
:
2952 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2953 switch (current_interface
.op
)
2956 case INTRINSIC_EQ_OS
:
2957 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
2958 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
2963 case INTRINSIC_NE_OS
:
2964 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
2965 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
2970 case INTRINSIC_GT_OS
:
2971 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
2972 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
2977 case INTRINSIC_GE_OS
:
2978 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
2979 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
2984 case INTRINSIC_LT_OS
:
2985 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
2986 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
2991 case INTRINSIC_LE_OS
:
2992 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
2993 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
2998 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
3002 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3005 case INTERFACE_GENERIC
:
3006 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3008 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3012 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
3016 head
= ¤t_interface
.sym
->generic
;
3019 case INTERFACE_USER_OP
:
3020 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
3024 head
= ¤t_interface
.uop
->op
;
3028 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3031 intr
= gfc_get_interface ();
3032 intr
->sym
= new_sym
;
3033 intr
->where
= gfc_current_locus
;
3043 gfc_current_interface_head (void)
3045 switch (current_interface
.type
)
3047 case INTERFACE_INTRINSIC_OP
:
3048 return current_interface
.ns
->op
[current_interface
.op
];
3051 case INTERFACE_GENERIC
:
3052 return current_interface
.sym
->generic
;
3055 case INTERFACE_USER_OP
:
3056 return current_interface
.uop
->op
;
3066 gfc_set_current_interface_head (gfc_interface
*i
)
3068 switch (current_interface
.type
)
3070 case INTERFACE_INTRINSIC_OP
:
3071 current_interface
.ns
->op
[current_interface
.op
] = i
;
3074 case INTERFACE_GENERIC
:
3075 current_interface
.sym
->generic
= i
;
3078 case INTERFACE_USER_OP
:
3079 current_interface
.uop
->op
= i
;
3088 /* Gets rid of a formal argument list. We do not free symbols.
3089 Symbols are freed when a namespace is freed. */
3092 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3094 gfc_formal_arglist
*q
;