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 * q0,
968 int generic_flag, const char *interface_name)
971 for (; p; p = p->next)
972 for (q = q0; 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))
1383 gfc_error ("Actual argument at %L must be definable to "
1384 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1395 /* Make sure missing actual arguments are optional. */
1397 for (f = formal; f; f = f->next, i++)
1401 if (!f->sym->attr.optional)
1404 gfc_error ("Missing actual argument for argument '%s' at %L",
1405 f->sym->name, where);
1410 /* The argument lists are compatible. We now relink a new actual
1411 argument list with null arguments in the right places. The head
1412 of the list remains the head. */
1413 for (i = 0; i < n; i++)
1415 new[i] = gfc_get_actual_arglist ();
1428 for (i = 0; i < n - 1; i++)
1429 new[i]->next = new[i + 1];
1431 new[i]->next = NULL;
1433 if (*ap == NULL && n > 0)
1436 /* Note the types of omitted optional arguments. */
1437 for (a = actual, f = formal; a; a = a->next, f = f->next)
1438 if (a->expr == NULL && a->label == NULL)
1439 a->missing_arg_type = f->sym->ts.type;
1447 gfc_formal_arglist *f;
1448 gfc_actual_arglist *a;
1452 /* qsort comparison function for argument pairs, with the following
1454 - p->a->expr == NULL
1455 - p->a->expr->expr_type != EXPR_VARIABLE
1456 - growing p->a->expr->symbol. */
1459 pair_cmp (const void *p1, const void *p2)
1461 const gfc_actual_arglist *a1, *a2;
1463 /* *p1 and *p2 are elements of the to-be-sorted array. */
1464 a1 = ((const argpair *) p1)->a;
1465 a2 = ((const argpair *) p2)->a;
1474 if (a1->expr->expr_type != EXPR_VARIABLE)
1476 if (a2->expr->expr_type != EXPR_VARIABLE)
1480 if (a2->expr->expr_type != EXPR_VARIABLE)
1482 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1486 /* Given two expressions from some actual arguments, test whether they
1487 refer to the same expression. The analysis is conservative.
1488 Returning FAILURE will produce no warning. */
1491 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1493 const gfc_ref *r1, *r2;
1496 || e1->expr_type != EXPR_VARIABLE
1497 || e2->expr_type != EXPR_VARIABLE
1498 || e1->symtree->n.sym != e2->symtree->n.sym)
1501 /* TODO: improve comparison, see expr.c:show_ref(). */
1502 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1504 if (r1->type != r2->type)
1509 if (r1->u.ar.type != r2->u.ar.type)
1511 /* TODO: At the moment, consider only full arrays;
1512 we could do better. */
1513 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1518 if (r1->u.c.component != r2->u.c.component)
1526 gfc_internal_error ("compare_actual_expr(): Bad component code");
1534 /* Given formal and actual argument lists that correspond to one
1535 another, check that identical actual arguments aren't not
1536 associated with some incompatible INTENTs. */
1539 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1541 sym_intent f1_intent, f2_intent;
1542 gfc_formal_arglist *f1;
1543 gfc_actual_arglist *a1;
1549 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1551 if (f1 == NULL && a1 == NULL)
1553 if (f1 == NULL || a1 == NULL)
1554 gfc_internal_error ("check_some_aliasing(): List mismatch");
1559 p = (argpair *) alloca (n * sizeof (argpair));
1561 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1567 qsort (p, n, sizeof (argpair), pair_cmp);
1569 for (i = 0; i < n; i++)
1572 || p[i].a->expr->expr_type != EXPR_VARIABLE
1573 || p[i].a->expr->ts.type == BT_PROCEDURE)
1575 f1_intent = p[i].f->sym->attr.intent;
1576 for (j = i + 1; j < n; j++)
1578 /* Expected order after the sort. */
1579 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1580 gfc_internal_error ("check_some_aliasing(): corrupted data");
1582 /* Are the expression the same? */
1583 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1585 f2_intent = p[j].f->sym->attr.intent;
1586 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1587 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1589 gfc_warning ("Same actual argument associated with INTENT(%s) "
1590 "argument '%s' and INTENT(%s) argument '%s' at %L",
1591 gfc_intent_string (f1_intent), p[i].f->sym->name,
1592 gfc_intent_string (f2_intent), p[j].f->sym->name,
1593 &p[i].a->expr->where);
1603 /* Given formal and actual argument lists that correspond to one
1604 another, check that they are compatible in the sense that intents
1605 are not mismatched. */
1608 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1610 sym_intent a_intent, f_intent;
1612 for (;; f = f->next, a = a->next)
1614 if (f == NULL && a == NULL)
1616 if (f == NULL || a == NULL)
1617 gfc_internal_error ("check_intents(): List mismatch");
1619 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1622 a_intent = a->expr->symtree->n.sym->attr.intent;
1623 f_intent = f->sym->attr.intent;
1625 if (a_intent == INTENT_IN
1626 && (f_intent == INTENT_INOUT
1627 || f_intent == INTENT_OUT))
1630 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1631 "specifies INTENT(%s)", &a->expr->where,
1632 gfc_intent_string (f_intent));
1636 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1638 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1641 ("Procedure argument at %L is local to a PURE procedure and "
1642 "is passed to an INTENT(%s) argument", &a->expr->where,
1643 gfc_intent_string (f_intent));
1647 if (a->expr->symtree->n.sym->attr.pointer)
1650 ("Procedure argument at %L is local to a PURE procedure and "
1651 "has the POINTER attribute", &a->expr->where);
1661 /* Check how a procedure is used against its interface. If all goes
1662 well, the actual argument list will also end up being properly
1666 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1669 /* Warn about calls with an implicit interface. */
1670 if (gfc_option.warn_implicit_interface
1671 && sym->attr.if_source == IFSRC_UNKNOWN)
1672 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1675 if (sym->attr.if_source == IFSRC_UNKNOWN
1676 || !compare_actual_formal (ap, sym->formal, 0,
1677 sym->attr.elemental, where))
1680 check_intents (sym->formal, *ap);
1681 if (gfc_option.warn_aliasing)
1682 check_some_aliasing (sym->formal, *ap);
1686 /* Given an interface pointer and an actual argument list, search for
1687 a formal argument list that matches the actual. If found, returns
1688 a pointer to the symbol of the correct interface. Returns NULL if
1692 gfc_search_interface (gfc_interface * intr, int sub_flag,
1693 gfc_actual_arglist ** ap)
1697 for (; intr; intr = intr->next)
1699 if (sub_flag && intr->sym->attr.function)
1701 if (!sub_flag && intr->sym->attr.subroutine)
1704 r = !intr->sym->attr.elemental;
1706 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1708 check_intents (intr->sym->formal, *ap);
1709 if (gfc_option.warn_aliasing)
1710 check_some_aliasing (intr->sym->formal, *ap);
1719 /* Do a brute force recursive search for a symbol. */
1721 static gfc_symtree *
1722 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1726 if (root->n.sym == sym)
1731 st = find_symtree0 (root->left, sym);
1732 if (root->right && ! st)
1733 st = find_symtree0 (root->right, sym);
1738 /* Find a symtree for a symbol. */
1740 static gfc_symtree *
1741 find_sym_in_symtree (gfc_symbol * sym)
1746 /* First try to find it by name. */
1747 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1748 if (st && st->n.sym == sym)
1751 /* if it's been renamed, resort to a brute-force search. */
1752 /* TODO: avoid having to do this search. If the symbol doesn't exist
1753 in the symtree for the current namespace, it should probably be added. */
1754 for (ns = gfc_current_ns; ns; ns = ns->parent)
1756 st = find_symtree0 (ns->sym_root, sym);
1760 gfc_internal_error ("Unable to find symbol %s", sym->name);
1765 /* This subroutine is called when an expression is being resolved.
1766 The expression node in question is either a user defined operator
1767 or an intrinsic operator with arguments that aren't compatible
1768 with the operator. This subroutine builds an actual argument list
1769 corresponding to the operands, then searches for a compatible
1770 interface. If one is found, the expression node is replaced with
1771 the appropriate function call. */
1774 gfc_extend_expr (gfc_expr * e)
1776 gfc_actual_arglist *actual;
1784 actual = gfc_get_actual_arglist ();
1785 actual->expr = e->value.op.op1;
1787 if (e->value.op.op2 != NULL)
1789 actual->next = gfc_get_actual_arglist ();
1790 actual->next->expr = e->value.op.op2;
1793 i = fold_unary (e->value.op.operator);
1795 if (i == INTRINSIC_USER)
1797 for (ns = gfc_current_ns; ns; ns = ns->parent)
1799 uop = gfc_find_uop (e->value.op.uop->name, ns);
1803 sym = gfc_search_interface (uop->operator, 0, &actual);
1810 for (ns = gfc_current_ns; ns; ns = ns->parent)
1812 sym = gfc_search_interface (ns->operator[i], 0, &actual);
1820 /* Don't use gfc_free_actual_arglist() */
1821 if (actual->next != NULL)
1822 gfc_free (actual->next);
1828 /* Change the expression node to a function call. */
1829 e->expr_type = EXPR_FUNCTION;
1830 e->symtree = find_sym_in_symtree (sym);
1831 e->value.function.actual = actual;
1832 e->value.function.esym = NULL;
1833 e->value.function.isym = NULL;
1834 e->value.function.name = NULL;
1836 if (gfc_pure (NULL) && !gfc_pure (sym))
1839 ("Function '%s' called in lieu of an operator at %L must be PURE",
1840 sym->name, &e->where);
1844 if (gfc_resolve_expr (e) == FAILURE)
1851 /* Tries to replace an assignment code node with a subroutine call to
1852 the subroutine associated with the assignment operator. Return
1853 SUCCESS if the node was replaced. On FAILURE, no error is
1857 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1859 gfc_actual_arglist *actual;
1860 gfc_expr *lhs, *rhs;
1866 /* Don't allow an intrinsic assignment to be replaced. */
1867 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1868 && (lhs->ts.type == rhs->ts.type
1869 || (gfc_numeric_ts (&lhs->ts)
1870 && gfc_numeric_ts (&rhs->ts))))
1873 actual = gfc_get_actual_arglist ();
1876 actual->next = gfc_get_actual_arglist ();
1877 actual->next->expr = rhs;
1881 for (; ns; ns = ns->parent)
1883 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1890 gfc_free (actual->next);
1895 /* Replace the assignment with the call. */
1896 c->op = EXEC_ASSIGN_CALL;
1897 c->symtree = find_sym_in_symtree (sym);
1900 c->ext.actual = actual;
1906 /* Make sure that the interface just parsed is not already present in
1907 the given interface list. Ambiguity isn't checked yet since module
1908 procedures can be present without interfaces. */
1911 check_new_interface (gfc_interface * base, gfc_symbol * new)
1915 for (ip = base; ip; ip = ip->next)
1919 gfc_error ("Entity '%s' at %C is already present in the interface",
1929 /* Add a symbol to the current interface. */
1932 gfc_add_interface (gfc_symbol * new)
1934 gfc_interface **head, *intr;
1938 switch (current_interface.type)
1940 case INTERFACE_NAMELESS:
1943 case INTERFACE_INTRINSIC_OP:
1944 for (ns = current_interface.ns; ns; ns = ns->parent)
1945 if (check_new_interface (ns->operator[current_interface.op], new)
1949 head = ¤t_interface.ns->operator[current_interface.op];
1952 case INTERFACE_GENERIC:
1953 for (ns = current_interface.ns; ns; ns = ns->parent)
1955 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1959 if (check_new_interface (sym->generic, new) == FAILURE)
1963 head = ¤t_interface.sym->generic;
1966 case INTERFACE_USER_OP:
1967 if (check_new_interface (current_interface.uop->operator, new) ==
1971 head = ¤t_interface.uop->operator;
1975 gfc_internal_error ("gfc_add_interface(): Bad interface type");
1978 intr = gfc_get_interface ();
1980 intr->where = gfc_current_locus;
1989 /* Gets rid of a formal argument list. We do not free symbols.
1990 Symbols are freed when a namespace is freed. */
1993 gfc_free_formal_arglist (gfc_formal_arglist * p)
1995 gfc_formal_arglist *q;