1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
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. */
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)
104 case INTRINSIC_UPLUS
:
105 operator = INTRINSIC_PLUS
;
107 case INTRINSIC_UMINUS
:
108 operator = INTRINSIC_MINUS
;
118 /* Match a generic specification. Depending on which type of
119 interface is found, the 'name' or 'operator' pointers may be set.
120 This subroutine doesn't return MATCH_NO. */
123 gfc_match_generic_spec (interface_type
* type
,
125 gfc_intrinsic_op
*operator)
127 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
131 if (gfc_match (" assignment ( = )") == MATCH_YES
)
133 *type
= INTERFACE_INTRINSIC_OP
;
134 *operator = INTRINSIC_ASSIGN
;
138 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
140 *type
= INTERFACE_INTRINSIC_OP
;
141 *operator = fold_unary (i
);
145 if (gfc_match (" operator ( ") == MATCH_YES
)
147 m
= gfc_match_defined_op_name (buffer
, 1);
153 m
= gfc_match_char (')');
159 strcpy (name
, buffer
);
160 *type
= INTERFACE_USER_OP
;
164 if (gfc_match_name (buffer
) == MATCH_YES
)
166 strcpy (name
, buffer
);
167 *type
= INTERFACE_GENERIC
;
171 *type
= INTERFACE_NAMELESS
;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five forms of an interface statement. */
183 gfc_match_interface (void)
185 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
188 gfc_intrinsic_op
operator;
191 m
= gfc_match_space ();
193 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type
!= INTERFACE_NAMELESS
204 ("Syntax error: Trailing garbage in INTERFACE statement at %C");
208 current_interface
.type
= type
;
212 case INTERFACE_GENERIC
:
213 if (gfc_get_symbol (name
, NULL
, &sym
))
216 if (!sym
->attr
.generic
217 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
220 current_interface
.sym
= gfc_new_block
= sym
;
223 case INTERFACE_USER_OP
:
224 current_interface
.uop
= gfc_get_uop (name
);
227 case INTERFACE_INTRINSIC_OP
:
228 current_interface
.op
= operator;
231 case INTERFACE_NAMELESS
:
239 /* Match the different sort of generic-specs that can be present after
240 the END INTERFACE itself. */
243 gfc_match_end_interface (void)
245 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
247 gfc_intrinsic_op
operator;
250 m
= gfc_match_space ();
252 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
255 /* If we're not looking at the end of the statement now, or if this
256 is not a nameless interface but we did not see a space, punt. */
257 if (gfc_match_eos () != MATCH_YES
258 || (type
!= INTERFACE_NAMELESS
262 ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
268 switch (current_interface
.type
)
270 case INTERFACE_NAMELESS
:
271 if (type
!= current_interface
.type
)
273 gfc_error ("Expected a nameless interface at %C");
279 case INTERFACE_INTRINSIC_OP
:
280 if (type
!= current_interface
.type
|| operator != current_interface
.op
)
283 if (current_interface
.op
== INTRINSIC_ASSIGN
)
284 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
286 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
287 gfc_op2string (current_interface
.op
));
294 case INTERFACE_USER_OP
:
295 /* Comparing the symbol node names is OK because only use-associated
296 symbols can be renamed. */
297 if (type
!= current_interface
.type
298 || strcmp (current_interface
.sym
->name
, name
) != 0)
300 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
301 current_interface
.sym
->name
);
307 case INTERFACE_GENERIC
:
308 if (type
!= current_interface
.type
309 || strcmp (current_interface
.sym
->name
, name
) != 0)
311 gfc_error ("Expecting 'END INTERFACE %s' at %C",
312 current_interface
.sym
->name
);
323 /* Compare two typespecs, recursively if necessary. */
326 gfc_compare_types (gfc_typespec
* ts1
, gfc_typespec
* ts2
)
328 gfc_component
*dt1
, *dt2
;
330 if (ts1
->type
!= ts2
->type
)
332 if (ts1
->type
!= BT_DERIVED
)
333 return (ts1
->kind
== ts2
->kind
);
335 /* Compare derived types. */
336 if (ts1
->derived
== ts2
->derived
)
339 /* Special case for comparing derived types across namespaces. If the
340 true names and module names are the same and the module name is
341 nonnull, then they are equal. */
342 if (strcmp (ts1
->derived
->name
, ts2
->derived
->name
) == 0
343 && ((ts1
->derived
->module
== NULL
&& ts2
->derived
->module
== NULL
)
344 || (ts1
->derived
!= NULL
&& ts2
->derived
!= NULL
345 && strcmp (ts1
->derived
->module
, ts2
->derived
->module
) == 0)))
348 /* Compare type via the rules of the standard. Both types must have
349 the SEQUENCE attribute to be equal. */
351 if (strcmp (ts1
->derived
->name
, ts2
->derived
->name
))
354 dt1
= ts1
->derived
->components
;
355 dt2
= ts2
->derived
->components
;
357 if (ts1
->derived
->attr
.sequence
== 0 || ts2
->derived
->attr
.sequence
== 0)
360 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
361 simple test can speed things up. Otherwise, lots of things have to
365 if (strcmp (dt1
->name
, dt2
->name
) != 0)
368 if (dt1
->pointer
!= dt2
->pointer
)
371 if (dt1
->dimension
!= dt2
->dimension
)
374 if (dt1
->dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
377 if (gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
383 if (dt1
== NULL
&& dt2
== NULL
)
385 if (dt1
== NULL
|| dt2
== NULL
)
393 /* Given two symbols that are formal arguments, compare their ranks
394 and types. Returns nonzero if they have the same rank and type,
398 compare_type_rank (gfc_symbol
* s1
, gfc_symbol
* s2
)
402 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
403 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
406 return 0; /* Ranks differ */
408 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
412 static int compare_interfaces (gfc_symbol
*, gfc_symbol
*, int);
414 /* Given two symbols that are formal arguments, compare their types
415 and rank and their formal interfaces if they are both dummy
416 procedures. Returns nonzero if the same, zero if different. */
419 compare_type_rank_if (gfc_symbol
* s1
, gfc_symbol
* s2
)
422 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
423 return compare_type_rank (s1
, s2
);
425 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
428 /* At this point, both symbols are procedures. */
429 if ((s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
430 || (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0))
433 if (s1
->attr
.function
!= s2
->attr
.function
434 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
437 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
440 return compare_interfaces (s1
, s2
, 0); /* Recurse! */
444 /* Given a formal argument list and a keyword name, search the list
445 for that keyword. Returns the correct symbol node if found, NULL
449 find_keyword_arg (const char *name
, gfc_formal_arglist
* f
)
452 for (; f
; f
= f
->next
)
453 if (strcmp (f
->sym
->name
, name
) == 0)
460 /******** Interface checking subroutines **********/
463 /* Given an operator interface and the operator, make sure that all
464 interfaces for that operator are legal. */
467 check_operator_interface (gfc_interface
* intr
, gfc_intrinsic_op
operator)
469 gfc_formal_arglist
*formal
;
479 t1
= t2
= BT_UNKNOWN
;
480 i1
= i2
= INTENT_UNKNOWN
;
482 for (formal
= intr
->sym
->formal
; formal
; formal
= formal
->next
)
489 i1
= sym
->attr
.intent
;
494 i2
= sym
->attr
.intent
;
499 if (args
== 0 || args
> 2)
504 if (operator == INTRINSIC_ASSIGN
)
506 if (!sym
->attr
.subroutine
)
509 ("Assignment operator interface at %L must be a SUBROUTINE",
516 if (!sym
->attr
.function
)
518 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
526 case INTRINSIC_PLUS
: /* Numeric unary or binary */
527 case INTRINSIC_MINUS
:
531 || t1
== BT_COMPLEX
))
535 && (t1
== BT_INTEGER
|| t1
== BT_REAL
|| t1
== BT_COMPLEX
)
536 && (t2
== BT_INTEGER
|| t2
== BT_REAL
|| t2
== BT_COMPLEX
))
541 case INTRINSIC_POWER
: /* Binary numeric */
542 case INTRINSIC_TIMES
:
543 case INTRINSIC_DIVIDE
:
550 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
|| t1
== BT_COMPLEX
)
551 && (t2
== BT_INTEGER
|| t2
== BT_REAL
|| t2
== BT_COMPLEX
))
556 case INTRINSIC_GE
: /* Binary numeric operators that do not support */
557 case INTRINSIC_LE
: /* complex numbers */
563 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
564 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
569 case INTRINSIC_OR
: /* Binary logical */
575 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
579 case INTRINSIC_NOT
: /* Unary logical */
582 if (t1
== BT_LOGICAL
)
586 case INTRINSIC_CONCAT
: /* Binary string */
589 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
593 case INTRINSIC_ASSIGN
: /* Class by itself */
598 gfc_internal_error ("check_operator_interface(): Bad operator");
601 /* Check intents on operator interfaces. */
602 if (operator == INTRINSIC_ASSIGN
)
604 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
605 gfc_error ("First argument of defined assignment at %L must be "
606 "INTENT(IN) or INTENT(INOUT)", &intr
->where
);
609 gfc_error ("Second argument of defined assignment at %L must be "
610 "INTENT(IN)", &intr
->where
);
615 gfc_error ("First argument of operator interface at %L must be "
616 "INTENT(IN)", &intr
->where
);
618 if (args
== 2 && i2
!= INTENT_IN
)
619 gfc_error ("Second argument of operator interface at %L must be "
620 "INTENT(IN)", &intr
->where
);
626 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
631 gfc_error ("Operator interface at %L has the wrong number of arguments",
637 /* Given a pair of formal argument lists, we see if the two lists can
638 be distinguished by counting the number of nonoptional arguments of
639 a given type/rank in f1 and seeing if there are less then that
640 number of those arguments in f2 (including optional arguments).
641 Since this test is asymmetric, it has to be called twice to make it
642 symmetric. Returns nonzero if the argument lists are incompatible
643 by this test. This subroutine implements rule 1 of section
647 count_types_test (gfc_formal_arglist
* f1
, gfc_formal_arglist
* f2
)
649 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
650 gfc_formal_arglist
*f
;
663 for (f
= f1
; f
; f
= f
->next
)
666 /* Build an array of integers that gives the same integer to
667 arguments of the same type/rank. */
668 arg
= gfc_getmem (n1
* sizeof (arginfo
));
671 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
679 for (i
= 0; i
< n1
; i
++)
681 if (arg
[i
].flag
!= -1)
684 if (arg
[i
].sym
->attr
.optional
)
685 continue; /* Skip optional arguments */
689 /* Find other nonoptional arguments of the same type/rank. */
690 for (j
= i
+ 1; j
< n1
; j
++)
691 if (!arg
[j
].sym
->attr
.optional
692 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
698 /* Now loop over each distinct type found in f1. */
702 for (i
= 0; i
< n1
; i
++)
704 if (arg
[i
].flag
!= k
)
708 for (j
= i
+ 1; j
< n1
; j
++)
709 if (arg
[j
].flag
== k
)
712 /* Count the number of arguments in f2 with that type, including
713 those that are optional. */
716 for (f
= f2
; f
; f
= f
->next
)
717 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
735 /* Perform the abbreviated correspondence test for operators. The
736 arguments cannot be optional and are always ordered correctly,
737 which makes this test much easier than that for generic tests.
739 This subroutine is also used when comparing a formal and actual
740 argument list when an actual parameter is a dummy procedure. At
741 that point, two formal interfaces must be compared for equality
742 which is what happens here. */
745 operator_correspondence (gfc_formal_arglist
* f1
, gfc_formal_arglist
* f2
)
749 if (f1
== NULL
&& f2
== NULL
)
751 if (f1
== NULL
|| f2
== NULL
)
754 if (!compare_type_rank (f1
->sym
, f2
->sym
))
765 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
766 Returns zero if no argument is found that satisfies rule 2, nonzero
769 This test is also not symmetric in f1 and f2 and must be called
770 twice. This test finds problems caused by sorting the actual
771 argument list with keywords. For example:
775 INTEGER :: A ; REAL :: B
779 INTEGER :: A ; REAL :: B
783 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
786 generic_correspondence (gfc_formal_arglist
* f1
, gfc_formal_arglist
* f2
)
789 gfc_formal_arglist
*f2_save
, *g
;
796 if (f1
->sym
->attr
.optional
)
799 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
802 /* Now search for a disambiguating keyword argument starting at
803 the current non-match. */
804 for (g
= f1
; g
; g
= g
->next
)
806 if (g
->sym
->attr
.optional
)
809 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
810 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
824 /* 'Compare' two formal interfaces associated with a pair of symbols.
825 We return nonzero if there exists an actual argument list that
826 would be ambiguous between the two interfaces, zero otherwise. */
829 compare_interfaces (gfc_symbol
* s1
, gfc_symbol
* s2
, int generic_flag
)
831 gfc_formal_arglist
*f1
, *f2
;
833 if (s1
->attr
.function
!= s2
->attr
.function
834 && s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
835 return 0; /* disagreement between function/subroutine */
840 if (f1
== NULL
&& f2
== NULL
)
841 return 1; /* Special case */
843 if (count_types_test (f1
, f2
))
845 if (count_types_test (f2
, f1
))
850 if (generic_correspondence (f1
, f2
))
852 if (generic_correspondence (f2
, f1
))
857 if (operator_correspondence (f1
, f2
))
865 /* Given a pointer to an interface pointer, remove duplicate
866 interfaces and make sure that all symbols are either functions or
867 subroutines. Returns nonzero if something goes wrong. */
870 check_interface0 (gfc_interface
* p
, const char *interface_name
)
872 gfc_interface
*psave
, *q
, *qlast
;
875 /* Make sure all symbols in the interface have been defined as
876 functions or subroutines. */
877 for (; p
; p
= p
->next
)
878 if (!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
880 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
881 "subroutine", p
->sym
->name
, interface_name
,
882 &p
->sym
->declared_at
);
887 /* Remove duplicate interfaces in this interface list. */
888 for (; p
; p
= p
->next
)
892 for (q
= p
->next
; q
;)
894 if (p
->sym
!= q
->sym
)
902 /* Duplicate interface */
903 qlast
->next
= q
->next
;
914 /* Check lists of interfaces to make sure that no two interfaces are
915 ambiguous. Duplicate interfaces (from the same symbol) are OK
919 check_interface1 (gfc_interface
* p
, gfc_interface
* q
,
920 int generic_flag
, const char *interface_name
)
923 for (; p
; p
= p
->next
)
924 for (; q
; q
= q
->next
)
926 if (p
->sym
== q
->sym
)
927 continue; /* Duplicates OK here */
929 if (strcmp (p
->sym
->name
, q
->sym
->name
) == 0
930 && strcmp (p
->sym
->module
, q
->sym
->module
) == 0)
933 if (compare_interfaces (p
->sym
, q
->sym
, generic_flag
))
935 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
936 p
->sym
->name
, q
->sym
->name
, interface_name
, &p
->where
);
945 /* Check the generic and operator interfaces of symbols to make sure
946 that none of the interfaces conflict. The check has to be done
947 after all of the symbols are actually loaded. */
950 check_sym_interfaces (gfc_symbol
* sym
)
952 char interface_name
[100];
955 if (sym
->ns
!= gfc_current_ns
)
958 if (sym
->generic
!= NULL
)
960 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
961 if (check_interface0 (sym
->generic
, interface_name
))
967 if (check_interface1 (sym
->generic
, s2
->generic
, 1, interface_name
))
970 if (s2
->ns
->parent
== NULL
)
972 if (gfc_find_symbol (sym
->name
, s2
->ns
->parent
, 1, &s2
))
980 check_uop_interfaces (gfc_user_op
* uop
)
982 char interface_name
[100];
986 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
987 if (check_interface0 (uop
->operator, interface_name
))
990 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
992 uop2
= gfc_find_uop (uop
->name
, ns
);
996 check_interface1 (uop
->operator, uop2
->operator, 0, interface_name
);
1001 /* For the namespace, check generic, user operator and intrinsic
1002 operator interfaces for consistency and to remove duplicate
1003 interfaces. We traverse the whole namespace, counting on the fact
1004 that most symbols will not have generic or operator interfaces. */
1007 gfc_check_interfaces (gfc_namespace
* ns
)
1009 gfc_namespace
*old_ns
, *ns2
;
1010 char interface_name
[100];
1013 old_ns
= gfc_current_ns
;
1014 gfc_current_ns
= ns
;
1016 gfc_traverse_ns (ns
, check_sym_interfaces
);
1018 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1020 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1022 if (i
== INTRINSIC_USER
)
1025 if (i
== INTRINSIC_ASSIGN
)
1026 strcpy (interface_name
, "intrinsic assignment operator");
1028 sprintf (interface_name
, "intrinsic '%s' operator",
1031 if (check_interface0 (ns
->operator[i
], interface_name
))
1034 check_operator_interface (ns
->operator[i
], i
);
1036 for (ns2
= ns
->parent
; ns2
; ns2
= ns2
->parent
)
1037 if (check_interface1 (ns
->operator[i
], ns2
->operator[i
], 0,
1042 gfc_current_ns
= old_ns
;
1047 symbol_rank (gfc_symbol
* sym
)
1050 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1054 /* Given a symbol of a formal argument list and an expression, if the
1055 formal argument is a pointer, see if the actual argument is a
1056 pointer. Returns nonzero if compatible, zero if not compatible. */
1059 compare_pointer (gfc_symbol
* formal
, gfc_expr
* actual
)
1061 symbol_attribute attr
;
1063 if (formal
->attr
.pointer
)
1065 attr
= gfc_expr_attr (actual
);
1074 /* Given a symbol of a formal argument list and an expression, see if
1075 the two are compatible as arguments. Returns nonzero if
1076 compatible, zero if not compatible. */
1079 compare_parameter (gfc_symbol
* formal
, gfc_expr
* actual
,
1080 int ranks_must_agree
, int is_elemental
)
1084 if (actual
->ts
.type
== BT_PROCEDURE
)
1086 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1089 if (formal
->attr
.function
1090 && !compare_type_rank (formal
, actual
->symtree
->n
.sym
))
1093 if (formal
->attr
.if_source
== IFSRC_UNKNOWN
)
1094 return 1; /* Assume match */
1096 return compare_interfaces (formal
, actual
->symtree
->n
.sym
, 0);
1099 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1100 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1103 if (symbol_rank (formal
) == actual
->rank
)
1106 /* At this point the ranks didn't agree. */
1107 if (ranks_must_agree
|| formal
->attr
.pointer
)
1110 if (actual
->rank
!= 0)
1111 return is_elemental
|| formal
->attr
.dimension
;
1113 /* At this point, we are considering a scalar passed to an array.
1114 This is legal if the scalar is an array element of the right sort. */
1115 if (formal
->as
->type
== AS_ASSUMED_SHAPE
)
1118 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1119 if (ref
->type
== REF_SUBSTRING
)
1122 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1123 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1127 return 0; /* Not an array element */
1133 /* Given formal and actual argument lists, see if they are compatible.
1134 If they are compatible, the actual argument list is sorted to
1135 correspond with the formal list, and elements for missing optional
1136 arguments are inserted. If WHERE pointer is nonnull, then we issue
1137 errors when things don't match instead of just returning the status
1141 compare_actual_formal (gfc_actual_arglist
** ap
,
1142 gfc_formal_arglist
* formal
,
1143 int ranks_must_agree
, int is_elemental
, locus
* where
)
1145 gfc_actual_arglist
**new, *a
, *actual
, temp
;
1146 gfc_formal_arglist
*f
;
1151 if (actual
== NULL
&& formal
== NULL
)
1155 for (f
= formal
; f
; f
= f
->next
)
1158 new = (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1160 for (i
= 0; i
< n
; i
++)
1167 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1169 if (a
->name
!= NULL
)
1172 for (f
= formal
; f
; f
= f
->next
, i
++)
1176 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1184 ("Keyword argument '%s' at %L is not in the procedure",
1185 a
->name
, &a
->expr
->where
);
1193 ("Keyword argument '%s' at %L is already associated "
1194 "with another actual argument", a
->name
, &a
->expr
->where
);
1203 ("More actual than formal arguments in procedure call at %L",
1209 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1216 ("Missing alternate return spec in subroutine call at %L",
1221 if (a
->expr
== NULL
)
1225 ("Unexpected alternate return spec in subroutine call at %L",
1230 if (!compare_parameter
1231 (f
->sym
, a
->expr
, ranks_must_agree
, is_elemental
))
1234 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1235 f
->sym
->name
, &a
->expr
->where
);
1239 if (a
->expr
->expr_type
!= EXPR_NULL
1240 && compare_pointer (f
->sym
, a
->expr
) == 0)
1243 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1244 f
->sym
->name
, &a
->expr
->where
);
1255 /* Make sure missing actual arguments are optional. */
1257 for (f
= formal
; f
; f
= f
->next
, i
++)
1261 if (!f
->sym
->attr
.optional
)
1264 gfc_error ("Missing actual argument for argument '%s' at %L",
1265 f
->sym
->name
, where
);
1270 /* The argument lists are compatible. We now relink a new actual
1271 argument list with null arguments in the right places. The head
1272 of the list remains the head. */
1273 for (i
= 0; i
< n
; i
++)
1275 new[i
] = gfc_get_actual_arglist ();
1288 for (i
= 0; i
< n
- 1; i
++)
1289 new[i
]->next
= new[i
+ 1];
1291 new[i
]->next
= NULL
;
1293 if (*ap
== NULL
&& n
> 0)
1296 /* Note the types of omitted optional arguments. */
1297 for (a
= actual
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
1298 if (a
->expr
== NULL
&& a
->label
== NULL
)
1299 a
->missing_arg_type
= f
->sym
->ts
.type
;
1307 gfc_formal_arglist
*f
;
1308 gfc_actual_arglist
*a
;
1312 /* qsort comparison function for argument pairs, with the following
1314 - p->a->expr == NULL
1315 - p->a->expr->expr_type != EXPR_VARIABLE
1316 - growing p->a->expr->symbol. */
1319 pair_cmp (const void *p1
, const void *p2
)
1321 const gfc_actual_arglist
*a1
, *a2
;
1323 /* *p1 and *p2 are elements of the to-be-sorted array. */
1324 a1
= ((const argpair
*) p1
)->a
;
1325 a2
= ((const argpair
*) p2
)->a
;
1334 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
1336 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1340 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1342 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
1346 /* Given two expressions from some actual arguments, test whether they
1347 refer to the same expression. The analysis is conservative.
1348 Returning FAILURE will produce no warning. */
1351 compare_actual_expr (gfc_expr
* e1
, gfc_expr
* e2
)
1353 const gfc_ref
*r1
, *r2
;
1356 || e1
->expr_type
!= EXPR_VARIABLE
1357 || e2
->expr_type
!= EXPR_VARIABLE
1358 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
1361 /* TODO: improve comparison, see expr.c:show_ref(). */
1362 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
1364 if (r1
->type
!= r2
->type
)
1369 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
1371 /* TODO: At the moment, consider only full arrays;
1372 we could do better. */
1373 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
1378 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
1386 gfc_internal_error ("compare_actual_expr(): Bad component code");
1394 /* Given formal and actual argument lists that correspond to one
1395 another, check that identical actual arguments aren't not
1396 associated with some incompatible INTENTs. */
1399 check_some_aliasing (gfc_formal_arglist
* f
, gfc_actual_arglist
* a
)
1401 sym_intent f1_intent
, f2_intent
;
1402 gfc_formal_arglist
*f1
;
1403 gfc_actual_arglist
*a1
;
1409 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
1411 if (f1
== NULL
&& a1
== NULL
)
1413 if (f1
== NULL
|| a1
== NULL
)
1414 gfc_internal_error ("check_some_aliasing(): List mismatch");
1419 p
= (argpair
*) alloca (n
* sizeof (argpair
));
1421 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
1427 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
1429 for (i
= 0; i
< n
; i
++)
1432 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
1433 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
1435 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
1436 for (j
= i
+ 1; j
< n
; j
++)
1438 /* Expected order after the sort. */
1439 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
1440 gfc_internal_error ("check_some_aliasing(): corrupted data");
1442 /* Are the expression the same? */
1443 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
1445 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
1446 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
1447 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
1449 gfc_warning ("Same actual argument associated with INTENT(%s) "
1450 "argument '%s' and INTENT(%s) argument '%s' at %L",
1451 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
1452 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
1453 &p
[i
].a
->expr
->where
);
1463 /* Given formal and actual argument lists that correspond to one
1464 another, check that they are compatible in the sense that intents
1465 are not mismatched. */
1468 check_intents (gfc_formal_arglist
* f
, gfc_actual_arglist
* a
)
1470 sym_intent a_intent
, f_intent
;
1472 for (;; f
= f
->next
, a
= a
->next
)
1474 if (f
== NULL
&& a
== NULL
)
1476 if (f
== NULL
|| a
== NULL
)
1477 gfc_internal_error ("check_intents(): List mismatch");
1479 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
1482 a_intent
= a
->expr
->symtree
->n
.sym
->attr
.intent
;
1483 f_intent
= f
->sym
->attr
.intent
;
1485 if (a_intent
== INTENT_IN
1486 && (f_intent
== INTENT_INOUT
1487 || f_intent
== INTENT_OUT
))
1490 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1491 "specifies INTENT(%s)", &a
->expr
->where
,
1492 gfc_intent_string (f_intent
));
1496 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
1498 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
1501 ("Procedure argument at %L is local to a PURE procedure and "
1502 "is passed to an INTENT(%s) argument", &a
->expr
->where
,
1503 gfc_intent_string (f_intent
));
1507 if (a
->expr
->symtree
->n
.sym
->attr
.pointer
)
1510 ("Procedure argument at %L is local to a PURE procedure and "
1511 "has the POINTER attribute", &a
->expr
->where
);
1521 /* Check how a procedure is used against its interface. If all goes
1522 well, the actual argument list will also end up being properly
1526 gfc_procedure_use (gfc_symbol
* sym
, gfc_actual_arglist
** ap
, locus
* where
)
1528 /* Warn about calls with an implicit interface. */
1529 if (gfc_option
.warn_implicit_interface
1530 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
1531 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1534 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
1535 || !compare_actual_formal (ap
, sym
->formal
, 0,
1536 sym
->attr
.elemental
, where
))
1539 check_intents (sym
->formal
, *ap
);
1540 if (gfc_option
.warn_aliasing
)
1541 check_some_aliasing (sym
->formal
, *ap
);
1545 /* Given an interface pointer and an actual argument list, search for
1546 a formal argument list that matches the actual. If found, returns
1547 a pointer to the symbol of the correct interface. Returns NULL if
1551 gfc_search_interface (gfc_interface
* intr
, int sub_flag
,
1552 gfc_actual_arglist
** ap
)
1556 for (; intr
; intr
= intr
->next
)
1558 if (sub_flag
&& intr
->sym
->attr
.function
)
1560 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
1563 r
= !intr
->sym
->attr
.elemental
;
1565 if (compare_actual_formal (ap
, intr
->sym
->formal
, r
, !r
, NULL
))
1567 check_intents (intr
->sym
->formal
, *ap
);
1568 if (gfc_option
.warn_aliasing
)
1569 check_some_aliasing (intr
->sym
->formal
, *ap
);
1578 /* Do a brute force recursive search for a symbol. */
1580 static gfc_symtree
*
1581 find_symtree0 (gfc_symtree
* root
, gfc_symbol
* sym
)
1585 if (root
->n
.sym
== sym
)
1590 st
= find_symtree0 (root
->left
, sym
);
1591 if (root
->right
&& ! st
)
1592 st
= find_symtree0 (root
->right
, sym
);
1597 /* Find a symtree for a symbol. */
1599 static gfc_symtree
*
1600 find_sym_in_symtree (gfc_symbol
* sym
)
1605 /* First try to find it by name. */
1606 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
1607 if (st
&& st
->n
.sym
== sym
)
1610 /* if it's been renamed, resort to a brute-force search. */
1611 /* TODO: avoid having to do this search. If the symbol doesn't exist
1612 in the symtree for the current namespace, it should probably be added. */
1613 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1615 st
= find_symtree0 (ns
->sym_root
, sym
);
1619 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
1624 /* This subroutine is called when an expression is being resolved.
1625 The expression node in question is either a user defined operator
1626 or an intrinsic operator with arguments that aren't compatible
1627 with the operator. This subroutine builds an actual argument list
1628 corresponding to the operands, then searches for a compatible
1629 interface. If one is found, the expression node is replaced with
1630 the appropriate function call. */
1633 gfc_extend_expr (gfc_expr
* e
)
1635 gfc_actual_arglist
*actual
;
1643 actual
= gfc_get_actual_arglist ();
1644 actual
->expr
= e
->value
.op
.op1
;
1646 if (e
->value
.op
.op2
!= NULL
)
1648 actual
->next
= gfc_get_actual_arglist ();
1649 actual
->next
->expr
= e
->value
.op
.op2
;
1652 i
= fold_unary (e
->value
.op
.operator);
1654 if (i
== INTRINSIC_USER
)
1656 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1658 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
1662 sym
= gfc_search_interface (uop
->operator, 0, &actual
);
1669 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1671 sym
= gfc_search_interface (ns
->operator[i
], 0, &actual
);
1679 /* Don't use gfc_free_actual_arglist() */
1680 if (actual
->next
!= NULL
)
1681 gfc_free (actual
->next
);
1687 /* Change the expression node to a function call. */
1688 e
->expr_type
= EXPR_FUNCTION
;
1689 e
->symtree
= find_sym_in_symtree (sym
);
1690 e
->value
.function
.actual
= actual
;
1691 e
->value
.function
.esym
= NULL
;
1692 e
->value
.function
.isym
= NULL
;
1694 if (gfc_pure (NULL
) && !gfc_pure (sym
))
1697 ("Function '%s' called in lieu of an operator at %L must be PURE",
1698 sym
->name
, &e
->where
);
1702 if (gfc_resolve_expr (e
) == FAILURE
)
1709 /* Tries to replace an assignment code node with a subroutine call to
1710 the subroutine associated with the assignment operator. Return
1711 SUCCESS if the node was replaced. On FAILURE, no error is
1715 gfc_extend_assign (gfc_code
* c
, gfc_namespace
* ns
)
1717 gfc_actual_arglist
*actual
;
1718 gfc_expr
*lhs
, *rhs
;
1724 /* Don't allow an intrinsic assignment to be replaced. */
1725 if (lhs
->ts
.type
!= BT_DERIVED
&& rhs
->ts
.type
!= BT_DERIVED
1726 && (lhs
->ts
.type
== rhs
->ts
.type
1727 || (gfc_numeric_ts (&lhs
->ts
)
1728 && gfc_numeric_ts (&rhs
->ts
))))
1731 actual
= gfc_get_actual_arglist ();
1734 actual
->next
= gfc_get_actual_arglist ();
1735 actual
->next
->expr
= rhs
;
1739 for (; ns
; ns
= ns
->parent
)
1741 sym
= gfc_search_interface (ns
->operator[INTRINSIC_ASSIGN
], 1, &actual
);
1748 gfc_free (actual
->next
);
1753 /* Replace the assignment with the call. */
1755 c
->symtree
= find_sym_in_symtree (sym
);
1758 c
->ext
.actual
= actual
;
1760 if (gfc_pure (NULL
) && !gfc_pure (sym
))
1762 gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
1763 "PURE", sym
->name
, &c
->loc
);
1771 /* Make sure that the interface just parsed is not already present in
1772 the given interface list. Ambiguity isn't checked yet since module
1773 procedures can be present without interfaces. */
1776 check_new_interface (gfc_interface
* base
, gfc_symbol
* new)
1780 for (ip
= base
; ip
; ip
= ip
->next
)
1784 gfc_error ("Entity '%s' at %C is already present in the interface",
1794 /* Add a symbol to the current interface. */
1797 gfc_add_interface (gfc_symbol
* new)
1799 gfc_interface
**head
, *intr
;
1803 switch (current_interface
.type
)
1805 case INTERFACE_NAMELESS
:
1808 case INTERFACE_INTRINSIC_OP
:
1809 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
1810 if (check_new_interface (ns
->operator[current_interface
.op
], new)
1814 head
= ¤t_interface
.ns
->operator[current_interface
.op
];
1817 case INTERFACE_GENERIC
:
1818 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
1820 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
1824 if (check_new_interface (sym
->generic
, new) == FAILURE
)
1828 head
= ¤t_interface
.sym
->generic
;
1831 case INTERFACE_USER_OP
:
1832 if (check_new_interface (current_interface
.uop
->operator, new) ==
1836 head
= ¤t_interface
.uop
->operator;
1840 gfc_internal_error ("gfc_add_interface(): Bad interface type");
1843 intr
= gfc_get_interface ();
1845 intr
->where
= gfc_current_locus
;
1854 /* Gets rid of a formal argument list. We do not free symbols.
1855 Symbols are freed when a namespace is freed. */
1858 gfc_free_formal_arglist (gfc_formal_arglist
* p
)
1860 gfc_formal_arglist
*q
;