1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
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. */
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface * intr)
88 for (; intr; intr = next)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary (gfc_intrinsic_op operator)
105 case INTRINSIC_UPLUS:
106 operator = INTRINSIC_PLUS;
108 case INTRINSIC_UMINUS:
109 operator = INTRINSIC_MINUS;
119 /* Match a generic specification. Depending on which type of
120 interface is found, the 'name' or 'operator' pointers may be set.
121 This subroutine doesn't return MATCH_NO. */
124 gfc_match_generic_spec (interface_type * type,
126 gfc_intrinsic_op *operator)
128 char buffer[GFC_MAX_SYMBOL_LEN + 1];
132 if (gfc_match (" assignment ( = )") == MATCH_YES)
134 *type = INTERFACE_INTRINSIC_OP;
135 *operator = INTRINSIC_ASSIGN;
139 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
141 *type = INTERFACE_INTRINSIC_OP;
142 *operator = fold_unary (i);
146 if (gfc_match (" operator ( ") == MATCH_YES)
148 m = gfc_match_defined_op_name (buffer, 1);
154 m = gfc_match_char (')');
160 strcpy (name, buffer);
161 *type = INTERFACE_USER_OP;
165 if (gfc_match_name (buffer) == MATCH_YES)
167 strcpy (name, buffer);
168 *type = INTERFACE_GENERIC;
172 *type = INTERFACE_NAMELESS;
176 gfc_error ("Syntax error in generic specification at %C");
181 /* Match one of the five forms of an interface statement. */
184 gfc_match_interface (void)
186 char name[GFC_MAX_SYMBOL_LEN + 1];
189 gfc_intrinsic_op operator;
192 m = gfc_match_space ();
194 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
198 /* If we're not looking at the end of the statement now, or if this
199 is not a nameless interface but we did not see a space, punt. */
200 if (gfc_match_eos () != MATCH_YES
201 || (type != INTERFACE_NAMELESS
205 ("Syntax error: Trailing garbage in INTERFACE statement at %C");
209 current_interface.type = type;
213 case INTERFACE_GENERIC:
214 if (gfc_get_symbol (name, NULL, &sym))
217 if (!sym->attr.generic
218 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
223 gfc_error ("Dummy procedure '%s' at %C cannot have a "
224 "generic interface", sym->name);
228 current_interface.sym = gfc_new_block = sym;
231 case INTERFACE_USER_OP:
232 current_interface.uop = gfc_get_uop (name);
235 case INTERFACE_INTRINSIC_OP:
236 current_interface.op = operator;
239 case INTERFACE_NAMELESS:
247 /* Match the different sort of generic-specs that can be present after
248 the END INTERFACE itself. */
251 gfc_match_end_interface (void)
253 char name[GFC_MAX_SYMBOL_LEN + 1];
255 gfc_intrinsic_op operator;
258 m = gfc_match_space ();
260 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
263 /* If we're not looking at the end of the statement now, or if this
264 is not a nameless interface but we did not see a space, punt. */
265 if (gfc_match_eos () != MATCH_YES
266 || (type != INTERFACE_NAMELESS
270 ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
276 switch (current_interface.type)
278 case INTERFACE_NAMELESS:
279 if (type != current_interface.type)
281 gfc_error ("Expected a nameless interface at %C");
287 case INTERFACE_INTRINSIC_OP:
288 if (type != current_interface.type || operator != current_interface.op)
291 if (current_interface.op == INTRINSIC_ASSIGN)
292 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
294 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
295 gfc_op2string (current_interface.op));
302 case INTERFACE_USER_OP:
303 /* Comparing the symbol node names is OK because only use-associated
304 symbols can be renamed. */
305 if (type != current_interface.type
306 || strcmp (current_interface.uop->name, name) != 0)
308 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
309 current_interface.uop->name);
315 case INTERFACE_GENERIC:
316 if (type != current_interface.type
317 || strcmp (current_interface.sym->name, name) != 0)
319 gfc_error ("Expecting 'END INTERFACE %s' at %C",
320 current_interface.sym->name);
331 /* Compare two derived types using the criteria in 4.4.2 of the standard,
332 recursing through gfc_compare_types for the components. */
335 gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
337 gfc_component *dt1, *dt2;
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 (derived1->name, derived2->name) == 0
343 && derived1 != NULL && derived2 != NULL
344 && derived1->module != NULL && derived2->module != NULL
345 && strcmp (derived1->module, derived2->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 (derived1->name, derived2->name))
354 if (derived1->component_access == ACCESS_PRIVATE
355 || derived2->component_access == ACCESS_PRIVATE)
358 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
361 dt1 = derived1->components;
362 dt2 = derived2->components;
364 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
365 simple test can speed things up. Otherwise, lots of things have to
369 if (strcmp (dt1->name, dt2->name) != 0)
372 if (dt1->pointer != dt2->pointer)
375 if (dt1->dimension != dt2->dimension)
378 if (dt1->allocatable != dt2->allocatable)
381 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
384 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
390 if (dt1 == NULL && dt2 == NULL)
392 if (dt1 == NULL || dt2 == NULL)
399 /* Compare two typespecs, recursively if necessary. */
402 gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
405 if (ts1->type != ts2->type)
407 if (ts1->type != BT_DERIVED)
408 return (ts1->kind == ts2->kind);
410 /* Compare derived types. */
411 if (ts1->derived == ts2->derived)
414 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
418 /* Given two symbols that are formal arguments, compare their ranks
419 and types. Returns nonzero if they have the same rank and type,
423 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
427 r1 = (s1->as != NULL) ? s1->as->rank : 0;
428 r2 = (s2->as != NULL) ? s2->as->rank : 0;
431 return 0; /* Ranks differ */
433 return gfc_compare_types (&s1->ts, &s2->ts);
437 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
439 /* Given two symbols that are formal arguments, compare their types
440 and rank and their formal interfaces if they are both dummy
441 procedures. Returns nonzero if the same, zero if different. */
444 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
446 if (s1 == NULL || s2 == NULL)
447 return s1 == s2 ? 1 : 0;
449 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
450 return compare_type_rank (s1, s2);
452 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
455 /* At this point, both symbols are procedures. */
456 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
457 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
460 if (s1->attr.function != s2->attr.function
461 || s1->attr.subroutine != s2->attr.subroutine)
464 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
467 /* Originally, gfortran recursed here to check the interfaces of passed
468 procedures. This is explicitly not required by the standard. */
473 /* Given a formal argument list and a keyword name, search the list
474 for that keyword. Returns the correct symbol node if found, NULL
478 find_keyword_arg (const char *name, gfc_formal_arglist * f)
481 for (; f; f = f->next)
482 if (strcmp (f->sym->name, name) == 0)
489 /******** Interface checking subroutines **********/
492 /* Given an operator interface and the operator, make sure that all
493 interfaces for that operator are legal. */
496 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
498 gfc_formal_arglist *formal;
508 t1 = t2 = BT_UNKNOWN;
509 i1 = i2 = INTENT_UNKNOWN;
511 for (formal = intr->sym->formal; formal; formal = formal->next)
516 gfc_error ("Alternate return cannot appear in operator "
517 "interface at %L", &intr->where);
523 i1 = sym->attr.intent;
528 i2 = sym->attr.intent;
533 if (args == 0 || args > 2)
538 if (operator == INTRINSIC_ASSIGN)
540 if (!sym->attr.subroutine)
543 ("Assignment operator interface at %L must be a SUBROUTINE",
550 ("Assignment operator interface at %L must have two arguments",
554 if (sym->formal->sym->ts.type != BT_DERIVED
555 && sym->formal->next->sym->ts.type != BT_DERIVED
556 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
557 || (gfc_numeric_ts (&sym->formal->sym->ts)
558 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
561 ("Assignment operator interface at %L must not redefine "
562 "an INTRINSIC type assignment", &intr->where);
568 if (!sym->attr.function)
570 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
578 case INTRINSIC_PLUS: /* Numeric unary or binary */
579 case INTRINSIC_MINUS:
583 || t1 == BT_COMPLEX))
587 && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
588 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
593 case INTRINSIC_POWER: /* Binary numeric */
594 case INTRINSIC_TIMES:
595 case INTRINSIC_DIVIDE:
602 if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
603 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
608 case INTRINSIC_GE: /* Binary numeric operators that do not support */
609 case INTRINSIC_LE: /* complex numbers */
615 if ((t1 == BT_INTEGER || t1 == BT_REAL)
616 && (t2 == BT_INTEGER || t2 == BT_REAL))
621 case INTRINSIC_OR: /* Binary logical */
627 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
631 case INTRINSIC_NOT: /* Unary logical */
634 if (t1 == BT_LOGICAL)
638 case INTRINSIC_CONCAT: /* Binary string */
641 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
645 case INTRINSIC_ASSIGN: /* Class by itself */
650 gfc_internal_error ("check_operator_interface(): Bad operator");
653 /* Check intents on operator interfaces. */
654 if (operator == INTRINSIC_ASSIGN)
656 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
657 gfc_error ("First argument of defined assignment at %L must be "
658 "INTENT(IN) or INTENT(INOUT)", &intr->where);
661 gfc_error ("Second argument of defined assignment at %L must be "
662 "INTENT(IN)", &intr->where);
667 gfc_error ("First argument of operator interface at %L must be "
668 "INTENT(IN)", &intr->where);
670 if (args == 2 && i2 != INTENT_IN)
671 gfc_error ("Second argument of operator interface at %L must be "
672 "INTENT(IN)", &intr->where);
678 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
683 gfc_error ("Operator interface at %L has the wrong number of arguments",
689 /* Given a pair of formal argument lists, we see if the two lists can
690 be distinguished by counting the number of nonoptional arguments of
691 a given type/rank in f1 and seeing if there are less then that
692 number of those arguments in f2 (including optional arguments).
693 Since this test is asymmetric, it has to be called twice to make it
694 symmetric. Returns nonzero if the argument lists are incompatible
695 by this test. This subroutine implements rule 1 of section
699 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
701 int rc, ac1, ac2, i, j, k, n1;
702 gfc_formal_arglist *f;
715 for (f = f1; f; f = f->next)
718 /* Build an array of integers that gives the same integer to
719 arguments of the same type/rank. */
720 arg = gfc_getmem (n1 * sizeof (arginfo));
723 for (i = 0; i < n1; i++, f = f->next)
731 for (i = 0; i < n1; i++)
733 if (arg[i].flag != -1)
736 if (arg[i].sym && arg[i].sym->attr.optional)
737 continue; /* Skip optional arguments */
741 /* Find other nonoptional arguments of the same type/rank. */
742 for (j = i + 1; j < n1; j++)
743 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
744 && compare_type_rank_if (arg[i].sym, arg[j].sym))
750 /* Now loop over each distinct type found in f1. */
754 for (i = 0; i < n1; i++)
756 if (arg[i].flag != k)
760 for (j = i + 1; j < n1; j++)
761 if (arg[j].flag == k)
764 /* Count the number of arguments in f2 with that type, including
765 those that are optional. */
768 for (f = f2; f; f = f->next)
769 if (compare_type_rank_if (arg[i].sym, f->sym))
787 /* Perform the abbreviated correspondence test for operators. The
788 arguments cannot be optional and are always ordered correctly,
789 which makes this test much easier than that for generic tests.
791 This subroutine is also used when comparing a formal and actual
792 argument list when an actual parameter is a dummy procedure. At
793 that point, two formal interfaces must be compared for equality
794 which is what happens here. */
797 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
801 if (f1 == NULL && f2 == NULL)
803 if (f1 == NULL || f2 == NULL)
806 if (!compare_type_rank (f1->sym, f2->sym))
817 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
818 Returns zero if no argument is found that satisfies rule 2, nonzero
821 This test is also not symmetric in f1 and f2 and must be called
822 twice. This test finds problems caused by sorting the actual
823 argument list with keywords. For example:
827 INTEGER :: A ; REAL :: B
831 INTEGER :: A ; REAL :: B
835 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
838 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
841 gfc_formal_arglist *f2_save, *g;
848 if (f1->sym->attr.optional)
851 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
854 /* Now search for a disambiguating keyword argument starting at
855 the current non-match. */
856 for (g = f1; g; g = g->next)
858 if (g->sym->attr.optional)
861 sym = find_keyword_arg (g->sym->name, f2_save);
862 if (sym == NULL || !compare_type_rank (g->sym, sym))
876 /* 'Compare' two formal interfaces associated with a pair of symbols.
877 We return nonzero if there exists an actual argument list that
878 would be ambiguous between the two interfaces, zero otherwise. */
881 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
883 gfc_formal_arglist *f1, *f2;
885 if (s1->attr.function != s2->attr.function
886 && s1->attr.subroutine != s2->attr.subroutine)
887 return 0; /* disagreement between function/subroutine */
892 if (f1 == NULL && f2 == NULL)
893 return 1; /* Special case */
895 if (count_types_test (f1, f2))
897 if (count_types_test (f2, f1))
902 if (generic_correspondence (f1, f2))
904 if (generic_correspondence (f2, f1))
909 if (operator_correspondence (f1, f2))
917 /* Given a pointer to an interface pointer, remove duplicate
918 interfaces and make sure that all symbols are either functions or
919 subroutines. Returns nonzero if something goes wrong. */
922 check_interface0 (gfc_interface * p, const char *interface_name)
924 gfc_interface *psave, *q, *qlast;
927 /* Make sure all symbols in the interface have been defined as
928 functions or subroutines. */
929 for (; p; p = p->next)
930 if (!p->sym->attr.function && !p->sym->attr.subroutine)
932 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
933 "subroutine", p->sym->name, interface_name,
934 &p->sym->declared_at);
939 /* Remove duplicate interfaces in this interface list. */
940 for (; p; p = p->next)
944 for (q = p->next; q;)
946 if (p->sym != q->sym)
954 /* Duplicate interface */
955 qlast->next = q->next;
966 /* Check lists of interfaces to make sure that no two interfaces are
967 ambiguous. Duplicate interfaces (from the same symbol) are OK
971 check_interface1 (gfc_interface * p, gfc_interface * q0,
972 int generic_flag, const char *interface_name,
976 for (; p; p = p->next)
977 for (q = q0; q; q = q->next)
979 if (p->sym == q->sym)
980 continue; /* Duplicates OK here */
982 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
985 if (compare_interfaces (p->sym, q->sym, generic_flag))
989 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
990 p->sym->name, q->sym->name, interface_name,
994 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
995 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
996 p->sym->name, q->sym->name, interface_name,
1005 /* Check the generic and operator interfaces of symbols to make sure
1006 that none of the interfaces conflict. The check has to be done
1007 after all of the symbols are actually loaded. */
1010 check_sym_interfaces (gfc_symbol * sym)
1012 char interface_name[100];
1016 if (sym->ns != gfc_current_ns)
1019 if (sym->generic != NULL)
1021 sprintf (interface_name, "generic interface '%s'", sym->name);
1022 if (check_interface0 (sym->generic, interface_name))
1025 for (p = sym->generic; p; p = p->next)
1027 if (!p->sym->attr.use_assoc
1028 && p->sym->attr.mod_proc
1029 && p->sym->attr.if_source != IFSRC_DECL)
1031 gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1032 "from a module", p->sym->name, &p->where);
1037 /* Originally, this test was applied to host interfaces too;
1038 this is incorrect since host associated symbols, from any
1039 source, cannot be ambiguous with local symbols. */
1040 k = sym->attr.referenced || !sym->attr.use_assoc;
1041 if (check_interface1 (sym->generic, sym->generic, 1,
1043 sym->attr.ambiguous_interfaces = 1;
1049 check_uop_interfaces (gfc_user_op * uop)
1051 char interface_name[100];
1055 sprintf (interface_name, "operator interface '%s'", uop->name);
1056 if (check_interface0 (uop->operator, interface_name))
1059 for (ns = gfc_current_ns; ns; ns = ns->parent)
1061 uop2 = gfc_find_uop (uop->name, ns);
1065 check_interface1 (uop->operator, uop2->operator, 0,
1066 interface_name, true);
1071 /* For the namespace, check generic, user operator and intrinsic
1072 operator interfaces for consistency and to remove duplicate
1073 interfaces. We traverse the whole namespace, counting on the fact
1074 that most symbols will not have generic or operator interfaces. */
1077 gfc_check_interfaces (gfc_namespace * ns)
1079 gfc_namespace *old_ns, *ns2;
1080 char interface_name[100];
1083 old_ns = gfc_current_ns;
1084 gfc_current_ns = ns;
1086 gfc_traverse_ns (ns, check_sym_interfaces);
1088 gfc_traverse_user_op (ns, check_uop_interfaces);
1090 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1092 if (i == INTRINSIC_USER)
1095 if (i == INTRINSIC_ASSIGN)
1096 strcpy (interface_name, "intrinsic assignment operator");
1098 sprintf (interface_name, "intrinsic '%s' operator",
1101 if (check_interface0 (ns->operator[i], interface_name))
1104 check_operator_interface (ns->operator[i], i);
1106 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1107 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1108 interface_name, true))
1112 gfc_current_ns = old_ns;
1117 symbol_rank (gfc_symbol * sym)
1120 return (sym->as == NULL) ? 0 : sym->as->rank;
1124 /* Given a symbol of a formal argument list and an expression, if the
1125 formal argument is allocatable, check that the actual argument is
1126 allocatable. Returns nonzero if compatible, zero if not compatible. */
1129 compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
1131 symbol_attribute attr;
1133 if (formal->attr.allocatable)
1135 attr = gfc_expr_attr (actual);
1136 if (!attr.allocatable)
1144 /* Given a symbol of a formal argument list and an expression, if the
1145 formal argument is a pointer, see if the actual argument is a
1146 pointer. Returns nonzero if compatible, zero if not compatible. */
1149 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1151 symbol_attribute attr;
1153 if (formal->attr.pointer)
1155 attr = gfc_expr_attr (actual);
1164 /* Given a symbol of a formal argument list and an expression, see if
1165 the two are compatible as arguments. Returns nonzero if
1166 compatible, zero if not compatible. */
1169 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1170 int ranks_must_agree, int is_elemental)
1174 if (actual->ts.type == BT_PROCEDURE)
1176 if (formal->attr.flavor != FL_PROCEDURE)
1179 if (formal->attr.function
1180 && !compare_type_rank (formal, actual->symtree->n.sym))
1183 if (formal->attr.if_source == IFSRC_UNKNOWN
1184 || actual->symtree->n.sym->attr.external)
1185 return 1; /* Assume match */
1187 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1190 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1191 && !gfc_compare_types (&formal->ts, &actual->ts))
1194 if (symbol_rank (formal) == actual->rank)
1197 /* At this point the ranks didn't agree. */
1198 if (ranks_must_agree || formal->attr.pointer)
1201 if (actual->rank != 0)
1202 return is_elemental || formal->attr.dimension;
1204 /* At this point, we are considering a scalar passed to an array.
1205 This is legal if the scalar is an array element of the right sort. */
1206 if (formal->as->type == AS_ASSUMED_SHAPE)
1209 for (ref = actual->ref; ref; ref = ref->next)
1210 if (ref->type == REF_SUBSTRING)
1213 for (ref = actual->ref; ref; ref = ref->next)
1214 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1218 return 0; /* Not an array element */
1224 /* Given a symbol of a formal argument list and an expression, see if
1225 the two are compatible as arguments. Returns nonzero if
1226 compatible, zero if not compatible. */
1229 compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
1231 if (actual->expr_type != EXPR_VARIABLE)
1234 if (!actual->symtree->n.sym->attr.protected)
1237 if (!actual->symtree->n.sym->attr.use_assoc)
1240 if (formal->attr.intent == INTENT_IN
1241 || formal->attr.intent == INTENT_UNKNOWN)
1244 if (!actual->symtree->n.sym->attr.pointer)
1247 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1254 /* Given formal and actual argument lists, see if they are compatible.
1255 If they are compatible, the actual argument list is sorted to
1256 correspond with the formal list, and elements for missing optional
1257 arguments are inserted. If WHERE pointer is nonnull, then we issue
1258 errors when things don't match instead of just returning the status
1262 compare_actual_formal (gfc_actual_arglist ** ap,
1263 gfc_formal_arglist * formal,
1264 int ranks_must_agree, int is_elemental, locus * where)
1266 gfc_actual_arglist **new, *a, *actual, temp;
1267 gfc_formal_arglist *f;
1273 if (actual == NULL && formal == NULL)
1277 for (f = formal; f; f = f->next)
1280 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1282 for (i = 0; i < n; i++)
1289 for (a = actual; a; a = a->next, f = f->next)
1291 /* Look for keywords but ignore g77 extensions like %VAL. */
1292 if (a->name != NULL && a->name[0] != '%')
1295 for (f = formal; f; f = f->next, i++)
1299 if (strcmp (f->sym->name, a->name) == 0)
1307 ("Keyword argument '%s' at %L is not in the procedure",
1308 a->name, &a->expr->where);
1316 ("Keyword argument '%s' at %L is already associated "
1317 "with another actual argument", a->name, &a->expr->where);
1326 ("More actual than formal arguments in procedure call at %L",
1332 if (f->sym == NULL && a->expr == NULL)
1339 ("Missing alternate return spec in subroutine call at %L",
1344 if (a->expr == NULL)
1348 ("Unexpected alternate return spec in subroutine call at %L",
1353 rank_check = where != NULL
1356 && (f->sym->as->type == AS_ASSUMED_SHAPE
1357 || f->sym->as->type == AS_DEFERRED);
1359 if (!compare_parameter
1360 (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
1363 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1364 f->sym->name, &a->expr->where);
1368 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1369 provided for a procedure formal argument. */
1370 if (a->expr->ts.type != BT_PROCEDURE
1371 && a->expr->expr_type == EXPR_VARIABLE
1372 && f->sym->attr.flavor == FL_PROCEDURE)
1375 gfc_error ("Expected a procedure for argument '%s' at %L",
1376 f->sym->name, &a->expr->where);
1380 if (f->sym->attr.flavor == FL_PROCEDURE
1381 && f->sym->attr.pure
1382 && a->expr->ts.type == BT_PROCEDURE
1383 && !a->expr->symtree->n.sym->attr.pure)
1386 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1387 f->sym->name, &a->expr->where);
1392 && f->sym->as->type == AS_ASSUMED_SHAPE
1393 && a->expr->expr_type == EXPR_VARIABLE
1394 && a->expr->symtree->n.sym->as
1395 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1396 && (a->expr->ref == NULL
1397 || (a->expr->ref->type == REF_ARRAY
1398 && a->expr->ref->u.ar.type == AR_FULL)))
1401 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1402 " array at %L", f->sym->name, where);
1406 if (a->expr->expr_type != EXPR_NULL
1407 && compare_pointer (f->sym, a->expr) == 0)
1410 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1411 f->sym->name, &a->expr->where);
1415 if (a->expr->expr_type != EXPR_NULL
1416 && compare_allocatable (f->sym, a->expr) == 0)
1419 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1420 f->sym->name, &a->expr->where);
1424 /* Check intent = OUT/INOUT for definable actual argument. */
1425 if (a->expr->expr_type != EXPR_VARIABLE
1426 && (f->sym->attr.intent == INTENT_OUT
1427 || f->sym->attr.intent == INTENT_INOUT))
1430 gfc_error ("Actual argument at %L must be definable to "
1431 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1435 if (!compare_parameter_protected(f->sym, a->expr))
1438 gfc_error ("Actual argument at %L is use-associated with "
1439 "PROTECTED attribute and dummy argument '%s' is "
1440 "INTENT = OUT/INOUT",
1441 &a->expr->where,f->sym->name);
1452 /* Make sure missing actual arguments are optional. */
1454 for (f = formal; f; f = f->next, i++)
1458 if (!f->sym->attr.optional)
1461 gfc_error ("Missing actual argument for argument '%s' at %L",
1462 f->sym->name, where);
1467 /* The argument lists are compatible. We now relink a new actual
1468 argument list with null arguments in the right places. The head
1469 of the list remains the head. */
1470 for (i = 0; i < n; i++)
1472 new[i] = gfc_get_actual_arglist ();
1485 for (i = 0; i < n - 1; i++)
1486 new[i]->next = new[i + 1];
1488 new[i]->next = NULL;
1490 if (*ap == NULL && n > 0)
1493 /* Note the types of omitted optional arguments. */
1494 for (a = actual, f = formal; a; a = a->next, f = f->next)
1495 if (a->expr == NULL && a->label == NULL)
1496 a->missing_arg_type = f->sym->ts.type;
1504 gfc_formal_arglist *f;
1505 gfc_actual_arglist *a;
1509 /* qsort comparison function for argument pairs, with the following
1511 - p->a->expr == NULL
1512 - p->a->expr->expr_type != EXPR_VARIABLE
1513 - growing p->a->expr->symbol. */
1516 pair_cmp (const void *p1, const void *p2)
1518 const gfc_actual_arglist *a1, *a2;
1520 /* *p1 and *p2 are elements of the to-be-sorted array. */
1521 a1 = ((const argpair *) p1)->a;
1522 a2 = ((const argpair *) p2)->a;
1531 if (a1->expr->expr_type != EXPR_VARIABLE)
1533 if (a2->expr->expr_type != EXPR_VARIABLE)
1537 if (a2->expr->expr_type != EXPR_VARIABLE)
1539 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1543 /* Given two expressions from some actual arguments, test whether they
1544 refer to the same expression. The analysis is conservative.
1545 Returning FAILURE will produce no warning. */
1548 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1550 const gfc_ref *r1, *r2;
1553 || e1->expr_type != EXPR_VARIABLE
1554 || e2->expr_type != EXPR_VARIABLE
1555 || e1->symtree->n.sym != e2->symtree->n.sym)
1558 /* TODO: improve comparison, see expr.c:show_ref(). */
1559 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1561 if (r1->type != r2->type)
1566 if (r1->u.ar.type != r2->u.ar.type)
1568 /* TODO: At the moment, consider only full arrays;
1569 we could do better. */
1570 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1575 if (r1->u.c.component != r2->u.c.component)
1583 gfc_internal_error ("compare_actual_expr(): Bad component code");
1591 /* Given formal and actual argument lists that correspond to one
1592 another, check that identical actual arguments aren't not
1593 associated with some incompatible INTENTs. */
1596 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1598 sym_intent f1_intent, f2_intent;
1599 gfc_formal_arglist *f1;
1600 gfc_actual_arglist *a1;
1606 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1608 if (f1 == NULL && a1 == NULL)
1610 if (f1 == NULL || a1 == NULL)
1611 gfc_internal_error ("check_some_aliasing(): List mismatch");
1616 p = (argpair *) alloca (n * sizeof (argpair));
1618 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1624 qsort (p, n, sizeof (argpair), pair_cmp);
1626 for (i = 0; i < n; i++)
1629 || p[i].a->expr->expr_type != EXPR_VARIABLE
1630 || p[i].a->expr->ts.type == BT_PROCEDURE)
1632 f1_intent = p[i].f->sym->attr.intent;
1633 for (j = i + 1; j < n; j++)
1635 /* Expected order after the sort. */
1636 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1637 gfc_internal_error ("check_some_aliasing(): corrupted data");
1639 /* Are the expression the same? */
1640 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1642 f2_intent = p[j].f->sym->attr.intent;
1643 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1644 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1646 gfc_warning ("Same actual argument associated with INTENT(%s) "
1647 "argument '%s' and INTENT(%s) argument '%s' at %L",
1648 gfc_intent_string (f1_intent), p[i].f->sym->name,
1649 gfc_intent_string (f2_intent), p[j].f->sym->name,
1650 &p[i].a->expr->where);
1660 /* Given formal and actual argument lists that correspond to one
1661 another, check that they are compatible in the sense that intents
1662 are not mismatched. */
1665 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1667 sym_intent a_intent, f_intent;
1669 for (;; f = f->next, a = a->next)
1671 if (f == NULL && a == NULL)
1673 if (f == NULL || a == NULL)
1674 gfc_internal_error ("check_intents(): List mismatch");
1676 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1679 a_intent = a->expr->symtree->n.sym->attr.intent;
1680 f_intent = f->sym->attr.intent;
1682 if (a_intent == INTENT_IN
1683 && (f_intent == INTENT_INOUT
1684 || f_intent == INTENT_OUT))
1687 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1688 "specifies INTENT(%s)", &a->expr->where,
1689 gfc_intent_string (f_intent));
1693 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1695 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1698 ("Procedure argument at %L is local to a PURE procedure and "
1699 "is passed to an INTENT(%s) argument", &a->expr->where,
1700 gfc_intent_string (f_intent));
1704 if (a->expr->symtree->n.sym->attr.pointer)
1707 ("Procedure argument at %L is local to a PURE procedure and "
1708 "has the POINTER attribute", &a->expr->where);
1718 /* Check how a procedure is used against its interface. If all goes
1719 well, the actual argument list will also end up being properly
1723 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1726 /* Warn about calls with an implicit interface. */
1727 if (gfc_option.warn_implicit_interface
1728 && sym->attr.if_source == IFSRC_UNKNOWN)
1729 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1732 if (sym->attr.if_source == IFSRC_UNKNOWN
1733 || !compare_actual_formal (ap, sym->formal, 0,
1734 sym->attr.elemental, where))
1737 check_intents (sym->formal, *ap);
1738 if (gfc_option.warn_aliasing)
1739 check_some_aliasing (sym->formal, *ap);
1743 /* Given an interface pointer and an actual argument list, search for
1744 a formal argument list that matches the actual. If found, returns
1745 a pointer to the symbol of the correct interface. Returns NULL if
1749 gfc_search_interface (gfc_interface * intr, int sub_flag,
1750 gfc_actual_arglist ** ap)
1754 for (; intr; intr = intr->next)
1756 if (sub_flag && intr->sym->attr.function)
1758 if (!sub_flag && intr->sym->attr.subroutine)
1761 r = !intr->sym->attr.elemental;
1763 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1765 check_intents (intr->sym->formal, *ap);
1766 if (gfc_option.warn_aliasing)
1767 check_some_aliasing (intr->sym->formal, *ap);
1776 /* Do a brute force recursive search for a symbol. */
1778 static gfc_symtree *
1779 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1783 if (root->n.sym == sym)
1788 st = find_symtree0 (root->left, sym);
1789 if (root->right && ! st)
1790 st = find_symtree0 (root->right, sym);
1795 /* Find a symtree for a symbol. */
1797 static gfc_symtree *
1798 find_sym_in_symtree (gfc_symbol * sym)
1803 /* First try to find it by name. */
1804 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1805 if (st && st->n.sym == sym)
1808 /* if it's been renamed, resort to a brute-force search. */
1809 /* TODO: avoid having to do this search. If the symbol doesn't exist
1810 in the symtree for the current namespace, it should probably be added. */
1811 for (ns = gfc_current_ns; ns; ns = ns->parent)
1813 st = find_symtree0 (ns->sym_root, sym);
1817 gfc_internal_error ("Unable to find symbol %s", sym->name);
1822 /* This subroutine is called when an expression is being resolved.
1823 The expression node in question is either a user defined operator
1824 or an intrinsic operator with arguments that aren't compatible
1825 with the operator. This subroutine builds an actual argument list
1826 corresponding to the operands, then searches for a compatible
1827 interface. If one is found, the expression node is replaced with
1828 the appropriate function call. */
1831 gfc_extend_expr (gfc_expr * e)
1833 gfc_actual_arglist *actual;
1841 actual = gfc_get_actual_arglist ();
1842 actual->expr = e->value.op.op1;
1844 if (e->value.op.op2 != NULL)
1846 actual->next = gfc_get_actual_arglist ();
1847 actual->next->expr = e->value.op.op2;
1850 i = fold_unary (e->value.op.operator);
1852 if (i == INTRINSIC_USER)
1854 for (ns = gfc_current_ns; ns; ns = ns->parent)
1856 uop = gfc_find_uop (e->value.op.uop->name, ns);
1860 sym = gfc_search_interface (uop->operator, 0, &actual);
1867 for (ns = gfc_current_ns; ns; ns = ns->parent)
1869 sym = gfc_search_interface (ns->operator[i], 0, &actual);
1877 /* Don't use gfc_free_actual_arglist() */
1878 if (actual->next != NULL)
1879 gfc_free (actual->next);
1885 /* Change the expression node to a function call. */
1886 e->expr_type = EXPR_FUNCTION;
1887 e->symtree = find_sym_in_symtree (sym);
1888 e->value.function.actual = actual;
1889 e->value.function.esym = NULL;
1890 e->value.function.isym = NULL;
1891 e->value.function.name = NULL;
1893 if (gfc_pure (NULL) && !gfc_pure (sym))
1896 ("Function '%s' called in lieu of an operator at %L must be PURE",
1897 sym->name, &e->where);
1901 if (gfc_resolve_expr (e) == FAILURE)
1908 /* Tries to replace an assignment code node with a subroutine call to
1909 the subroutine associated with the assignment operator. Return
1910 SUCCESS if the node was replaced. On FAILURE, no error is
1914 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1916 gfc_actual_arglist *actual;
1917 gfc_expr *lhs, *rhs;
1923 /* Don't allow an intrinsic assignment to be replaced. */
1924 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1925 && (lhs->ts.type == rhs->ts.type
1926 || (gfc_numeric_ts (&lhs->ts)
1927 && gfc_numeric_ts (&rhs->ts))))
1930 actual = gfc_get_actual_arglist ();
1933 actual->next = gfc_get_actual_arglist ();
1934 actual->next->expr = rhs;
1938 for (; ns; ns = ns->parent)
1940 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1947 gfc_free (actual->next);
1952 /* Replace the assignment with the call. */
1953 c->op = EXEC_ASSIGN_CALL;
1954 c->symtree = find_sym_in_symtree (sym);
1957 c->ext.actual = actual;
1963 /* Make sure that the interface just parsed is not already present in
1964 the given interface list. Ambiguity isn't checked yet since module
1965 procedures can be present without interfaces. */
1968 check_new_interface (gfc_interface * base, gfc_symbol * new)
1972 for (ip = base; ip; ip = ip->next)
1976 gfc_error ("Entity '%s' at %C is already present in the interface",
1986 /* Add a symbol to the current interface. */
1989 gfc_add_interface (gfc_symbol * new)
1991 gfc_interface **head, *intr;
1995 switch (current_interface.type)
1997 case INTERFACE_NAMELESS:
2000 case INTERFACE_INTRINSIC_OP:
2001 for (ns = current_interface.ns; ns; ns = ns->parent)
2002 if (check_new_interface (ns->operator[current_interface.op], new)
2006 head = ¤t_interface.ns->operator[current_interface.op];
2009 case INTERFACE_GENERIC:
2010 for (ns = current_interface.ns; ns; ns = ns->parent)
2012 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2016 if (check_new_interface (sym->generic, new) == FAILURE)
2020 head = ¤t_interface.sym->generic;
2023 case INTERFACE_USER_OP:
2024 if (check_new_interface (current_interface.uop->operator, new) ==
2028 head = ¤t_interface.uop->operator;
2032 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2035 intr = gfc_get_interface ();
2037 intr->where = gfc_current_locus;
2046 /* Gets rid of a formal argument list. We do not free symbols.
2047 Symbols are freed when a namespace is freed. */
2050 gfc_free_formal_arglist (gfc_formal_arglist * p)
2052 gfc_formal_arglist *q;