1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* Deal with interfaces. An explicit interface is represented as a
24 singly linked list of formal argument structures attached to the
25 relevant symbols. For an implicit interface, the arguments don't
26 point to symbols. Explicit interfaces point to namespaces that
27 contain the symbols within that interface.
29 Implicit interfaces are linked together in a singly linked list
30 along the next_if member of symbol nodes. Since a particular
31 symbol can only have a single explicit interface, the symbol cannot
32 be part of multiple lists and a single next-member suffices.
34 This is not the case for general classes, though. An operator
35 definition is independent of just about all other uses and has it's
39 Nameless interfaces create symbols with explicit interfaces within
40 the current namespace. They are otherwise unlinked.
43 The generic name points to a linked list of symbols. Each symbol
44 has an explicit interface. Each explicit interface has its own
45 namespace containing the arguments. Module procedures are symbols in
46 which the interface is added later when the module procedure is parsed.
49 User-defined operators are stored in a their own set of symtrees
50 separate from regular symbols. The symtrees point to gfc_user_op
51 structures which in turn head up a list of relevant interfaces.
53 Extended intrinsics and assignment:
54 The head of these interface lists are stored in the containing namespace.
57 An implicit interface is represented as a singly linked list of
58 formal argument list structures that don't point to any symbol
59 nodes -- they just contain types.
62 When a subprogram is defined, the program unit's name points to an
63 interface as usual, but the link to the namespace is NULL and the
64 formal argument list points to symbols within the same namespace as
65 the program unit name. */
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface * intr)
87 for (; intr; intr = next)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary (gfc_intrinsic_op operator)
104 case INTRINSIC_UPLUS:
105 operator = INTRINSIC_PLUS;
107 case INTRINSIC_UMINUS:
108 operator = INTRINSIC_MINUS;
118 /* Match a generic specification. Depending on which type of
119 interface is found, the 'name' or 'operator' pointers may be set.
120 This subroutine doesn't return MATCH_NO. */
123 gfc_match_generic_spec (interface_type * type,
125 gfc_intrinsic_op *operator)
127 char buffer[GFC_MAX_SYMBOL_LEN + 1];
131 if (gfc_match (" assignment ( = )") == MATCH_YES)
133 *type = INTERFACE_INTRINSIC_OP;
134 *operator = INTRINSIC_ASSIGN;
138 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
140 *type = INTERFACE_INTRINSIC_OP;
141 *operator = fold_unary (i);
145 if (gfc_match (" operator ( ") == MATCH_YES)
147 m = gfc_match_defined_op_name (buffer, 1);
153 m = gfc_match_char (')');
159 strcpy (name, buffer);
160 *type = INTERFACE_USER_OP;
164 if (gfc_match_name (buffer) == MATCH_YES)
166 strcpy (name, buffer);
167 *type = INTERFACE_GENERIC;
171 *type = INTERFACE_NAMELESS;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five forms of an interface statement. */
183 gfc_match_interface (void)
185 char name[GFC_MAX_SYMBOL_LEN + 1];
188 gfc_intrinsic_op operator;
191 m = gfc_match_space ();
193 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type != INTERFACE_NAMELESS
204 ("Syntax error: Trailing garbage in INTERFACE statement at %C");
208 current_interface.type = type;
212 case INTERFACE_GENERIC:
213 if (gfc_get_symbol (name, NULL, &sym))
216 if (!sym->attr.generic
217 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
222 gfc_error ("Dummy procedure '%s' at %C cannot have a "
223 "generic interface", sym->name);
227 current_interface.sym = gfc_new_block = sym;
230 case INTERFACE_USER_OP:
231 current_interface.uop = gfc_get_uop (name);
234 case INTERFACE_INTRINSIC_OP:
235 current_interface.op = operator;
238 case INTERFACE_NAMELESS:
246 /* Match the different sort of generic-specs that can be present after
247 the END INTERFACE itself. */
250 gfc_match_end_interface (void)
252 char name[GFC_MAX_SYMBOL_LEN + 1];
254 gfc_intrinsic_op operator;
257 m = gfc_match_space ();
259 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
262 /* If we're not looking at the end of the statement now, or if this
263 is not a nameless interface but we did not see a space, punt. */
264 if (gfc_match_eos () != MATCH_YES
265 || (type != INTERFACE_NAMELESS
269 ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
275 switch (current_interface.type)
277 case INTERFACE_NAMELESS:
278 if (type != current_interface.type)
280 gfc_error ("Expected a nameless interface at %C");
286 case INTERFACE_INTRINSIC_OP:
287 if (type != current_interface.type || operator != current_interface.op)
290 if (current_interface.op == INTRINSIC_ASSIGN)
291 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
293 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
294 gfc_op2string (current_interface.op));
301 case INTERFACE_USER_OP:
302 /* Comparing the symbol node names is OK because only use-associated
303 symbols can be renamed. */
304 if (type != current_interface.type
305 || strcmp (current_interface.uop->name, name) != 0)
307 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
308 current_interface.uop->name);
314 case INTERFACE_GENERIC:
315 if (type != current_interface.type
316 || strcmp (current_interface.sym->name, name) != 0)
318 gfc_error ("Expecting 'END INTERFACE %s' at %C",
319 current_interface.sym->name);
330 /* Compare two derived types using the criteria in 4.4.2 of the standard,
331 recursing through gfc_compare_types for the components. */
334 gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
336 gfc_component *dt1, *dt2;
338 /* Special case for comparing derived types across namespaces. If the
339 true names and module names are the same and the module name is
340 nonnull, then they are equal. */
341 if (strcmp (derived1->name, derived2->name) == 0
342 && derived1 != NULL && derived2 != NULL
343 && derived1->module != NULL && derived2->module != NULL
344 && strcmp (derived1->module, derived2->module) == 0)
347 /* Compare type via the rules of the standard. Both types must have
348 the SEQUENCE attribute to be equal. */
350 if (strcmp (derived1->name, derived2->name))
353 if (derived1->component_access == ACCESS_PRIVATE
354 || derived2->component_access == ACCESS_PRIVATE)
357 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
360 dt1 = derived1->components;
361 dt2 = derived2->components;
363 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
364 simple test can speed things up. Otherwise, lots of things have to
368 if (strcmp (dt1->name, dt2->name) != 0)
371 if (dt1->pointer != dt2->pointer)
374 if (dt1->dimension != dt2->dimension)
377 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
380 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
386 if (dt1 == NULL && dt2 == NULL)
388 if (dt1 == NULL || dt2 == NULL)
395 /* Compare two typespecs, recursively if necessary. */
398 gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
401 if (ts1->type != ts2->type)
403 if (ts1->type != BT_DERIVED)
404 return (ts1->kind == ts2->kind);
406 /* Compare derived types. */
407 if (ts1->derived == ts2->derived)
410 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
414 /* Given two symbols that are formal arguments, compare their ranks
415 and types. Returns nonzero if they have the same rank and type,
419 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
423 r1 = (s1->as != NULL) ? s1->as->rank : 0;
424 r2 = (s2->as != NULL) ? s2->as->rank : 0;
427 return 0; /* Ranks differ */
429 return gfc_compare_types (&s1->ts, &s2->ts);
433 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
435 /* Given two symbols that are formal arguments, compare their types
436 and rank and their formal interfaces if they are both dummy
437 procedures. Returns nonzero if the same, zero if different. */
440 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
443 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
444 return compare_type_rank (s1, s2);
446 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
449 /* At this point, both symbols are procedures. */
450 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
451 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
454 if (s1->attr.function != s2->attr.function
455 || s1->attr.subroutine != s2->attr.subroutine)
458 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
461 return compare_interfaces (s1, s2, 0); /* Recurse! */
465 /* Given a formal argument list and a keyword name, search the list
466 for that keyword. Returns the correct symbol node if found, NULL
470 find_keyword_arg (const char *name, gfc_formal_arglist * f)
473 for (; f; f = f->next)
474 if (strcmp (f->sym->name, name) == 0)
481 /******** Interface checking subroutines **********/
484 /* Given an operator interface and the operator, make sure that all
485 interfaces for that operator are legal. */
488 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
490 gfc_formal_arglist *formal;
500 t1 = t2 = BT_UNKNOWN;
501 i1 = i2 = INTENT_UNKNOWN;
503 for (formal = intr->sym->formal; formal; formal = formal->next)
510 i1 = sym->attr.intent;
515 i2 = sym->attr.intent;
520 if (args == 0 || args > 2)
525 if (operator == INTRINSIC_ASSIGN)
527 if (!sym->attr.subroutine)
530 ("Assignment operator interface at %L must be a SUBROUTINE",
537 if (!sym->attr.function)
539 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
547 case INTRINSIC_PLUS: /* Numeric unary or binary */
548 case INTRINSIC_MINUS:
552 || t1 == BT_COMPLEX))
556 && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
557 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
562 case INTRINSIC_POWER: /* Binary numeric */
563 case INTRINSIC_TIMES:
564 case INTRINSIC_DIVIDE:
571 if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
572 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
577 case INTRINSIC_GE: /* Binary numeric operators that do not support */
578 case INTRINSIC_LE: /* complex numbers */
584 if ((t1 == BT_INTEGER || t1 == BT_REAL)
585 && (t2 == BT_INTEGER || t2 == BT_REAL))
590 case INTRINSIC_OR: /* Binary logical */
596 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
600 case INTRINSIC_NOT: /* Unary logical */
603 if (t1 == BT_LOGICAL)
607 case INTRINSIC_CONCAT: /* Binary string */
610 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
614 case INTRINSIC_ASSIGN: /* Class by itself */
619 gfc_internal_error ("check_operator_interface(): Bad operator");
622 /* Check intents on operator interfaces. */
623 if (operator == INTRINSIC_ASSIGN)
625 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
626 gfc_error ("First argument of defined assignment at %L must be "
627 "INTENT(IN) or INTENT(INOUT)", &intr->where);
630 gfc_error ("Second argument of defined assignment at %L must be "
631 "INTENT(IN)", &intr->where);
636 gfc_error ("First argument of operator interface at %L must be "
637 "INTENT(IN)", &intr->where);
639 if (args == 2 && i2 != INTENT_IN)
640 gfc_error ("Second argument of operator interface at %L must be "
641 "INTENT(IN)", &intr->where);
647 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
652 gfc_error ("Operator interface at %L has the wrong number of arguments",
658 /* Given a pair of formal argument lists, we see if the two lists can
659 be distinguished by counting the number of nonoptional arguments of
660 a given type/rank in f1 and seeing if there are less then that
661 number of those arguments in f2 (including optional arguments).
662 Since this test is asymmetric, it has to be called twice to make it
663 symmetric. Returns nonzero if the argument lists are incompatible
664 by this test. This subroutine implements rule 1 of section
668 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
670 int rc, ac1, ac2, i, j, k, n1;
671 gfc_formal_arglist *f;
684 for (f = f1; f; f = f->next)
687 /* Build an array of integers that gives the same integer to
688 arguments of the same type/rank. */
689 arg = gfc_getmem (n1 * sizeof (arginfo));
692 for (i = 0; i < n1; i++, f = f->next)
700 for (i = 0; i < n1; i++)
702 if (arg[i].flag != -1)
705 if (arg[i].sym->attr.optional)
706 continue; /* Skip optional arguments */
710 /* Find other nonoptional arguments of the same type/rank. */
711 for (j = i + 1; j < n1; j++)
712 if (!arg[j].sym->attr.optional
713 && compare_type_rank_if (arg[i].sym, arg[j].sym))
719 /* Now loop over each distinct type found in f1. */
723 for (i = 0; i < n1; i++)
725 if (arg[i].flag != k)
729 for (j = i + 1; j < n1; j++)
730 if (arg[j].flag == k)
733 /* Count the number of arguments in f2 with that type, including
734 those that are optional. */
737 for (f = f2; f; f = f->next)
738 if (compare_type_rank_if (arg[i].sym, f->sym))
756 /* Perform the abbreviated correspondence test for operators. The
757 arguments cannot be optional and are always ordered correctly,
758 which makes this test much easier than that for generic tests.
760 This subroutine is also used when comparing a formal and actual
761 argument list when an actual parameter is a dummy procedure. At
762 that point, two formal interfaces must be compared for equality
763 which is what happens here. */
766 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
770 if (f1 == NULL && f2 == NULL)
772 if (f1 == NULL || f2 == NULL)
775 if (!compare_type_rank (f1->sym, f2->sym))
786 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
787 Returns zero if no argument is found that satisfies rule 2, nonzero
790 This test is also not symmetric in f1 and f2 and must be called
791 twice. This test finds problems caused by sorting the actual
792 argument list with keywords. For example:
796 INTEGER :: A ; REAL :: B
800 INTEGER :: A ; REAL :: B
804 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
807 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
810 gfc_formal_arglist *f2_save, *g;
817 if (f1->sym->attr.optional)
820 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
823 /* Now search for a disambiguating keyword argument starting at
824 the current non-match. */
825 for (g = f1; g; g = g->next)
827 if (g->sym->attr.optional)
830 sym = find_keyword_arg (g->sym->name, f2_save);
831 if (sym == NULL || !compare_type_rank (g->sym, sym))
845 /* 'Compare' two formal interfaces associated with a pair of symbols.
846 We return nonzero if there exists an actual argument list that
847 would be ambiguous between the two interfaces, zero otherwise. */
850 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
852 gfc_formal_arglist *f1, *f2;
854 if (s1->attr.function != s2->attr.function
855 && s1->attr.subroutine != s2->attr.subroutine)
856 return 0; /* disagreement between function/subroutine */
861 if (f1 == NULL && f2 == NULL)
862 return 1; /* Special case */
864 if (count_types_test (f1, f2))
866 if (count_types_test (f2, f1))
871 if (generic_correspondence (f1, f2))
873 if (generic_correspondence (f2, f1))
878 if (operator_correspondence (f1, f2))
886 /* Given a pointer to an interface pointer, remove duplicate
887 interfaces and make sure that all symbols are either functions or
888 subroutines. Returns nonzero if something goes wrong. */
891 check_interface0 (gfc_interface * p, const char *interface_name)
893 gfc_interface *psave, *q, *qlast;
896 /* Make sure all symbols in the interface have been defined as
897 functions or subroutines. */
898 for (; p; p = p->next)
899 if (!p->sym->attr.function && !p->sym->attr.subroutine)
901 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
902 "subroutine", p->sym->name, interface_name,
903 &p->sym->declared_at);
908 /* Remove duplicate interfaces in this interface list. */
909 for (; p; p = p->next)
913 for (q = p->next; q;)
915 if (p->sym != q->sym)
923 /* Duplicate interface */
924 qlast->next = q->next;
935 /* Check lists of interfaces to make sure that no two interfaces are
936 ambiguous. Duplicate interfaces (from the same symbol) are OK
940 check_interface1 (gfc_interface * p, gfc_interface * q,
941 int generic_flag, const char *interface_name)
944 for (; p; p = p->next)
945 for (; q; q = q->next)
947 if (p->sym == q->sym)
948 continue; /* Duplicates OK here */
950 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
953 if (compare_interfaces (p->sym, q->sym, generic_flag))
955 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
956 p->sym->name, q->sym->name, interface_name, &p->where);
965 /* Check the generic and operator interfaces of symbols to make sure
966 that none of the interfaces conflict. The check has to be done
967 after all of the symbols are actually loaded. */
970 check_sym_interfaces (gfc_symbol * sym)
972 char interface_name[100];
975 if (sym->ns != gfc_current_ns)
978 if (sym->generic != NULL)
980 sprintf (interface_name, "generic interface '%s'", sym->name);
981 if (check_interface0 (sym->generic, interface_name))
987 if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
990 if (s2->ns->parent == NULL)
992 if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
1000 check_uop_interfaces (gfc_user_op * uop)
1002 char interface_name[100];
1006 sprintf (interface_name, "operator interface '%s'", uop->name);
1007 if (check_interface0 (uop->operator, interface_name))
1010 for (ns = gfc_current_ns; ns; ns = ns->parent)
1012 uop2 = gfc_find_uop (uop->name, ns);
1016 check_interface1 (uop->operator, uop2->operator, 0, interface_name);
1021 /* For the namespace, check generic, user operator and intrinsic
1022 operator interfaces for consistency and to remove duplicate
1023 interfaces. We traverse the whole namespace, counting on the fact
1024 that most symbols will not have generic or operator interfaces. */
1027 gfc_check_interfaces (gfc_namespace * ns)
1029 gfc_namespace *old_ns, *ns2;
1030 char interface_name[100];
1033 old_ns = gfc_current_ns;
1034 gfc_current_ns = ns;
1036 gfc_traverse_ns (ns, check_sym_interfaces);
1038 gfc_traverse_user_op (ns, check_uop_interfaces);
1040 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1042 if (i == INTRINSIC_USER)
1045 if (i == INTRINSIC_ASSIGN)
1046 strcpy (interface_name, "intrinsic assignment operator");
1048 sprintf (interface_name, "intrinsic '%s' operator",
1051 if (check_interface0 (ns->operator[i], interface_name))
1054 check_operator_interface (ns->operator[i], i);
1056 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1057 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1062 gfc_current_ns = old_ns;
1067 symbol_rank (gfc_symbol * sym)
1070 return (sym->as == NULL) ? 0 : sym->as->rank;
1074 /* Given a symbol of a formal argument list and an expression, if the
1075 formal argument is allocatable, check that the actual argument is
1076 allocatable. Returns nonzero if compatible, zero if not compatible. */
1079 compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
1081 symbol_attribute attr;
1083 if (formal->attr.allocatable)
1085 attr = gfc_expr_attr (actual);
1086 if (!attr.allocatable)
1094 /* Given a symbol of a formal argument list and an expression, if the
1095 formal argument is a pointer, see if the actual argument is a
1096 pointer. Returns nonzero if compatible, zero if not compatible. */
1099 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1101 symbol_attribute attr;
1103 if (formal->attr.pointer)
1105 attr = gfc_expr_attr (actual);
1114 /* Given a symbol of a formal argument list and an expression, see if
1115 the two are compatible as arguments. Returns nonzero if
1116 compatible, zero if not compatible. */
1119 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1120 int ranks_must_agree, int is_elemental)
1124 if (actual->ts.type == BT_PROCEDURE)
1126 if (formal->attr.flavor != FL_PROCEDURE)
1129 if (formal->attr.function
1130 && !compare_type_rank (formal, actual->symtree->n.sym))
1133 if (formal->attr.if_source == IFSRC_UNKNOWN
1134 || actual->symtree->n.sym->attr.external)
1135 return 1; /* Assume match */
1137 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1140 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1141 && !gfc_compare_types (&formal->ts, &actual->ts))
1144 if (symbol_rank (formal) == actual->rank)
1147 /* At this point the ranks didn't agree. */
1148 if (ranks_must_agree || formal->attr.pointer)
1151 if (actual->rank != 0)
1152 return is_elemental || formal->attr.dimension;
1154 /* At this point, we are considering a scalar passed to an array.
1155 This is legal if the scalar is an array element of the right sort. */
1156 if (formal->as->type == AS_ASSUMED_SHAPE)
1159 for (ref = actual->ref; ref; ref = ref->next)
1160 if (ref->type == REF_SUBSTRING)
1163 for (ref = actual->ref; ref; ref = ref->next)
1164 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1168 return 0; /* Not an array element */
1174 /* Given formal and actual argument lists, see if they are compatible.
1175 If they are compatible, the actual argument list is sorted to
1176 correspond with the formal list, and elements for missing optional
1177 arguments are inserted. If WHERE pointer is nonnull, then we issue
1178 errors when things don't match instead of just returning the status
1182 compare_actual_formal (gfc_actual_arglist ** ap,
1183 gfc_formal_arglist * formal,
1184 int ranks_must_agree, int is_elemental, locus * where)
1186 gfc_actual_arglist **new, *a, *actual, temp;
1187 gfc_formal_arglist *f;
1194 if (actual == NULL && formal == NULL)
1198 for (f = formal; f; f = f->next)
1201 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1203 for (i = 0; i < n; i++)
1210 for (a = actual; a; a = a->next, f = f->next)
1212 if (a->name != NULL)
1215 for (f = formal; f; f = f->next, i++)
1219 if (strcmp (f->sym->name, a->name) == 0)
1227 ("Keyword argument '%s' at %L is not in the procedure",
1228 a->name, &a->expr->where);
1236 ("Keyword argument '%s' at %L is already associated "
1237 "with another actual argument", a->name, &a->expr->where);
1246 ("More actual than formal arguments in procedure call at %L",
1252 if (f->sym == NULL && a->expr == NULL)
1259 ("Missing alternate return spec in subroutine call at %L",
1264 if (a->expr == NULL)
1268 ("Unexpected alternate return spec in subroutine call at %L",
1273 rank_check = where != NULL
1276 && (f->sym->as->type == AS_ASSUMED_SHAPE
1277 || f->sym->as->type == AS_DEFERRED);
1279 if (!compare_parameter
1280 (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
1283 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1284 f->sym->name, &a->expr->where);
1288 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1289 provided for a procedure formal argument. */
1290 if (a->expr->ts.type != BT_PROCEDURE
1291 && a->expr->expr_type == EXPR_VARIABLE
1292 && f->sym->attr.flavor == FL_PROCEDURE)
1294 gsym = gfc_find_gsymbol (gfc_gsym_root,
1295 a->expr->symtree->n.sym->name);
1296 if (gsym == NULL || (gsym->type != GSYM_FUNCTION
1297 && gsym->type != GSYM_SUBROUTINE))
1300 gfc_error ("Expected a procedure for argument '%s' at %L",
1301 f->sym->name, &a->expr->where);
1306 if (f->sym->attr.flavor == FL_PROCEDURE
1307 && f->sym->attr.pure
1308 && a->expr->ts.type == BT_PROCEDURE
1309 && !a->expr->symtree->n.sym->attr.pure)
1312 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1313 f->sym->name, &a->expr->where);
1318 && f->sym->as->type == AS_ASSUMED_SHAPE
1319 && a->expr->expr_type == EXPR_VARIABLE
1320 && a->expr->symtree->n.sym->as
1321 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1322 && (a->expr->ref == NULL
1323 || (a->expr->ref->type == REF_ARRAY
1324 && a->expr->ref->u.ar.type == AR_FULL)))
1327 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1328 " array at %L", f->sym->name, where);
1332 if (a->expr->expr_type != EXPR_NULL
1333 && compare_pointer (f->sym, a->expr) == 0)
1336 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1337 f->sym->name, &a->expr->where);
1341 if (a->expr->expr_type != EXPR_NULL
1342 && compare_allocatable (f->sym, a->expr) == 0)
1345 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1346 f->sym->name, &a->expr->where);
1350 /* Check intent = OUT/INOUT for definable actual argument. */
1351 if (a->expr->expr_type != EXPR_VARIABLE
1352 && (f->sym->attr.intent == INTENT_OUT
1353 || f->sym->attr.intent == INTENT_INOUT))
1355 gfc_error ("Actual argument at %L must be definable to "
1356 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1367 /* Make sure missing actual arguments are optional. */
1369 for (f = formal; f; f = f->next, i++)
1373 if (!f->sym->attr.optional)
1376 gfc_error ("Missing actual argument for argument '%s' at %L",
1377 f->sym->name, where);
1382 /* The argument lists are compatible. We now relink a new actual
1383 argument list with null arguments in the right places. The head
1384 of the list remains the head. */
1385 for (i = 0; i < n; i++)
1387 new[i] = gfc_get_actual_arglist ();
1400 for (i = 0; i < n - 1; i++)
1401 new[i]->next = new[i + 1];
1403 new[i]->next = NULL;
1405 if (*ap == NULL && n > 0)
1408 /* Note the types of omitted optional arguments. */
1409 for (a = actual, f = formal; a; a = a->next, f = f->next)
1410 if (a->expr == NULL && a->label == NULL)
1411 a->missing_arg_type = f->sym->ts.type;
1419 gfc_formal_arglist *f;
1420 gfc_actual_arglist *a;
1424 /* qsort comparison function for argument pairs, with the following
1426 - p->a->expr == NULL
1427 - p->a->expr->expr_type != EXPR_VARIABLE
1428 - growing p->a->expr->symbol. */
1431 pair_cmp (const void *p1, const void *p2)
1433 const gfc_actual_arglist *a1, *a2;
1435 /* *p1 and *p2 are elements of the to-be-sorted array. */
1436 a1 = ((const argpair *) p1)->a;
1437 a2 = ((const argpair *) p2)->a;
1446 if (a1->expr->expr_type != EXPR_VARIABLE)
1448 if (a2->expr->expr_type != EXPR_VARIABLE)
1452 if (a2->expr->expr_type != EXPR_VARIABLE)
1454 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1458 /* Given two expressions from some actual arguments, test whether they
1459 refer to the same expression. The analysis is conservative.
1460 Returning FAILURE will produce no warning. */
1463 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1465 const gfc_ref *r1, *r2;
1468 || e1->expr_type != EXPR_VARIABLE
1469 || e2->expr_type != EXPR_VARIABLE
1470 || e1->symtree->n.sym != e2->symtree->n.sym)
1473 /* TODO: improve comparison, see expr.c:show_ref(). */
1474 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1476 if (r1->type != r2->type)
1481 if (r1->u.ar.type != r2->u.ar.type)
1483 /* TODO: At the moment, consider only full arrays;
1484 we could do better. */
1485 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1490 if (r1->u.c.component != r2->u.c.component)
1498 gfc_internal_error ("compare_actual_expr(): Bad component code");
1506 /* Given formal and actual argument lists that correspond to one
1507 another, check that identical actual arguments aren't not
1508 associated with some incompatible INTENTs. */
1511 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1513 sym_intent f1_intent, f2_intent;
1514 gfc_formal_arglist *f1;
1515 gfc_actual_arglist *a1;
1521 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1523 if (f1 == NULL && a1 == NULL)
1525 if (f1 == NULL || a1 == NULL)
1526 gfc_internal_error ("check_some_aliasing(): List mismatch");
1531 p = (argpair *) alloca (n * sizeof (argpair));
1533 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1539 qsort (p, n, sizeof (argpair), pair_cmp);
1541 for (i = 0; i < n; i++)
1544 || p[i].a->expr->expr_type != EXPR_VARIABLE
1545 || p[i].a->expr->ts.type == BT_PROCEDURE)
1547 f1_intent = p[i].f->sym->attr.intent;
1548 for (j = i + 1; j < n; j++)
1550 /* Expected order after the sort. */
1551 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1552 gfc_internal_error ("check_some_aliasing(): corrupted data");
1554 /* Are the expression the same? */
1555 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1557 f2_intent = p[j].f->sym->attr.intent;
1558 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1559 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1561 gfc_warning ("Same actual argument associated with INTENT(%s) "
1562 "argument '%s' and INTENT(%s) argument '%s' at %L",
1563 gfc_intent_string (f1_intent), p[i].f->sym->name,
1564 gfc_intent_string (f2_intent), p[j].f->sym->name,
1565 &p[i].a->expr->where);
1575 /* Given formal and actual argument lists that correspond to one
1576 another, check that they are compatible in the sense that intents
1577 are not mismatched. */
1580 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1582 sym_intent a_intent, f_intent;
1584 for (;; f = f->next, a = a->next)
1586 if (f == NULL && a == NULL)
1588 if (f == NULL || a == NULL)
1589 gfc_internal_error ("check_intents(): List mismatch");
1591 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1594 a_intent = a->expr->symtree->n.sym->attr.intent;
1595 f_intent = f->sym->attr.intent;
1597 if (a_intent == INTENT_IN
1598 && (f_intent == INTENT_INOUT
1599 || f_intent == INTENT_OUT))
1602 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1603 "specifies INTENT(%s)", &a->expr->where,
1604 gfc_intent_string (f_intent));
1608 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1610 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1613 ("Procedure argument at %L is local to a PURE procedure and "
1614 "is passed to an INTENT(%s) argument", &a->expr->where,
1615 gfc_intent_string (f_intent));
1619 if (a->expr->symtree->n.sym->attr.pointer)
1622 ("Procedure argument at %L is local to a PURE procedure and "
1623 "has the POINTER attribute", &a->expr->where);
1633 /* Check how a procedure is used against its interface. If all goes
1634 well, the actual argument list will also end up being properly
1638 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1641 /* Warn about calls with an implicit interface. */
1642 if (gfc_option.warn_implicit_interface
1643 && sym->attr.if_source == IFSRC_UNKNOWN)
1644 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1647 if (sym->attr.if_source == IFSRC_UNKNOWN
1648 || !compare_actual_formal (ap, sym->formal, 0,
1649 sym->attr.elemental, where))
1652 check_intents (sym->formal, *ap);
1653 if (gfc_option.warn_aliasing)
1654 check_some_aliasing (sym->formal, *ap);
1658 /* Given an interface pointer and an actual argument list, search for
1659 a formal argument list that matches the actual. If found, returns
1660 a pointer to the symbol of the correct interface. Returns NULL if
1664 gfc_search_interface (gfc_interface * intr, int sub_flag,
1665 gfc_actual_arglist ** ap)
1669 for (; intr; intr = intr->next)
1671 if (sub_flag && intr->sym->attr.function)
1673 if (!sub_flag && intr->sym->attr.subroutine)
1676 r = !intr->sym->attr.elemental;
1678 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1680 check_intents (intr->sym->formal, *ap);
1681 if (gfc_option.warn_aliasing)
1682 check_some_aliasing (intr->sym->formal, *ap);
1691 /* Do a brute force recursive search for a symbol. */
1693 static gfc_symtree *
1694 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1698 if (root->n.sym == sym)
1703 st = find_symtree0 (root->left, sym);
1704 if (root->right && ! st)
1705 st = find_symtree0 (root->right, sym);
1710 /* Find a symtree for a symbol. */
1712 static gfc_symtree *
1713 find_sym_in_symtree (gfc_symbol * sym)
1718 /* First try to find it by name. */
1719 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1720 if (st && st->n.sym == sym)
1723 /* if it's been renamed, resort to a brute-force search. */
1724 /* TODO: avoid having to do this search. If the symbol doesn't exist
1725 in the symtree for the current namespace, it should probably be added. */
1726 for (ns = gfc_current_ns; ns; ns = ns->parent)
1728 st = find_symtree0 (ns->sym_root, sym);
1732 gfc_internal_error ("Unable to find symbol %s", sym->name);
1737 /* This subroutine is called when an expression is being resolved.
1738 The expression node in question is either a user defined operator
1739 or an intrinsic operator with arguments that aren't compatible
1740 with the operator. This subroutine builds an actual argument list
1741 corresponding to the operands, then searches for a compatible
1742 interface. If one is found, the expression node is replaced with
1743 the appropriate function call. */
1746 gfc_extend_expr (gfc_expr * e)
1748 gfc_actual_arglist *actual;
1756 actual = gfc_get_actual_arglist ();
1757 actual->expr = e->value.op.op1;
1759 if (e->value.op.op2 != NULL)
1761 actual->next = gfc_get_actual_arglist ();
1762 actual->next->expr = e->value.op.op2;
1765 i = fold_unary (e->value.op.operator);
1767 if (i == INTRINSIC_USER)
1769 for (ns = gfc_current_ns; ns; ns = ns->parent)
1771 uop = gfc_find_uop (e->value.op.uop->name, ns);
1775 sym = gfc_search_interface (uop->operator, 0, &actual);
1782 for (ns = gfc_current_ns; ns; ns = ns->parent)
1784 sym = gfc_search_interface (ns->operator[i], 0, &actual);
1792 /* Don't use gfc_free_actual_arglist() */
1793 if (actual->next != NULL)
1794 gfc_free (actual->next);
1800 /* Change the expression node to a function call. */
1801 e->expr_type = EXPR_FUNCTION;
1802 e->symtree = find_sym_in_symtree (sym);
1803 e->value.function.actual = actual;
1804 e->value.function.esym = NULL;
1805 e->value.function.isym = NULL;
1806 e->value.function.name = NULL;
1808 if (gfc_pure (NULL) && !gfc_pure (sym))
1811 ("Function '%s' called in lieu of an operator at %L must be PURE",
1812 sym->name, &e->where);
1816 if (gfc_resolve_expr (e) == FAILURE)
1823 /* Tries to replace an assignment code node with a subroutine call to
1824 the subroutine associated with the assignment operator. Return
1825 SUCCESS if the node was replaced. On FAILURE, no error is
1829 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1831 gfc_actual_arglist *actual;
1832 gfc_expr *lhs, *rhs;
1838 /* Don't allow an intrinsic assignment to be replaced. */
1839 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1840 && (lhs->ts.type == rhs->ts.type
1841 || (gfc_numeric_ts (&lhs->ts)
1842 && gfc_numeric_ts (&rhs->ts))))
1845 actual = gfc_get_actual_arglist ();
1848 actual->next = gfc_get_actual_arglist ();
1849 actual->next->expr = rhs;
1853 for (; ns; ns = ns->parent)
1855 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1862 gfc_free (actual->next);
1867 /* Replace the assignment with the call. */
1868 c->op = EXEC_ASSIGN_CALL;
1869 c->symtree = find_sym_in_symtree (sym);
1872 c->ext.actual = actual;
1878 /* Make sure that the interface just parsed is not already present in
1879 the given interface list. Ambiguity isn't checked yet since module
1880 procedures can be present without interfaces. */
1883 check_new_interface (gfc_interface * base, gfc_symbol * new)
1887 for (ip = base; ip; ip = ip->next)
1891 gfc_error ("Entity '%s' at %C is already present in the interface",
1901 /* Add a symbol to the current interface. */
1904 gfc_add_interface (gfc_symbol * new)
1906 gfc_interface **head, *intr;
1910 switch (current_interface.type)
1912 case INTERFACE_NAMELESS:
1915 case INTERFACE_INTRINSIC_OP:
1916 for (ns = current_interface.ns; ns; ns = ns->parent)
1917 if (check_new_interface (ns->operator[current_interface.op], new)
1921 head = ¤t_interface.ns->operator[current_interface.op];
1924 case INTERFACE_GENERIC:
1925 for (ns = current_interface.ns; ns; ns = ns->parent)
1927 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1931 if (check_new_interface (sym->generic, new) == FAILURE)
1935 head = ¤t_interface.sym->generic;
1938 case INTERFACE_USER_OP:
1939 if (check_new_interface (current_interface.uop->operator, new) ==
1943 head = ¤t_interface.uop->operator;
1947 gfc_internal_error ("gfc_add_interface(): Bad interface type");
1950 intr = gfc_get_interface ();
1952 intr->where = gfc_current_locus;
1961 /* Gets rid of a formal argument list. We do not free symbols.
1962 Symbols are freed when a namespace is freed. */
1965 gfc_free_formal_arglist (gfc_formal_arglist * p)
1967 gfc_formal_arglist *q;