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. */
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface
;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface
*intr
)
87 for (; intr
; intr
= next
)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary_intrinsic (gfc_intrinsic_op op
)
103 case INTRINSIC_UPLUS
:
106 case INTRINSIC_UMINUS
:
107 op
= INTRINSIC_MINUS
;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'op' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type
*type
,
124 gfc_intrinsic_op
*op
)
126 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES
)
132 *type
= INTERFACE_INTRINSIC_OP
;
133 *op
= INTRINSIC_ASSIGN
;
137 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
139 *type
= INTERFACE_INTRINSIC_OP
;
140 *op
= fold_unary_intrinsic (i
);
144 *op
= INTRINSIC_NONE
;
145 if (gfc_match (" operator ( ") == MATCH_YES
)
147 m
= gfc_match_defined_op_name (buffer
, 1);
153 m
= gfc_match_char (')');
159 strcpy (name
, buffer
);
160 *type
= INTERFACE_USER_OP
;
164 if (gfc_match_name (buffer
) == MATCH_YES
)
166 strcpy (name
, buffer
);
167 *type
= INTERFACE_GENERIC
;
171 *type
= INTERFACE_NAMELESS
;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five F95 forms of an interface statement. The
181 matcher for the abstract interface follows. */
184 gfc_match_interface (void)
186 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
192 m
= gfc_match_space ();
194 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
202 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
207 current_interface
.type
= type
;
211 case INTERFACE_GENERIC
:
212 if (gfc_get_symbol (name
, NULL
, &sym
))
215 if (!sym
->attr
.generic
216 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
221 gfc_error ("Dummy procedure '%s' at %C cannot have a "
222 "generic interface", sym
->name
);
226 current_interface
.sym
= gfc_new_block
= sym
;
229 case INTERFACE_USER_OP
:
230 current_interface
.uop
= gfc_get_uop (name
);
233 case INTERFACE_INTRINSIC_OP
:
234 current_interface
.op
= op
;
237 case INTERFACE_NAMELESS
:
238 case INTERFACE_ABSTRACT
:
247 /* Match a F2003 abstract interface. */
250 gfc_match_abstract_interface (void)
254 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ABSTRACT INTERFACE at %C")
258 m
= gfc_match_eos ();
262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
266 current_interface
.type
= INTERFACE_ABSTRACT
;
272 /* Match the different sort of generic-specs that can be present after
273 the END INTERFACE itself. */
276 gfc_match_end_interface (void)
278 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
283 m
= gfc_match_space ();
285 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
288 /* If we're not looking at the end of the statement now, or if this
289 is not a nameless interface but we did not see a space, punt. */
290 if (gfc_match_eos () != MATCH_YES
291 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
300 switch (current_interface
.type
)
302 case INTERFACE_NAMELESS
:
303 case INTERFACE_ABSTRACT
:
304 if (type
!= INTERFACE_NAMELESS
)
306 gfc_error ("Expected a nameless interface at %C");
312 case INTERFACE_INTRINSIC_OP
:
313 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
316 if (current_interface
.op
== INTRINSIC_ASSIGN
)
317 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
319 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
320 gfc_op2string (current_interface
.op
));
327 case INTERFACE_USER_OP
:
328 /* Comparing the symbol node names is OK because only use-associated
329 symbols can be renamed. */
330 if (type
!= current_interface
.type
331 || strcmp (current_interface
.uop
->name
, name
) != 0)
333 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
334 current_interface
.uop
->name
);
340 case INTERFACE_GENERIC
:
341 if (type
!= current_interface
.type
342 || strcmp (current_interface
.sym
->name
, name
) != 0)
344 gfc_error ("Expecting 'END INTERFACE %s' at %C",
345 current_interface
.sym
->name
);
356 /* Compare two derived types using the criteria in 4.4.2 of the standard,
357 recursing through gfc_compare_types for the components. */
360 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
362 gfc_component
*dt1
, *dt2
;
364 if (derived1
== derived2
)
367 /* Special case for comparing derived types across namespaces. If the
368 true names and module names are the same and the module name is
369 nonnull, then they are equal. */
370 if (derived1
!= NULL
&& derived2
!= NULL
371 && strcmp (derived1
->name
, derived2
->name
) == 0
372 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
373 && strcmp (derived1
->module
, derived2
->module
) == 0)
376 /* Compare type via the rules of the standard. Both types must have
377 the SEQUENCE attribute to be equal. */
379 if (strcmp (derived1
->name
, derived2
->name
))
382 if (derived1
->component_access
== ACCESS_PRIVATE
383 || derived2
->component_access
== ACCESS_PRIVATE
)
386 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
389 dt1
= derived1
->components
;
390 dt2
= derived2
->components
;
392 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
393 simple test can speed things up. Otherwise, lots of things have to
397 if (strcmp (dt1
->name
, dt2
->name
) != 0)
400 if (dt1
->attr
.access
!= dt2
->attr
.access
)
403 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
406 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
409 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
412 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
415 /* Make sure that link lists do not put this function into an
416 endless recursive loop! */
417 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
418 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
419 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
422 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
423 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
426 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
427 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
433 if (dt1
== NULL
&& dt2
== NULL
)
435 if (dt1
== NULL
|| dt2
== NULL
)
443 /* Compare two typespecs, recursively if necessary. */
446 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
448 /* See if one of the typespecs is a BT_VOID, which is what is being used
449 to allow the funcs like c_f_pointer to accept any pointer type.
450 TODO: Possibly should narrow this to just the one typespec coming in
451 that is for the formal arg, but oh well. */
452 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
455 if (ts1
->type
!= ts2
->type
456 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
457 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
459 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
460 return (ts1
->kind
== ts2
->kind
);
462 /* Compare derived types. */
463 if (gfc_type_compatible (ts1
, ts2
))
466 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
470 /* Given two symbols that are formal arguments, compare their ranks
471 and types. Returns nonzero if they have the same rank and type,
475 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
479 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
480 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
483 return 0; /* Ranks differ. */
485 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
489 /* Given two symbols that are formal arguments, compare their types
490 and rank and their formal interfaces if they are both dummy
491 procedures. Returns nonzero if the same, zero if different. */
494 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
496 if (s1
== NULL
|| s2
== NULL
)
497 return s1
== s2
? 1 : 0;
502 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
503 return compare_type_rank (s1
, s2
);
505 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
508 /* At this point, both symbols are procedures. It can happen that
509 external procedures are compared, where one is identified by usage
510 to be a function or subroutine but the other is not. Check TKR
511 nonetheless for these cases. */
512 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
513 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
515 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
516 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
518 /* Now the type of procedure has been identified. */
519 if (s1
->attr
.function
!= s2
->attr
.function
520 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
523 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
526 /* Originally, gfortran recursed here to check the interfaces of passed
527 procedures. This is explicitly not required by the standard. */
532 /* Given a formal argument list and a keyword name, search the list
533 for that keyword. Returns the correct symbol node if found, NULL
537 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
539 for (; f
; f
= f
->next
)
540 if (strcmp (f
->sym
->name
, name
) == 0)
547 /******** Interface checking subroutines **********/
550 /* Given an operator interface and the operator, make sure that all
551 interfaces for that operator are legal. */
554 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
557 gfc_formal_arglist
*formal
;
560 int args
, r1
, r2
, k1
, k2
;
565 t1
= t2
= BT_UNKNOWN
;
566 i1
= i2
= INTENT_UNKNOWN
;
570 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
572 gfc_symbol
*fsym
= formal
->sym
;
575 gfc_error ("Alternate return cannot appear in operator "
576 "interface at %L", &sym
->declared_at
);
582 i1
= fsym
->attr
.intent
;
583 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
589 i2
= fsym
->attr
.intent
;
590 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
596 /* Only +, - and .not. can be unary operators.
597 .not. cannot be a binary operator. */
598 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
599 && op
!= INTRINSIC_MINUS
600 && op
!= INTRINSIC_NOT
)
601 || (args
== 2 && op
== INTRINSIC_NOT
))
603 gfc_error ("Operator interface at %L has the wrong number of arguments",
608 /* Check that intrinsics are mapped to functions, except
609 INTRINSIC_ASSIGN which should map to a subroutine. */
610 if (op
== INTRINSIC_ASSIGN
)
612 if (!sym
->attr
.subroutine
)
614 gfc_error ("Assignment operator interface at %L must be "
615 "a SUBROUTINE", &sym
->declared_at
);
620 gfc_error ("Assignment operator interface at %L must have "
621 "two arguments", &sym
->declared_at
);
625 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
626 - First argument an array with different rank than second,
627 - Types and kinds do not conform, and
628 - First argument is of derived type. */
629 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
630 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
631 && (r1
== 0 || r1
== r2
)
632 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
633 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
634 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
636 gfc_error ("Assignment operator interface at %L must not redefine "
637 "an INTRINSIC type assignment", &sym
->declared_at
);
643 if (!sym
->attr
.function
)
645 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
651 /* Check intents on operator interfaces. */
652 if (op
== INTRINSIC_ASSIGN
)
654 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
656 gfc_error ("First argument of defined assignment at %L must be "
657 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
663 gfc_error ("Second argument of defined assignment at %L must be "
664 "INTENT(IN)", &sym
->declared_at
);
672 gfc_error ("First argument of operator interface at %L must be "
673 "INTENT(IN)", &sym
->declared_at
);
677 if (args
== 2 && i2
!= INTENT_IN
)
679 gfc_error ("Second argument of operator interface at %L must be "
680 "INTENT(IN)", &sym
->declared_at
);
685 /* From now on, all we have to do is check that the operator definition
686 doesn't conflict with an intrinsic operator. The rules for this
687 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
688 as well as 12.3.2.1.1 of Fortran 2003:
690 "If the operator is an intrinsic-operator (R310), the number of
691 function arguments shall be consistent with the intrinsic uses of
692 that operator, and the types, kind type parameters, or ranks of the
693 dummy arguments shall differ from those required for the intrinsic
694 operation (7.1.2)." */
696 #define IS_NUMERIC_TYPE(t) \
697 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
699 /* Unary ops are easy, do them first. */
700 if (op
== INTRINSIC_NOT
)
702 if (t1
== BT_LOGICAL
)
708 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
710 if (IS_NUMERIC_TYPE (t1
))
716 /* Character intrinsic operators have same character kind, thus
717 operator definitions with operands of different character kinds
719 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
722 /* Intrinsic operators always perform on arguments of same rank,
723 so different ranks is also always safe. (rank == 0) is an exception
724 to that, because all intrinsic operators are elemental. */
725 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
731 case INTRINSIC_EQ_OS
:
733 case INTRINSIC_NE_OS
:
734 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
739 case INTRINSIC_MINUS
:
740 case INTRINSIC_TIMES
:
741 case INTRINSIC_DIVIDE
:
742 case INTRINSIC_POWER
:
743 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
748 case INTRINSIC_GT_OS
:
750 case INTRINSIC_GE_OS
:
752 case INTRINSIC_LT_OS
:
754 case INTRINSIC_LE_OS
:
755 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
757 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
758 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
762 case INTRINSIC_CONCAT
:
763 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
771 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
781 #undef IS_NUMERIC_TYPE
784 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
790 /* Given a pair of formal argument lists, we see if the two lists can
791 be distinguished by counting the number of nonoptional arguments of
792 a given type/rank in f1 and seeing if there are less then that
793 number of those arguments in f2 (including optional arguments).
794 Since this test is asymmetric, it has to be called twice to make it
795 symmetric. Returns nonzero if the argument lists are incompatible
796 by this test. This subroutine implements rule 1 of section
797 14.1.2.3 in the Fortran 95 standard. */
800 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
802 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
803 gfc_formal_arglist
*f
;
816 for (f
= f1
; f
; f
= f
->next
)
819 /* Build an array of integers that gives the same integer to
820 arguments of the same type/rank. */
821 arg
= XCNEWVEC (arginfo
, n1
);
824 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
832 for (i
= 0; i
< n1
; i
++)
834 if (arg
[i
].flag
!= -1)
837 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
838 continue; /* Skip optional arguments. */
842 /* Find other nonoptional arguments of the same type/rank. */
843 for (j
= i
+ 1; j
< n1
; j
++)
844 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
845 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
851 /* Now loop over each distinct type found in f1. */
855 for (i
= 0; i
< n1
; i
++)
857 if (arg
[i
].flag
!= k
)
861 for (j
= i
+ 1; j
< n1
; j
++)
862 if (arg
[j
].flag
== k
)
865 /* Count the number of arguments in f2 with that type, including
866 those that are optional. */
869 for (f
= f2
; f
; f
= f
->next
)
870 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
888 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
889 Returns zero if no argument is found that satisfies rule 2, nonzero
892 This test is also not symmetric in f1 and f2 and must be called
893 twice. This test finds problems caused by sorting the actual
894 argument list with keywords. For example:
898 INTEGER :: A ; REAL :: B
902 INTEGER :: A ; REAL :: B
906 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
909 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
911 gfc_formal_arglist
*f2_save
, *g
;
918 if (f1
->sym
->attr
.optional
)
921 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
924 /* Now search for a disambiguating keyword argument starting at
925 the current non-match. */
926 for (g
= f1
; g
; g
= g
->next
)
928 if (g
->sym
->attr
.optional
)
931 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
932 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
946 /* 'Compare' two formal interfaces associated with a pair of symbols.
947 We return nonzero if there exists an actual argument list that
948 would be ambiguous between the two interfaces, zero otherwise.
949 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
950 required to match, which is not the case for ambiguity checks.*/
953 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
954 int generic_flag
, int intent_flag
,
955 char *errmsg
, int err_len
)
957 gfc_formal_arglist
*f1
, *f2
;
959 gcc_assert (name2
!= NULL
);
961 if (s1
->attr
.function
&& (s2
->attr
.subroutine
962 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
963 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
966 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
970 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
973 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
977 /* If the arguments are functions, check type and kind
978 (only for dummy procedures and procedure pointer assignments). */
979 if (!generic_flag
&& intent_flag
&& s1
->attr
.function
&& s2
->attr
.function
)
981 if (s1
->ts
.type
== BT_UNKNOWN
)
983 if ((s1
->ts
.type
!= s2
->ts
.type
) || (s1
->ts
.kind
!= s2
->ts
.kind
))
986 snprintf (errmsg
, err_len
, "Type/kind mismatch in return value "
992 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
993 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
999 if (f1
== NULL
&& f2
== NULL
)
1000 return 1; /* Special case: No arguments. */
1004 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1006 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
1010 /* Perform the abbreviated correspondence test for operators (the
1011 arguments cannot be optional and are always ordered correctly).
1012 This is also done when comparing interfaces for dummy procedures and in
1013 procedure pointer assignments. */
1017 /* Check existence. */
1018 if (f1
== NULL
&& f2
== NULL
)
1020 if (f1
== NULL
|| f2
== NULL
)
1023 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1024 "arguments", name2
);
1028 /* Check type and rank. */
1029 if (!compare_type_rank (f1
->sym
, f2
->sym
))
1032 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1038 if (intent_flag
&& (f1
->sym
->attr
.intent
!= f2
->sym
->attr
.intent
))
1040 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1045 /* Check OPTIONAL. */
1046 if (intent_flag
&& (f1
->sym
->attr
.optional
!= f2
->sym
->attr
.optional
))
1048 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1061 /* Given a pointer to an interface pointer, remove duplicate
1062 interfaces and make sure that all symbols are either functions or
1063 subroutines. Returns nonzero if something goes wrong. */
1066 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1068 gfc_interface
*psave
, *q
, *qlast
;
1071 /* Make sure all symbols in the interface have been defined as
1072 functions or subroutines. */
1073 for (; p
; p
= p
->next
)
1074 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1075 || !p
->sym
->attr
.if_source
)
1077 if (p
->sym
->attr
.external
)
1078 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1079 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1081 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1082 "subroutine", p
->sym
->name
, interface_name
,
1083 &p
->sym
->declared_at
);
1088 /* Remove duplicate interfaces in this interface list. */
1089 for (; p
; p
= p
->next
)
1093 for (q
= p
->next
; q
;)
1095 if (p
->sym
!= q
->sym
)
1102 /* Duplicate interface. */
1103 qlast
->next
= q
->next
;
1114 /* Check lists of interfaces to make sure that no two interfaces are
1115 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1118 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1119 int generic_flag
, const char *interface_name
,
1123 for (; p
; p
= p
->next
)
1124 for (q
= q0
; q
; q
= q
->next
)
1126 if (p
->sym
== q
->sym
)
1127 continue; /* Duplicates OK here. */
1129 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1132 if (gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
, generic_flag
,
1136 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1137 p
->sym
->name
, q
->sym
->name
, interface_name
,
1139 else 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
,
1144 gfc_warning ("Although not referenced, '%s' has ambiguous "
1145 "interfaces at %L", interface_name
, &p
->where
);
1153 /* Check the generic and operator interfaces of symbols to make sure
1154 that none of the interfaces conflict. The check has to be done
1155 after all of the symbols are actually loaded. */
1158 check_sym_interfaces (gfc_symbol
*sym
)
1160 char interface_name
[100];
1163 if (sym
->ns
!= gfc_current_ns
)
1166 if (sym
->generic
!= NULL
)
1168 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1169 if (check_interface0 (sym
->generic
, interface_name
))
1172 for (p
= sym
->generic
; p
; p
= p
->next
)
1174 if (p
->sym
->attr
.mod_proc
1175 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1176 || p
->sym
->attr
.procedure
))
1178 gfc_error ("'%s' at %L is not a module procedure",
1179 p
->sym
->name
, &p
->where
);
1184 /* Originally, this test was applied to host interfaces too;
1185 this is incorrect since host associated symbols, from any
1186 source, cannot be ambiguous with local symbols. */
1187 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1188 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1194 check_uop_interfaces (gfc_user_op
*uop
)
1196 char interface_name
[100];
1200 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1201 if (check_interface0 (uop
->op
, interface_name
))
1204 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1206 uop2
= gfc_find_uop (uop
->name
, ns
);
1210 check_interface1 (uop
->op
, uop2
->op
, 0,
1211 interface_name
, true);
1216 /* For the namespace, check generic, user operator and intrinsic
1217 operator interfaces for consistency and to remove duplicate
1218 interfaces. We traverse the whole namespace, counting on the fact
1219 that most symbols will not have generic or operator interfaces. */
1222 gfc_check_interfaces (gfc_namespace
*ns
)
1224 gfc_namespace
*old_ns
, *ns2
;
1225 char interface_name
[100];
1228 old_ns
= gfc_current_ns
;
1229 gfc_current_ns
= ns
;
1231 gfc_traverse_ns (ns
, check_sym_interfaces
);
1233 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1235 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1237 if (i
== INTRINSIC_USER
)
1240 if (i
== INTRINSIC_ASSIGN
)
1241 strcpy (interface_name
, "intrinsic assignment operator");
1243 sprintf (interface_name
, "intrinsic '%s' operator",
1244 gfc_op2string ((gfc_intrinsic_op
) i
));
1246 if (check_interface0 (ns
->op
[i
], interface_name
))
1250 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1253 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1255 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1256 interface_name
, true))
1262 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ_OS
],
1263 0, interface_name
, true)) goto done
;
1266 case INTRINSIC_EQ_OS
:
1267 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ
],
1268 0, interface_name
, true)) goto done
;
1272 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE_OS
],
1273 0, interface_name
, true)) goto done
;
1276 case INTRINSIC_NE_OS
:
1277 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE
],
1278 0, interface_name
, true)) goto done
;
1282 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT_OS
],
1283 0, interface_name
, true)) goto done
;
1286 case INTRINSIC_GT_OS
:
1287 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT
],
1288 0, interface_name
, true)) goto done
;
1292 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE_OS
],
1293 0, interface_name
, true)) goto done
;
1296 case INTRINSIC_GE_OS
:
1297 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE
],
1298 0, interface_name
, true)) goto done
;
1302 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT_OS
],
1303 0, interface_name
, true)) goto done
;
1306 case INTRINSIC_LT_OS
:
1307 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT
],
1308 0, interface_name
, true)) goto done
;
1312 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE_OS
],
1313 0, interface_name
, true)) goto done
;
1316 case INTRINSIC_LE_OS
:
1317 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE
],
1318 0, interface_name
, true)) goto done
;
1328 gfc_current_ns
= old_ns
;
1333 symbol_rank (gfc_symbol
*sym
)
1335 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1339 /* Given a symbol of a formal argument list and an expression, if the
1340 formal argument is allocatable, check that the actual argument is
1341 allocatable. Returns nonzero if compatible, zero if not compatible. */
1344 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1346 symbol_attribute attr
;
1348 if (formal
->attr
.allocatable
)
1350 attr
= gfc_expr_attr (actual
);
1351 if (!attr
.allocatable
)
1359 /* Given a symbol of a formal argument list and an expression, if the
1360 formal argument is a pointer, see if the actual argument is a
1361 pointer. Returns nonzero if compatible, zero if not compatible. */
1364 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1366 symbol_attribute attr
;
1368 if (formal
->attr
.pointer
)
1370 attr
= gfc_expr_attr (actual
);
1379 /* Emit clear error messages for rank mismatch. */
1382 argument_rank_mismatch (const char *name
, locus
*where
,
1383 int rank1
, int rank2
)
1387 gfc_error ("Rank mismatch in argument '%s' at %L "
1388 "(scalar and rank-%d)", name
, where
, rank2
);
1390 else if (rank2
== 0)
1392 gfc_error ("Rank mismatch in argument '%s' at %L "
1393 "(rank-%d and scalar)", name
, where
, rank1
);
1397 gfc_error ("Rank mismatch in argument '%s' at %L "
1398 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1403 /* Given a symbol of a formal argument list and an expression, see if
1404 the two are compatible as arguments. Returns nonzero if
1405 compatible, zero if not compatible. */
1408 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1409 int ranks_must_agree
, int is_elemental
, locus
*where
)
1414 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1415 procs c_f_pointer or c_f_procpointer, and we need to accept most
1416 pointers the user could give us. This should allow that. */
1417 if (formal
->ts
.type
== BT_VOID
)
1420 if (formal
->ts
.type
== BT_DERIVED
1421 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1422 && actual
->ts
.type
== BT_DERIVED
1423 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1426 if (actual
->ts
.type
== BT_PROCEDURE
)
1429 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1431 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1434 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1438 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1442 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1443 formal
->name
, &actual
->where
, err
);
1447 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1449 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1450 &act_sym
->declared_at
);
1451 if (act_sym
->ts
.type
== BT_UNKNOWN
1452 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1455 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1456 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1457 &act_sym
->declared_at
);
1463 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1464 && !gfc_is_simply_contiguous (actual
, true))
1467 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1468 "must be simply contigous", formal
->name
, &actual
->where
);
1472 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1473 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1476 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1477 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1478 gfc_typename (&formal
->ts
));
1482 if (formal
->attr
.codimension
)
1484 gfc_ref
*last
= NULL
;
1486 if (actual
->expr_type
!= EXPR_VARIABLE
1487 || (actual
->ref
== NULL
1488 && !actual
->symtree
->n
.sym
->attr
.codimension
))
1491 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1492 formal
->name
, &actual
->where
);
1496 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1498 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
!= 0)
1501 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1502 "and not coindexed", formal
->name
, &ref
->u
.ar
.where
);
1505 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
->corank
1506 && ref
->u
.ar
.type
!= AR_FULL
&& ref
->u
.ar
.dimen
!= 0)
1509 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1510 "and thus shall not have an array designator",
1511 formal
->name
, &ref
->u
.ar
.where
);
1514 if (ref
->type
== REF_COMPONENT
)
1518 if (last
&& !last
->u
.c
.component
->attr
.codimension
)
1521 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1522 formal
->name
, &actual
->where
);
1526 /* F2008, 12.5.2.6. */
1527 if (formal
->attr
.allocatable
&&
1528 ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1530 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
)))
1533 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1534 formal
->name
, &actual
->where
, formal
->as
->corank
,
1535 last
? last
->u
.c
.component
->as
->corank
1536 : actual
->symtree
->n
.sym
->as
->corank
);
1540 /* F2008, 12.5.2.8. */
1541 if (formal
->attr
.dimension
1542 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1543 && !gfc_is_simply_contiguous (actual
, true))
1546 gfc_error ("Actual argument to '%s' at %L must be simply "
1547 "contiguous", formal
->name
, &actual
->where
);
1552 /* F2008, C1239/C1240. */
1553 if (actual
->expr_type
== EXPR_VARIABLE
1554 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1555 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1556 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1557 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1558 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1559 || formal
->attr
.contiguous
))
1562 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1563 "array without CONTIGUOUS attribute - as actual argument at"
1564 " %L is not simply contiguous and both are ASYNCHRONOUS "
1565 "or VOLATILE", formal
->name
, &actual
->where
);
1569 if (symbol_rank (formal
) == actual
->rank
)
1572 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1573 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1574 || formal
->as
->type
== AS_DEFERRED
)
1575 && actual
->expr_type
!= EXPR_NULL
;
1577 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1578 if (rank_check
|| ranks_must_agree
1579 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
1580 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1581 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
)
1582 || (actual
->rank
== 0 && formal
->attr
.dimension
1583 && gfc_is_coindexed (actual
)))
1586 argument_rank_mismatch (formal
->name
, &actual
->where
,
1587 symbol_rank (formal
), actual
->rank
);
1590 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1593 /* At this point, we are considering a scalar passed to an array. This
1594 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1595 - if the actual argument is (a substring of) an element of a
1596 non-assumed-shape/non-pointer array;
1597 - (F2003) if the actual argument is of type character. */
1599 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1600 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1601 && ref
->u
.ar
.dimen
> 0)
1604 /* Not an array element. */
1605 if (formal
->ts
.type
== BT_CHARACTER
1607 || (actual
->expr_type
== EXPR_VARIABLE
1608 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1609 || actual
->symtree
->n
.sym
->attr
.pointer
))))
1611 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1613 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1614 "array dummy argument '%s' at %L",
1615 formal
->name
, &actual
->where
);
1618 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1623 else if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
1626 argument_rank_mismatch (formal
->name
, &actual
->where
,
1627 symbol_rank (formal
), actual
->rank
);
1631 if (actual
->expr_type
== EXPR_VARIABLE
1632 && actual
->symtree
->n
.sym
->as
1633 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1634 || actual
->symtree
->n
.sym
->attr
.pointer
))
1637 gfc_error ("Element of assumed-shaped array passed to dummy "
1638 "argument '%s' at %L", formal
->name
, &actual
->where
);
1646 /* Given a symbol of a formal argument list and an expression, see if
1647 the two are compatible as arguments. Returns nonzero if
1648 compatible, zero if not compatible. */
1651 compare_parameter_protected (gfc_symbol
*formal
, gfc_expr
*actual
)
1653 if (actual
->expr_type
!= EXPR_VARIABLE
)
1656 if (!actual
->symtree
->n
.sym
->attr
.is_protected
)
1659 if (!actual
->symtree
->n
.sym
->attr
.use_assoc
)
1662 if (formal
->attr
.intent
== INTENT_IN
1663 || formal
->attr
.intent
== INTENT_UNKNOWN
)
1666 if (!actual
->symtree
->n
.sym
->attr
.pointer
)
1669 if (actual
->symtree
->n
.sym
->attr
.pointer
&& formal
->attr
.pointer
)
1676 /* Returns the storage size of a symbol (formal argument) or
1677 zero if it cannot be determined. */
1679 static unsigned long
1680 get_sym_storage_size (gfc_symbol
*sym
)
1683 unsigned long strlen
, elements
;
1685 if (sym
->ts
.type
== BT_CHARACTER
)
1687 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1688 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1689 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
1696 if (symbol_rank (sym
) == 0)
1700 if (sym
->as
->type
!= AS_EXPLICIT
)
1702 for (i
= 0; i
< sym
->as
->rank
; i
++)
1704 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1705 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1708 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
1709 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1712 return strlen
*elements
;
1716 /* Returns the storage size of an expression (actual argument) or
1717 zero if it cannot be determined. For an array element, it returns
1718 the remaining size as the element sequence consists of all storage
1719 units of the actual argument up to the end of the array. */
1721 static unsigned long
1722 get_expr_storage_size (gfc_expr
*e
)
1725 long int strlen
, elements
;
1726 long int substrlen
= 0;
1727 bool is_str_storage
= false;
1733 if (e
->ts
.type
== BT_CHARACTER
)
1735 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1736 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1737 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
1738 else if (e
->expr_type
== EXPR_CONSTANT
1739 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
1740 strlen
= e
->value
.character
.length
;
1745 strlen
= 1; /* Length per element. */
1747 if (e
->rank
== 0 && !e
->ref
)
1755 for (i
= 0; i
< e
->rank
; i
++)
1756 elements
*= mpz_get_si (e
->shape
[i
]);
1757 return elements
*strlen
;
1760 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1762 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1763 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1767 /* The string length is the substring length.
1768 Set now to full string length. */
1769 if (ref
->u
.ss
.length
== NULL
1770 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1773 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1775 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1779 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1780 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1781 && ref
->u
.ar
.as
->upper
)
1782 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1784 long int start
, end
, stride
;
1787 if (ref
->u
.ar
.stride
[i
])
1789 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1790 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1795 if (ref
->u
.ar
.start
[i
])
1797 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1798 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1802 else if (ref
->u
.ar
.as
->lower
[i
]
1803 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1804 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1808 if (ref
->u
.ar
.end
[i
])
1810 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1811 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1815 else if (ref
->u
.ar
.as
->upper
[i
]
1816 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1817 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1821 elements
*= (end
- start
)/stride
+ 1L;
1823 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1824 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1825 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1827 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1828 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1829 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1830 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1831 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1836 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1837 && e
->expr_type
== EXPR_VARIABLE
)
1839 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1840 || e
->symtree
->n
.sym
->attr
.pointer
)
1846 /* Determine the number of remaining elements in the element
1847 sequence for array element designators. */
1848 is_str_storage
= true;
1849 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1851 if (ref
->u
.ar
.start
[i
] == NULL
1852 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1853 || ref
->u
.ar
.as
->upper
[i
] == NULL
1854 || ref
->u
.ar
.as
->lower
[i
] == NULL
1855 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1856 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1861 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1862 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1864 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1865 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1873 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1876 return elements
*strlen
;
1880 /* Given an expression, check whether it is an array section
1881 which has a vector subscript. If it has, one is returned,
1885 gfc_has_vector_subscript (gfc_expr
*e
)
1890 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1893 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1894 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1895 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1896 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1903 /* Given formal and actual argument lists, see if they are compatible.
1904 If they are compatible, the actual argument list is sorted to
1905 correspond with the formal list, and elements for missing optional
1906 arguments are inserted. If WHERE pointer is nonnull, then we issue
1907 errors when things don't match instead of just returning the status
1911 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1912 int ranks_must_agree
, int is_elemental
, locus
*where
)
1914 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
1915 gfc_formal_arglist
*f
;
1917 unsigned long actual_size
, formal_size
;
1921 if (actual
== NULL
&& formal
== NULL
)
1925 for (f
= formal
; f
; f
= f
->next
)
1928 new_arg
= (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1930 for (i
= 0; i
< n
; i
++)
1937 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1939 /* Look for keywords but ignore g77 extensions like %VAL. */
1940 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1943 for (f
= formal
; f
; f
= f
->next
, i
++)
1947 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1954 gfc_error ("Keyword argument '%s' at %L is not in "
1955 "the procedure", a
->name
, &a
->expr
->where
);
1959 if (new_arg
[i
] != NULL
)
1962 gfc_error ("Keyword argument '%s' at %L is already associated "
1963 "with another actual argument", a
->name
,
1972 gfc_error ("More actual than formal arguments in procedure "
1973 "call at %L", where
);
1978 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1984 gfc_error ("Missing alternate return spec in subroutine call "
1989 if (a
->expr
== NULL
)
1992 gfc_error ("Unexpected alternate return spec in subroutine "
1993 "call at %L", where
);
1997 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
1998 is_elemental
, where
))
2001 /* Special case for character arguments. For allocatable, pointer
2002 and assumed-shape dummies, the string length needs to match
2004 if (a
->expr
->ts
.type
== BT_CHARACTER
2005 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2006 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2007 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2008 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2009 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2010 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2011 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2012 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2014 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2015 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2016 "argument and pointer or allocatable dummy argument "
2018 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2019 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2020 f
->sym
->name
, &a
->expr
->where
);
2022 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2023 "argument and assumed-shape dummy argument '%s' "
2025 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2026 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2027 f
->sym
->name
, &a
->expr
->where
);
2031 actual_size
= get_expr_storage_size (a
->expr
);
2032 formal_size
= get_sym_storage_size (f
->sym
);
2033 if (actual_size
!= 0
2034 && actual_size
< formal_size
2035 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
2037 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2038 gfc_warning ("Character length of actual argument shorter "
2039 "than of dummy argument '%s' (%lu/%lu) at %L",
2040 f
->sym
->name
, actual_size
, formal_size
,
2043 gfc_warning ("Actual argument contains too few "
2044 "elements for dummy argument '%s' (%lu/%lu) at %L",
2045 f
->sym
->name
, actual_size
, formal_size
,
2050 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2051 is provided for a procedure pointer formal argument. */
2052 if (f
->sym
->attr
.proc_pointer
2053 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2054 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2055 || (a
->expr
->expr_type
== EXPR_FUNCTION
2056 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2057 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
2060 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2061 f
->sym
->name
, &a
->expr
->where
);
2065 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2066 provided for a procedure formal argument. */
2067 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
2068 && a
->expr
->expr_type
== EXPR_VARIABLE
2069 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2072 gfc_error ("Expected a procedure for argument '%s' at %L",
2073 f
->sym
->name
, &a
->expr
->where
);
2077 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
2078 && a
->expr
->ts
.type
== BT_PROCEDURE
2079 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
2082 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2083 f
->sym
->name
, &a
->expr
->where
);
2087 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2088 && a
->expr
->expr_type
== EXPR_VARIABLE
2089 && a
->expr
->symtree
->n
.sym
->as
2090 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2091 && (a
->expr
->ref
== NULL
2092 || (a
->expr
->ref
->type
== REF_ARRAY
2093 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2096 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2097 " array at %L", f
->sym
->name
, where
);
2101 if (a
->expr
->expr_type
!= EXPR_NULL
2102 && compare_pointer (f
->sym
, a
->expr
) == 0)
2105 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2106 f
->sym
->name
, &a
->expr
->where
);
2110 /* Fortran 2008, C1242. */
2111 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2114 gfc_error ("Coindexed actual argument at %L to pointer "
2116 &a
->expr
->where
, f
->sym
->name
);
2120 /* Fortran 2008, 12.5.2.5 (no constraint). */
2121 if (a
->expr
->expr_type
== EXPR_VARIABLE
2122 && f
->sym
->attr
.intent
!= INTENT_IN
2123 && f
->sym
->attr
.allocatable
2124 && gfc_is_coindexed (a
->expr
))
2127 gfc_error ("Coindexed actual argument at %L to allocatable "
2128 "dummy '%s' requires INTENT(IN)",
2129 &a
->expr
->where
, f
->sym
->name
);
2133 /* Fortran 2008, C1237. */
2134 if (a
->expr
->expr_type
== EXPR_VARIABLE
2135 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2136 && gfc_is_coindexed (a
->expr
)
2137 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2138 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2141 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2142 "at %L requires that dummy %s' has neither "
2143 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2148 /* Fortran 2008, 12.5.2.4 (no constraint). */
2149 if (a
->expr
->expr_type
== EXPR_VARIABLE
2150 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2151 && gfc_is_coindexed (a
->expr
)
2152 && gfc_has_ultimate_allocatable (a
->expr
))
2155 gfc_error ("Coindexed actual argument at %L with allocatable "
2156 "ultimate component to dummy '%s' requires either VALUE "
2157 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2161 if (a
->expr
->expr_type
!= EXPR_NULL
2162 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2165 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2166 f
->sym
->name
, &a
->expr
->where
);
2170 /* Check intent = OUT/INOUT for definable actual argument. */
2171 if ((a
->expr
->expr_type
!= EXPR_VARIABLE
2172 || (a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
2173 && a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
))
2174 && (f
->sym
->attr
.intent
== INTENT_OUT
2175 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2178 gfc_error ("Actual argument at %L must be definable as "
2179 "the dummy argument '%s' is INTENT = OUT/INOUT",
2180 &a
->expr
->where
, f
->sym
->name
);
2184 if (!compare_parameter_protected(f
->sym
, a
->expr
))
2187 gfc_error ("Actual argument at %L is use-associated with "
2188 "PROTECTED attribute and dummy argument '%s' is "
2189 "INTENT = OUT/INOUT",
2190 &a
->expr
->where
,f
->sym
->name
);
2194 if ((f
->sym
->attr
.intent
== INTENT_OUT
2195 || f
->sym
->attr
.intent
== INTENT_INOUT
2196 || f
->sym
->attr
.volatile_
2197 || f
->sym
->attr
.asynchronous
)
2198 && gfc_has_vector_subscript (a
->expr
))
2201 gfc_error ("Array-section actual argument with vector "
2202 "subscripts at %L is incompatible with INTENT(OUT), "
2203 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2204 "of the dummy argument '%s'",
2205 &a
->expr
->where
, f
->sym
->name
);
2209 /* C1232 (R1221) For an actual argument which is an array section or
2210 an assumed-shape array, the dummy argument shall be an assumed-
2211 shape array, if the dummy argument has the VOLATILE attribute. */
2213 if (f
->sym
->attr
.volatile_
2214 && a
->expr
->symtree
->n
.sym
->as
2215 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2216 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2219 gfc_error ("Assumed-shape actual argument at %L is "
2220 "incompatible with the non-assumed-shape "
2221 "dummy argument '%s' due to VOLATILE attribute",
2222 &a
->expr
->where
,f
->sym
->name
);
2226 if (f
->sym
->attr
.volatile_
2227 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2228 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2231 gfc_error ("Array-section actual argument at %L is "
2232 "incompatible with the non-assumed-shape "
2233 "dummy argument '%s' due to VOLATILE attribute",
2234 &a
->expr
->where
,f
->sym
->name
);
2238 /* C1233 (R1221) For an actual argument which is a pointer array, the
2239 dummy argument shall be an assumed-shape or pointer array, if the
2240 dummy argument has the VOLATILE attribute. */
2242 if (f
->sym
->attr
.volatile_
2243 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2244 && a
->expr
->symtree
->n
.sym
->as
2246 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2247 || f
->sym
->attr
.pointer
)))
2250 gfc_error ("Pointer-array actual argument at %L requires "
2251 "an assumed-shape or pointer-array dummy "
2252 "argument '%s' due to VOLATILE attribute",
2253 &a
->expr
->where
,f
->sym
->name
);
2264 /* Make sure missing actual arguments are optional. */
2266 for (f
= formal
; f
; f
= f
->next
, i
++)
2268 if (new_arg
[i
] != NULL
)
2273 gfc_error ("Missing alternate return spec in subroutine call "
2277 if (!f
->sym
->attr
.optional
)
2280 gfc_error ("Missing actual argument for argument '%s' at %L",
2281 f
->sym
->name
, where
);
2286 /* The argument lists are compatible. We now relink a new actual
2287 argument list with null arguments in the right places. The head
2288 of the list remains the head. */
2289 for (i
= 0; i
< n
; i
++)
2290 if (new_arg
[i
] == NULL
)
2291 new_arg
[i
] = gfc_get_actual_arglist ();
2296 *new_arg
[0] = *actual
;
2300 new_arg
[0] = new_arg
[na
];
2304 for (i
= 0; i
< n
- 1; i
++)
2305 new_arg
[i
]->next
= new_arg
[i
+ 1];
2307 new_arg
[i
]->next
= NULL
;
2309 if (*ap
== NULL
&& n
> 0)
2312 /* Note the types of omitted optional arguments. */
2313 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2314 if (a
->expr
== NULL
&& a
->label
== NULL
)
2315 a
->missing_arg_type
= f
->sym
->ts
.type
;
2323 gfc_formal_arglist
*f
;
2324 gfc_actual_arglist
*a
;
2328 /* qsort comparison function for argument pairs, with the following
2330 - p->a->expr == NULL
2331 - p->a->expr->expr_type != EXPR_VARIABLE
2332 - growing p->a->expr->symbol. */
2335 pair_cmp (const void *p1
, const void *p2
)
2337 const gfc_actual_arglist
*a1
, *a2
;
2339 /* *p1 and *p2 are elements of the to-be-sorted array. */
2340 a1
= ((const argpair
*) p1
)->a
;
2341 a2
= ((const argpair
*) p2
)->a
;
2350 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2352 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2356 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2358 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2362 /* Given two expressions from some actual arguments, test whether they
2363 refer to the same expression. The analysis is conservative.
2364 Returning FAILURE will produce no warning. */
2367 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2369 const gfc_ref
*r1
, *r2
;
2372 || e1
->expr_type
!= EXPR_VARIABLE
2373 || e2
->expr_type
!= EXPR_VARIABLE
2374 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2377 /* TODO: improve comparison, see expr.c:show_ref(). */
2378 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2380 if (r1
->type
!= r2
->type
)
2385 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2387 /* TODO: At the moment, consider only full arrays;
2388 we could do better. */
2389 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2394 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2402 gfc_internal_error ("compare_actual_expr(): Bad component code");
2411 /* Given formal and actual argument lists that correspond to one
2412 another, check that identical actual arguments aren't not
2413 associated with some incompatible INTENTs. */
2416 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2418 sym_intent f1_intent
, f2_intent
;
2419 gfc_formal_arglist
*f1
;
2420 gfc_actual_arglist
*a1
;
2423 gfc_try t
= SUCCESS
;
2426 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2428 if (f1
== NULL
&& a1
== NULL
)
2430 if (f1
== NULL
|| a1
== NULL
)
2431 gfc_internal_error ("check_some_aliasing(): List mismatch");
2436 p
= (argpair
*) alloca (n
* sizeof (argpair
));
2438 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2444 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2446 for (i
= 0; i
< n
; i
++)
2449 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2450 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2452 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2453 for (j
= i
+ 1; j
< n
; j
++)
2455 /* Expected order after the sort. */
2456 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2457 gfc_internal_error ("check_some_aliasing(): corrupted data");
2459 /* Are the expression the same? */
2460 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2462 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2463 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2464 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2466 gfc_warning ("Same actual argument associated with INTENT(%s) "
2467 "argument '%s' and INTENT(%s) argument '%s' at %L",
2468 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2469 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2470 &p
[i
].a
->expr
->where
);
2480 /* Given a symbol of a formal argument list and an expression,
2481 return nonzero if their intents are compatible, zero otherwise. */
2484 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2486 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2489 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2492 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2499 /* Given formal and actual argument lists that correspond to one
2500 another, check that they are compatible in the sense that intents
2501 are not mismatched. */
2504 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2506 sym_intent f_intent
;
2508 for (;; f
= f
->next
, a
= a
->next
)
2510 if (f
== NULL
&& a
== NULL
)
2512 if (f
== NULL
|| a
== NULL
)
2513 gfc_internal_error ("check_intents(): List mismatch");
2515 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2518 f_intent
= f
->sym
->attr
.intent
;
2520 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2522 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2523 "specifies INTENT(%s)", &a
->expr
->where
,
2524 gfc_intent_string (f_intent
));
2528 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2530 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2532 gfc_error ("Procedure argument at %L is local to a PURE "
2533 "procedure and is passed to an INTENT(%s) argument",
2534 &a
->expr
->where
, gfc_intent_string (f_intent
));
2538 if (f
->sym
->attr
.pointer
)
2540 gfc_error ("Procedure argument at %L is local to a PURE "
2541 "procedure and has the POINTER attribute",
2547 /* Fortran 2008, C1283. */
2548 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
2550 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2552 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2553 "is passed to an INTENT(%s) argument",
2554 &a
->expr
->where
, gfc_intent_string (f_intent
));
2558 if (f
->sym
->attr
.pointer
)
2560 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2561 "is passed to a POINTER dummy argument",
2567 /* F2008, Section 12.5.2.4. */
2568 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
2569 && gfc_is_coindexed (a
->expr
))
2571 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2572 "polymorphic dummy argument '%s'",
2573 &a
->expr
->where
, f
->sym
->name
);
2582 /* Check how a procedure is used against its interface. If all goes
2583 well, the actual argument list will also end up being properly
2587 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2590 /* Warn about calls with an implicit interface. Special case
2591 for calling a ISO_C_BINDING becase c_loc and c_funloc
2592 are pseudo-unknown. Additionally, warn about procedures not
2593 explicitly declared at all if requested. */
2594 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2596 if (gfc_option
.warn_implicit_interface
)
2597 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2599 else if (gfc_option
.warn_implicit_procedure
2600 && sym
->attr
.proc
== PROC_UNKNOWN
)
2601 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2605 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2607 gfc_actual_arglist
*a
;
2608 for (a
= *ap
; a
; a
= a
->next
)
2610 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2611 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2613 gfc_error("Keyword argument requires explicit interface "
2614 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2622 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2625 check_intents (sym
->formal
, *ap
);
2626 if (gfc_option
.warn_aliasing
)
2627 check_some_aliasing (sym
->formal
, *ap
);
2631 /* Check how a procedure pointer component is used against its interface.
2632 If all goes well, the actual argument list will also end up being properly
2633 sorted. Completely analogous to gfc_procedure_use. */
2636 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2639 /* Warn about calls with an implicit interface. Special case
2640 for calling a ISO_C_BINDING becase c_loc and c_funloc
2641 are pseudo-unknown. */
2642 if (gfc_option
.warn_implicit_interface
2643 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2644 && !comp
->attr
.is_iso_c
)
2645 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2646 "interface at %L", comp
->name
, where
);
2648 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2650 gfc_actual_arglist
*a
;
2651 for (a
= *ap
; a
; a
= a
->next
)
2653 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2654 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2656 gfc_error("Keyword argument requires explicit interface "
2657 "for procedure pointer component '%s' at %L",
2658 comp
->name
, &a
->expr
->where
);
2666 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2669 check_intents (comp
->formal
, *ap
);
2670 if (gfc_option
.warn_aliasing
)
2671 check_some_aliasing (comp
->formal
, *ap
);
2675 /* Try if an actual argument list matches the formal list of a symbol,
2676 respecting the symbol's attributes like ELEMENTAL. This is used for
2677 GENERIC resolution. */
2680 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2684 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2686 r
= !sym
->attr
.elemental
;
2687 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2689 check_intents (sym
->formal
, *args
);
2690 if (gfc_option
.warn_aliasing
)
2691 check_some_aliasing (sym
->formal
, *args
);
2699 /* Given an interface pointer and an actual argument list, search for
2700 a formal argument list that matches the actual. If found, returns
2701 a pointer to the symbol of the correct interface. Returns NULL if
2705 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2706 gfc_actual_arglist
**ap
)
2708 gfc_symbol
*elem_sym
= NULL
;
2709 for (; intr
; intr
= intr
->next
)
2711 if (sub_flag
&& intr
->sym
->attr
.function
)
2713 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2716 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
2718 /* Satisfy 12.4.4.1 such that an elemental match has lower
2719 weight than a non-elemental match. */
2720 if (intr
->sym
->attr
.elemental
)
2722 elem_sym
= intr
->sym
;
2729 return elem_sym
? elem_sym
: NULL
;
2733 /* Do a brute force recursive search for a symbol. */
2735 static gfc_symtree
*
2736 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2740 if (root
->n
.sym
== sym
)
2745 st
= find_symtree0 (root
->left
, sym
);
2746 if (root
->right
&& ! st
)
2747 st
= find_symtree0 (root
->right
, sym
);
2752 /* Find a symtree for a symbol. */
2755 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
2760 /* First try to find it by name. */
2761 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2762 if (st
&& st
->n
.sym
== sym
)
2765 /* If it's been renamed, resort to a brute-force search. */
2766 /* TODO: avoid having to do this search. If the symbol doesn't exist
2767 in the symtree for the current namespace, it should probably be added. */
2768 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2770 st
= find_symtree0 (ns
->sym_root
, sym
);
2774 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2779 /* See if the arglist to an operator-call contains a derived-type argument
2780 with a matching type-bound operator. If so, return the matching specific
2781 procedure defined as operator-target as well as the base-object to use
2782 (which is the found derived-type argument with operator). */
2784 static gfc_typebound_proc
*
2785 matching_typebound_op (gfc_expr
** tb_base
,
2786 gfc_actual_arglist
* args
,
2787 gfc_intrinsic_op op
, const char* uop
)
2789 gfc_actual_arglist
* base
;
2791 for (base
= args
; base
; base
= base
->next
)
2792 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
2794 gfc_typebound_proc
* tb
;
2795 gfc_symbol
* derived
;
2798 if (base
->expr
->ts
.type
== BT_CLASS
)
2799 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
2801 derived
= base
->expr
->ts
.u
.derived
;
2803 if (op
== INTRINSIC_USER
)
2805 gfc_symtree
* tb_uop
;
2808 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
2817 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
2820 /* This means we hit a PRIVATE operator which is use-associated and
2821 should thus not be seen. */
2822 if (result
== FAILURE
)
2825 /* Look through the super-type hierarchy for a matching specific
2827 for (; tb
; tb
= tb
->overridden
)
2831 gcc_assert (tb
->is_generic
);
2832 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
2835 gfc_actual_arglist
* argcopy
;
2838 gcc_assert (g
->specific
);
2839 if (g
->specific
->error
)
2842 target
= g
->specific
->u
.specific
->n
.sym
;
2844 /* Check if this arglist matches the formal. */
2845 argcopy
= gfc_copy_actual_arglist (args
);
2846 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
2847 gfc_free_actual_arglist (argcopy
);
2849 /* Return if we found a match. */
2852 *tb_base
= base
->expr
;
2863 /* For the 'actual arglist' of an operator call and a specific typebound
2864 procedure that has been found the target of a type-bound operator, build the
2865 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2866 type-bound procedures rather than resolving type-bound operators 'directly'
2867 so that we can reuse the existing logic. */
2870 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
2871 gfc_expr
* base
, gfc_typebound_proc
* target
)
2873 e
->expr_type
= EXPR_COMPCALL
;
2874 e
->value
.compcall
.tbp
= target
;
2875 e
->value
.compcall
.name
= "operator"; /* Should not matter. */
2876 e
->value
.compcall
.actual
= actual
;
2877 e
->value
.compcall
.base_object
= base
;
2878 e
->value
.compcall
.ignore_pass
= 1;
2879 e
->value
.compcall
.assign
= 0;
2883 /* This subroutine is called when an expression is being resolved.
2884 The expression node in question is either a user defined operator
2885 or an intrinsic operator with arguments that aren't compatible
2886 with the operator. This subroutine builds an actual argument list
2887 corresponding to the operands, then searches for a compatible
2888 interface. If one is found, the expression node is replaced with
2889 the appropriate function call.
2890 real_error is an additional output argument that specifies if FAILURE
2891 is because of some real error and not because no match was found. */
2894 gfc_extend_expr (gfc_expr
*e
, bool *real_error
)
2896 gfc_actual_arglist
*actual
;
2904 actual
= gfc_get_actual_arglist ();
2905 actual
->expr
= e
->value
.op
.op1
;
2907 *real_error
= false;
2909 if (e
->value
.op
.op2
!= NULL
)
2911 actual
->next
= gfc_get_actual_arglist ();
2912 actual
->next
->expr
= e
->value
.op
.op2
;
2915 i
= fold_unary_intrinsic (e
->value
.op
.op
);
2917 if (i
== INTRINSIC_USER
)
2919 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2921 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2925 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
2932 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2934 /* Due to the distinction between '==' and '.eq.' and friends, one has
2935 to check if either is defined. */
2938 #define CHECK_OS_COMPARISON(comp) \
2939 case INTRINSIC_##comp: \
2940 case INTRINSIC_##comp##_OS: \
2941 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2943 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2945 CHECK_OS_COMPARISON(EQ
)
2946 CHECK_OS_COMPARISON(NE
)
2947 CHECK_OS_COMPARISON(GT
)
2948 CHECK_OS_COMPARISON(GE
)
2949 CHECK_OS_COMPARISON(LT
)
2950 CHECK_OS_COMPARISON(LE
)
2951 #undef CHECK_OS_COMPARISON
2954 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
2962 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2963 found rather than just taking the first one and not checking further. */
2967 gfc_typebound_proc
* tbo
;
2970 /* See if we find a matching type-bound operator. */
2971 if (i
== INTRINSIC_USER
)
2972 tbo
= matching_typebound_op (&tb_base
, actual
,
2973 i
, e
->value
.op
.uop
->name
);
2977 #define CHECK_OS_COMPARISON(comp) \
2978 case INTRINSIC_##comp: \
2979 case INTRINSIC_##comp##_OS: \
2980 tbo = matching_typebound_op (&tb_base, actual, \
2981 INTRINSIC_##comp, NULL); \
2983 tbo = matching_typebound_op (&tb_base, actual, \
2984 INTRINSIC_##comp##_OS, NULL); \
2986 CHECK_OS_COMPARISON(EQ
)
2987 CHECK_OS_COMPARISON(NE
)
2988 CHECK_OS_COMPARISON(GT
)
2989 CHECK_OS_COMPARISON(GE
)
2990 CHECK_OS_COMPARISON(LT
)
2991 CHECK_OS_COMPARISON(LE
)
2992 #undef CHECK_OS_COMPARISON
2995 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
);
2999 /* If there is a matching typebound-operator, replace the expression with
3000 a call to it and succeed. */
3005 gcc_assert (tb_base
);
3006 build_compcall_for_operator (e
, actual
, tb_base
, tbo
);
3008 result
= gfc_resolve_expr (e
);
3009 if (result
== FAILURE
)
3015 /* Don't use gfc_free_actual_arglist(). */
3016 if (actual
->next
!= NULL
)
3017 gfc_free (actual
->next
);
3023 /* Change the expression node to a function call. */
3024 e
->expr_type
= EXPR_FUNCTION
;
3025 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3026 e
->value
.function
.actual
= actual
;
3027 e
->value
.function
.esym
= NULL
;
3028 e
->value
.function
.isym
= NULL
;
3029 e
->value
.function
.name
= NULL
;
3030 e
->user_operator
= 1;
3032 if (gfc_resolve_expr (e
) == FAILURE
)
3042 /* Tries to replace an assignment code node with a subroutine call to
3043 the subroutine associated with the assignment operator. Return
3044 SUCCESS if the node was replaced. On FAILURE, no error is
3048 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3050 gfc_actual_arglist
*actual
;
3051 gfc_expr
*lhs
, *rhs
;
3057 /* Don't allow an intrinsic assignment to be replaced. */
3058 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3059 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3060 && (lhs
->ts
.type
== rhs
->ts
.type
3061 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3064 actual
= gfc_get_actual_arglist ();
3067 actual
->next
= gfc_get_actual_arglist ();
3068 actual
->next
->expr
= rhs
;
3072 for (; ns
; ns
= ns
->parent
)
3074 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3079 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3083 gfc_typebound_proc
* tbo
;
3086 /* See if we find a matching type-bound assignment. */
3087 tbo
= matching_typebound_op (&tb_base
, actual
,
3088 INTRINSIC_ASSIGN
, NULL
);
3090 /* If there is one, replace the expression with a call to it and
3094 gcc_assert (tb_base
);
3095 c
->expr1
= gfc_get_expr ();
3096 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
);
3097 c
->expr1
->value
.compcall
.assign
= 1;
3099 c
->op
= EXEC_COMPCALL
;
3101 /* c is resolved from the caller, so no need to do it here. */
3106 gfc_free (actual
->next
);
3111 /* Replace the assignment with the call. */
3112 c
->op
= EXEC_ASSIGN_CALL
;
3113 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3116 c
->ext
.actual
= actual
;
3122 /* Make sure that the interface just parsed is not already present in
3123 the given interface list. Ambiguity isn't checked yet since module
3124 procedures can be present without interfaces. */
3127 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
3131 for (ip
= base
; ip
; ip
= ip
->next
)
3133 if (ip
->sym
== new_sym
)
3135 gfc_error ("Entity '%s' at %C is already present in the interface",
3145 /* Add a symbol to the current interface. */
3148 gfc_add_interface (gfc_symbol
*new_sym
)
3150 gfc_interface
**head
, *intr
;
3154 switch (current_interface
.type
)
3156 case INTERFACE_NAMELESS
:
3157 case INTERFACE_ABSTRACT
:
3160 case INTERFACE_INTRINSIC_OP
:
3161 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3162 switch (current_interface
.op
)
3165 case INTRINSIC_EQ_OS
:
3166 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
3167 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
3172 case INTRINSIC_NE_OS
:
3173 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
3174 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
3179 case INTRINSIC_GT_OS
:
3180 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
3181 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
3186 case INTRINSIC_GE_OS
:
3187 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
3188 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
3193 case INTRINSIC_LT_OS
:
3194 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
3195 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
3200 case INTRINSIC_LE_OS
:
3201 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
3202 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
3207 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
3211 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3214 case INTERFACE_GENERIC
:
3215 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3217 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3221 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
3225 head
= ¤t_interface
.sym
->generic
;
3228 case INTERFACE_USER_OP
:
3229 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
3233 head
= ¤t_interface
.uop
->op
;
3237 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3240 intr
= gfc_get_interface ();
3241 intr
->sym
= new_sym
;
3242 intr
->where
= gfc_current_locus
;
3252 gfc_current_interface_head (void)
3254 switch (current_interface
.type
)
3256 case INTERFACE_INTRINSIC_OP
:
3257 return current_interface
.ns
->op
[current_interface
.op
];
3260 case INTERFACE_GENERIC
:
3261 return current_interface
.sym
->generic
;
3264 case INTERFACE_USER_OP
:
3265 return current_interface
.uop
->op
;
3275 gfc_set_current_interface_head (gfc_interface
*i
)
3277 switch (current_interface
.type
)
3279 case INTERFACE_INTRINSIC_OP
:
3280 current_interface
.ns
->op
[current_interface
.op
] = i
;
3283 case INTERFACE_GENERIC
:
3284 current_interface
.sym
->generic
= i
;
3287 case INTERFACE_USER_OP
:
3288 current_interface
.uop
->op
= i
;
3297 /* Gets rid of a formal argument list. We do not free symbols.
3298 Symbols are freed when a namespace is freed. */
3301 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3303 gfc_formal_arglist
*q
;