1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
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 (gfc_intrinsic_op
operator)
102 case INTRINSIC_UPLUS
:
103 operator = INTRINSIC_PLUS
;
105 case INTRINSIC_UMINUS
:
106 operator = INTRINSIC_MINUS
;
116 /* Match a generic specification. Depending on which type of
117 interface is found, the 'name' or 'operator' pointers may be set.
118 This subroutine doesn't return MATCH_NO. */
121 gfc_match_generic_spec (interface_type
*type
,
123 gfc_intrinsic_op
*operator)
125 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
129 if (gfc_match (" assignment ( = )") == MATCH_YES
)
131 *type
= INTERFACE_INTRINSIC_OP
;
132 *operator = INTRINSIC_ASSIGN
;
136 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
138 *type
= INTERFACE_INTRINSIC_OP
;
139 *operator = fold_unary (i
);
143 if (gfc_match (" operator ( ") == MATCH_YES
)
145 m
= gfc_match_defined_op_name (buffer
, 1);
151 m
= gfc_match_char (')');
157 strcpy (name
, buffer
);
158 *type
= INTERFACE_USER_OP
;
162 if (gfc_match_name (buffer
) == MATCH_YES
)
164 strcpy (name
, buffer
);
165 *type
= INTERFACE_GENERIC
;
169 *type
= INTERFACE_NAMELESS
;
173 gfc_error ("Syntax error in generic specification at %C");
178 /* Match one of the five forms of an interface statement. */
181 gfc_match_interface (void)
183 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
186 gfc_intrinsic_op
operator;
189 m
= gfc_match_space ();
191 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
194 /* If we're not looking at the end of the statement now, or if this
195 is not a nameless interface but we did not see a space, punt. */
196 if (gfc_match_eos () != MATCH_YES
197 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
199 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
204 current_interface
.type
= type
;
208 case INTERFACE_GENERIC
:
209 if (gfc_get_symbol (name
, NULL
, &sym
))
212 if (!sym
->attr
.generic
213 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
218 gfc_error ("Dummy procedure '%s' at %C cannot have a "
219 "generic interface", sym
->name
);
223 current_interface
.sym
= gfc_new_block
= sym
;
226 case INTERFACE_USER_OP
:
227 current_interface
.uop
= gfc_get_uop (name
);
230 case INTERFACE_INTRINSIC_OP
:
231 current_interface
.op
= operator;
234 case INTERFACE_NAMELESS
:
242 /* Match the different sort of generic-specs that can be present after
243 the END INTERFACE itself. */
246 gfc_match_end_interface (void)
248 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
250 gfc_intrinsic_op
operator;
253 m
= gfc_match_space ();
255 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
258 /* If we're not looking at the end of the statement now, or if this
259 is not a nameless interface but we did not see a space, punt. */
260 if (gfc_match_eos () != MATCH_YES
261 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
263 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
270 switch (current_interface
.type
)
272 case INTERFACE_NAMELESS
:
273 if (type
!= current_interface
.type
)
275 gfc_error ("Expected a nameless interface at %C");
281 case INTERFACE_INTRINSIC_OP
:
282 if (type
!= current_interface
.type
|| operator != current_interface
.op
)
285 if (current_interface
.op
== INTRINSIC_ASSIGN
)
286 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
288 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
289 gfc_op2string (current_interface
.op
));
296 case INTERFACE_USER_OP
:
297 /* Comparing the symbol node names is OK because only use-associated
298 symbols can be renamed. */
299 if (type
!= current_interface
.type
300 || strcmp (current_interface
.uop
->name
, name
) != 0)
302 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
303 current_interface
.uop
->name
);
309 case INTERFACE_GENERIC
:
310 if (type
!= current_interface
.type
311 || strcmp (current_interface
.sym
->name
, name
) != 0)
313 gfc_error ("Expecting 'END INTERFACE %s' at %C",
314 current_interface
.sym
->name
);
325 /* Compare two derived types using the criteria in 4.4.2 of the standard,
326 recursing through gfc_compare_types for the components. */
329 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
331 gfc_component
*dt1
, *dt2
;
333 /* Special case for comparing derived types across namespaces. If the
334 true names and module names are the same and the module name is
335 nonnull, then they are equal. */
336 if (derived1
!= NULL
&& derived2
!= NULL
337 && strcmp (derived1
->name
, derived2
->name
) == 0
338 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
339 && strcmp (derived1
->module
, derived2
->module
) == 0)
342 /* Compare type via the rules of the standard. Both types must have
343 the SEQUENCE attribute to be equal. */
345 if (strcmp (derived1
->name
, derived2
->name
))
348 if (derived1
->component_access
== ACCESS_PRIVATE
349 || derived2
->component_access
== ACCESS_PRIVATE
)
352 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
355 dt1
= derived1
->components
;
356 dt2
= derived2
->components
;
358 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
359 simple test can speed things up. Otherwise, lots of things have to
363 if (strcmp (dt1
->name
, dt2
->name
) != 0)
366 if (dt1
->access
!= dt2
->access
)
369 if (dt1
->pointer
!= dt2
->pointer
)
372 if (dt1
->dimension
!= dt2
->dimension
)
375 if (dt1
->allocatable
!= dt2
->allocatable
)
378 if (dt1
->dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
381 if (gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
387 if (dt1
== NULL
&& dt2
== NULL
)
389 if (dt1
== NULL
|| dt2
== NULL
)
397 /* Compare two typespecs, recursively if necessary. */
400 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
402 /* See if one of the typespecs is a BT_VOID, which is what is being used
403 to allow the funcs like c_f_pointer to accept any pointer type.
404 TODO: Possibly should narrow this to just the one typespec coming in
405 that is for the formal arg, but oh well. */
406 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
409 if (ts1
->type
!= ts2
->type
)
411 if (ts1
->type
!= BT_DERIVED
)
412 return (ts1
->kind
== ts2
->kind
);
414 /* Compare derived types. */
415 if (ts1
->derived
== ts2
->derived
)
418 return gfc_compare_derived_types (ts1
->derived
,ts2
->derived
);
422 /* Given two symbols that are formal arguments, compare their ranks
423 and types. Returns nonzero if they have the same rank and type,
427 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
431 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
432 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
435 return 0; /* Ranks differ. */
437 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
441 static int compare_interfaces (gfc_symbol
*, gfc_symbol
*, int);
443 /* Given two symbols that are formal arguments, compare their types
444 and rank and their formal interfaces if they are both dummy
445 procedures. Returns nonzero if the same, zero if different. */
448 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
450 if (s1
== NULL
|| s2
== NULL
)
451 return s1
== s2
? 1 : 0;
453 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
454 return compare_type_rank (s1
, s2
);
456 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
459 /* At this point, both symbols are procedures. */
460 if ((s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
461 || (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0))
464 if (s1
->attr
.function
!= s2
->attr
.function
465 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
468 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
471 /* Originally, gfortran recursed here to check the interfaces of passed
472 procedures. This is explicitly not required by the standard. */
477 /* Given a formal argument list and a keyword name, search the list
478 for that keyword. Returns the correct symbol node if found, NULL
482 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
484 for (; f
; f
= f
->next
)
485 if (strcmp (f
->sym
->name
, name
) == 0)
492 /******** Interface checking subroutines **********/
495 /* Given an operator interface and the operator, make sure that all
496 interfaces for that operator are legal. */
499 check_operator_interface (gfc_interface
*intr
, gfc_intrinsic_op
operator)
501 gfc_formal_arglist
*formal
;
505 int args
, r1
, r2
, k1
, k2
;
511 t1
= t2
= BT_UNKNOWN
;
512 i1
= i2
= INTENT_UNKNOWN
;
516 for (formal
= intr
->sym
->formal
; formal
; formal
= formal
->next
)
521 gfc_error ("Alternate return cannot appear in operator "
522 "interface at %L", &intr
->where
);
528 i1
= sym
->attr
.intent
;
529 r1
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
535 i2
= sym
->attr
.intent
;
536 r2
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
544 /* Only +, - and .not. can be unary operators.
545 .not. cannot be a binary operator. */
546 if (args
== 0 || args
> 2 || (args
== 1 && operator != INTRINSIC_PLUS
547 && operator != INTRINSIC_MINUS
548 && operator != INTRINSIC_NOT
)
549 || (args
== 2 && operator == INTRINSIC_NOT
))
551 gfc_error ("Operator interface at %L has the wrong number of arguments",
556 /* Check that intrinsics are mapped to functions, except
557 INTRINSIC_ASSIGN which should map to a subroutine. */
558 if (operator == INTRINSIC_ASSIGN
)
560 if (!sym
->attr
.subroutine
)
562 gfc_error ("Assignment operator interface at %L must be "
563 "a SUBROUTINE", &intr
->where
);
568 gfc_error ("Assignment operator interface at %L must have "
569 "two arguments", &intr
->where
);
572 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
573 && sym
->formal
->next
->sym
->ts
.type
!= BT_DERIVED
574 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
575 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
576 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
578 gfc_error ("Assignment operator interface at %L must not redefine "
579 "an INTRINSIC type assignment", &intr
->where
);
585 if (!sym
->attr
.function
)
587 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
593 /* Check intents on operator interfaces. */
594 if (operator == INTRINSIC_ASSIGN
)
596 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
597 gfc_error ("First argument of defined assignment at %L must be "
598 "INTENT(IN) or INTENT(INOUT)", &intr
->where
);
601 gfc_error ("Second argument of defined assignment at %L must be "
602 "INTENT(IN)", &intr
->where
);
607 gfc_error ("First argument of operator interface at %L must be "
608 "INTENT(IN)", &intr
->where
);
610 if (args
== 2 && i2
!= INTENT_IN
)
611 gfc_error ("Second argument of operator interface at %L must be "
612 "INTENT(IN)", &intr
->where
);
615 /* From now on, all we have to do is check that the operator definition
616 doesn't conflict with an intrinsic operator. The rules for this
617 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
618 as well as 12.3.2.1.1 of Fortran 2003:
620 "If the operator is an intrinsic-operator (R310), the number of
621 function arguments shall be consistent with the intrinsic uses of
622 that operator, and the types, kind type parameters, or ranks of the
623 dummy arguments shall differ from those required for the intrinsic
624 operation (7.1.2)." */
626 #define IS_NUMERIC_TYPE(t) \
627 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
629 /* Unary ops are easy, do them first. */
630 if (operator == INTRINSIC_NOT
)
632 if (t1
== BT_LOGICAL
)
638 if (args
== 1 && (operator == INTRINSIC_PLUS
|| operator == INTRINSIC_MINUS
))
640 if (IS_NUMERIC_TYPE (t1
))
646 /* Character intrinsic operators have same character kind, thus
647 operator definitions with operands of different character kinds
649 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
652 /* Intrinsic operators always perform on arguments of same rank,
653 so different ranks is also always safe. (rank == 0) is an exception
654 to that, because all intrinsic operators are elemental. */
655 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
661 case INTRINSIC_EQ_OS
:
663 case INTRINSIC_NE_OS
:
664 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
669 case INTRINSIC_MINUS
:
670 case INTRINSIC_TIMES
:
671 case INTRINSIC_DIVIDE
:
672 case INTRINSIC_POWER
:
673 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
678 case INTRINSIC_GT_OS
:
680 case INTRINSIC_GE_OS
:
682 case INTRINSIC_LT_OS
:
684 case INTRINSIC_LE_OS
:
685 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
687 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
688 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
692 case INTRINSIC_CONCAT
:
693 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
701 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
711 #undef IS_NUMERIC_TYPE
714 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
720 /* Given a pair of formal argument lists, we see if the two lists can
721 be distinguished by counting the number of nonoptional arguments of
722 a given type/rank in f1 and seeing if there are less then that
723 number of those arguments in f2 (including optional arguments).
724 Since this test is asymmetric, it has to be called twice to make it
725 symmetric. Returns nonzero if the argument lists are incompatible
726 by this test. This subroutine implements rule 1 of section
730 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
732 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
733 gfc_formal_arglist
*f
;
746 for (f
= f1
; f
; f
= f
->next
)
749 /* Build an array of integers that gives the same integer to
750 arguments of the same type/rank. */
751 arg
= gfc_getmem (n1
* sizeof (arginfo
));
754 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
762 for (i
= 0; i
< n1
; i
++)
764 if (arg
[i
].flag
!= -1)
767 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
768 continue; /* Skip optional arguments. */
772 /* Find other nonoptional arguments of the same type/rank. */
773 for (j
= i
+ 1; j
< n1
; j
++)
774 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
775 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
781 /* Now loop over each distinct type found in f1. */
785 for (i
= 0; i
< n1
; i
++)
787 if (arg
[i
].flag
!= k
)
791 for (j
= i
+ 1; j
< n1
; j
++)
792 if (arg
[j
].flag
== k
)
795 /* Count the number of arguments in f2 with that type, including
796 those that are optional. */
799 for (f
= f2
; f
; f
= f
->next
)
800 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
818 /* Perform the abbreviated correspondence test for operators. The
819 arguments cannot be optional and are always ordered correctly,
820 which makes this test much easier than that for generic tests.
822 This subroutine is also used when comparing a formal and actual
823 argument list when an actual parameter is a dummy procedure. At
824 that point, two formal interfaces must be compared for equality
825 which is what happens here. */
828 operator_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
832 if (f1
== NULL
&& f2
== NULL
)
834 if (f1
== NULL
|| f2
== NULL
)
837 if (!compare_type_rank (f1
->sym
, f2
->sym
))
848 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
849 Returns zero if no argument is found that satisfies rule 2, nonzero
852 This test is also not symmetric in f1 and f2 and must be called
853 twice. This test finds problems caused by sorting the actual
854 argument list with keywords. For example:
858 INTEGER :: A ; REAL :: B
862 INTEGER :: A ; REAL :: B
866 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
869 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
871 gfc_formal_arglist
*f2_save
, *g
;
878 if (f1
->sym
->attr
.optional
)
881 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
884 /* Now search for a disambiguating keyword argument starting at
885 the current non-match. */
886 for (g
= f1
; g
; g
= g
->next
)
888 if (g
->sym
->attr
.optional
)
891 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
892 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
906 /* 'Compare' two formal interfaces associated with a pair of symbols.
907 We return nonzero if there exists an actual argument list that
908 would be ambiguous between the two interfaces, zero otherwise. */
911 compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, int generic_flag
)
913 gfc_formal_arglist
*f1
, *f2
;
915 if (s1
->attr
.function
!= s2
->attr
.function
916 && s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
917 return 0; /* Disagreement between function/subroutine. */
922 if (f1
== NULL
&& f2
== NULL
)
923 return 1; /* Special case. */
925 if (count_types_test (f1
, f2
))
927 if (count_types_test (f2
, f1
))
932 if (generic_correspondence (f1
, f2
))
934 if (generic_correspondence (f2
, f1
))
939 if (operator_correspondence (f1
, f2
))
947 /* Given a pointer to an interface pointer, remove duplicate
948 interfaces and make sure that all symbols are either functions or
949 subroutines. Returns nonzero if something goes wrong. */
952 check_interface0 (gfc_interface
*p
, const char *interface_name
)
954 gfc_interface
*psave
, *q
, *qlast
;
957 /* Make sure all symbols in the interface have been defined as
958 functions or subroutines. */
959 for (; p
; p
= p
->next
)
960 if (!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
962 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
963 "subroutine", p
->sym
->name
, interface_name
,
964 &p
->sym
->declared_at
);
969 /* Remove duplicate interfaces in this interface list. */
970 for (; p
; p
= p
->next
)
974 for (q
= p
->next
; q
;)
976 if (p
->sym
!= q
->sym
)
983 /* Duplicate interface. */
984 qlast
->next
= q
->next
;
995 /* Check lists of interfaces to make sure that no two interfaces are
996 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
999 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1000 int generic_flag
, const char *interface_name
,
1004 for (; p
; p
= p
->next
)
1005 for (q
= q0
; q
; q
= q
->next
)
1007 if (p
->sym
== q
->sym
)
1008 continue; /* Duplicates OK here. */
1010 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1013 if (compare_interfaces (p
->sym
, q
->sym
, generic_flag
))
1017 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1018 p
->sym
->name
, q
->sym
->name
, interface_name
,
1022 if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1023 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1024 p
->sym
->name
, q
->sym
->name
, interface_name
,
1033 /* Check the generic and operator interfaces of symbols to make sure
1034 that none of the interfaces conflict. The check has to be done
1035 after all of the symbols are actually loaded. */
1038 check_sym_interfaces (gfc_symbol
*sym
)
1040 char interface_name
[100];
1044 if (sym
->ns
!= gfc_current_ns
)
1047 if (sym
->generic
!= NULL
)
1049 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1050 if (check_interface0 (sym
->generic
, interface_name
))
1053 for (p
= sym
->generic
; p
; p
= p
->next
)
1055 if (!p
->sym
->attr
.use_assoc
&& p
->sym
->attr
.mod_proc
1056 && p
->sym
->attr
.if_source
!= IFSRC_DECL
)
1058 gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1059 "from a module", p
->sym
->name
, &p
->where
);
1064 /* Originally, this test was applied to host interfaces too;
1065 this is incorrect since host associated symbols, from any
1066 source, cannot be ambiguous with local symbols. */
1067 k
= sym
->attr
.referenced
|| !sym
->attr
.use_assoc
;
1068 if (check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
, k
))
1069 sym
->attr
.ambiguous_interfaces
= 1;
1075 check_uop_interfaces (gfc_user_op
*uop
)
1077 char interface_name
[100];
1081 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1082 if (check_interface0 (uop
->operator, interface_name
))
1085 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1087 uop2
= gfc_find_uop (uop
->name
, ns
);
1091 check_interface1 (uop
->operator, uop2
->operator, 0,
1092 interface_name
, true);
1097 /* For the namespace, check generic, user operator and intrinsic
1098 operator interfaces for consistency and to remove duplicate
1099 interfaces. We traverse the whole namespace, counting on the fact
1100 that most symbols will not have generic or operator interfaces. */
1103 gfc_check_interfaces (gfc_namespace
*ns
)
1105 gfc_namespace
*old_ns
, *ns2
;
1106 char interface_name
[100];
1109 old_ns
= gfc_current_ns
;
1110 gfc_current_ns
= ns
;
1112 gfc_traverse_ns (ns
, check_sym_interfaces
);
1114 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1116 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1118 if (i
== INTRINSIC_USER
)
1121 if (i
== INTRINSIC_ASSIGN
)
1122 strcpy (interface_name
, "intrinsic assignment operator");
1124 sprintf (interface_name
, "intrinsic '%s' operator",
1127 if (check_interface0 (ns
->operator[i
], interface_name
))
1130 check_operator_interface (ns
->operator[i
], i
);
1132 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1134 if (check_interface1 (ns
->operator[i
], ns2
->operator[i
], 0,
1135 interface_name
, true))
1141 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_EQ_OS
],
1142 0, interface_name
, true)) goto done
;
1145 case INTRINSIC_EQ_OS
:
1146 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_EQ
],
1147 0, interface_name
, true)) goto done
;
1151 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_NE_OS
],
1152 0, interface_name
, true)) goto done
;
1155 case INTRINSIC_NE_OS
:
1156 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_NE
],
1157 0, interface_name
, true)) goto done
;
1161 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GT_OS
],
1162 0, interface_name
, true)) goto done
;
1165 case INTRINSIC_GT_OS
:
1166 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GT
],
1167 0, interface_name
, true)) goto done
;
1171 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GE_OS
],
1172 0, interface_name
, true)) goto done
;
1175 case INTRINSIC_GE_OS
:
1176 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GE
],
1177 0, interface_name
, true)) goto done
;
1181 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LT_OS
],
1182 0, interface_name
, true)) goto done
;
1185 case INTRINSIC_LT_OS
:
1186 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LT
],
1187 0, interface_name
, true)) goto done
;
1191 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LE_OS
],
1192 0, interface_name
, true)) goto done
;
1195 case INTRINSIC_LE_OS
:
1196 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LE
],
1197 0, interface_name
, true)) goto done
;
1207 gfc_current_ns
= old_ns
;
1212 symbol_rank (gfc_symbol
*sym
)
1214 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1218 /* Given a symbol of a formal argument list and an expression, if the
1219 formal argument is allocatable, check that the actual argument is
1220 allocatable. Returns nonzero if compatible, zero if not compatible. */
1223 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1225 symbol_attribute attr
;
1227 if (formal
->attr
.allocatable
)
1229 attr
= gfc_expr_attr (actual
);
1230 if (!attr
.allocatable
)
1238 /* Given a symbol of a formal argument list and an expression, if the
1239 formal argument is a pointer, see if the actual argument is a
1240 pointer. Returns nonzero if compatible, zero if not compatible. */
1243 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1245 symbol_attribute attr
;
1247 if (formal
->attr
.pointer
)
1249 attr
= gfc_expr_attr (actual
);
1258 /* Given a symbol of a formal argument list and an expression, see if
1259 the two are compatible as arguments. Returns nonzero if
1260 compatible, zero if not compatible. */
1263 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1264 int ranks_must_agree
, int is_elemental
)
1268 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1269 procs c_f_pointer or c_f_procpointer, and we need to accept most
1270 pointers the user could give us. This should allow that. */
1271 if (formal
->ts
.type
== BT_VOID
)
1274 if (formal
->ts
.type
== BT_DERIVED
1275 && formal
->ts
.derived
&& formal
->ts
.derived
->ts
.is_iso_c
1276 && actual
->ts
.type
== BT_DERIVED
1277 && actual
->ts
.derived
&& actual
->ts
.derived
->ts
.is_iso_c
)
1280 if (actual
->ts
.type
== BT_PROCEDURE
)
1282 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1285 if (formal
->attr
.function
1286 && !compare_type_rank (formal
, actual
->symtree
->n
.sym
))
1289 if (formal
->attr
.if_source
== IFSRC_UNKNOWN
1290 || actual
->symtree
->n
.sym
->attr
.external
)
1291 return 1; /* Assume match. */
1293 return compare_interfaces (formal
, actual
->symtree
->n
.sym
, 0);
1296 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1297 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1300 if (symbol_rank (formal
) == actual
->rank
)
1303 /* At this point the ranks didn't agree. */
1304 if (ranks_must_agree
|| formal
->attr
.pointer
)
1307 if (actual
->rank
!= 0)
1308 return is_elemental
|| formal
->attr
.dimension
;
1310 /* At this point, we are considering a scalar passed to an array.
1311 This is legal if the scalar is an array element of the right sort. */
1312 if (formal
->as
->type
== AS_ASSUMED_SHAPE
)
1315 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1316 if (ref
->type
== REF_SUBSTRING
)
1319 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1320 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1324 return 0; /* Not an array element. */
1330 /* Given a symbol of a formal argument list and an expression, see if
1331 the two are compatible as arguments. Returns nonzero if
1332 compatible, zero if not compatible. */
1335 compare_parameter_protected (gfc_symbol
*formal
, gfc_expr
*actual
)
1337 if (actual
->expr_type
!= EXPR_VARIABLE
)
1340 if (!actual
->symtree
->n
.sym
->attr
.protected)
1343 if (!actual
->symtree
->n
.sym
->attr
.use_assoc
)
1346 if (formal
->attr
.intent
== INTENT_IN
1347 || formal
->attr
.intent
== INTENT_UNKNOWN
)
1350 if (!actual
->symtree
->n
.sym
->attr
.pointer
)
1353 if (actual
->symtree
->n
.sym
->attr
.pointer
&& formal
->attr
.pointer
)
1360 /* Returns the storage size of a symbol (formal argument) or
1361 zero if it cannot be determined. */
1363 static unsigned long
1364 get_sym_storage_size (gfc_symbol
*sym
)
1367 unsigned long strlen
, elements
;
1369 if (sym
->ts
.type
== BT_CHARACTER
)
1371 if (sym
->ts
.cl
&& sym
->ts
.cl
->length
1372 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1373 strlen
= mpz_get_ui (sym
->ts
.cl
->length
->value
.integer
);
1380 if (symbol_rank (sym
) == 0)
1384 if (sym
->as
->type
!= AS_EXPLICIT
)
1386 for (i
= 0; i
< sym
->as
->rank
; i
++)
1388 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1389 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1392 elements
*= mpz_get_ui (sym
->as
->upper
[i
]->value
.integer
)
1393 - mpz_get_ui (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1396 return strlen
*elements
;
1400 /* Returns the storage size of an expression (actual argument) or
1401 zero if it cannot be determined. For an array element, it returns
1402 the remaining size as the element sequence consists of all storage
1403 units of the actual argument up to the end of the array. */
1405 static unsigned long
1406 get_expr_storage_size (gfc_expr
*e
)
1409 long int strlen
, elements
;
1415 if (e
->ts
.type
== BT_CHARACTER
)
1417 if (e
->ts
.cl
&& e
->ts
.cl
->length
1418 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1419 strlen
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
1420 else if (e
->expr_type
== EXPR_CONSTANT
1421 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
1422 strlen
= e
->value
.character
.length
;
1427 strlen
= 1; /* Length per element. */
1429 if (e
->rank
== 0 && !e
->ref
)
1437 for (i
= 0; i
< e
->rank
; i
++)
1438 elements
*= mpz_get_si (e
->shape
[i
]);
1439 return elements
*strlen
;
1442 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1444 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1445 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1446 && ref
->u
.ar
.as
->upper
)
1447 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1449 long int start
, end
, stride
;
1452 if (ref
->u
.ar
.stride
[i
])
1454 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1455 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1460 if (ref
->u
.ar
.start
[i
])
1462 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1463 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1467 else if (ref
->u
.ar
.as
->lower
[i
]
1468 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1469 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1473 if (ref
->u
.ar
.end
[i
])
1475 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1476 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1480 else if (ref
->u
.ar
.as
->upper
[i
]
1481 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1482 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1486 elements
*= (end
- start
)/stride
+ 1L;
1488 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1489 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1490 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1492 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1493 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1494 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1495 elements
*= mpz_get_ui (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1496 - mpz_get_ui (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1502 /* TODO: Determine the number of remaining elements in the element
1503 sequence for array element designators.
1504 See also get_array_index in data.c. */
1508 return elements
*strlen
;
1512 /* Given an expression, check whether it is an array section
1513 which has a vector subscript. If it has, one is returned,
1517 has_vector_subscript (gfc_expr
*e
)
1522 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1525 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1526 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1527 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1528 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1535 /* Given formal and actual argument lists, see if they are compatible.
1536 If they are compatible, the actual argument list is sorted to
1537 correspond with the formal list, and elements for missing optional
1538 arguments are inserted. If WHERE pointer is nonnull, then we issue
1539 errors when things don't match instead of just returning the status
1543 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1544 int ranks_must_agree
, int is_elemental
, locus
*where
)
1546 gfc_actual_arglist
**new, *a
, *actual
, temp
;
1547 gfc_formal_arglist
*f
;
1550 unsigned long actual_size
, formal_size
;
1554 if (actual
== NULL
&& formal
== NULL
)
1558 for (f
= formal
; f
; f
= f
->next
)
1561 new = (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1563 for (i
= 0; i
< n
; i
++)
1570 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1572 /* Look for keywords but ignore g77 extensions like %VAL. */
1573 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1576 for (f
= formal
; f
; f
= f
->next
, i
++)
1580 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1587 gfc_error ("Keyword argument '%s' at %L is not in "
1588 "the procedure", a
->name
, &a
->expr
->where
);
1595 gfc_error ("Keyword argument '%s' at %L is already associated "
1596 "with another actual argument", a
->name
,
1605 gfc_error ("More actual than formal arguments in procedure "
1606 "call at %L", where
);
1611 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1617 gfc_error ("Missing alternate return spec in subroutine call "
1622 if (a
->expr
== NULL
)
1625 gfc_error ("Unexpected alternate return spec in subroutine "
1626 "call at %L", where
);
1630 rank_check
= where
!= NULL
&& !is_elemental
&& f
->sym
->as
1631 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1632 || f
->sym
->as
->type
== AS_DEFERRED
);
1634 if (f
->sym
->ts
.type
== BT_CHARACTER
&& a
->expr
->ts
.type
== BT_CHARACTER
1635 && a
->expr
->rank
== 0
1636 && f
->sym
->as
&& f
->sym
->as
->type
!= AS_ASSUMED_SHAPE
)
1638 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1640 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
1641 "with array dummy argument '%s' at %L",
1642 f
->sym
->name
, &a
->expr
->where
);
1645 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1649 else if (!compare_parameter (f
->sym
, a
->expr
,
1650 ranks_must_agree
|| rank_check
, is_elemental
))
1653 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1654 f
->sym
->name
, &a
->expr
->where
);
1658 if (a
->expr
->ts
.type
== BT_CHARACTER
1659 && a
->expr
->ts
.cl
&& a
->expr
->ts
.cl
->length
1660 && a
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
1661 && f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
->length
1662 && f
->sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1664 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
1665 && (mpz_cmp (a
->expr
->ts
.cl
->length
->value
.integer
,
1666 f
->sym
->ts
.cl
->length
->value
.integer
) != 0))
1669 gfc_warning ("Character length mismatch between actual "
1670 "argument and pointer or allocatable dummy "
1671 "argument '%s' at %L",
1672 f
->sym
->name
, &a
->expr
->where
);
1677 actual_size
= get_expr_storage_size (a
->expr
);
1678 formal_size
= get_sym_storage_size (f
->sym
);
1679 if (actual_size
!= 0 && actual_size
< formal_size
)
1681 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
1682 gfc_warning ("Character length of actual argument shorter "
1683 "than of dummy argument '%s' (%d/%d) at %L",
1684 f
->sym
->name
, (int) actual_size
,
1685 (int) formal_size
, &a
->expr
->where
);
1687 gfc_warning ("Actual argument contains too few "
1688 "elements for dummy argument '%s' (%d/%d) at %L",
1689 f
->sym
->name
, (int) actual_size
,
1690 (int) formal_size
, &a
->expr
->where
);
1694 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1695 provided for a procedure formal argument. */
1696 if (a
->expr
->ts
.type
!= BT_PROCEDURE
1697 && a
->expr
->expr_type
== EXPR_VARIABLE
1698 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1701 gfc_error ("Expected a procedure for argument '%s' at %L",
1702 f
->sym
->name
, &a
->expr
->where
);
1706 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
1707 && a
->expr
->ts
.type
== BT_PROCEDURE
1708 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
1711 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1712 f
->sym
->name
, &a
->expr
->where
);
1716 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1717 && a
->expr
->expr_type
== EXPR_VARIABLE
1718 && a
->expr
->symtree
->n
.sym
->as
1719 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
1720 && (a
->expr
->ref
== NULL
1721 || (a
->expr
->ref
->type
== REF_ARRAY
1722 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
1725 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1726 " array at %L", f
->sym
->name
, where
);
1730 if (a
->expr
->expr_type
!= EXPR_NULL
1731 && compare_pointer (f
->sym
, a
->expr
) == 0)
1734 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1735 f
->sym
->name
, &a
->expr
->where
);
1739 if (a
->expr
->expr_type
!= EXPR_NULL
1740 && compare_allocatable (f
->sym
, a
->expr
) == 0)
1743 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1744 f
->sym
->name
, &a
->expr
->where
);
1748 /* Check intent = OUT/INOUT for definable actual argument. */
1749 if (a
->expr
->expr_type
!= EXPR_VARIABLE
1750 && (f
->sym
->attr
.intent
== INTENT_OUT
1751 || f
->sym
->attr
.intent
== INTENT_INOUT
))
1754 gfc_error ("Actual argument at %L must be definable to "
1755 "match dummy INTENT = OUT/INOUT", &a
->expr
->where
);
1759 if (!compare_parameter_protected(f
->sym
, a
->expr
))
1762 gfc_error ("Actual argument at %L is use-associated with "
1763 "PROTECTED attribute and dummy argument '%s' is "
1764 "INTENT = OUT/INOUT",
1765 &a
->expr
->where
,f
->sym
->name
);
1769 if ((f
->sym
->attr
.intent
== INTENT_OUT
1770 || f
->sym
->attr
.intent
== INTENT_INOUT
1771 || f
->sym
->attr
.volatile_
)
1772 && has_vector_subscript (a
->expr
))
1775 gfc_error ("Array-section actual argument with vector subscripts "
1776 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1777 "or VOLATILE attribute of the dummy argument '%s'",
1778 &a
->expr
->where
, f
->sym
->name
);
1782 /* C1232 (R1221) For an actual argument which is an array section or
1783 an assumed-shape array, the dummy argument shall be an assumed-
1784 shape array, if the dummy argument has the VOLATILE attribute. */
1786 if (f
->sym
->attr
.volatile_
1787 && a
->expr
->symtree
->n
.sym
->as
1788 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1789 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1792 gfc_error ("Assumed-shape actual argument at %L is "
1793 "incompatible with the non-assumed-shape "
1794 "dummy argument '%s' due to VOLATILE attribute",
1795 &a
->expr
->where
,f
->sym
->name
);
1799 if (f
->sym
->attr
.volatile_
1800 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
1801 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1804 gfc_error ("Array-section actual argument at %L is "
1805 "incompatible with the non-assumed-shape "
1806 "dummy argument '%s' due to VOLATILE attribute",
1807 &a
->expr
->where
,f
->sym
->name
);
1811 /* C1233 (R1221) For an actual argument which is a pointer array, the
1812 dummy argument shall be an assumed-shape or pointer array, if the
1813 dummy argument has the VOLATILE attribute. */
1815 if (f
->sym
->attr
.volatile_
1816 && a
->expr
->symtree
->n
.sym
->attr
.pointer
1817 && a
->expr
->symtree
->n
.sym
->as
1819 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1820 || f
->sym
->attr
.pointer
)))
1823 gfc_error ("Pointer-array actual argument at %L requires "
1824 "an assumed-shape or pointer-array dummy "
1825 "argument '%s' due to VOLATILE attribute",
1826 &a
->expr
->where
,f
->sym
->name
);
1837 /* Make sure missing actual arguments are optional. */
1839 for (f
= formal
; f
; f
= f
->next
, i
++)
1846 gfc_error ("Missing alternate return spec in subroutine call "
1850 if (!f
->sym
->attr
.optional
)
1853 gfc_error ("Missing actual argument for argument '%s' at %L",
1854 f
->sym
->name
, where
);
1859 /* The argument lists are compatible. We now relink a new actual
1860 argument list with null arguments in the right places. The head
1861 of the list remains the head. */
1862 for (i
= 0; i
< n
; i
++)
1864 new[i
] = gfc_get_actual_arglist ();
1877 for (i
= 0; i
< n
- 1; i
++)
1878 new[i
]->next
= new[i
+ 1];
1880 new[i
]->next
= NULL
;
1882 if (*ap
== NULL
&& n
> 0)
1885 /* Note the types of omitted optional arguments. */
1886 for (a
= actual
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
1887 if (a
->expr
== NULL
&& a
->label
== NULL
)
1888 a
->missing_arg_type
= f
->sym
->ts
.type
;
1896 gfc_formal_arglist
*f
;
1897 gfc_actual_arglist
*a
;
1901 /* qsort comparison function for argument pairs, with the following
1903 - p->a->expr == NULL
1904 - p->a->expr->expr_type != EXPR_VARIABLE
1905 - growing p->a->expr->symbol. */
1908 pair_cmp (const void *p1
, const void *p2
)
1910 const gfc_actual_arglist
*a1
, *a2
;
1912 /* *p1 and *p2 are elements of the to-be-sorted array. */
1913 a1
= ((const argpair
*) p1
)->a
;
1914 a2
= ((const argpair
*) p2
)->a
;
1923 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
1925 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1929 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1931 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
1935 /* Given two expressions from some actual arguments, test whether they
1936 refer to the same expression. The analysis is conservative.
1937 Returning FAILURE will produce no warning. */
1940 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
1942 const gfc_ref
*r1
, *r2
;
1945 || e1
->expr_type
!= EXPR_VARIABLE
1946 || e2
->expr_type
!= EXPR_VARIABLE
1947 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
1950 /* TODO: improve comparison, see expr.c:show_ref(). */
1951 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
1953 if (r1
->type
!= r2
->type
)
1958 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
1960 /* TODO: At the moment, consider only full arrays;
1961 we could do better. */
1962 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
1967 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
1975 gfc_internal_error ("compare_actual_expr(): Bad component code");
1984 /* Given formal and actual argument lists that correspond to one
1985 another, check that identical actual arguments aren't not
1986 associated with some incompatible INTENTs. */
1989 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
1991 sym_intent f1_intent
, f2_intent
;
1992 gfc_formal_arglist
*f1
;
1993 gfc_actual_arglist
*a1
;
1999 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2001 if (f1
== NULL
&& a1
== NULL
)
2003 if (f1
== NULL
|| a1
== NULL
)
2004 gfc_internal_error ("check_some_aliasing(): List mismatch");
2009 p
= (argpair
*) alloca (n
* sizeof (argpair
));
2011 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2017 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2019 for (i
= 0; i
< n
; i
++)
2022 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2023 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2025 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2026 for (j
= i
+ 1; j
< n
; j
++)
2028 /* Expected order after the sort. */
2029 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2030 gfc_internal_error ("check_some_aliasing(): corrupted data");
2032 /* Are the expression the same? */
2033 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2035 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2036 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2037 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2039 gfc_warning ("Same actual argument associated with INTENT(%s) "
2040 "argument '%s' and INTENT(%s) argument '%s' at %L",
2041 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2042 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2043 &p
[i
].a
->expr
->where
);
2053 /* Given a symbol of a formal argument list and an expression,
2054 return nonzero if their intents are compatible, zero otherwise. */
2057 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2059 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2062 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2065 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2072 /* Given formal and actual argument lists that correspond to one
2073 another, check that they are compatible in the sense that intents
2074 are not mismatched. */
2077 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2079 sym_intent f_intent
;
2081 for (;; f
= f
->next
, a
= a
->next
)
2083 if (f
== NULL
&& a
== NULL
)
2085 if (f
== NULL
|| a
== NULL
)
2086 gfc_internal_error ("check_intents(): List mismatch");
2088 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2091 f_intent
= f
->sym
->attr
.intent
;
2093 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2095 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2096 "specifies INTENT(%s)", &a
->expr
->where
,
2097 gfc_intent_string (f_intent
));
2101 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2103 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2105 gfc_error ("Procedure argument at %L is local to a PURE "
2106 "procedure and is passed to an INTENT(%s) argument",
2107 &a
->expr
->where
, gfc_intent_string (f_intent
));
2111 if (a
->expr
->symtree
->n
.sym
->attr
.pointer
)
2113 gfc_error ("Procedure argument at %L is local to a PURE "
2114 "procedure and has the POINTER attribute",
2125 /* Check how a procedure is used against its interface. If all goes
2126 well, the actual argument list will also end up being properly
2130 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2133 /* Warn about calls with an implicit interface. */
2134 if (gfc_option
.warn_implicit_interface
2135 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2136 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2139 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2140 || !compare_actual_formal (ap
, sym
->formal
, 0,
2141 sym
->attr
.elemental
, where
))
2144 check_intents (sym
->formal
, *ap
);
2145 if (gfc_option
.warn_aliasing
)
2146 check_some_aliasing (sym
->formal
, *ap
);
2150 /* Given an interface pointer and an actual argument list, search for
2151 a formal argument list that matches the actual. If found, returns
2152 a pointer to the symbol of the correct interface. Returns NULL if
2156 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2157 gfc_actual_arglist
**ap
)
2161 for (; intr
; intr
= intr
->next
)
2163 if (sub_flag
&& intr
->sym
->attr
.function
)
2165 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2168 r
= !intr
->sym
->attr
.elemental
;
2170 if (compare_actual_formal (ap
, intr
->sym
->formal
, r
, !r
, NULL
))
2172 check_intents (intr
->sym
->formal
, *ap
);
2173 if (gfc_option
.warn_aliasing
)
2174 check_some_aliasing (intr
->sym
->formal
, *ap
);
2183 /* Do a brute force recursive search for a symbol. */
2185 static gfc_symtree
*
2186 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2190 if (root
->n
.sym
== sym
)
2195 st
= find_symtree0 (root
->left
, sym
);
2196 if (root
->right
&& ! st
)
2197 st
= find_symtree0 (root
->right
, sym
);
2202 /* Find a symtree for a symbol. */
2204 static gfc_symtree
*
2205 find_sym_in_symtree (gfc_symbol
*sym
)
2210 /* First try to find it by name. */
2211 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2212 if (st
&& st
->n
.sym
== sym
)
2215 /* If it's been renamed, resort to a brute-force search. */
2216 /* TODO: avoid having to do this search. If the symbol doesn't exist
2217 in the symtree for the current namespace, it should probably be added. */
2218 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2220 st
= find_symtree0 (ns
->sym_root
, sym
);
2224 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2229 /* This subroutine is called when an expression is being resolved.
2230 The expression node in question is either a user defined operator
2231 or an intrinsic operator with arguments that aren't compatible
2232 with the operator. This subroutine builds an actual argument list
2233 corresponding to the operands, then searches for a compatible
2234 interface. If one is found, the expression node is replaced with
2235 the appropriate function call. */
2238 gfc_extend_expr (gfc_expr
*e
)
2240 gfc_actual_arglist
*actual
;
2248 actual
= gfc_get_actual_arglist ();
2249 actual
->expr
= e
->value
.op
.op1
;
2251 if (e
->value
.op
.op2
!= NULL
)
2253 actual
->next
= gfc_get_actual_arglist ();
2254 actual
->next
->expr
= e
->value
.op
.op2
;
2257 i
= fold_unary (e
->value
.op
.operator);
2259 if (i
== INTRINSIC_USER
)
2261 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2263 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2267 sym
= gfc_search_interface (uop
->operator, 0, &actual
);
2274 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2276 /* Due to the distinction between '==' and '.eq.' and friends, one has
2277 to check if either is defined. */
2281 case INTRINSIC_EQ_OS
:
2282 sym
= gfc_search_interface (ns
->operator[INTRINSIC_EQ
], 0, &actual
);
2284 sym
= gfc_search_interface (ns
->operator[INTRINSIC_EQ_OS
], 0, &actual
);
2288 case INTRINSIC_NE_OS
:
2289 sym
= gfc_search_interface (ns
->operator[INTRINSIC_NE
], 0, &actual
);
2291 sym
= gfc_search_interface (ns
->operator[INTRINSIC_NE_OS
], 0, &actual
);
2295 case INTRINSIC_GT_OS
:
2296 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GT
], 0, &actual
);
2298 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GT_OS
], 0, &actual
);
2302 case INTRINSIC_GE_OS
:
2303 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GE
], 0, &actual
);
2305 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GE_OS
], 0, &actual
);
2309 case INTRINSIC_LT_OS
:
2310 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LT
], 0, &actual
);
2312 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LT_OS
], 0, &actual
);
2316 case INTRINSIC_LE_OS
:
2317 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LE
], 0, &actual
);
2319 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LE_OS
], 0, &actual
);
2323 sym
= gfc_search_interface (ns
->operator[i
], 0, &actual
);
2333 /* Don't use gfc_free_actual_arglist(). */
2334 if (actual
->next
!= NULL
)
2335 gfc_free (actual
->next
);
2341 /* Change the expression node to a function call. */
2342 e
->expr_type
= EXPR_FUNCTION
;
2343 e
->symtree
= find_sym_in_symtree (sym
);
2344 e
->value
.function
.actual
= actual
;
2345 e
->value
.function
.esym
= NULL
;
2346 e
->value
.function
.isym
= NULL
;
2347 e
->value
.function
.name
= NULL
;
2349 if (gfc_pure (NULL
) && !gfc_pure (sym
))
2351 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2352 "be PURE", sym
->name
, &e
->where
);
2356 if (gfc_resolve_expr (e
) == FAILURE
)
2363 /* Tries to replace an assignment code node with a subroutine call to
2364 the subroutine associated with the assignment operator. Return
2365 SUCCESS if the node was replaced. On FAILURE, no error is
2369 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
2371 gfc_actual_arglist
*actual
;
2372 gfc_expr
*lhs
, *rhs
;
2378 /* Don't allow an intrinsic assignment to be replaced. */
2379 if (lhs
->ts
.type
!= BT_DERIVED
&& rhs
->ts
.type
!= BT_DERIVED
2380 && (lhs
->ts
.type
== rhs
->ts
.type
2381 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
2384 actual
= gfc_get_actual_arglist ();
2387 actual
->next
= gfc_get_actual_arglist ();
2388 actual
->next
->expr
= rhs
;
2392 for (; ns
; ns
= ns
->parent
)
2394 sym
= gfc_search_interface (ns
->operator[INTRINSIC_ASSIGN
], 1, &actual
);
2401 gfc_free (actual
->next
);
2406 /* Replace the assignment with the call. */
2407 c
->op
= EXEC_ASSIGN_CALL
;
2408 c
->symtree
= find_sym_in_symtree (sym
);
2411 c
->ext
.actual
= actual
;
2417 /* Make sure that the interface just parsed is not already present in
2418 the given interface list. Ambiguity isn't checked yet since module
2419 procedures can be present without interfaces. */
2422 check_new_interface (gfc_interface
*base
, gfc_symbol
*new)
2426 for (ip
= base
; ip
; ip
= ip
->next
)
2430 gfc_error ("Entity '%s' at %C is already present in the interface",
2440 /* Add a symbol to the current interface. */
2443 gfc_add_interface (gfc_symbol
*new)
2445 gfc_interface
**head
, *intr
;
2449 switch (current_interface
.type
)
2451 case INTERFACE_NAMELESS
:
2454 case INTERFACE_INTRINSIC_OP
:
2455 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2456 switch (current_interface
.op
)
2459 case INTRINSIC_EQ_OS
:
2460 if (check_new_interface (ns
->operator[INTRINSIC_EQ
], new) == FAILURE
||
2461 check_new_interface (ns
->operator[INTRINSIC_EQ_OS
], new) == FAILURE
)
2466 case INTRINSIC_NE_OS
:
2467 if (check_new_interface (ns
->operator[INTRINSIC_NE
], new) == FAILURE
||
2468 check_new_interface (ns
->operator[INTRINSIC_NE_OS
], new) == FAILURE
)
2473 case INTRINSIC_GT_OS
:
2474 if (check_new_interface (ns
->operator[INTRINSIC_GT
], new) == FAILURE
||
2475 check_new_interface (ns
->operator[INTRINSIC_GT_OS
], new) == FAILURE
)
2480 case INTRINSIC_GE_OS
:
2481 if (check_new_interface (ns
->operator[INTRINSIC_GE
], new) == FAILURE
||
2482 check_new_interface (ns
->operator[INTRINSIC_GE_OS
], new) == FAILURE
)
2487 case INTRINSIC_LT_OS
:
2488 if (check_new_interface (ns
->operator[INTRINSIC_LT
], new) == FAILURE
||
2489 check_new_interface (ns
->operator[INTRINSIC_LT_OS
], new) == FAILURE
)
2494 case INTRINSIC_LE_OS
:
2495 if (check_new_interface (ns
->operator[INTRINSIC_LE
], new) == FAILURE
||
2496 check_new_interface (ns
->operator[INTRINSIC_LE_OS
], new) == FAILURE
)
2501 if (check_new_interface (ns
->operator[current_interface
.op
], new) == FAILURE
)
2505 head
= ¤t_interface
.ns
->operator[current_interface
.op
];
2508 case INTERFACE_GENERIC
:
2509 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2511 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
2515 if (check_new_interface (sym
->generic
, new) == FAILURE
)
2519 head
= ¤t_interface
.sym
->generic
;
2522 case INTERFACE_USER_OP
:
2523 if (check_new_interface (current_interface
.uop
->operator, new)
2527 head
= ¤t_interface
.uop
->operator;
2531 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2534 intr
= gfc_get_interface ();
2536 intr
->where
= gfc_current_locus
;
2545 /* Gets rid of a formal argument list. We do not free symbols.
2546 Symbols are freed when a namespace is freed. */
2549 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
2551 gfc_formal_arglist
*q
;