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)
447 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
448 return compare_type_rank (s1, s2);
450 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
453 /* At this point, both symbols are procedures. */
454 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
455 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
458 if (s1->attr.function != s2->attr.function
459 || s1->attr.subroutine != s2->attr.subroutine)
462 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
465 return compare_interfaces (s1, s2, 0); /* Recurse! */
469 /* Given a formal argument list and a keyword name, search the list
470 for that keyword. Returns the correct symbol node if found, NULL
474 find_keyword_arg (const char *name, gfc_formal_arglist * f)
477 for (; f; f = f->next)
478 if (strcmp (f->sym->name, name) == 0)
485 /******** Interface checking subroutines **********/
488 /* Given an operator interface and the operator, make sure that all
489 interfaces for that operator are legal. */
492 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
494 gfc_formal_arglist *formal;
504 t1 = t2 = BT_UNKNOWN;
505 i1 = i2 = INTENT_UNKNOWN;
507 for (formal = intr->sym->formal; formal; formal = formal->next)
512 gfc_error ("Alternate return cannot appear in operator "
513 "interface at %L", &intr->where);
519 i1 = sym->attr.intent;
524 i2 = sym->attr.intent;
529 if (args == 0 || args > 2)
534 if (operator == INTRINSIC_ASSIGN)
536 if (!sym->attr.subroutine)
539 ("Assignment operator interface at %L must be a SUBROUTINE",
546 ("Assignment operator interface at %L must have two arguments",
550 if (sym->formal->sym->ts.type != BT_DERIVED
551 && sym->formal->next->sym->ts.type != BT_DERIVED
552 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
553 || (gfc_numeric_ts (&sym->formal->sym->ts)
554 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
557 ("Assignment operator interface at %L must not redefine "
558 "an INTRINSIC type assignment", &intr->where);
564 if (!sym->attr.function)
566 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
574 case INTRINSIC_PLUS: /* Numeric unary or binary */
575 case INTRINSIC_MINUS:
579 || t1 == BT_COMPLEX))
583 && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
584 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
589 case INTRINSIC_POWER: /* Binary numeric */
590 case INTRINSIC_TIMES:
591 case INTRINSIC_DIVIDE:
598 if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
599 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
604 case INTRINSIC_GE: /* Binary numeric operators that do not support */
605 case INTRINSIC_LE: /* complex numbers */
611 if ((t1 == BT_INTEGER || t1 == BT_REAL)
612 && (t2 == BT_INTEGER || t2 == BT_REAL))
617 case INTRINSIC_OR: /* Binary logical */
623 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
627 case INTRINSIC_NOT: /* Unary logical */
630 if (t1 == BT_LOGICAL)
634 case INTRINSIC_CONCAT: /* Binary string */
637 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
641 case INTRINSIC_ASSIGN: /* Class by itself */
646 gfc_internal_error ("check_operator_interface(): Bad operator");
649 /* Check intents on operator interfaces. */
650 if (operator == INTRINSIC_ASSIGN)
652 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
653 gfc_error ("First argument of defined assignment at %L must be "
654 "INTENT(IN) or INTENT(INOUT)", &intr->where);
657 gfc_error ("Second argument of defined assignment at %L must be "
658 "INTENT(IN)", &intr->where);
663 gfc_error ("First argument of operator interface at %L must be "
664 "INTENT(IN)", &intr->where);
666 if (args == 2 && i2 != INTENT_IN)
667 gfc_error ("Second argument of operator interface at %L must be "
668 "INTENT(IN)", &intr->where);
674 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
679 gfc_error ("Operator interface at %L has the wrong number of arguments",
685 /* Given a pair of formal argument lists, we see if the two lists can
686 be distinguished by counting the number of nonoptional arguments of
687 a given type/rank in f1 and seeing if there are less then that
688 number of those arguments in f2 (including optional arguments).
689 Since this test is asymmetric, it has to be called twice to make it
690 symmetric. Returns nonzero if the argument lists are incompatible
691 by this test. This subroutine implements rule 1 of section
695 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
697 int rc, ac1, ac2, i, j, k, n1;
698 gfc_formal_arglist *f;
711 for (f = f1; f; f = f->next)
714 /* Build an array of integers that gives the same integer to
715 arguments of the same type/rank. */
716 arg = gfc_getmem (n1 * sizeof (arginfo));
719 for (i = 0; i < n1; i++, f = f->next)
727 for (i = 0; i < n1; i++)
729 if (arg[i].flag != -1)
732 if (arg[i].sym->attr.optional)
733 continue; /* Skip optional arguments */
737 /* Find other nonoptional arguments of the same type/rank. */
738 for (j = i + 1; j < n1; j++)
739 if (!arg[j].sym->attr.optional
740 && compare_type_rank_if (arg[i].sym, arg[j].sym))
746 /* Now loop over each distinct type found in f1. */
750 for (i = 0; i < n1; i++)
752 if (arg[i].flag != k)
756 for (j = i + 1; j < n1; j++)
757 if (arg[j].flag == k)
760 /* Count the number of arguments in f2 with that type, including
761 those that are optional. */
764 for (f = f2; f; f = f->next)
765 if (compare_type_rank_if (arg[i].sym, f->sym))
783 /* Perform the abbreviated correspondence test for operators. The
784 arguments cannot be optional and are always ordered correctly,
785 which makes this test much easier than that for generic tests.
787 This subroutine is also used when comparing a formal and actual
788 argument list when an actual parameter is a dummy procedure. At
789 that point, two formal interfaces must be compared for equality
790 which is what happens here. */
793 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
797 if (f1 == NULL && f2 == NULL)
799 if (f1 == NULL || f2 == NULL)
802 if (!compare_type_rank (f1->sym, f2->sym))
813 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
814 Returns zero if no argument is found that satisfies rule 2, nonzero
817 This test is also not symmetric in f1 and f2 and must be called
818 twice. This test finds problems caused by sorting the actual
819 argument list with keywords. For example:
823 INTEGER :: A ; REAL :: B
827 INTEGER :: A ; REAL :: B
831 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
834 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
837 gfc_formal_arglist *f2_save, *g;
844 if (f1->sym->attr.optional)
847 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
850 /* Now search for a disambiguating keyword argument starting at
851 the current non-match. */
852 for (g = f1; g; g = g->next)
854 if (g->sym->attr.optional)
857 sym = find_keyword_arg (g->sym->name, f2_save);
858 if (sym == NULL || !compare_type_rank (g->sym, sym))
872 /* 'Compare' two formal interfaces associated with a pair of symbols.
873 We return nonzero if there exists an actual argument list that
874 would be ambiguous between the two interfaces, zero otherwise. */
877 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
879 gfc_formal_arglist *f1, *f2;
881 if (s1->attr.function != s2->attr.function
882 && s1->attr.subroutine != s2->attr.subroutine)
883 return 0; /* disagreement between function/subroutine */
888 if (f1 == NULL && f2 == NULL)
889 return 1; /* Special case */
891 if (count_types_test (f1, f2))
893 if (count_types_test (f2, f1))
898 if (generic_correspondence (f1, f2))
900 if (generic_correspondence (f2, f1))
905 if (operator_correspondence (f1, f2))
913 /* Given a pointer to an interface pointer, remove duplicate
914 interfaces and make sure that all symbols are either functions or
915 subroutines. Returns nonzero if something goes wrong. */
918 check_interface0 (gfc_interface * p, const char *interface_name)
920 gfc_interface *psave, *q, *qlast;
923 /* Make sure all symbols in the interface have been defined as
924 functions or subroutines. */
925 for (; p; p = p->next)
926 if (!p->sym->attr.function && !p->sym->attr.subroutine)
928 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
929 "subroutine", p->sym->name, interface_name,
930 &p->sym->declared_at);
935 /* Remove duplicate interfaces in this interface list. */
936 for (; p; p = p->next)
940 for (q = p->next; q;)
942 if (p->sym != q->sym)
950 /* Duplicate interface */
951 qlast->next = q->next;
962 /* Check lists of interfaces to make sure that no two interfaces are
963 ambiguous. Duplicate interfaces (from the same symbol) are OK
967 check_interface1 (gfc_interface * p, gfc_interface * q,
968 int generic_flag, const char *interface_name)
971 for (; p; p = p->next)
972 for (; q; q = q->next)
974 if (p->sym == q->sym)
975 continue; /* Duplicates OK here */
977 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
980 if (compare_interfaces (p->sym, q->sym, generic_flag))
982 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
983 p->sym->name, q->sym->name, interface_name, &p->where);
992 /* Check the generic and operator interfaces of symbols to make sure
993 that none of the interfaces conflict. The check has to be done
994 after all of the symbols are actually loaded. */
997 check_sym_interfaces (gfc_symbol * sym)
999 char interface_name[100];
1002 if (sym->ns != gfc_current_ns)
1005 if (sym->generic != NULL)
1007 sprintf (interface_name, "generic interface '%s'", sym->name);
1008 if (check_interface0 (sym->generic, interface_name))
1014 if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
1017 if (s2->ns->parent == NULL)
1019 if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
1027 check_uop_interfaces (gfc_user_op * uop)
1029 char interface_name[100];
1033 sprintf (interface_name, "operator interface '%s'", uop->name);
1034 if (check_interface0 (uop->operator, interface_name))
1037 for (ns = gfc_current_ns; ns; ns = ns->parent)
1039 uop2 = gfc_find_uop (uop->name, ns);
1043 check_interface1 (uop->operator, uop2->operator, 0, interface_name);
1048 /* For the namespace, check generic, user operator and intrinsic
1049 operator interfaces for consistency and to remove duplicate
1050 interfaces. We traverse the whole namespace, counting on the fact
1051 that most symbols will not have generic or operator interfaces. */
1054 gfc_check_interfaces (gfc_namespace * ns)
1056 gfc_namespace *old_ns, *ns2;
1057 char interface_name[100];
1060 old_ns = gfc_current_ns;
1061 gfc_current_ns = ns;
1063 gfc_traverse_ns (ns, check_sym_interfaces);
1065 gfc_traverse_user_op (ns, check_uop_interfaces);
1067 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1069 if (i == INTRINSIC_USER)
1072 if (i == INTRINSIC_ASSIGN)
1073 strcpy (interface_name, "intrinsic assignment operator");
1075 sprintf (interface_name, "intrinsic '%s' operator",
1078 if (check_interface0 (ns->operator[i], interface_name))
1081 check_operator_interface (ns->operator[i], i);
1083 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1084 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1089 gfc_current_ns = old_ns;
1094 symbol_rank (gfc_symbol * sym)
1097 return (sym->as == NULL) ? 0 : sym->as->rank;
1101 /* Given a symbol of a formal argument list and an expression, if the
1102 formal argument is allocatable, check that the actual argument is
1103 allocatable. Returns nonzero if compatible, zero if not compatible. */
1106 compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
1108 symbol_attribute attr;
1110 if (formal->attr.allocatable)
1112 attr = gfc_expr_attr (actual);
1113 if (!attr.allocatable)
1121 /* Given a symbol of a formal argument list and an expression, if the
1122 formal argument is a pointer, see if the actual argument is a
1123 pointer. Returns nonzero if compatible, zero if not compatible. */
1126 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1128 symbol_attribute attr;
1130 if (formal->attr.pointer)
1132 attr = gfc_expr_attr (actual);
1141 /* Given a symbol of a formal argument list and an expression, see if
1142 the two are compatible as arguments. Returns nonzero if
1143 compatible, zero if not compatible. */
1146 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1147 int ranks_must_agree, int is_elemental)
1151 if (actual->ts.type == BT_PROCEDURE)
1153 if (formal->attr.flavor != FL_PROCEDURE)
1156 if (formal->attr.function
1157 && !compare_type_rank (formal, actual->symtree->n.sym))
1160 if (formal->attr.if_source == IFSRC_UNKNOWN
1161 || actual->symtree->n.sym->attr.external)
1162 return 1; /* Assume match */
1164 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1167 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1168 && !gfc_compare_types (&formal->ts, &actual->ts))
1171 if (symbol_rank (formal) == actual->rank)
1174 /* At this point the ranks didn't agree. */
1175 if (ranks_must_agree || formal->attr.pointer)
1178 if (actual->rank != 0)
1179 return is_elemental || formal->attr.dimension;
1181 /* At this point, we are considering a scalar passed to an array.
1182 This is legal if the scalar is an array element of the right sort. */
1183 if (formal->as->type == AS_ASSUMED_SHAPE)
1186 for (ref = actual->ref; ref; ref = ref->next)
1187 if (ref->type == REF_SUBSTRING)
1190 for (ref = actual->ref; ref; ref = ref->next)
1191 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1195 return 0; /* Not an array element */
1201 /* Given formal and actual argument lists, see if they are compatible.
1202 If they are compatible, the actual argument list is sorted to
1203 correspond with the formal list, and elements for missing optional
1204 arguments are inserted. If WHERE pointer is nonnull, then we issue
1205 errors when things don't match instead of just returning the status
1209 compare_actual_formal (gfc_actual_arglist ** ap,
1210 gfc_formal_arglist * formal,
1211 int ranks_must_agree, int is_elemental, locus * where)
1213 gfc_actual_arglist **new, *a, *actual, temp;
1214 gfc_formal_arglist *f;
1221 if (actual == NULL && formal == NULL)
1225 for (f = formal; f; f = f->next)
1228 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1230 for (i = 0; i < n; i++)
1237 for (a = actual; a; a = a->next, f = f->next)
1239 if (a->name != NULL)
1242 for (f = formal; f; f = f->next, i++)
1246 if (strcmp (f->sym->name, a->name) == 0)
1254 ("Keyword argument '%s' at %L is not in the procedure",
1255 a->name, &a->expr->where);
1263 ("Keyword argument '%s' at %L is already associated "
1264 "with another actual argument", a->name, &a->expr->where);
1273 ("More actual than formal arguments in procedure call at %L",
1279 if (f->sym == NULL && a->expr == NULL)
1286 ("Missing alternate return spec in subroutine call at %L",
1291 if (a->expr == NULL)
1295 ("Unexpected alternate return spec in subroutine call at %L",
1300 rank_check = where != NULL
1303 && (f->sym->as->type == AS_ASSUMED_SHAPE
1304 || f->sym->as->type == AS_DEFERRED);
1306 if (!compare_parameter
1307 (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
1310 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1311 f->sym->name, &a->expr->where);
1315 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1316 provided for a procedure formal argument. */
1317 if (a->expr->ts.type != BT_PROCEDURE
1318 && a->expr->expr_type == EXPR_VARIABLE
1319 && f->sym->attr.flavor == FL_PROCEDURE)
1321 gsym = gfc_find_gsymbol (gfc_gsym_root,
1322 a->expr->symtree->n.sym->name);
1323 if (gsym == NULL || (gsym->type != GSYM_FUNCTION
1324 && gsym->type != GSYM_SUBROUTINE))
1327 gfc_error ("Expected a procedure for argument '%s' at %L",
1328 f->sym->name, &a->expr->where);
1333 if (f->sym->attr.flavor == FL_PROCEDURE
1334 && f->sym->attr.pure
1335 && a->expr->ts.type == BT_PROCEDURE
1336 && !a->expr->symtree->n.sym->attr.pure)
1339 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1340 f->sym->name, &a->expr->where);
1345 && f->sym->as->type == AS_ASSUMED_SHAPE
1346 && a->expr->expr_type == EXPR_VARIABLE
1347 && a->expr->symtree->n.sym->as
1348 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1349 && (a->expr->ref == NULL
1350 || (a->expr->ref->type == REF_ARRAY
1351 && a->expr->ref->u.ar.type == AR_FULL)))
1354 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1355 " array at %L", f->sym->name, where);
1359 if (a->expr->expr_type != EXPR_NULL
1360 && compare_pointer (f->sym, a->expr) == 0)
1363 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1364 f->sym->name, &a->expr->where);
1368 if (a->expr->expr_type != EXPR_NULL
1369 && compare_allocatable (f->sym, a->expr) == 0)
1372 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1373 f->sym->name, &a->expr->where);
1377 /* Check intent = OUT/INOUT for definable actual argument. */
1378 if (a->expr->expr_type != EXPR_VARIABLE
1379 && (f->sym->attr.intent == INTENT_OUT
1380 || f->sym->attr.intent == INTENT_INOUT))
1382 gfc_error ("Actual argument at %L must be definable to "
1383 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1394 /* Make sure missing actual arguments are optional. */
1396 for (f = formal; f; f = f->next, i++)
1400 if (!f->sym->attr.optional)
1403 gfc_error ("Missing actual argument for argument '%s' at %L",
1404 f->sym->name, where);
1409 /* The argument lists are compatible. We now relink a new actual
1410 argument list with null arguments in the right places. The head
1411 of the list remains the head. */
1412 for (i = 0; i < n; i++)
1414 new[i] = gfc_get_actual_arglist ();
1427 for (i = 0; i < n - 1; i++)
1428 new[i]->next = new[i + 1];
1430 new[i]->next = NULL;
1432 if (*ap == NULL && n > 0)
1435 /* Note the types of omitted optional arguments. */
1436 for (a = actual, f = formal; a; a = a->next, f = f->next)
1437 if (a->expr == NULL && a->label == NULL)
1438 a->missing_arg_type = f->sym->ts.type;
1446 gfc_formal_arglist *f;
1447 gfc_actual_arglist *a;
1451 /* qsort comparison function for argument pairs, with the following
1453 - p->a->expr == NULL
1454 - p->a->expr->expr_type != EXPR_VARIABLE
1455 - growing p->a->expr->symbol. */
1458 pair_cmp (const void *p1, const void *p2)
1460 const gfc_actual_arglist *a1, *a2;
1462 /* *p1 and *p2 are elements of the to-be-sorted array. */
1463 a1 = ((const argpair *) p1)->a;
1464 a2 = ((const argpair *) p2)->a;
1473 if (a1->expr->expr_type != EXPR_VARIABLE)
1475 if (a2->expr->expr_type != EXPR_VARIABLE)
1479 if (a2->expr->expr_type != EXPR_VARIABLE)
1481 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1485 /* Given two expressions from some actual arguments, test whether they
1486 refer to the same expression. The analysis is conservative.
1487 Returning FAILURE will produce no warning. */
1490 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1492 const gfc_ref *r1, *r2;
1495 || e1->expr_type != EXPR_VARIABLE
1496 || e2->expr_type != EXPR_VARIABLE
1497 || e1->symtree->n.sym != e2->symtree->n.sym)
1500 /* TODO: improve comparison, see expr.c:show_ref(). */
1501 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1503 if (r1->type != r2->type)
1508 if (r1->u.ar.type != r2->u.ar.type)
1510 /* TODO: At the moment, consider only full arrays;
1511 we could do better. */
1512 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1517 if (r1->u.c.component != r2->u.c.component)
1525 gfc_internal_error ("compare_actual_expr(): Bad component code");
1533 /* Given formal and actual argument lists that correspond to one
1534 another, check that identical actual arguments aren't not
1535 associated with some incompatible INTENTs. */
1538 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1540 sym_intent f1_intent, f2_intent;
1541 gfc_formal_arglist *f1;
1542 gfc_actual_arglist *a1;
1548 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1550 if (f1 == NULL && a1 == NULL)
1552 if (f1 == NULL || a1 == NULL)
1553 gfc_internal_error ("check_some_aliasing(): List mismatch");
1558 p = (argpair *) alloca (n * sizeof (argpair));
1560 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1566 qsort (p, n, sizeof (argpair), pair_cmp);
1568 for (i = 0; i < n; i++)
1571 || p[i].a->expr->expr_type != EXPR_VARIABLE
1572 || p[i].a->expr->ts.type == BT_PROCEDURE)
1574 f1_intent = p[i].f->sym->attr.intent;
1575 for (j = i + 1; j < n; j++)
1577 /* Expected order after the sort. */
1578 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1579 gfc_internal_error ("check_some_aliasing(): corrupted data");
1581 /* Are the expression the same? */
1582 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1584 f2_intent = p[j].f->sym->attr.intent;
1585 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1586 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1588 gfc_warning ("Same actual argument associated with INTENT(%s) "
1589 "argument '%s' and INTENT(%s) argument '%s' at %L",
1590 gfc_intent_string (f1_intent), p[i].f->sym->name,
1591 gfc_intent_string (f2_intent), p[j].f->sym->name,
1592 &p[i].a->expr->where);
1602 /* Given formal and actual argument lists that correspond to one
1603 another, check that they are compatible in the sense that intents
1604 are not mismatched. */
1607 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1609 sym_intent a_intent, f_intent;
1611 for (;; f = f->next, a = a->next)
1613 if (f == NULL && a == NULL)
1615 if (f == NULL || a == NULL)
1616 gfc_internal_error ("check_intents(): List mismatch");
1618 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1621 a_intent = a->expr->symtree->n.sym->attr.intent;
1622 f_intent = f->sym->attr.intent;
1624 if (a_intent == INTENT_IN
1625 && (f_intent == INTENT_INOUT
1626 || f_intent == INTENT_OUT))
1629 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1630 "specifies INTENT(%s)", &a->expr->where,
1631 gfc_intent_string (f_intent));
1635 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1637 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1640 ("Procedure argument at %L is local to a PURE procedure and "
1641 "is passed to an INTENT(%s) argument", &a->expr->where,
1642 gfc_intent_string (f_intent));
1646 if (a->expr->symtree->n.sym->attr.pointer)
1649 ("Procedure argument at %L is local to a PURE procedure and "
1650 "has the POINTER attribute", &a->expr->where);
1660 /* Check how a procedure is used against its interface. If all goes
1661 well, the actual argument list will also end up being properly
1665 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1668 /* Warn about calls with an implicit interface. */
1669 if (gfc_option.warn_implicit_interface
1670 && sym->attr.if_source == IFSRC_UNKNOWN)
1671 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1674 if (sym->attr.if_source == IFSRC_UNKNOWN
1675 || !compare_actual_formal (ap, sym->formal, 0,
1676 sym->attr.elemental, where))
1679 check_intents (sym->formal, *ap);
1680 if (gfc_option.warn_aliasing)
1681 check_some_aliasing (sym->formal, *ap);
1685 /* Given an interface pointer and an actual argument list, search for
1686 a formal argument list that matches the actual. If found, returns
1687 a pointer to the symbol of the correct interface. Returns NULL if
1691 gfc_search_interface (gfc_interface * intr, int sub_flag,
1692 gfc_actual_arglist ** ap)
1696 for (; intr; intr = intr->next)
1698 if (sub_flag && intr->sym->attr.function)
1700 if (!sub_flag && intr->sym->attr.subroutine)
1703 r = !intr->sym->attr.elemental;
1705 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1707 check_intents (intr->sym->formal, *ap);
1708 if (gfc_option.warn_aliasing)
1709 check_some_aliasing (intr->sym->formal, *ap);
1718 /* Do a brute force recursive search for a symbol. */
1720 static gfc_symtree *
1721 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1725 if (root->n.sym == sym)
1730 st = find_symtree0 (root->left, sym);
1731 if (root->right && ! st)
1732 st = find_symtree0 (root->right, sym);
1737 /* Find a symtree for a symbol. */
1739 static gfc_symtree *
1740 find_sym_in_symtree (gfc_symbol * sym)
1745 /* First try to find it by name. */
1746 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1747 if (st && st->n.sym == sym)
1750 /* if it's been renamed, resort to a brute-force search. */
1751 /* TODO: avoid having to do this search. If the symbol doesn't exist
1752 in the symtree for the current namespace, it should probably be added. */
1753 for (ns = gfc_current_ns; ns; ns = ns->parent)
1755 st = find_symtree0 (ns->sym_root, sym);
1759 gfc_internal_error ("Unable to find symbol %s", sym->name);
1764 /* This subroutine is called when an expression is being resolved.
1765 The expression node in question is either a user defined operator
1766 or an intrinsic operator with arguments that aren't compatible
1767 with the operator. This subroutine builds an actual argument list
1768 corresponding to the operands, then searches for a compatible
1769 interface. If one is found, the expression node is replaced with
1770 the appropriate function call. */
1773 gfc_extend_expr (gfc_expr * e)
1775 gfc_actual_arglist *actual;
1783 actual = gfc_get_actual_arglist ();
1784 actual->expr = e->value.op.op1;
1786 if (e->value.op.op2 != NULL)
1788 actual->next = gfc_get_actual_arglist ();
1789 actual->next->expr = e->value.op.op2;
1792 i = fold_unary (e->value.op.operator);
1794 if (i == INTRINSIC_USER)
1796 for (ns = gfc_current_ns; ns; ns = ns->parent)
1798 uop = gfc_find_uop (e->value.op.uop->name, ns);
1802 sym = gfc_search_interface (uop->operator, 0, &actual);
1809 for (ns = gfc_current_ns; ns; ns = ns->parent)
1811 sym = gfc_search_interface (ns->operator[i], 0, &actual);
1819 /* Don't use gfc_free_actual_arglist() */
1820 if (actual->next != NULL)
1821 gfc_free (actual->next);
1827 /* Change the expression node to a function call. */
1828 e->expr_type = EXPR_FUNCTION;
1829 e->symtree = find_sym_in_symtree (sym);
1830 e->value.function.actual = actual;
1831 e->value.function.esym = NULL;
1832 e->value.function.isym = NULL;
1833 e->value.function.name = NULL;
1835 if (gfc_pure (NULL) && !gfc_pure (sym))
1838 ("Function '%s' called in lieu of an operator at %L must be PURE",
1839 sym->name, &e->where);
1843 if (gfc_resolve_expr (e) == FAILURE)
1850 /* Tries to replace an assignment code node with a subroutine call to
1851 the subroutine associated with the assignment operator. Return
1852 SUCCESS if the node was replaced. On FAILURE, no error is
1856 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1858 gfc_actual_arglist *actual;
1859 gfc_expr *lhs, *rhs;
1865 /* Don't allow an intrinsic assignment to be replaced. */
1866 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1867 && (lhs->ts.type == rhs->ts.type
1868 || (gfc_numeric_ts (&lhs->ts)
1869 && gfc_numeric_ts (&rhs->ts))))
1872 actual = gfc_get_actual_arglist ();
1875 actual->next = gfc_get_actual_arglist ();
1876 actual->next->expr = rhs;
1880 for (; ns; ns = ns->parent)
1882 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1889 gfc_free (actual->next);
1894 /* Replace the assignment with the call. */
1895 c->op = EXEC_ASSIGN_CALL;
1896 c->symtree = find_sym_in_symtree (sym);
1899 c->ext.actual = actual;
1905 /* Make sure that the interface just parsed is not already present in
1906 the given interface list. Ambiguity isn't checked yet since module
1907 procedures can be present without interfaces. */
1910 check_new_interface (gfc_interface * base, gfc_symbol * new)
1914 for (ip = base; ip; ip = ip->next)
1918 gfc_error ("Entity '%s' at %C is already present in the interface",
1928 /* Add a symbol to the current interface. */
1931 gfc_add_interface (gfc_symbol * new)
1933 gfc_interface **head, *intr;
1937 switch (current_interface.type)
1939 case INTERFACE_NAMELESS:
1942 case INTERFACE_INTRINSIC_OP:
1943 for (ns = current_interface.ns; ns; ns = ns->parent)
1944 if (check_new_interface (ns->operator[current_interface.op], new)
1948 head = ¤t_interface.ns->operator[current_interface.op];
1951 case INTERFACE_GENERIC:
1952 for (ns = current_interface.ns; ns; ns = ns->parent)
1954 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1958 if (check_new_interface (sym->generic, new) == FAILURE)
1962 head = ¤t_interface.sym->generic;
1965 case INTERFACE_USER_OP:
1966 if (check_new_interface (current_interface.uop->operator, new) ==
1970 head = ¤t_interface.uop->operator;
1974 gfc_internal_error ("gfc_add_interface(): Bad interface type");
1977 intr = gfc_get_interface ();
1979 intr->where = gfc_current_locus;
1988 /* Gets rid of a formal argument list. We do not free symbols.
1989 Symbols are freed when a namespace is freed. */
1992 gfc_free_formal_arglist (gfc_formal_arglist * p)
1994 gfc_formal_arglist *q;