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, 51 Franklin Street, Fifth Floor, 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
)
222 gfc_error ("Dummy procedure '%s' at %C cannot have a "
223 "generic interface", sym
->name
);
227 current_interface
.sym
= gfc_new_block
= sym
;
230 case INTERFACE_USER_OP
:
231 current_interface
.uop
= gfc_get_uop (name
);
234 case INTERFACE_INTRINSIC_OP
:
235 current_interface
.op
= operator;
238 case INTERFACE_NAMELESS
:
246 /* Match the different sort of generic-specs that can be present after
247 the END INTERFACE itself. */
250 gfc_match_end_interface (void)
252 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
254 gfc_intrinsic_op
operator;
257 m
= gfc_match_space ();
259 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
262 /* If we're not looking at the end of the statement now, or if this
263 is not a nameless interface but we did not see a space, punt. */
264 if (gfc_match_eos () != MATCH_YES
265 || (type
!= INTERFACE_NAMELESS
269 ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
275 switch (current_interface
.type
)
277 case INTERFACE_NAMELESS
:
278 if (type
!= current_interface
.type
)
280 gfc_error ("Expected a nameless interface at %C");
286 case INTERFACE_INTRINSIC_OP
:
287 if (type
!= current_interface
.type
|| operator != current_interface
.op
)
290 if (current_interface
.op
== INTRINSIC_ASSIGN
)
291 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
293 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
294 gfc_op2string (current_interface
.op
));
301 case INTERFACE_USER_OP
:
302 /* Comparing the symbol node names is OK because only use-associated
303 symbols can be renamed. */
304 if (type
!= current_interface
.type
305 || strcmp (current_interface
.uop
->name
, name
) != 0)
307 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
308 current_interface
.uop
->name
);
314 case INTERFACE_GENERIC
:
315 if (type
!= current_interface
.type
316 || strcmp (current_interface
.sym
->name
, name
) != 0)
318 gfc_error ("Expecting 'END INTERFACE %s' at %C",
319 current_interface
.sym
->name
);
330 /* Compare two derived types using the criteria in 4.4.2 of the standard,
331 recursing through gfc_compare_types for the components. */
334 gfc_compare_derived_types (gfc_symbol
* derived1
, gfc_symbol
* derived2
)
336 gfc_component
*dt1
, *dt2
;
338 /* Special case for comparing derived types across namespaces. If the
339 true names and module names are the same and the module name is
340 nonnull, then they are equal. */
341 if (strcmp (derived1
->name
, derived2
->name
) == 0
342 && derived1
!= NULL
&& derived2
!= NULL
343 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
344 && strcmp (derived1
->module
, derived2
->module
) == 0)
347 /* Compare type via the rules of the standard. Both types must have
348 the SEQUENCE attribute to be equal. */
350 if (strcmp (derived1
->name
, derived2
->name
))
353 if (derived1
->component_access
== ACCESS_PRIVATE
354 || derived2
->component_access
== ACCESS_PRIVATE
)
357 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
360 dt1
= derived1
->components
;
361 dt2
= derived2
->components
;
363 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
364 simple test can speed things up. Otherwise, lots of things have to
368 if (strcmp (dt1
->name
, dt2
->name
) != 0)
371 if (dt1
->pointer
!= dt2
->pointer
)
374 if (dt1
->dimension
!= dt2
->dimension
)
377 if (dt1
->allocatable
!= dt2
->allocatable
)
380 if (dt1
->dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
383 if (gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
389 if (dt1
== NULL
&& dt2
== NULL
)
391 if (dt1
== NULL
|| dt2
== NULL
)
398 /* Compare two typespecs, recursively if necessary. */
401 gfc_compare_types (gfc_typespec
* ts1
, gfc_typespec
* ts2
)
404 if (ts1
->type
!= ts2
->type
)
406 if (ts1
->type
!= BT_DERIVED
)
407 return (ts1
->kind
== ts2
->kind
);
409 /* Compare derived types. */
410 if (ts1
->derived
== ts2
->derived
)
413 return gfc_compare_derived_types (ts1
->derived
,ts2
->derived
);
417 /* Given two symbols that are formal arguments, compare their ranks
418 and types. Returns nonzero if they have the same rank and type,
422 compare_type_rank (gfc_symbol
* s1
, gfc_symbol
* s2
)
426 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
427 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
430 return 0; /* Ranks differ */
432 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
436 static int compare_interfaces (gfc_symbol
*, gfc_symbol
*, int);
438 /* Given two symbols that are formal arguments, compare their types
439 and rank and their formal interfaces if they are both dummy
440 procedures. Returns nonzero if the same, zero if different. */
443 compare_type_rank_if (gfc_symbol
* s1
, gfc_symbol
* s2
)
446 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
447 return compare_type_rank (s1
, s2
);
449 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
452 /* At this point, both symbols are procedures. */
453 if ((s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
454 || (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0))
457 if (s1
->attr
.function
!= s2
->attr
.function
458 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
461 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
464 return compare_interfaces (s1
, s2
, 0); /* Recurse! */
468 /* Given a formal argument list and a keyword name, search the list
469 for that keyword. Returns the correct symbol node if found, NULL
473 find_keyword_arg (const char *name
, gfc_formal_arglist
* f
)
476 for (; f
; f
= f
->next
)
477 if (strcmp (f
->sym
->name
, name
) == 0)
484 /******** Interface checking subroutines **********/
487 /* Given an operator interface and the operator, make sure that all
488 interfaces for that operator are legal. */
491 check_operator_interface (gfc_interface
* intr
, gfc_intrinsic_op
operator)
493 gfc_formal_arglist
*formal
;
503 t1
= t2
= BT_UNKNOWN
;
504 i1
= i2
= INTENT_UNKNOWN
;
506 for (formal
= intr
->sym
->formal
; formal
; formal
= formal
->next
)
511 gfc_error ("Alternate return cannot appear in operator "
512 "interface at %L", &intr
->where
);
518 i1
= sym
->attr
.intent
;
523 i2
= sym
->attr
.intent
;
528 if (args
== 0 || args
> 2)
533 if (operator == INTRINSIC_ASSIGN
)
535 if (!sym
->attr
.subroutine
)
538 ("Assignment operator interface at %L must be a SUBROUTINE",
545 ("Assignment operator interface at %L must have two arguments",
549 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
550 && sym
->formal
->next
->sym
->ts
.type
!= BT_DERIVED
551 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
552 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
553 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
556 ("Assignment operator interface at %L must not redefine "
557 "an INTRINSIC type assignment", &intr
->where
);
563 if (!sym
->attr
.function
)
565 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
573 case INTRINSIC_PLUS
: /* Numeric unary or binary */
574 case INTRINSIC_MINUS
:
578 || t1
== BT_COMPLEX
))
582 && (t1
== BT_INTEGER
|| t1
== BT_REAL
|| t1
== BT_COMPLEX
)
583 && (t2
== BT_INTEGER
|| t2
== BT_REAL
|| t2
== BT_COMPLEX
))
588 case INTRINSIC_POWER
: /* Binary numeric */
589 case INTRINSIC_TIMES
:
590 case INTRINSIC_DIVIDE
:
597 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
|| t1
== BT_COMPLEX
)
598 && (t2
== BT_INTEGER
|| t2
== BT_REAL
|| t2
== BT_COMPLEX
))
603 case INTRINSIC_GE
: /* Binary numeric operators that do not support */
604 case INTRINSIC_LE
: /* complex numbers */
610 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
611 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
616 case INTRINSIC_OR
: /* Binary logical */
622 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
626 case INTRINSIC_NOT
: /* Unary logical */
629 if (t1
== BT_LOGICAL
)
633 case INTRINSIC_CONCAT
: /* Binary string */
636 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
640 case INTRINSIC_ASSIGN
: /* Class by itself */
645 gfc_internal_error ("check_operator_interface(): Bad operator");
648 /* Check intents on operator interfaces. */
649 if (operator == INTRINSIC_ASSIGN
)
651 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
652 gfc_error ("First argument of defined assignment at %L must be "
653 "INTENT(IN) or INTENT(INOUT)", &intr
->where
);
656 gfc_error ("Second argument of defined assignment at %L must be "
657 "INTENT(IN)", &intr
->where
);
662 gfc_error ("First argument of operator interface at %L must be "
663 "INTENT(IN)", &intr
->where
);
665 if (args
== 2 && i2
!= INTENT_IN
)
666 gfc_error ("Second argument of operator interface at %L must be "
667 "INTENT(IN)", &intr
->where
);
673 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
678 gfc_error ("Operator interface at %L has the wrong number of arguments",
684 /* Given a pair of formal argument lists, we see if the two lists can
685 be distinguished by counting the number of nonoptional arguments of
686 a given type/rank in f1 and seeing if there are less then that
687 number of those arguments in f2 (including optional arguments).
688 Since this test is asymmetric, it has to be called twice to make it
689 symmetric. Returns nonzero if the argument lists are incompatible
690 by this test. This subroutine implements rule 1 of section
694 count_types_test (gfc_formal_arglist
* f1
, gfc_formal_arglist
* f2
)
696 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
697 gfc_formal_arglist
*f
;
710 for (f
= f1
; f
; f
= f
->next
)
713 /* Build an array of integers that gives the same integer to
714 arguments of the same type/rank. */
715 arg
= gfc_getmem (n1
* sizeof (arginfo
));
718 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
726 for (i
= 0; i
< n1
; i
++)
728 if (arg
[i
].flag
!= -1)
731 if (arg
[i
].sym
->attr
.optional
)
732 continue; /* Skip optional arguments */
736 /* Find other nonoptional arguments of the same type/rank. */
737 for (j
= i
+ 1; j
< n1
; j
++)
738 if (!arg
[j
].sym
->attr
.optional
739 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
745 /* Now loop over each distinct type found in f1. */
749 for (i
= 0; i
< n1
; i
++)
751 if (arg
[i
].flag
!= k
)
755 for (j
= i
+ 1; j
< n1
; j
++)
756 if (arg
[j
].flag
== k
)
759 /* Count the number of arguments in f2 with that type, including
760 those that are optional. */
763 for (f
= f2
; f
; f
= f
->next
)
764 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
782 /* Perform the abbreviated correspondence test for operators. The
783 arguments cannot be optional and are always ordered correctly,
784 which makes this test much easier than that for generic tests.
786 This subroutine is also used when comparing a formal and actual
787 argument list when an actual parameter is a dummy procedure. At
788 that point, two formal interfaces must be compared for equality
789 which is what happens here. */
792 operator_correspondence (gfc_formal_arglist
* f1
, gfc_formal_arglist
* f2
)
796 if (f1
== NULL
&& f2
== NULL
)
798 if (f1
== NULL
|| f2
== NULL
)
801 if (!compare_type_rank (f1
->sym
, f2
->sym
))
812 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
813 Returns zero if no argument is found that satisfies rule 2, nonzero
816 This test is also not symmetric in f1 and f2 and must be called
817 twice. This test finds problems caused by sorting the actual
818 argument list with keywords. For example:
822 INTEGER :: A ; REAL :: B
826 INTEGER :: A ; REAL :: B
830 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
833 generic_correspondence (gfc_formal_arglist
* f1
, gfc_formal_arglist
* f2
)
836 gfc_formal_arglist
*f2_save
, *g
;
843 if (f1
->sym
->attr
.optional
)
846 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
849 /* Now search for a disambiguating keyword argument starting at
850 the current non-match. */
851 for (g
= f1
; g
; g
= g
->next
)
853 if (g
->sym
->attr
.optional
)
856 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
857 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
871 /* 'Compare' two formal interfaces associated with a pair of symbols.
872 We return nonzero if there exists an actual argument list that
873 would be ambiguous between the two interfaces, zero otherwise. */
876 compare_interfaces (gfc_symbol
* s1
, gfc_symbol
* s2
, int generic_flag
)
878 gfc_formal_arglist
*f1
, *f2
;
880 if (s1
->attr
.function
!= s2
->attr
.function
881 && s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
882 return 0; /* disagreement between function/subroutine */
887 if (f1
== NULL
&& f2
== NULL
)
888 return 1; /* Special case */
890 if (count_types_test (f1
, f2
))
892 if (count_types_test (f2
, f1
))
897 if (generic_correspondence (f1
, f2
))
899 if (generic_correspondence (f2
, f1
))
904 if (operator_correspondence (f1
, f2
))
912 /* Given a pointer to an interface pointer, remove duplicate
913 interfaces and make sure that all symbols are either functions or
914 subroutines. Returns nonzero if something goes wrong. */
917 check_interface0 (gfc_interface
* p
, const char *interface_name
)
919 gfc_interface
*psave
, *q
, *qlast
;
922 /* Make sure all symbols in the interface have been defined as
923 functions or subroutines. */
924 for (; p
; p
= p
->next
)
925 if (!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
927 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
928 "subroutine", p
->sym
->name
, interface_name
,
929 &p
->sym
->declared_at
);
934 /* Remove duplicate interfaces in this interface list. */
935 for (; p
; p
= p
->next
)
939 for (q
= p
->next
; q
;)
941 if (p
->sym
!= q
->sym
)
949 /* Duplicate interface */
950 qlast
->next
= q
->next
;
961 /* Check lists of interfaces to make sure that no two interfaces are
962 ambiguous. Duplicate interfaces (from the same symbol) are OK
966 check_interface1 (gfc_interface
* p
, gfc_interface
* q
,
967 int generic_flag
, const char *interface_name
)
970 for (; p
; p
= p
->next
)
971 for (; q
; q
= q
->next
)
973 if (p
->sym
== q
->sym
)
974 continue; /* Duplicates OK here */
976 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
979 if (compare_interfaces (p
->sym
, q
->sym
, generic_flag
))
981 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
982 p
->sym
->name
, q
->sym
->name
, interface_name
, &p
->where
);
991 /* Check the generic and operator interfaces of symbols to make sure
992 that none of the interfaces conflict. The check has to be done
993 after all of the symbols are actually loaded. */
996 check_sym_interfaces (gfc_symbol
* sym
)
998 char interface_name
[100];
1001 if (sym
->ns
!= gfc_current_ns
)
1004 if (sym
->generic
!= NULL
)
1006 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1007 if (check_interface0 (sym
->generic
, interface_name
))
1013 if (check_interface1 (sym
->generic
, s2
->generic
, 1, interface_name
))
1016 if (s2
->ns
->parent
== NULL
)
1018 if (gfc_find_symbol (sym
->name
, s2
->ns
->parent
, 1, &s2
))
1026 check_uop_interfaces (gfc_user_op
* uop
)
1028 char interface_name
[100];
1032 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1033 if (check_interface0 (uop
->operator, interface_name
))
1036 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1038 uop2
= gfc_find_uop (uop
->name
, ns
);
1042 check_interface1 (uop
->operator, uop2
->operator, 0, interface_name
);
1047 /* For the namespace, check generic, user operator and intrinsic
1048 operator interfaces for consistency and to remove duplicate
1049 interfaces. We traverse the whole namespace, counting on the fact
1050 that most symbols will not have generic or operator interfaces. */
1053 gfc_check_interfaces (gfc_namespace
* ns
)
1055 gfc_namespace
*old_ns
, *ns2
;
1056 char interface_name
[100];
1059 old_ns
= gfc_current_ns
;
1060 gfc_current_ns
= ns
;
1062 gfc_traverse_ns (ns
, check_sym_interfaces
);
1064 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1066 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1068 if (i
== INTRINSIC_USER
)
1071 if (i
== INTRINSIC_ASSIGN
)
1072 strcpy (interface_name
, "intrinsic assignment operator");
1074 sprintf (interface_name
, "intrinsic '%s' operator",
1077 if (check_interface0 (ns
->operator[i
], interface_name
))
1080 check_operator_interface (ns
->operator[i
], i
);
1082 for (ns2
= ns
->parent
; ns2
; ns2
= ns2
->parent
)
1083 if (check_interface1 (ns
->operator[i
], ns2
->operator[i
], 0,
1088 gfc_current_ns
= old_ns
;
1093 symbol_rank (gfc_symbol
* sym
)
1096 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1100 /* Given a symbol of a formal argument list and an expression, if the
1101 formal argument is allocatable, check that the actual argument is
1102 allocatable. Returns nonzero if compatible, zero if not compatible. */
1105 compare_allocatable (gfc_symbol
* formal
, gfc_expr
* actual
)
1107 symbol_attribute attr
;
1109 if (formal
->attr
.allocatable
)
1111 attr
= gfc_expr_attr (actual
);
1112 if (!attr
.allocatable
)
1120 /* Given a symbol of a formal argument list and an expression, if the
1121 formal argument is a pointer, see if the actual argument is a
1122 pointer. Returns nonzero if compatible, zero if not compatible. */
1125 compare_pointer (gfc_symbol
* formal
, gfc_expr
* actual
)
1127 symbol_attribute attr
;
1129 if (formal
->attr
.pointer
)
1131 attr
= gfc_expr_attr (actual
);
1140 /* Given a symbol of a formal argument list and an expression, see if
1141 the two are compatible as arguments. Returns nonzero if
1142 compatible, zero if not compatible. */
1145 compare_parameter (gfc_symbol
* formal
, gfc_expr
* actual
,
1146 int ranks_must_agree
, int is_elemental
)
1150 if (actual
->ts
.type
== BT_PROCEDURE
)
1152 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1155 if (formal
->attr
.function
1156 && !compare_type_rank (formal
, actual
->symtree
->n
.sym
))
1159 if (formal
->attr
.if_source
== IFSRC_UNKNOWN
1160 || actual
->symtree
->n
.sym
->attr
.external
)
1161 return 1; /* Assume match */
1163 return compare_interfaces (formal
, actual
->symtree
->n
.sym
, 0);
1166 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1167 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1170 if (symbol_rank (formal
) == actual
->rank
)
1173 /* At this point the ranks didn't agree. */
1174 if (ranks_must_agree
|| formal
->attr
.pointer
)
1177 if (actual
->rank
!= 0)
1178 return is_elemental
|| formal
->attr
.dimension
;
1180 /* At this point, we are considering a scalar passed to an array.
1181 This is legal if the scalar is an array element of the right sort. */
1182 if (formal
->as
->type
== AS_ASSUMED_SHAPE
)
1185 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1186 if (ref
->type
== REF_SUBSTRING
)
1189 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1190 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1194 return 0; /* Not an array element */
1200 /* Given formal and actual argument lists, see if they are compatible.
1201 If they are compatible, the actual argument list is sorted to
1202 correspond with the formal list, and elements for missing optional
1203 arguments are inserted. If WHERE pointer is nonnull, then we issue
1204 errors when things don't match instead of just returning the status
1208 compare_actual_formal (gfc_actual_arglist
** ap
,
1209 gfc_formal_arglist
* formal
,
1210 int ranks_must_agree
, int is_elemental
, locus
* where
)
1212 gfc_actual_arglist
**new, *a
, *actual
, temp
;
1213 gfc_formal_arglist
*f
;
1220 if (actual
== NULL
&& formal
== NULL
)
1224 for (f
= formal
; f
; f
= f
->next
)
1227 new = (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1229 for (i
= 0; i
< n
; i
++)
1236 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1238 if (a
->name
!= NULL
)
1241 for (f
= formal
; f
; f
= f
->next
, i
++)
1245 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1253 ("Keyword argument '%s' at %L is not in the procedure",
1254 a
->name
, &a
->expr
->where
);
1262 ("Keyword argument '%s' at %L is already associated "
1263 "with another actual argument", a
->name
, &a
->expr
->where
);
1272 ("More actual than formal arguments in procedure call at %L",
1278 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1285 ("Missing alternate return spec in subroutine call at %L",
1290 if (a
->expr
== NULL
)
1294 ("Unexpected alternate return spec in subroutine call at %L",
1299 rank_check
= where
!= NULL
1302 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1303 || f
->sym
->as
->type
== AS_DEFERRED
);
1305 if (!compare_parameter
1306 (f
->sym
, a
->expr
, ranks_must_agree
|| rank_check
, is_elemental
))
1309 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1310 f
->sym
->name
, &a
->expr
->where
);
1314 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1315 provided for a procedure formal argument. */
1316 if (a
->expr
->ts
.type
!= BT_PROCEDURE
1317 && a
->expr
->expr_type
== EXPR_VARIABLE
1318 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1320 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1321 a
->expr
->symtree
->n
.sym
->name
);
1322 if (gsym
== NULL
|| (gsym
->type
!= GSYM_FUNCTION
1323 && gsym
->type
!= GSYM_SUBROUTINE
))
1326 gfc_error ("Expected a procedure for argument '%s' at %L",
1327 f
->sym
->name
, &a
->expr
->where
);
1332 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
1333 && f
->sym
->attr
.pure
1334 && a
->expr
->ts
.type
== BT_PROCEDURE
1335 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
1338 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1339 f
->sym
->name
, &a
->expr
->where
);
1344 && f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1345 && a
->expr
->expr_type
== EXPR_VARIABLE
1346 && a
->expr
->symtree
->n
.sym
->as
1347 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
1348 && (a
->expr
->ref
== NULL
1349 || (a
->expr
->ref
->type
== REF_ARRAY
1350 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
1353 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1354 " array at %L", f
->sym
->name
, where
);
1358 if (a
->expr
->expr_type
!= EXPR_NULL
1359 && compare_pointer (f
->sym
, a
->expr
) == 0)
1362 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1363 f
->sym
->name
, &a
->expr
->where
);
1367 if (a
->expr
->expr_type
!= EXPR_NULL
1368 && compare_allocatable (f
->sym
, a
->expr
) == 0)
1371 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1372 f
->sym
->name
, &a
->expr
->where
);
1376 /* Check intent = OUT/INOUT for definable actual argument. */
1377 if (a
->expr
->expr_type
!= EXPR_VARIABLE
1378 && (f
->sym
->attr
.intent
== INTENT_OUT
1379 || f
->sym
->attr
.intent
== INTENT_INOUT
))
1381 gfc_error ("Actual argument at %L must be definable to "
1382 "match dummy INTENT = OUT/INOUT", &a
->expr
->where
);
1393 /* Make sure missing actual arguments are optional. */
1395 for (f
= formal
; f
; f
= f
->next
, i
++)
1399 if (!f
->sym
->attr
.optional
)
1402 gfc_error ("Missing actual argument for argument '%s' at %L",
1403 f
->sym
->name
, where
);
1408 /* The argument lists are compatible. We now relink a new actual
1409 argument list with null arguments in the right places. The head
1410 of the list remains the head. */
1411 for (i
= 0; i
< n
; i
++)
1413 new[i
] = gfc_get_actual_arglist ();
1426 for (i
= 0; i
< n
- 1; i
++)
1427 new[i
]->next
= new[i
+ 1];
1429 new[i
]->next
= NULL
;
1431 if (*ap
== NULL
&& n
> 0)
1434 /* Note the types of omitted optional arguments. */
1435 for (a
= actual
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
1436 if (a
->expr
== NULL
&& a
->label
== NULL
)
1437 a
->missing_arg_type
= f
->sym
->ts
.type
;
1445 gfc_formal_arglist
*f
;
1446 gfc_actual_arglist
*a
;
1450 /* qsort comparison function for argument pairs, with the following
1452 - p->a->expr == NULL
1453 - p->a->expr->expr_type != EXPR_VARIABLE
1454 - growing p->a->expr->symbol. */
1457 pair_cmp (const void *p1
, const void *p2
)
1459 const gfc_actual_arglist
*a1
, *a2
;
1461 /* *p1 and *p2 are elements of the to-be-sorted array. */
1462 a1
= ((const argpair
*) p1
)->a
;
1463 a2
= ((const argpair
*) p2
)->a
;
1472 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
1474 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1478 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
1480 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
1484 /* Given two expressions from some actual arguments, test whether they
1485 refer to the same expression. The analysis is conservative.
1486 Returning FAILURE will produce no warning. */
1489 compare_actual_expr (gfc_expr
* e1
, gfc_expr
* e2
)
1491 const gfc_ref
*r1
, *r2
;
1494 || e1
->expr_type
!= EXPR_VARIABLE
1495 || e2
->expr_type
!= EXPR_VARIABLE
1496 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
1499 /* TODO: improve comparison, see expr.c:show_ref(). */
1500 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
1502 if (r1
->type
!= r2
->type
)
1507 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
1509 /* TODO: At the moment, consider only full arrays;
1510 we could do better. */
1511 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
1516 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
1524 gfc_internal_error ("compare_actual_expr(): Bad component code");
1532 /* Given formal and actual argument lists that correspond to one
1533 another, check that identical actual arguments aren't not
1534 associated with some incompatible INTENTs. */
1537 check_some_aliasing (gfc_formal_arglist
* f
, gfc_actual_arglist
* a
)
1539 sym_intent f1_intent
, f2_intent
;
1540 gfc_formal_arglist
*f1
;
1541 gfc_actual_arglist
*a1
;
1547 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
1549 if (f1
== NULL
&& a1
== NULL
)
1551 if (f1
== NULL
|| a1
== NULL
)
1552 gfc_internal_error ("check_some_aliasing(): List mismatch");
1557 p
= (argpair
*) alloca (n
* sizeof (argpair
));
1559 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
1565 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
1567 for (i
= 0; i
< n
; i
++)
1570 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
1571 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
1573 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
1574 for (j
= i
+ 1; j
< n
; j
++)
1576 /* Expected order after the sort. */
1577 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
1578 gfc_internal_error ("check_some_aliasing(): corrupted data");
1580 /* Are the expression the same? */
1581 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
1583 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
1584 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
1585 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
1587 gfc_warning ("Same actual argument associated with INTENT(%s) "
1588 "argument '%s' and INTENT(%s) argument '%s' at %L",
1589 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
1590 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
1591 &p
[i
].a
->expr
->where
);
1601 /* Given formal and actual argument lists that correspond to one
1602 another, check that they are compatible in the sense that intents
1603 are not mismatched. */
1606 check_intents (gfc_formal_arglist
* f
, gfc_actual_arglist
* a
)
1608 sym_intent a_intent
, f_intent
;
1610 for (;; f
= f
->next
, a
= a
->next
)
1612 if (f
== NULL
&& a
== NULL
)
1614 if (f
== NULL
|| a
== NULL
)
1615 gfc_internal_error ("check_intents(): List mismatch");
1617 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
1620 a_intent
= a
->expr
->symtree
->n
.sym
->attr
.intent
;
1621 f_intent
= f
->sym
->attr
.intent
;
1623 if (a_intent
== INTENT_IN
1624 && (f_intent
== INTENT_INOUT
1625 || f_intent
== INTENT_OUT
))
1628 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1629 "specifies INTENT(%s)", &a
->expr
->where
,
1630 gfc_intent_string (f_intent
));
1634 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
1636 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
1639 ("Procedure argument at %L is local to a PURE procedure and "
1640 "is passed to an INTENT(%s) argument", &a
->expr
->where
,
1641 gfc_intent_string (f_intent
));
1645 if (a
->expr
->symtree
->n
.sym
->attr
.pointer
)
1648 ("Procedure argument at %L is local to a PURE procedure and "
1649 "has the POINTER attribute", &a
->expr
->where
);
1659 /* Check how a procedure is used against its interface. If all goes
1660 well, the actual argument list will also end up being properly
1664 gfc_procedure_use (gfc_symbol
* sym
, gfc_actual_arglist
** ap
, locus
* where
)
1667 /* Warn about calls with an implicit interface. */
1668 if (gfc_option
.warn_implicit_interface
1669 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
1670 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1673 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
1674 || !compare_actual_formal (ap
, sym
->formal
, 0,
1675 sym
->attr
.elemental
, where
))
1678 check_intents (sym
->formal
, *ap
);
1679 if (gfc_option
.warn_aliasing
)
1680 check_some_aliasing (sym
->formal
, *ap
);
1684 /* Given an interface pointer and an actual argument list, search for
1685 a formal argument list that matches the actual. If found, returns
1686 a pointer to the symbol of the correct interface. Returns NULL if
1690 gfc_search_interface (gfc_interface
* intr
, int sub_flag
,
1691 gfc_actual_arglist
** ap
)
1695 for (; intr
; intr
= intr
->next
)
1697 if (sub_flag
&& intr
->sym
->attr
.function
)
1699 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
1702 r
= !intr
->sym
->attr
.elemental
;
1704 if (compare_actual_formal (ap
, intr
->sym
->formal
, r
, !r
, NULL
))
1706 check_intents (intr
->sym
->formal
, *ap
);
1707 if (gfc_option
.warn_aliasing
)
1708 check_some_aliasing (intr
->sym
->formal
, *ap
);
1717 /* Do a brute force recursive search for a symbol. */
1719 static gfc_symtree
*
1720 find_symtree0 (gfc_symtree
* root
, gfc_symbol
* sym
)
1724 if (root
->n
.sym
== sym
)
1729 st
= find_symtree0 (root
->left
, sym
);
1730 if (root
->right
&& ! st
)
1731 st
= find_symtree0 (root
->right
, sym
);
1736 /* Find a symtree for a symbol. */
1738 static gfc_symtree
*
1739 find_sym_in_symtree (gfc_symbol
* sym
)
1744 /* First try to find it by name. */
1745 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
1746 if (st
&& st
->n
.sym
== sym
)
1749 /* if it's been renamed, resort to a brute-force search. */
1750 /* TODO: avoid having to do this search. If the symbol doesn't exist
1751 in the symtree for the current namespace, it should probably be added. */
1752 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1754 st
= find_symtree0 (ns
->sym_root
, sym
);
1758 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
1763 /* This subroutine is called when an expression is being resolved.
1764 The expression node in question is either a user defined operator
1765 or an intrinsic operator with arguments that aren't compatible
1766 with the operator. This subroutine builds an actual argument list
1767 corresponding to the operands, then searches for a compatible
1768 interface. If one is found, the expression node is replaced with
1769 the appropriate function call. */
1772 gfc_extend_expr (gfc_expr
* e
)
1774 gfc_actual_arglist
*actual
;
1782 actual
= gfc_get_actual_arglist ();
1783 actual
->expr
= e
->value
.op
.op1
;
1785 if (e
->value
.op
.op2
!= NULL
)
1787 actual
->next
= gfc_get_actual_arglist ();
1788 actual
->next
->expr
= e
->value
.op
.op2
;
1791 i
= fold_unary (e
->value
.op
.operator);
1793 if (i
== INTRINSIC_USER
)
1795 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1797 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
1801 sym
= gfc_search_interface (uop
->operator, 0, &actual
);
1808 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1810 sym
= gfc_search_interface (ns
->operator[i
], 0, &actual
);
1818 /* Don't use gfc_free_actual_arglist() */
1819 if (actual
->next
!= NULL
)
1820 gfc_free (actual
->next
);
1826 /* Change the expression node to a function call. */
1827 e
->expr_type
= EXPR_FUNCTION
;
1828 e
->symtree
= find_sym_in_symtree (sym
);
1829 e
->value
.function
.actual
= actual
;
1830 e
->value
.function
.esym
= NULL
;
1831 e
->value
.function
.isym
= NULL
;
1832 e
->value
.function
.name
= NULL
;
1834 if (gfc_pure (NULL
) && !gfc_pure (sym
))
1837 ("Function '%s' called in lieu of an operator at %L must be PURE",
1838 sym
->name
, &e
->where
);
1842 if (gfc_resolve_expr (e
) == FAILURE
)
1849 /* Tries to replace an assignment code node with a subroutine call to
1850 the subroutine associated with the assignment operator. Return
1851 SUCCESS if the node was replaced. On FAILURE, no error is
1855 gfc_extend_assign (gfc_code
* c
, gfc_namespace
* ns
)
1857 gfc_actual_arglist
*actual
;
1858 gfc_expr
*lhs
, *rhs
;
1864 /* Don't allow an intrinsic assignment to be replaced. */
1865 if (lhs
->ts
.type
!= BT_DERIVED
&& rhs
->ts
.type
!= BT_DERIVED
1866 && (lhs
->ts
.type
== rhs
->ts
.type
1867 || (gfc_numeric_ts (&lhs
->ts
)
1868 && gfc_numeric_ts (&rhs
->ts
))))
1871 actual
= gfc_get_actual_arglist ();
1874 actual
->next
= gfc_get_actual_arglist ();
1875 actual
->next
->expr
= rhs
;
1879 for (; ns
; ns
= ns
->parent
)
1881 sym
= gfc_search_interface (ns
->operator[INTRINSIC_ASSIGN
], 1, &actual
);
1888 gfc_free (actual
->next
);
1893 /* Replace the assignment with the call. */
1894 c
->op
= EXEC_ASSIGN_CALL
;
1895 c
->symtree
= find_sym_in_symtree (sym
);
1898 c
->ext
.actual
= actual
;
1904 /* Make sure that the interface just parsed is not already present in
1905 the given interface list. Ambiguity isn't checked yet since module
1906 procedures can be present without interfaces. */
1909 check_new_interface (gfc_interface
* base
, gfc_symbol
* new)
1913 for (ip
= base
; ip
; ip
= ip
->next
)
1917 gfc_error ("Entity '%s' at %C is already present in the interface",
1927 /* Add a symbol to the current interface. */
1930 gfc_add_interface (gfc_symbol
* new)
1932 gfc_interface
**head
, *intr
;
1936 switch (current_interface
.type
)
1938 case INTERFACE_NAMELESS
:
1941 case INTERFACE_INTRINSIC_OP
:
1942 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
1943 if (check_new_interface (ns
->operator[current_interface
.op
], new)
1947 head
= ¤t_interface
.ns
->operator[current_interface
.op
];
1950 case INTERFACE_GENERIC
:
1951 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
1953 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
1957 if (check_new_interface (sym
->generic
, new) == FAILURE
)
1961 head
= ¤t_interface
.sym
->generic
;
1964 case INTERFACE_USER_OP
:
1965 if (check_new_interface (current_interface
.uop
->operator, new) ==
1969 head
= ¤t_interface
.uop
->operator;
1973 gfc_internal_error ("gfc_add_interface(): Bad interface type");
1976 intr
= gfc_get_interface ();
1978 intr
->where
= gfc_current_locus
;
1987 /* Gets rid of a formal argument list. We do not free symbols.
1988 Symbols are freed when a namespace is freed. */
1991 gfc_free_formal_arglist (gfc_formal_arglist
* p
)
1993 gfc_formal_arglist
*q
;