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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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 (gfc_intrinsic_op
operator)
103 case INTRINSIC_UPLUS
:
104 operator = INTRINSIC_PLUS
;
106 case INTRINSIC_UMINUS
:
107 operator = INTRINSIC_MINUS
;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'operator' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type
*type
,
124 gfc_intrinsic_op
*operator)
126 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES
)
132 *type
= INTERFACE_INTRINSIC_OP
;
133 *operator = INTRINSIC_ASSIGN
;
137 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
139 *type
= INTERFACE_INTRINSIC_OP
;
140 *operator = fold_unary (i
);
144 if (gfc_match (" operator ( ") == MATCH_YES
)
146 m
= gfc_match_defined_op_name (buffer
, 1);
152 m
= gfc_match_char (')');
158 strcpy (name
, buffer
);
159 *type
= INTERFACE_USER_OP
;
163 if (gfc_match_name (buffer
) == MATCH_YES
)
165 strcpy (name
, buffer
);
166 *type
= INTERFACE_GENERIC
;
170 *type
= INTERFACE_NAMELESS
;
174 gfc_error ("Syntax error in generic specification at %C");
179 /* Match one of the five forms of an interface statement. */
182 gfc_match_interface (void)
184 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
187 gfc_intrinsic_op
operator;
190 m
= gfc_match_space ();
192 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
195 /* If we're not looking at the end of the statement now, or if this
196 is not a nameless interface but we did not see a space, punt. */
197 if (gfc_match_eos () != MATCH_YES
198 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
200 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
205 current_interface
.type
= type
;
209 case INTERFACE_GENERIC
:
210 if (gfc_get_symbol (name
, NULL
, &sym
))
213 if (!sym
->attr
.generic
214 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
219 gfc_error ("Dummy procedure '%s' at %C cannot have a "
220 "generic interface", sym
->name
);
224 current_interface
.sym
= gfc_new_block
= sym
;
227 case INTERFACE_USER_OP
:
228 current_interface
.uop
= gfc_get_uop (name
);
231 case INTERFACE_INTRINSIC_OP
:
232 current_interface
.op
= operator;
235 case INTERFACE_NAMELESS
:
243 /* Match the different sort of generic-specs that can be present after
244 the END INTERFACE itself. */
247 gfc_match_end_interface (void)
249 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
251 gfc_intrinsic_op
operator;
254 m
= gfc_match_space ();
256 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
259 /* If we're not looking at the end of the statement now, or if this
260 is not a nameless interface but we did not see a space, punt. */
261 if (gfc_match_eos () != MATCH_YES
262 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
264 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
271 switch (current_interface
.type
)
273 case INTERFACE_NAMELESS
:
274 if (type
!= current_interface
.type
)
276 gfc_error ("Expected a nameless interface at %C");
282 case INTERFACE_INTRINSIC_OP
:
283 if (type
!= current_interface
.type
|| operator != current_interface
.op
)
286 if (current_interface
.op
== INTRINSIC_ASSIGN
)
287 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
289 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
290 gfc_op2string (current_interface
.op
));
297 case INTERFACE_USER_OP
:
298 /* Comparing the symbol node names is OK because only use-associated
299 symbols can be renamed. */
300 if (type
!= current_interface
.type
301 || strcmp (current_interface
.uop
->name
, name
) != 0)
303 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
304 current_interface
.uop
->name
);
310 case INTERFACE_GENERIC
:
311 if (type
!= current_interface
.type
312 || strcmp (current_interface
.sym
->name
, name
) != 0)
314 gfc_error ("Expecting 'END INTERFACE %s' at %C",
315 current_interface
.sym
->name
);
326 /* Compare two derived types using the criteria in 4.4.2 of the standard,
327 recursing through gfc_compare_types for the components. */
330 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
332 gfc_component
*dt1
, *dt2
;
334 /* Special case for comparing derived types across namespaces. If the
335 true names and module names are the same and the module name is
336 nonnull, then they are equal. */
337 if (derived1
!= NULL
&& derived2
!= NULL
338 && strcmp (derived1
->name
, derived2
->name
) == 0
339 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
340 && strcmp (derived1
->module
, derived2
->module
) == 0)
343 /* Compare type via the rules of the standard. Both types must have
344 the SEQUENCE attribute to be equal. */
346 if (strcmp (derived1
->name
, derived2
->name
))
349 if (derived1
->component_access
== ACCESS_PRIVATE
350 || derived2
->component_access
== ACCESS_PRIVATE
)
353 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
356 dt1
= derived1
->components
;
357 dt2
= derived2
->components
;
359 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
360 simple test can speed things up. Otherwise, lots of things have to
364 if (strcmp (dt1
->name
, dt2
->name
) != 0)
367 if (dt1
->access
!= dt2
->access
)
370 if (dt1
->pointer
!= dt2
->pointer
)
373 if (dt1
->dimension
!= dt2
->dimension
)
376 if (dt1
->allocatable
!= dt2
->allocatable
)
379 if (dt1
->dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
382 if (gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
388 if (dt1
== NULL
&& dt2
== NULL
)
390 if (dt1
== NULL
|| dt2
== NULL
)
398 /* Compare two typespecs, recursively if necessary. */
401 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
403 /* See if one of the typespecs is a BT_VOID, which is what is being used
404 to allow the funcs like c_f_pointer to accept any pointer type.
405 TODO: Possibly should narrow this to just the one typespec coming in
406 that is for the formal arg, but oh well. */
407 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
410 if (ts1
->type
!= ts2
->type
)
412 if (ts1
->type
!= BT_DERIVED
)
413 return (ts1
->kind
== ts2
->kind
);
415 /* Compare derived types. */
416 if (ts1
->derived
== ts2
->derived
)
419 return gfc_compare_derived_types (ts1
->derived
,ts2
->derived
);
423 /* Given two symbols that are formal arguments, compare their ranks
424 and types. Returns nonzero if they have the same rank and type,
428 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
432 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
433 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
436 return 0; /* Ranks differ. */
438 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
442 static int compare_interfaces (gfc_symbol
*, gfc_symbol
*, int);
444 /* Given two symbols that are formal arguments, compare their types
445 and rank and their formal interfaces if they are both dummy
446 procedures. Returns nonzero if the same, zero if different. */
449 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
451 if (s1
== NULL
|| s2
== NULL
)
452 return s1
== s2
? 1 : 0;
454 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
455 return compare_type_rank (s1
, s2
);
457 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
460 /* At this point, both symbols are procedures. */
461 if ((s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
462 || (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0))
465 if (s1
->attr
.function
!= s2
->attr
.function
466 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
469 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
472 /* Originally, gfortran recursed here to check the interfaces of passed
473 procedures. This is explicitly not required by the standard. */
478 /* Given a formal argument list and a keyword name, search the list
479 for that keyword. Returns the correct symbol node if found, NULL
483 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
485 for (; f
; f
= f
->next
)
486 if (strcmp (f
->sym
->name
, name
) == 0)
493 /******** Interface checking subroutines **********/
496 /* Given an operator interface and the operator, make sure that all
497 interfaces for that operator are legal. */
500 check_operator_interface (gfc_interface
*intr
, gfc_intrinsic_op
operator)
502 gfc_formal_arglist
*formal
;
506 int args
, r1
, r2
, k1
, k2
;
512 t1
= t2
= BT_UNKNOWN
;
513 i1
= i2
= INTENT_UNKNOWN
;
517 for (formal
= intr
->sym
->formal
; formal
; formal
= formal
->next
)
522 gfc_error ("Alternate return cannot appear in operator "
523 "interface at %L", &intr
->where
);
529 i1
= sym
->attr
.intent
;
530 r1
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
536 i2
= sym
->attr
.intent
;
537 r2
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
545 /* Only +, - and .not. can be unary operators.
546 .not. cannot be a binary operator. */
547 if (args
== 0 || args
> 2 || (args
== 1 && operator != INTRINSIC_PLUS
548 && operator != INTRINSIC_MINUS
549 && operator != INTRINSIC_NOT
)
550 || (args
== 2 && operator == INTRINSIC_NOT
))
552 gfc_error ("Operator interface at %L has the wrong number of arguments",
557 /* Check that intrinsics are mapped to functions, except
558 INTRINSIC_ASSIGN which should map to a subroutine. */
559 if (operator == INTRINSIC_ASSIGN
)
561 if (!sym
->attr
.subroutine
)
563 gfc_error ("Assignment operator interface at %L must be "
564 "a SUBROUTINE", &intr
->where
);
569 gfc_error ("Assignment operator interface at %L must have "
570 "two arguments", &intr
->where
);
573 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
574 && sym
->formal
->next
->sym
->ts
.type
!= BT_DERIVED
575 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
576 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
577 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
579 gfc_error ("Assignment operator interface at %L must not redefine "
580 "an INTRINSIC type assignment", &intr
->where
);
586 if (!sym
->attr
.function
)
588 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
594 /* Check intents on operator interfaces. */
595 if (operator == INTRINSIC_ASSIGN
)
597 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
598 gfc_error ("First argument of defined assignment at %L must be "
599 "INTENT(IN) or INTENT(INOUT)", &intr
->where
);
602 gfc_error ("Second argument of defined assignment at %L must be "
603 "INTENT(IN)", &intr
->where
);
608 gfc_error ("First argument of operator interface at %L must be "
609 "INTENT(IN)", &intr
->where
);
611 if (args
== 2 && i2
!= INTENT_IN
)
612 gfc_error ("Second argument of operator interface at %L must be "
613 "INTENT(IN)", &intr
->where
);
616 /* From now on, all we have to do is check that the operator definition
617 doesn't conflict with an intrinsic operator. The rules for this
618 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
619 as well as 12.3.2.1.1 of Fortran 2003:
621 "If the operator is an intrinsic-operator (R310), the number of
622 function arguments shall be consistent with the intrinsic uses of
623 that operator, and the types, kind type parameters, or ranks of the
624 dummy arguments shall differ from those required for the intrinsic
625 operation (7.1.2)." */
627 #define IS_NUMERIC_TYPE(t) \
628 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
630 /* Unary ops are easy, do them first. */
631 if (operator == INTRINSIC_NOT
)
633 if (t1
== BT_LOGICAL
)
639 if (args
== 1 && (operator == INTRINSIC_PLUS
|| operator == INTRINSIC_MINUS
))
641 if (IS_NUMERIC_TYPE (t1
))
647 /* Character intrinsic operators have same character kind, thus
648 operator definitions with operands of different character kinds
650 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
653 /* Intrinsic operators always perform on arguments of same rank,
654 so different ranks is also always safe. (rank == 0) is an exception
655 to that, because all intrinsic operators are elemental. */
656 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
662 case INTRINSIC_EQ_OS
:
664 case INTRINSIC_NE_OS
:
665 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
670 case INTRINSIC_MINUS
:
671 case INTRINSIC_TIMES
:
672 case INTRINSIC_DIVIDE
:
673 case INTRINSIC_POWER
:
674 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
679 case INTRINSIC_GT_OS
:
681 case INTRINSIC_GE_OS
:
683 case INTRINSIC_LT_OS
:
685 case INTRINSIC_LE_OS
:
686 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
688 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
689 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
693 case INTRINSIC_CONCAT
:
694 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
702 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
712 #undef IS_NUMERIC_TYPE
715 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
721 /* Given a pair of formal argument lists, we see if the two lists can
722 be distinguished by counting the number of nonoptional arguments of
723 a given type/rank in f1 and seeing if there are less then that
724 number of those arguments in f2 (including optional arguments).
725 Since this test is asymmetric, it has to be called twice to make it
726 symmetric. Returns nonzero if the argument lists are incompatible
727 by this test. This subroutine implements rule 1 of section
731 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
733 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
734 gfc_formal_arglist
*f
;
747 for (f
= f1
; f
; f
= f
->next
)
750 /* Build an array of integers that gives the same integer to
751 arguments of the same type/rank. */
752 arg
= gfc_getmem (n1
* sizeof (arginfo
));
755 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
763 for (i
= 0; i
< n1
; i
++)
765 if (arg
[i
].flag
!= -1)
768 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
769 continue; /* Skip optional arguments. */
773 /* Find other nonoptional arguments of the same type/rank. */
774 for (j
= i
+ 1; j
< n1
; j
++)
775 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
776 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
782 /* Now loop over each distinct type found in f1. */
786 for (i
= 0; i
< n1
; i
++)
788 if (arg
[i
].flag
!= k
)
792 for (j
= i
+ 1; j
< n1
; j
++)
793 if (arg
[j
].flag
== k
)
796 /* Count the number of arguments in f2 with that type, including
797 those that are optional. */
800 for (f
= f2
; f
; f
= f
->next
)
801 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
819 /* Perform the abbreviated correspondence test for operators. The
820 arguments cannot be optional and are always ordered correctly,
821 which makes this test much easier than that for generic tests.
823 This subroutine is also used when comparing a formal and actual
824 argument list when an actual parameter is a dummy procedure. At
825 that point, two formal interfaces must be compared for equality
826 which is what happens here. */
829 operator_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
833 if (f1
== NULL
&& f2
== NULL
)
835 if (f1
== NULL
|| f2
== NULL
)
838 if (!compare_type_rank (f1
->sym
, f2
->sym
))
849 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
850 Returns zero if no argument is found that satisfies rule 2, nonzero
853 This test is also not symmetric in f1 and f2 and must be called
854 twice. This test finds problems caused by sorting the actual
855 argument list with keywords. For example:
859 INTEGER :: A ; REAL :: B
863 INTEGER :: A ; REAL :: B
867 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
870 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
872 gfc_formal_arglist
*f2_save
, *g
;
879 if (f1
->sym
->attr
.optional
)
882 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
885 /* Now search for a disambiguating keyword argument starting at
886 the current non-match. */
887 for (g
= f1
; g
; g
= g
->next
)
889 if (g
->sym
->attr
.optional
)
892 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
893 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
907 /* 'Compare' two formal interfaces associated with a pair of symbols.
908 We return nonzero if there exists an actual argument list that
909 would be ambiguous between the two interfaces, zero otherwise. */
912 compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, int generic_flag
)
914 gfc_formal_arglist
*f1
, *f2
;
916 if (s1
->attr
.function
!= s2
->attr
.function
917 && s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
918 return 0; /* Disagreement between function/subroutine. */
923 if (f1
== NULL
&& f2
== NULL
)
924 return 1; /* Special case. */
926 if (count_types_test (f1
, f2
))
928 if (count_types_test (f2
, f1
))
933 if (generic_correspondence (f1
, f2
))
935 if (generic_correspondence (f2
, f1
))
940 if (operator_correspondence (f1
, f2
))
948 /* Given a pointer to an interface pointer, remove duplicate
949 interfaces and make sure that all symbols are either functions or
950 subroutines. Returns nonzero if something goes wrong. */
953 check_interface0 (gfc_interface
*p
, const char *interface_name
)
955 gfc_interface
*psave
, *q
, *qlast
;
958 /* Make sure all symbols in the interface have been defined as
959 functions or subroutines. */
960 for (; p
; p
= p
->next
)
961 if (!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
963 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
964 "subroutine", p
->sym
->name
, interface_name
,
965 &p
->sym
->declared_at
);
970 /* Remove duplicate interfaces in this interface list. */
971 for (; p
; p
= p
->next
)
975 for (q
= p
->next
; q
;)
977 if (p
->sym
!= q
->sym
)
984 /* Duplicate interface. */
985 qlast
->next
= q
->next
;
996 /* Check lists of interfaces to make sure that no two interfaces are
997 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1000 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1001 int generic_flag
, const char *interface_name
,
1005 for (; p
; p
= p
->next
)
1006 for (q
= q0
; q
; q
= q
->next
)
1008 if (p
->sym
== q
->sym
)
1009 continue; /* Duplicates OK here. */
1011 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1014 if (compare_interfaces (p
->sym
, q
->sym
, generic_flag
))
1018 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1019 p
->sym
->name
, q
->sym
->name
, interface_name
,
1023 if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1024 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1025 p
->sym
->name
, q
->sym
->name
, interface_name
,
1034 /* Check the generic and operator interfaces of symbols to make sure
1035 that none of the interfaces conflict. The check has to be done
1036 after all of the symbols are actually loaded. */
1039 check_sym_interfaces (gfc_symbol
*sym
)
1041 char interface_name
[100];
1045 if (sym
->ns
!= gfc_current_ns
)
1048 if (sym
->generic
!= NULL
)
1050 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1051 if (check_interface0 (sym
->generic
, interface_name
))
1054 for (p
= sym
->generic
; p
; p
= p
->next
)
1056 if (!p
->sym
->attr
.use_assoc
&& p
->sym
->attr
.mod_proc
1057 && p
->sym
->attr
.if_source
!= IFSRC_DECL
)
1059 gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1060 "from a module", p
->sym
->name
, &p
->where
);
1065 /* Originally, this test was applied to host interfaces too;
1066 this is incorrect since host associated symbols, from any
1067 source, cannot be ambiguous with local symbols. */
1068 k
= sym
->attr
.referenced
|| !sym
->attr
.use_assoc
;
1069 if (check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
, k
))
1070 sym
->attr
.ambiguous_interfaces
= 1;
1076 check_uop_interfaces (gfc_user_op
*uop
)
1078 char interface_name
[100];
1082 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1083 if (check_interface0 (uop
->operator, interface_name
))
1086 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1088 uop2
= gfc_find_uop (uop
->name
, ns
);
1092 check_interface1 (uop
->operator, uop2
->operator, 0,
1093 interface_name
, true);
1098 /* For the namespace, check generic, user operator and intrinsic
1099 operator interfaces for consistency and to remove duplicate
1100 interfaces. We traverse the whole namespace, counting on the fact
1101 that most symbols will not have generic or operator interfaces. */
1104 gfc_check_interfaces (gfc_namespace
*ns
)
1106 gfc_namespace
*old_ns
, *ns2
;
1107 char interface_name
[100];
1110 old_ns
= gfc_current_ns
;
1111 gfc_current_ns
= ns
;
1113 gfc_traverse_ns (ns
, check_sym_interfaces
);
1115 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1117 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1119 if (i
== INTRINSIC_USER
)
1122 if (i
== INTRINSIC_ASSIGN
)
1123 strcpy (interface_name
, "intrinsic assignment operator");
1125 sprintf (interface_name
, "intrinsic '%s' operator",
1128 if (check_interface0 (ns
->operator[i
], interface_name
))
1131 check_operator_interface (ns
->operator[i
], i
);
1133 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1135 if (check_interface1 (ns
->operator[i
], ns2
->operator[i
], 0,
1136 interface_name
, true))
1142 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_EQ_OS
],
1143 0, interface_name
, true)) goto done
;
1146 case INTRINSIC_EQ_OS
:
1147 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_EQ
],
1148 0, interface_name
, true)) goto done
;
1152 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_NE_OS
],
1153 0, interface_name
, true)) goto done
;
1156 case INTRINSIC_NE_OS
:
1157 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_NE
],
1158 0, interface_name
, true)) goto done
;
1162 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GT_OS
],
1163 0, interface_name
, true)) goto done
;
1166 case INTRINSIC_GT_OS
:
1167 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GT
],
1168 0, interface_name
, true)) goto done
;
1172 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GE_OS
],
1173 0, interface_name
, true)) goto done
;
1176 case INTRINSIC_GE_OS
:
1177 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GE
],
1178 0, interface_name
, true)) goto done
;
1182 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LT_OS
],
1183 0, interface_name
, true)) goto done
;
1186 case INTRINSIC_LT_OS
:
1187 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LT
],
1188 0, interface_name
, true)) goto done
;
1192 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LE_OS
],
1193 0, interface_name
, true)) goto done
;
1196 case INTRINSIC_LE_OS
:
1197 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LE
],
1198 0, interface_name
, true)) goto done
;
1208 gfc_current_ns
= old_ns
;
1213 symbol_rank (gfc_symbol
*sym
)
1215 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1219 /* Given a symbol of a formal argument list and an expression, if the
1220 formal argument is allocatable, check that the actual argument is
1221 allocatable. Returns nonzero if compatible, zero if not compatible. */
1224 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1226 symbol_attribute attr
;
1228 if (formal
->attr
.allocatable
)
1230 attr
= gfc_expr_attr (actual
);
1231 if (!attr
.allocatable
)
1239 /* Given a symbol of a formal argument list and an expression, if the
1240 formal argument is a pointer, see if the actual argument is a
1241 pointer. Returns nonzero if compatible, zero if not compatible. */
1244 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1246 symbol_attribute attr
;
1248 if (formal
->attr
.pointer
)
1250 attr
= gfc_expr_attr (actual
);
1259 /* Given a symbol of a formal argument list and an expression, see if
1260 the two are compatible as arguments. Returns nonzero if
1261 compatible, zero if not compatible. */
1264 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1265 int ranks_must_agree
, int is_elemental
)
1269 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1270 procs c_f_pointer or c_f_procpointer, and we need to accept most
1271 pointers the user could give us. This should allow that. */
1272 if (formal
->ts
.type
== BT_VOID
)
1275 if (formal
->ts
.type
== BT_DERIVED
1276 && formal
->ts
.derived
&& formal
->ts
.derived
->ts
.is_iso_c
1277 && actual
->ts
.type
== BT_DERIVED
1278 && actual
->ts
.derived
&& actual
->ts
.derived
->ts
.is_iso_c
)
1281 if (actual
->ts
.type
== BT_PROCEDURE
)
1283 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1286 if (formal
->attr
.function
1287 && !compare_type_rank (formal
, actual
->symtree
->n
.sym
))
1290 if (formal
->attr
.if_source
== IFSRC_UNKNOWN
1291 || actual
->symtree
->n
.sym
->attr
.external
)
1292 return 1; /* Assume match. */
1294 return compare_interfaces (formal
, actual
->symtree
->n
.sym
, 0);
1297 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1298 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1301 if (symbol_rank (formal
) == actual
->rank
)
1304 /* At this point the ranks didn't agree. */
1305 if (ranks_must_agree
|| formal
->attr
.pointer
)
1308 if (actual
->rank
!= 0)
1309 return is_elemental
|| formal
->attr
.dimension
;
1311 /* At this point, we are considering a scalar passed to an array.
1312 This is legal if the scalar is an array element of the right sort. */
1313 if (formal
->as
->type
== AS_ASSUMED_SHAPE
)
1316 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1317 if (ref
->type
== REF_SUBSTRING
)
1320 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1321 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1325 return 0; /* Not an array element. */
1331 /* Given a symbol of a formal argument list and an expression, see if
1332 the two are compatible as arguments. Returns nonzero if
1333 compatible, zero if not compatible. */
1336 compare_parameter_protected (gfc_symbol
*formal
, gfc_expr
*actual
)
1338 if (actual
->expr_type
!= EXPR_VARIABLE
)
1341 if (!actual
->symtree
->n
.sym
->attr
.protected)
1344 if (!actual
->symtree
->n
.sym
->attr
.use_assoc
)
1347 if (formal
->attr
.intent
== INTENT_IN
1348 || formal
->attr
.intent
== INTENT_UNKNOWN
)
1351 if (!actual
->symtree
->n
.sym
->attr
.pointer
)
1354 if (actual
->symtree
->n
.sym
->attr
.pointer
&& formal
->attr
.pointer
)
1361 /* Returns the storage size of a symbol (formal argument) or
1362 zero if it cannot be determined. */
1364 static unsigned long
1365 get_sym_storage_size (gfc_symbol
*sym
)
1368 unsigned long strlen
, elements
;
1370 if (sym
->ts
.type
== BT_CHARACTER
)
1372 if (sym
->ts
.cl
&& sym
->ts
.cl
->length
1373 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1374 strlen
= mpz_get_ui (sym
->ts
.cl
->length
->value
.integer
);
1381 if (symbol_rank (sym
) == 0)
1385 if (sym
->as
->type
!= AS_EXPLICIT
)
1387 for (i
= 0; i
< sym
->as
->rank
; i
++)
1389 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1390 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1393 elements
*= mpz_get_ui (sym
->as
->upper
[i
]->value
.integer
)
1394 - mpz_get_ui (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1397 return strlen
*elements
;
1401 /* Returns the storage size of an expression (actual argument) or
1402 zero if it cannot be determined. For an array element, it returns
1403 the remaining size as the element sequence consists of all storage
1404 units of the actual argument up to the end of the array. */
1406 static unsigned long
1407 get_expr_storage_size (gfc_expr
*e
)
1410 long int strlen
, elements
;
1416 if (e
->ts
.type
== BT_CHARACTER
)
1418 if (e
->ts
.cl
&& e
->ts
.cl
->length
1419 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1420 strlen
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
1421 else if (e
->expr_type
== EXPR_CONSTANT
1422 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
1423 strlen
= e
->value
.character
.length
;
1428 strlen
= 1; /* Length per element. */
1430 if (e
->rank
== 0 && !e
->ref
)
1438 for (i
= 0; i
< e
->rank
; i
++)
1439 elements
*= mpz_get_si (e
->shape
[i
]);
1440 return elements
*strlen
;
1443 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1445 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1446 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1447 && ref
->u
.ar
.as
->upper
)
1448 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1450 long int start
, end
, stride
;
1453 if (ref
->u
.ar
.stride
[i
])
1455 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1456 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1461 if (ref
->u
.ar
.start
[i
])
1463 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1464 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1468 else if (ref
->u
.ar
.as
->lower
[i
]
1469 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1470 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1474 if (ref
->u
.ar
.end
[i
])
1476 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1477 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1481 else if (ref
->u
.ar
.as
->upper
[i
]
1482 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1483 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1487 elements
*= (end
- start
)/stride
+ 1L;
1489 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1490 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1491 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1493 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1494 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1495 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1496 elements
*= mpz_get_ui (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1497 - mpz_get_ui (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1503 /* TODO: Determine the number of remaining elements in the element
1504 sequence for array element designators.
1505 See also get_array_index in data.c. */
1509 return elements
*strlen
;
1513 /* Given an expression, check whether it is an array section
1514 which has a vector subscript. If it has, one is returned,
1518 has_vector_subscript (gfc_expr
*e
)
1523 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1526 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1527 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1528 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1529 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1536 /* Given formal and actual argument lists, see if they are compatible.
1537 If they are compatible, the actual argument list is sorted to
1538 correspond with the formal list, and elements for missing optional
1539 arguments are inserted. If WHERE pointer is nonnull, then we issue
1540 errors when things don't match instead of just returning the status
1544 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1545 int ranks_must_agree
, int is_elemental
, locus
*where
)
1547 gfc_actual_arglist
**new, *a
, *actual
, temp
;
1548 gfc_formal_arglist
*f
;
1551 unsigned long actual_size
, formal_size
;
1555 if (actual
== NULL
&& formal
== NULL
)
1559 for (f
= formal
; f
; f
= f
->next
)
1562 new = (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1564 for (i
= 0; i
< n
; i
++)
1571 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1573 /* Look for keywords but ignore g77 extensions like %VAL. */
1574 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1577 for (f
= formal
; f
; f
= f
->next
, i
++)
1581 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1588 gfc_error ("Keyword argument '%s' at %L is not in "
1589 "the procedure", a
->name
, &a
->expr
->where
);
1596 gfc_error ("Keyword argument '%s' at %L is already associated "
1597 "with another actual argument", a
->name
,
1606 gfc_error ("More actual than formal arguments in procedure "
1607 "call at %L", where
);
1612 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1618 gfc_error ("Missing alternate return spec in subroutine call "
1623 if (a
->expr
== NULL
)
1626 gfc_error ("Unexpected alternate return spec in subroutine "
1627 "call at %L", where
);
1631 rank_check
= where
!= NULL
&& !is_elemental
&& f
->sym
->as
1632 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1633 || f
->sym
->as
->type
== AS_DEFERRED
);
1635 if (f
->sym
->ts
.type
== BT_CHARACTER
&& a
->expr
->ts
.type
== BT_CHARACTER
1636 && a
->expr
->rank
== 0
1637 && f
->sym
->as
&& f
->sym
->as
->type
!= AS_ASSUMED_SHAPE
)
1639 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1641 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
1642 "with array dummy argument '%s' at %L",
1643 f
->sym
->name
, &a
->expr
->where
);
1646 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1650 else if (!compare_parameter (f
->sym
, a
->expr
,
1651 ranks_must_agree
|| rank_check
, is_elemental
))
1654 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1655 f
->sym
->name
, &a
->expr
->where
);
1659 if (a
->expr
->ts
.type
== BT_CHARACTER
1660 && a
->expr
->ts
.cl
&& a
->expr
->ts
.cl
->length
1661 && a
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
1662 && f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
->length
1663 && f
->sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1665 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
1666 && (mpz_cmp (a
->expr
->ts
.cl
->length
->value
.integer
,
1667 f
->sym
->ts
.cl
->length
->value
.integer
) != 0))
1670 gfc_warning ("Character length mismatch between actual "
1671 "argument and pointer or allocatable dummy "
1672 "argument '%s' at %L",
1673 f
->sym
->name
, &a
->expr
->where
);
1678 actual_size
= get_expr_storage_size (a
->expr
);
1679 formal_size
= get_sym_storage_size (f
->sym
);
1680 if (actual_size
!= 0 && actual_size
< formal_size
)
1682 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
1683 gfc_warning ("Character length of actual argument shorter "
1684 "than of dummy argument '%s' (%d/%d) at %L",
1685 f
->sym
->name
, (int) actual_size
,
1686 (int) formal_size
, &a
->expr
->where
);
1688 gfc_warning ("Actual argument contains too few "
1689 "elements for dummy argument '%s' (%d/%d) at %L",
1690 f
->sym
->name
, (int) actual_size
,
1691 (int) formal_size
, &a
->expr
->where
);
1695 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1696 provided for a procedure formal argument. */
1697 if (a
->expr
->ts
.type
!= BT_PROCEDURE
1698 && a
->expr
->expr_type
== EXPR_VARIABLE
1699 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1702 gfc_error ("Expected a procedure for argument '%s' at %L",
1703 f
->sym
->name
, &a
->expr
->where
);
1707 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
1708 && a
->expr
->ts
.type
== BT_PROCEDURE
1709 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
1712 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1713 f
->sym
->name
, &a
->expr
->where
);
1717 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1718 && a
->expr
->expr_type
== EXPR_VARIABLE
1719 && a
->expr
->symtree
->n
.sym
->as
1720 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
1721 && (a
->expr
->ref
== NULL
1722 || (a
->expr
->ref
->type
== REF_ARRAY
1723 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
1726 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1727 " array at %L", f
->sym
->name
, where
);
1731 if (a
->expr
->expr_type
!= EXPR_NULL
1732 && compare_pointer (f
->sym
, a
->expr
) == 0)
1735 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1736 f
->sym
->name
, &a
->expr
->where
);
1740 if (a
->expr
->expr_type
!= EXPR_NULL
1741 && compare_allocatable (f
->sym
, a
->expr
) == 0)
1744 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1745 f
->sym
->name
, &a
->expr
->where
);
1749 /* Check intent = OUT/INOUT for definable actual argument. */
1750 if (a
->expr
->expr_type
!= EXPR_VARIABLE
1751 && (f
->sym
->attr
.intent
== INTENT_OUT
1752 || f
->sym
->attr
.intent
== INTENT_INOUT
))
1755 gfc_error ("Actual argument at %L must be definable to "
1756 "match dummy INTENT = OUT/INOUT", &a
->expr
->where
);
1760 if (!compare_parameter_protected(f
->sym
, a
->expr
))
1763 gfc_error ("Actual argument at %L is use-associated with "
1764 "PROTECTED attribute and dummy argument '%s' is "
1765 "INTENT = OUT/INOUT",
1766 &a
->expr
->where
,f
->sym
->name
);
1770 if ((f
->sym
->attr
.intent
== INTENT_OUT
1771 || f
->sym
->attr
.intent
== INTENT_INOUT
1772 || f
->sym
->attr
.volatile_
)
1773 && has_vector_subscript (a
->expr
))
1776 gfc_error ("Array-section actual argument with vector subscripts "
1777 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1778 "or VOLATILE attribute of the dummy argument '%s'",
1779 &a
->expr
->where
, f
->sym
->name
);
1783 /* C1232 (R1221) For an actual argument which is an array section or
1784 an assumed-shape array, the dummy argument shall be an assumed-
1785 shape array, if the dummy argument has the VOLATILE attribute. */
1787 if (f
->sym
->attr
.volatile_
1788 && a
->expr
->symtree
->n
.sym
->as
1789 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1790 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1793 gfc_error ("Assumed-shape actual argument at %L is "
1794 "incompatible with the non-assumed-shape "
1795 "dummy argument '%s' due to VOLATILE attribute",
1796 &a
->expr
->where
,f
->sym
->name
);
1800 if (f
->sym
->attr
.volatile_
1801 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
1802 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1805 gfc_error ("Array-section actual argument at %L is "
1806 "incompatible with the non-assumed-shape "
1807 "dummy argument '%s' due to VOLATILE attribute",
1808 &a
->expr
->where
,f
->sym
->name
);
1812 /* C1233 (R1221) For an actual argument which is a pointer array, the
1813 dummy argument shall be an assumed-shape or pointer array, if the
1814 dummy argument has the VOLATILE attribute. */
1816 if (f
->sym
->attr
.volatile_
1817 && a
->expr
->symtree
->n
.sym
->attr
.pointer
1818 && a
->expr
->symtree
->n
.sym
->as
1820 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1821 || f
->sym
->attr
.pointer
)))
1824 gfc_error ("Pointer-array actual argument at %L requires "
1825 "an assumed-shape or pointer-array dummy "
1826 "argument '%s' due to VOLATILE attribute",
1827 &a
->expr
->where
,f
->sym
->name
);
1838 /* Make sure missing actual arguments are optional. */
1840 for (f
= formal
; f
; f
= f
->next
, i
++)
1847 gfc_error ("Missing alternate return spec in subroutine call "
1851 if (!f
->sym
->attr
.optional
)
1854 gfc_error ("Missing actual argument for argument '%s' at %L",
1855 f
->sym
->name
, where
);
1860 /* The argument lists are compatible. We now relink a new actual
1861 argument list with null arguments in the right places. The head
1862 of the list remains the head. */
1863 for (i
= 0; i
< n
; i
++)
1865 new[i
] = gfc_get_actual_arglist ();
1878 for (i
= 0; i
< n
- 1; i
++)
1879 new[i
]->next
= new[i
+ 1];
1881 new[i
]->next
= NULL
;
1883 if (*ap
== NULL
&& n
> 0)
1886 /* Note the types of omitted optional arguments. */
1887 for (a
= actual
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
1888 if (a
->expr
== NULL
&& a
->label
== NULL
)
1889 a
->missing_arg_type
= f
->sym
->ts
.type
;
1897 gfc_formal_arglist
*f
;
1898 gfc_actual_arglist
*a
;
1902 /* qsort comparison function for argument pairs, with the following
1904 - p->a->expr == NULL
1905 - p->a->expr->expr_type != EXPR_VARIABLE
1906 - growing p->a->expr->symbol. */
1909 pair_cmp (const void *p1
, const void *p2
)
1911 const gfc_actual_arglist
*a1
, *a2
;
1913 /* *p1 and *p2 are elements of the to-be-sorted array. */
1914 a1
= ((const argpair
*) p1
)->a
;
1915 a2
= ((const argpair
*) p2
)->a
;
1924 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
1926 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1930 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1932 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
1936 /* Given two expressions from some actual arguments, test whether they
1937 refer to the same expression. The analysis is conservative.
1938 Returning FAILURE will produce no warning. */
1941 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
1943 const gfc_ref
*r1
, *r2
;
1946 || e1
->expr_type
!= EXPR_VARIABLE
1947 || e2
->expr_type
!= EXPR_VARIABLE
1948 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
1951 /* TODO: improve comparison, see expr.c:show_ref(). */
1952 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
1954 if (r1
->type
!= r2
->type
)
1959 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
1961 /* TODO: At the moment, consider only full arrays;
1962 we could do better. */
1963 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
1968 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
1976 gfc_internal_error ("compare_actual_expr(): Bad component code");
1985 /* Given formal and actual argument lists that correspond to one
1986 another, check that identical actual arguments aren't not
1987 associated with some incompatible INTENTs. */
1990 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
1992 sym_intent f1_intent
, f2_intent
;
1993 gfc_formal_arglist
*f1
;
1994 gfc_actual_arglist
*a1
;
2000 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2002 if (f1
== NULL
&& a1
== NULL
)
2004 if (f1
== NULL
|| a1
== NULL
)
2005 gfc_internal_error ("check_some_aliasing(): List mismatch");
2010 p
= (argpair
*) alloca (n
* sizeof (argpair
));
2012 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2018 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2020 for (i
= 0; i
< n
; i
++)
2023 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2024 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2026 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2027 for (j
= i
+ 1; j
< n
; j
++)
2029 /* Expected order after the sort. */
2030 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2031 gfc_internal_error ("check_some_aliasing(): corrupted data");
2033 /* Are the expression the same? */
2034 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2036 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2037 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2038 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2040 gfc_warning ("Same actual argument associated with INTENT(%s) "
2041 "argument '%s' and INTENT(%s) argument '%s' at %L",
2042 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2043 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2044 &p
[i
].a
->expr
->where
);
2054 /* Given a symbol of a formal argument list and an expression,
2055 return nonzero if their intents are compatible, zero otherwise. */
2058 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2060 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2063 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2066 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2073 /* Given formal and actual argument lists that correspond to one
2074 another, check that they are compatible in the sense that intents
2075 are not mismatched. */
2078 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2080 sym_intent f_intent
;
2082 for (;; f
= f
->next
, a
= a
->next
)
2084 if (f
== NULL
&& a
== NULL
)
2086 if (f
== NULL
|| a
== NULL
)
2087 gfc_internal_error ("check_intents(): List mismatch");
2089 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2092 f_intent
= f
->sym
->attr
.intent
;
2094 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2096 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2097 "specifies INTENT(%s)", &a
->expr
->where
,
2098 gfc_intent_string (f_intent
));
2102 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2104 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2106 gfc_error ("Procedure argument at %L is local to a PURE "
2107 "procedure and is passed to an INTENT(%s) argument",
2108 &a
->expr
->where
, gfc_intent_string (f_intent
));
2112 if (a
->expr
->symtree
->n
.sym
->attr
.pointer
)
2114 gfc_error ("Procedure argument at %L is local to a PURE "
2115 "procedure and has the POINTER attribute",
2126 /* Check how a procedure is used against its interface. If all goes
2127 well, the actual argument list will also end up being properly
2131 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2134 /* Warn about calls with an implicit interface. */
2135 if (gfc_option
.warn_implicit_interface
2136 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2137 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2140 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2141 || !compare_actual_formal (ap
, sym
->formal
, 0,
2142 sym
->attr
.elemental
, where
))
2145 check_intents (sym
->formal
, *ap
);
2146 if (gfc_option
.warn_aliasing
)
2147 check_some_aliasing (sym
->formal
, *ap
);
2151 /* Given an interface pointer and an actual argument list, search for
2152 a formal argument list that matches the actual. If found, returns
2153 a pointer to the symbol of the correct interface. Returns NULL if
2157 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2158 gfc_actual_arglist
**ap
)
2162 for (; intr
; intr
= intr
->next
)
2164 if (sub_flag
&& intr
->sym
->attr
.function
)
2166 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2169 r
= !intr
->sym
->attr
.elemental
;
2171 if (compare_actual_formal (ap
, intr
->sym
->formal
, r
, !r
, NULL
))
2173 check_intents (intr
->sym
->formal
, *ap
);
2174 if (gfc_option
.warn_aliasing
)
2175 check_some_aliasing (intr
->sym
->formal
, *ap
);
2184 /* Do a brute force recursive search for a symbol. */
2186 static gfc_symtree
*
2187 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2191 if (root
->n
.sym
== sym
)
2196 st
= find_symtree0 (root
->left
, sym
);
2197 if (root
->right
&& ! st
)
2198 st
= find_symtree0 (root
->right
, sym
);
2203 /* Find a symtree for a symbol. */
2205 static gfc_symtree
*
2206 find_sym_in_symtree (gfc_symbol
*sym
)
2211 /* First try to find it by name. */
2212 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2213 if (st
&& st
->n
.sym
== sym
)
2216 /* If it's been renamed, resort to a brute-force search. */
2217 /* TODO: avoid having to do this search. If the symbol doesn't exist
2218 in the symtree for the current namespace, it should probably be added. */
2219 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2221 st
= find_symtree0 (ns
->sym_root
, sym
);
2225 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2230 /* This subroutine is called when an expression is being resolved.
2231 The expression node in question is either a user defined operator
2232 or an intrinsic operator with arguments that aren't compatible
2233 with the operator. This subroutine builds an actual argument list
2234 corresponding to the operands, then searches for a compatible
2235 interface. If one is found, the expression node is replaced with
2236 the appropriate function call. */
2239 gfc_extend_expr (gfc_expr
*e
)
2241 gfc_actual_arglist
*actual
;
2249 actual
= gfc_get_actual_arglist ();
2250 actual
->expr
= e
->value
.op
.op1
;
2252 if (e
->value
.op
.op2
!= NULL
)
2254 actual
->next
= gfc_get_actual_arglist ();
2255 actual
->next
->expr
= e
->value
.op
.op2
;
2258 i
= fold_unary (e
->value
.op
.operator);
2260 if (i
== INTRINSIC_USER
)
2262 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2264 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2268 sym
= gfc_search_interface (uop
->operator, 0, &actual
);
2275 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2277 /* Due to the distinction between '==' and '.eq.' and friends, one has
2278 to check if either is defined. */
2282 case INTRINSIC_EQ_OS
:
2283 sym
= gfc_search_interface (ns
->operator[INTRINSIC_EQ
], 0, &actual
);
2285 sym
= gfc_search_interface (ns
->operator[INTRINSIC_EQ_OS
], 0, &actual
);
2289 case INTRINSIC_NE_OS
:
2290 sym
= gfc_search_interface (ns
->operator[INTRINSIC_NE
], 0, &actual
);
2292 sym
= gfc_search_interface (ns
->operator[INTRINSIC_NE_OS
], 0, &actual
);
2296 case INTRINSIC_GT_OS
:
2297 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GT
], 0, &actual
);
2299 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GT_OS
], 0, &actual
);
2303 case INTRINSIC_GE_OS
:
2304 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GE
], 0, &actual
);
2306 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GE_OS
], 0, &actual
);
2310 case INTRINSIC_LT_OS
:
2311 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LT
], 0, &actual
);
2313 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LT_OS
], 0, &actual
);
2317 case INTRINSIC_LE_OS
:
2318 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LE
], 0, &actual
);
2320 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LE_OS
], 0, &actual
);
2324 sym
= gfc_search_interface (ns
->operator[i
], 0, &actual
);
2334 /* Don't use gfc_free_actual_arglist(). */
2335 if (actual
->next
!= NULL
)
2336 gfc_free (actual
->next
);
2342 /* Change the expression node to a function call. */
2343 e
->expr_type
= EXPR_FUNCTION
;
2344 e
->symtree
= find_sym_in_symtree (sym
);
2345 e
->value
.function
.actual
= actual
;
2346 e
->value
.function
.esym
= NULL
;
2347 e
->value
.function
.isym
= NULL
;
2348 e
->value
.function
.name
= NULL
;
2350 if (gfc_pure (NULL
) && !gfc_pure (sym
))
2352 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2353 "be PURE", sym
->name
, &e
->where
);
2357 if (gfc_resolve_expr (e
) == FAILURE
)
2364 /* Tries to replace an assignment code node with a subroutine call to
2365 the subroutine associated with the assignment operator. Return
2366 SUCCESS if the node was replaced. On FAILURE, no error is
2370 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
2372 gfc_actual_arglist
*actual
;
2373 gfc_expr
*lhs
, *rhs
;
2379 /* Don't allow an intrinsic assignment to be replaced. */
2380 if (lhs
->ts
.type
!= BT_DERIVED
&& rhs
->ts
.type
!= BT_DERIVED
2381 && (lhs
->ts
.type
== rhs
->ts
.type
2382 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
2385 actual
= gfc_get_actual_arglist ();
2388 actual
->next
= gfc_get_actual_arglist ();
2389 actual
->next
->expr
= rhs
;
2393 for (; ns
; ns
= ns
->parent
)
2395 sym
= gfc_search_interface (ns
->operator[INTRINSIC_ASSIGN
], 1, &actual
);
2402 gfc_free (actual
->next
);
2407 /* Replace the assignment with the call. */
2408 c
->op
= EXEC_ASSIGN_CALL
;
2409 c
->symtree
= find_sym_in_symtree (sym
);
2412 c
->ext
.actual
= actual
;
2418 /* Make sure that the interface just parsed is not already present in
2419 the given interface list. Ambiguity isn't checked yet since module
2420 procedures can be present without interfaces. */
2423 check_new_interface (gfc_interface
*base
, gfc_symbol
*new)
2427 for (ip
= base
; ip
; ip
= ip
->next
)
2431 gfc_error ("Entity '%s' at %C is already present in the interface",
2441 /* Add a symbol to the current interface. */
2444 gfc_add_interface (gfc_symbol
*new)
2446 gfc_interface
**head
, *intr
;
2450 switch (current_interface
.type
)
2452 case INTERFACE_NAMELESS
:
2455 case INTERFACE_INTRINSIC_OP
:
2456 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2457 switch (current_interface
.op
)
2460 case INTRINSIC_EQ_OS
:
2461 if (check_new_interface (ns
->operator[INTRINSIC_EQ
], new) == FAILURE
||
2462 check_new_interface (ns
->operator[INTRINSIC_EQ_OS
], new) == FAILURE
)
2467 case INTRINSIC_NE_OS
:
2468 if (check_new_interface (ns
->operator[INTRINSIC_NE
], new) == FAILURE
||
2469 check_new_interface (ns
->operator[INTRINSIC_NE_OS
], new) == FAILURE
)
2474 case INTRINSIC_GT_OS
:
2475 if (check_new_interface (ns
->operator[INTRINSIC_GT
], new) == FAILURE
||
2476 check_new_interface (ns
->operator[INTRINSIC_GT_OS
], new) == FAILURE
)
2481 case INTRINSIC_GE_OS
:
2482 if (check_new_interface (ns
->operator[INTRINSIC_GE
], new) == FAILURE
||
2483 check_new_interface (ns
->operator[INTRINSIC_GE_OS
], new) == FAILURE
)
2488 case INTRINSIC_LT_OS
:
2489 if (check_new_interface (ns
->operator[INTRINSIC_LT
], new) == FAILURE
||
2490 check_new_interface (ns
->operator[INTRINSIC_LT_OS
], new) == FAILURE
)
2495 case INTRINSIC_LE_OS
:
2496 if (check_new_interface (ns
->operator[INTRINSIC_LE
], new) == FAILURE
||
2497 check_new_interface (ns
->operator[INTRINSIC_LE_OS
], new) == FAILURE
)
2502 if (check_new_interface (ns
->operator[current_interface
.op
], new) == FAILURE
)
2506 head
= ¤t_interface
.ns
->operator[current_interface
.op
];
2509 case INTERFACE_GENERIC
:
2510 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2512 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
2516 if (check_new_interface (sym
->generic
, new) == FAILURE
)
2520 head
= ¤t_interface
.sym
->generic
;
2523 case INTERFACE_USER_OP
:
2524 if (check_new_interface (current_interface
.uop
->operator, new)
2528 head
= ¤t_interface
.uop
->operator;
2532 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2535 intr
= gfc_get_interface ();
2537 intr
->where
= gfc_current_locus
;
2546 /* Gets rid of a formal argument list. We do not free symbols.
2547 Symbols are freed when a namespace is freed. */
2550 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
2552 gfc_formal_arglist
*q
;