1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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. */
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)
103 case INTRINSIC_UPLUS:
104 operator = INTRINSIC_PLUS;
106 case INTRINSIC_UMINUS:
107 operator = INTRINSIC_MINUS;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'operator' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type *type,
124 gfc_intrinsic_op *operator)
126 char buffer[GFC_MAX_SYMBOL_LEN + 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES)
132 *type = INTERFACE_INTRINSIC_OP;
133 *operator = INTRINSIC_ASSIGN;
137 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
139 *type = INTERFACE_INTRINSIC_OP;
140 *operator = fold_unary (i);
144 if (gfc_match (" operator ( ") == MATCH_YES)
146 m = gfc_match_defined_op_name (buffer, 1);
152 m = gfc_match_char (')');
158 strcpy (name, buffer);
159 *type = INTERFACE_USER_OP;
163 if (gfc_match_name (buffer) == MATCH_YES)
165 strcpy (name, buffer);
166 *type = INTERFACE_GENERIC;
170 *type = INTERFACE_NAMELESS;
174 gfc_error ("Syntax error in generic specification at %C");
179 /* Match one of the five forms of an interface statement. */
182 gfc_match_interface (void)
184 char name[GFC_MAX_SYMBOL_LEN + 1];
187 gfc_intrinsic_op operator;
190 m = gfc_match_space ();
192 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
195 /* If we're not looking at the end of the statement now, or if this
196 is not a nameless interface but we did not see a space, punt. */
197 if (gfc_match_eos () != MATCH_YES
198 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
200 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
205 current_interface.type = type;
209 case INTERFACE_GENERIC:
210 if (gfc_get_symbol (name, NULL, &sym))
213 if (!sym->attr.generic
214 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
219 gfc_error ("Dummy procedure '%s' at %C cannot have a "
220 "generic interface", sym->name);
224 current_interface.sym = gfc_new_block = sym;
227 case INTERFACE_USER_OP:
228 current_interface.uop = gfc_get_uop (name);
231 case INTERFACE_INTRINSIC_OP:
232 current_interface.op = operator;
235 case INTERFACE_NAMELESS:
243 /* Match the different sort of generic-specs that can be present after
244 the END INTERFACE itself. */
247 gfc_match_end_interface (void)
249 char name[GFC_MAX_SYMBOL_LEN + 1];
251 gfc_intrinsic_op operator;
254 m = gfc_match_space ();
256 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
259 /* If we're not looking at the end of the statement now, or if this
260 is not a nameless interface but we did not see a space, punt. */
261 if (gfc_match_eos () != MATCH_YES
262 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
264 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
271 switch (current_interface.type)
273 case INTERFACE_NAMELESS:
274 if (type != current_interface.type)
276 gfc_error ("Expected a nameless interface at %C");
282 case INTERFACE_INTRINSIC_OP:
283 if (type != current_interface.type || operator != current_interface.op)
286 if (current_interface.op == INTRINSIC_ASSIGN)
287 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
289 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
290 gfc_op2string (current_interface.op));
297 case INTERFACE_USER_OP:
298 /* Comparing the symbol node names is OK because only use-associated
299 symbols can be renamed. */
300 if (type != current_interface.type
301 || strcmp (current_interface.uop->name, name) != 0)
303 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
304 current_interface.uop->name);
310 case INTERFACE_GENERIC:
311 if (type != current_interface.type
312 || strcmp (current_interface.sym->name, name) != 0)
314 gfc_error ("Expecting 'END INTERFACE %s' at %C",
315 current_interface.sym->name);
326 /* Compare two derived types using the criteria in 4.4.2 of the standard,
327 recursing through gfc_compare_types for the components. */
330 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
332 gfc_component *dt1, *dt2;
334 /* Special case for comparing derived types across namespaces. If the
335 true names and module names are the same and the module name is
336 nonnull, then they are equal. */
337 if (strcmp (derived1->name, derived2->name) == 0
338 && derived1 != NULL && derived2 != NULL
339 && derived1->module != NULL && derived2->module != NULL
340 && strcmp (derived1->module, derived2->module) == 0)
343 /* Compare type via the rules of the standard. Both types must have
344 the SEQUENCE attribute to be equal. */
346 if (strcmp (derived1->name, derived2->name))
349 if (derived1->component_access == ACCESS_PRIVATE
350 || derived2->component_access == ACCESS_PRIVATE)
353 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
356 dt1 = derived1->components;
357 dt2 = derived2->components;
359 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
360 simple test can speed things up. Otherwise, lots of things have to
364 if (strcmp (dt1->name, dt2->name) != 0)
367 if (dt1->pointer != dt2->pointer)
370 if (dt1->dimension != dt2->dimension)
373 if (dt1->allocatable != dt2->allocatable)
376 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
379 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
385 if (dt1 == NULL && dt2 == NULL)
387 if (dt1 == NULL || dt2 == NULL)
395 /* Compare two typespecs, recursively if necessary. */
398 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
400 if (ts1->type != ts2->type)
402 if (ts1->type != BT_DERIVED)
403 return (ts1->kind == ts2->kind);
405 /* Compare derived types. */
406 if (ts1->derived == ts2->derived)
409 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
413 /* Given two symbols that are formal arguments, compare their ranks
414 and types. Returns nonzero if they have the same rank and type,
418 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
422 r1 = (s1->as != NULL) ? s1->as->rank : 0;
423 r2 = (s2->as != NULL) ? s2->as->rank : 0;
426 return 0; /* Ranks differ. */
428 return gfc_compare_types (&s1->ts, &s2->ts);
432 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
434 /* Given two symbols that are formal arguments, compare their types
435 and rank and their formal interfaces if they are both dummy
436 procedures. Returns nonzero if the same, zero if different. */
439 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
441 if (s1 == NULL || s2 == NULL)
442 return s1 == s2 ? 1 : 0;
444 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
445 return compare_type_rank (s1, s2);
447 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
450 /* At this point, both symbols are procedures. */
451 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
452 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
455 if (s1->attr.function != s2->attr.function
456 || s1->attr.subroutine != s2->attr.subroutine)
459 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
462 /* Originally, gfortran recursed here to check the interfaces of passed
463 procedures. This is explicitly not required by the standard. */
468 /* Given a formal argument list and a keyword name, search the list
469 for that keyword. Returns the correct symbol node if found, NULL
473 find_keyword_arg (const char *name, gfc_formal_arglist *f)
475 for (; f; f = f->next)
476 if (strcmp (f->sym->name, name) == 0)
483 /******** Interface checking subroutines **********/
486 /* Given an operator interface and the operator, make sure that all
487 interfaces for that operator are legal. */
490 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
492 gfc_formal_arglist *formal;
496 int args, r1, r2, k1, k2;
502 t1 = t2 = BT_UNKNOWN;
503 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;
520 r1 = (sym->as != NULL) ? sym->as->rank : 0;
526 i2 = sym->attr.intent;
527 r2 = (sym->as != NULL) ? sym->as->rank : 0;
535 /* Only +, - and .not. can be unary operators.
536 .not. cannot be a binary operator. */
537 if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
538 && operator != INTRINSIC_MINUS
539 && operator != INTRINSIC_NOT)
540 || (args == 2 && operator == INTRINSIC_NOT))
542 gfc_error ("Operator interface at %L has the wrong number of arguments",
547 /* Check that intrinsics are mapped to functions, except
548 INTRINSIC_ASSIGN which should map to a subroutine. */
549 if (operator == INTRINSIC_ASSIGN)
551 if (!sym->attr.subroutine)
553 gfc_error ("Assignment operator interface at %L must be "
554 "a SUBROUTINE", &intr->where);
559 gfc_error ("Assignment operator interface at %L must have "
560 "two arguments", &intr->where);
563 if (sym->formal->sym->ts.type != BT_DERIVED
564 && sym->formal->next->sym->ts.type != BT_DERIVED
565 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
566 || (gfc_numeric_ts (&sym->formal->sym->ts)
567 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
569 gfc_error ("Assignment operator interface at %L must not redefine "
570 "an INTRINSIC type assignment", &intr->where);
576 if (!sym->attr.function)
578 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
584 /* Check intents on operator interfaces. */
585 if (operator == INTRINSIC_ASSIGN)
587 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
588 gfc_error ("First argument of defined assignment at %L must be "
589 "INTENT(IN) or INTENT(INOUT)", &intr->where);
592 gfc_error ("Second argument of defined assignment at %L must be "
593 "INTENT(IN)", &intr->where);
598 gfc_error ("First argument of operator interface at %L must be "
599 "INTENT(IN)", &intr->where);
601 if (args == 2 && i2 != INTENT_IN)
602 gfc_error ("Second argument of operator interface at %L must be "
603 "INTENT(IN)", &intr->where);
606 /* From now on, all we have to do is check that the operator definition
607 doesn't conflict with an intrinsic operator. The rules for this
608 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
609 as well as 12.3.2.1.1 of Fortran 2003:
611 "If the operator is an intrinsic-operator (R310), the number of
612 function arguments shall be consistent with the intrinsic uses of
613 that operator, and the types, kind type parameters, or ranks of the
614 dummy arguments shall differ from those required for the intrinsic
615 operation (7.1.2)." */
617 #define IS_NUMERIC_TYPE(t) \
618 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
620 /* Unary ops are easy, do them first. */
621 if (operator == INTRINSIC_NOT)
623 if (t1 == BT_LOGICAL)
629 if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
631 if (IS_NUMERIC_TYPE (t1))
637 /* Character intrinsic operators have same character kind, thus
638 operator definitions with operands of different character kinds
640 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
643 /* Intrinsic operators always perform on arguments of same rank,
644 so different ranks is also always safe. (rank == 0) is an exception
645 to that, because all intrinsic operators are elemental. */
646 if (r1 != r2 && r1 != 0 && r2 != 0)
653 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
658 case INTRINSIC_MINUS:
659 case INTRINSIC_TIMES:
660 case INTRINSIC_DIVIDE:
661 case INTRINSIC_POWER:
662 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
670 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
672 if ((t1 == BT_INTEGER || t1 == BT_REAL)
673 && (t2 == BT_INTEGER || t2 == BT_REAL))
677 case INTRINSIC_CONCAT:
678 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
686 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
696 #undef IS_NUMERIC_TYPE
699 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
705 /* Given a pair of formal argument lists, we see if the two lists can
706 be distinguished by counting the number of nonoptional arguments of
707 a given type/rank in f1 and seeing if there are less then that
708 number of those arguments in f2 (including optional arguments).
709 Since this test is asymmetric, it has to be called twice to make it
710 symmetric. Returns nonzero if the argument lists are incompatible
711 by this test. This subroutine implements rule 1 of section
715 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
717 int rc, ac1, ac2, i, j, k, n1;
718 gfc_formal_arglist *f;
731 for (f = f1; f; f = f->next)
734 /* Build an array of integers that gives the same integer to
735 arguments of the same type/rank. */
736 arg = gfc_getmem (n1 * sizeof (arginfo));
739 for (i = 0; i < n1; i++, f = f->next)
747 for (i = 0; i < n1; i++)
749 if (arg[i].flag != -1)
752 if (arg[i].sym && arg[i].sym->attr.optional)
753 continue; /* Skip optional arguments. */
757 /* Find other nonoptional arguments of the same type/rank. */
758 for (j = i + 1; j < n1; j++)
759 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
760 && compare_type_rank_if (arg[i].sym, arg[j].sym))
766 /* Now loop over each distinct type found in f1. */
770 for (i = 0; i < n1; i++)
772 if (arg[i].flag != k)
776 for (j = i + 1; j < n1; j++)
777 if (arg[j].flag == k)
780 /* Count the number of arguments in f2 with that type, including
781 those that are optional. */
784 for (f = f2; f; f = f->next)
785 if (compare_type_rank_if (arg[i].sym, f->sym))
803 /* Perform the abbreviated correspondence test for operators. The
804 arguments cannot be optional and are always ordered correctly,
805 which makes this test much easier than that for generic tests.
807 This subroutine is also used when comparing a formal and actual
808 argument list when an actual parameter is a dummy procedure. At
809 that point, two formal interfaces must be compared for equality
810 which is what happens here. */
813 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
817 if (f1 == NULL && f2 == NULL)
819 if (f1 == NULL || f2 == NULL)
822 if (!compare_type_rank (f1->sym, f2->sym))
833 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
834 Returns zero if no argument is found that satisfies rule 2, nonzero
837 This test is also not symmetric in f1 and f2 and must be called
838 twice. This test finds problems caused by sorting the actual
839 argument list with keywords. For example:
843 INTEGER :: A ; REAL :: B
847 INTEGER :: A ; REAL :: B
851 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
854 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
856 gfc_formal_arglist *f2_save, *g;
863 if (f1->sym->attr.optional)
866 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
869 /* Now search for a disambiguating keyword argument starting at
870 the current non-match. */
871 for (g = f1; g; g = g->next)
873 if (g->sym->attr.optional)
876 sym = find_keyword_arg (g->sym->name, f2_save);
877 if (sym == NULL || !compare_type_rank (g->sym, sym))
891 /* 'Compare' two formal interfaces associated with a pair of symbols.
892 We return nonzero if there exists an actual argument list that
893 would be ambiguous between the two interfaces, zero otherwise. */
896 compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
898 gfc_formal_arglist *f1, *f2;
900 if (s1->attr.function != s2->attr.function
901 && s1->attr.subroutine != s2->attr.subroutine)
902 return 0; /* Disagreement between function/subroutine. */
907 if (f1 == NULL && f2 == NULL)
908 return 1; /* Special case. */
910 if (count_types_test (f1, f2))
912 if (count_types_test (f2, f1))
917 if (generic_correspondence (f1, f2))
919 if (generic_correspondence (f2, f1))
924 if (operator_correspondence (f1, f2))
932 /* Given a pointer to an interface pointer, remove duplicate
933 interfaces and make sure that all symbols are either functions or
934 subroutines. Returns nonzero if something goes wrong. */
937 check_interface0 (gfc_interface *p, const char *interface_name)
939 gfc_interface *psave, *q, *qlast;
942 /* Make sure all symbols in the interface have been defined as
943 functions or subroutines. */
944 for (; p; p = p->next)
945 if (!p->sym->attr.function && !p->sym->attr.subroutine)
947 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
948 "subroutine", p->sym->name, interface_name,
949 &p->sym->declared_at);
954 /* Remove duplicate interfaces in this interface list. */
955 for (; p; p = p->next)
959 for (q = p->next; q;)
961 if (p->sym != q->sym)
968 /* Duplicate interface. */
969 qlast->next = q->next;
980 /* Check lists of interfaces to make sure that no two interfaces are
981 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
984 check_interface1 (gfc_interface *p, gfc_interface *q0,
985 int generic_flag, const char *interface_name,
989 for (; p; p = p->next)
990 for (q = q0; q; q = q->next)
992 if (p->sym == q->sym)
993 continue; /* Duplicates OK here. */
995 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
998 if (compare_interfaces (p->sym, q->sym, generic_flag))
1002 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1003 p->sym->name, q->sym->name, interface_name,
1007 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1008 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1009 p->sym->name, q->sym->name, interface_name,
1018 /* Check the generic and operator interfaces of symbols to make sure
1019 that none of the interfaces conflict. The check has to be done
1020 after all of the symbols are actually loaded. */
1023 check_sym_interfaces (gfc_symbol *sym)
1025 char interface_name[100];
1029 if (sym->ns != gfc_current_ns)
1032 if (sym->generic != NULL)
1034 sprintf (interface_name, "generic interface '%s'", sym->name);
1035 if (check_interface0 (sym->generic, interface_name))
1038 for (p = sym->generic; p; p = p->next)
1040 if (!p->sym->attr.use_assoc && p->sym->attr.mod_proc
1041 && p->sym->attr.if_source != IFSRC_DECL)
1043 gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1044 "from a module", p->sym->name, &p->where);
1049 /* Originally, this test was applied to host interfaces too;
1050 this is incorrect since host associated symbols, from any
1051 source, cannot be ambiguous with local symbols. */
1052 k = sym->attr.referenced || !sym->attr.use_assoc;
1053 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1054 sym->attr.ambiguous_interfaces = 1;
1060 check_uop_interfaces (gfc_user_op *uop)
1062 char interface_name[100];
1066 sprintf (interface_name, "operator interface '%s'", uop->name);
1067 if (check_interface0 (uop->operator, interface_name))
1070 for (ns = gfc_current_ns; ns; ns = ns->parent)
1072 uop2 = gfc_find_uop (uop->name, ns);
1076 check_interface1 (uop->operator, uop2->operator, 0,
1077 interface_name, true);
1082 /* For the namespace, check generic, user operator and intrinsic
1083 operator interfaces for consistency and to remove duplicate
1084 interfaces. We traverse the whole namespace, counting on the fact
1085 that most symbols will not have generic or operator interfaces. */
1088 gfc_check_interfaces (gfc_namespace *ns)
1090 gfc_namespace *old_ns, *ns2;
1091 char interface_name[100];
1094 old_ns = gfc_current_ns;
1095 gfc_current_ns = ns;
1097 gfc_traverse_ns (ns, check_sym_interfaces);
1099 gfc_traverse_user_op (ns, check_uop_interfaces);
1101 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1103 if (i == INTRINSIC_USER)
1106 if (i == INTRINSIC_ASSIGN)
1107 strcpy (interface_name, "intrinsic assignment operator");
1109 sprintf (interface_name, "intrinsic '%s' operator",
1112 if (check_interface0 (ns->operator[i], interface_name))
1115 check_operator_interface (ns->operator[i], i);
1117 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1118 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1119 interface_name, true))
1123 gfc_current_ns = old_ns;
1128 symbol_rank (gfc_symbol *sym)
1130 return (sym->as == NULL) ? 0 : sym->as->rank;
1134 /* Given a symbol of a formal argument list and an expression, if the
1135 formal argument is allocatable, check that the actual argument is
1136 allocatable. Returns nonzero if compatible, zero if not compatible. */
1139 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1141 symbol_attribute attr;
1143 if (formal->attr.allocatable)
1145 attr = gfc_expr_attr (actual);
1146 if (!attr.allocatable)
1154 /* Given a symbol of a formal argument list and an expression, if the
1155 formal argument is a pointer, see if the actual argument is a
1156 pointer. Returns nonzero if compatible, zero if not compatible. */
1159 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1161 symbol_attribute attr;
1163 if (formal->attr.pointer)
1165 attr = gfc_expr_attr (actual);
1174 /* Given a symbol of a formal argument list and an expression, see if
1175 the two are compatible as arguments. Returns nonzero if
1176 compatible, zero if not compatible. */
1179 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1180 int ranks_must_agree, int is_elemental)
1184 if (actual->ts.type == BT_PROCEDURE)
1186 if (formal->attr.flavor != FL_PROCEDURE)
1189 if (formal->attr.function
1190 && !compare_type_rank (formal, actual->symtree->n.sym))
1193 if (formal->attr.if_source == IFSRC_UNKNOWN
1194 || actual->symtree->n.sym->attr.external)
1195 return 1; /* Assume match. */
1197 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1200 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1201 && !gfc_compare_types (&formal->ts, &actual->ts))
1204 if (symbol_rank (formal) == actual->rank)
1207 /* At this point the ranks didn't agree. */
1208 if (ranks_must_agree || formal->attr.pointer)
1211 if (actual->rank != 0)
1212 return is_elemental || formal->attr.dimension;
1214 /* At this point, we are considering a scalar passed to an array.
1215 This is legal if the scalar is an array element of the right sort. */
1216 if (formal->as->type == AS_ASSUMED_SHAPE)
1219 for (ref = actual->ref; ref; ref = ref->next)
1220 if (ref->type == REF_SUBSTRING)
1223 for (ref = actual->ref; ref; ref = ref->next)
1224 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1228 return 0; /* Not an array element. */
1234 /* Given a symbol of a formal argument list and an expression, see if
1235 the two are compatible as arguments. Returns nonzero if
1236 compatible, zero if not compatible. */
1239 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1241 if (actual->expr_type != EXPR_VARIABLE)
1244 if (!actual->symtree->n.sym->attr.protected)
1247 if (!actual->symtree->n.sym->attr.use_assoc)
1250 if (formal->attr.intent == INTENT_IN
1251 || formal->attr.intent == INTENT_UNKNOWN)
1254 if (!actual->symtree->n.sym->attr.pointer)
1257 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1264 /* Given an expression, check whether it is an array section
1265 which has a vector subscript. If it has, one is returned,
1269 has_vector_subscript (gfc_expr *e)
1274 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1277 for (ref = e->ref; ref; ref = ref->next)
1278 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1279 for (i = 0; i < ref->u.ar.dimen; i++)
1280 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1287 /* Given formal and actual argument lists, see if they are compatible.
1288 If they are compatible, the actual argument list is sorted to
1289 correspond with the formal list, and elements for missing optional
1290 arguments are inserted. If WHERE pointer is nonnull, then we issue
1291 errors when things don't match instead of just returning the status
1295 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1296 int ranks_must_agree, int is_elemental, locus *where)
1298 gfc_actual_arglist **new, *a, *actual, temp;
1299 gfc_formal_arglist *f;
1305 if (actual == NULL && formal == NULL)
1309 for (f = formal; f; f = f->next)
1312 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1314 for (i = 0; i < n; i++)
1321 for (a = actual; a; a = a->next, f = f->next)
1323 /* Look for keywords but ignore g77 extensions like %VAL. */
1324 if (a->name != NULL && a->name[0] != '%')
1327 for (f = formal; f; f = f->next, i++)
1331 if (strcmp (f->sym->name, a->name) == 0)
1338 gfc_error ("Keyword argument '%s' at %L is not in "
1339 "the procedure", a->name, &a->expr->where);
1346 gfc_error ("Keyword argument '%s' at %L is already associated "
1347 "with another actual argument", a->name,
1356 gfc_error ("More actual than formal arguments in procedure "
1357 "call at %L", where);
1362 if (f->sym == NULL && a->expr == NULL)
1368 gfc_error ("Missing alternate return spec in subroutine call "
1373 if (a->expr == NULL)
1376 gfc_error ("Unexpected alternate return spec in subroutine "
1377 "call at %L", where);
1381 rank_check = where != NULL && !is_elemental && f->sym->as
1382 && (f->sym->as->type == AS_ASSUMED_SHAPE
1383 || f->sym->as->type == AS_DEFERRED);
1385 if (!compare_parameter (f->sym, a->expr,
1386 ranks_must_agree || rank_check, is_elemental))
1389 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1390 f->sym->name, &a->expr->where);
1394 if (a->expr->ts.type == BT_CHARACTER
1395 && a->expr->ts.cl && a->expr->ts.cl->length
1396 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1397 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1398 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1400 if (mpz_cmp (a->expr->ts.cl->length->value.integer,
1401 f->sym->ts.cl->length->value.integer) < 0)
1404 gfc_error ("Character length of actual argument shorter "
1405 "than of dummy argument '%s' at %L",
1406 f->sym->name, &a->expr->where);
1410 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
1411 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1412 f->sym->ts.cl->length->value.integer) != 0))
1415 gfc_error ("Character length mismatch between actual argument "
1416 "and pointer or allocatable dummy argument "
1417 "'%s' at %L", f->sym->name, &a->expr->where);
1422 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1423 provided for a procedure formal argument. */
1424 if (a->expr->ts.type != BT_PROCEDURE
1425 && a->expr->expr_type == EXPR_VARIABLE
1426 && f->sym->attr.flavor == FL_PROCEDURE)
1429 gfc_error ("Expected a procedure for argument '%s' at %L",
1430 f->sym->name, &a->expr->where);
1434 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1435 && a->expr->ts.type == BT_PROCEDURE
1436 && !a->expr->symtree->n.sym->attr.pure)
1439 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1440 f->sym->name, &a->expr->where);
1444 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1445 && a->expr->expr_type == EXPR_VARIABLE
1446 && a->expr->symtree->n.sym->as
1447 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1448 && (a->expr->ref == NULL
1449 || (a->expr->ref->type == REF_ARRAY
1450 && a->expr->ref->u.ar.type == AR_FULL)))
1453 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1454 " array at %L", f->sym->name, where);
1458 if (a->expr->expr_type != EXPR_NULL
1459 && compare_pointer (f->sym, a->expr) == 0)
1462 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1463 f->sym->name, &a->expr->where);
1467 if (a->expr->expr_type != EXPR_NULL
1468 && compare_allocatable (f->sym, a->expr) == 0)
1471 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1472 f->sym->name, &a->expr->where);
1476 /* Check intent = OUT/INOUT for definable actual argument. */
1477 if (a->expr->expr_type != EXPR_VARIABLE
1478 && (f->sym->attr.intent == INTENT_OUT
1479 || f->sym->attr.intent == INTENT_INOUT))
1482 gfc_error ("Actual argument at %L must be definable to "
1483 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1487 if (!compare_parameter_protected(f->sym, a->expr))
1490 gfc_error ("Actual argument at %L is use-associated with "
1491 "PROTECTED attribute and dummy argument '%s' is "
1492 "INTENT = OUT/INOUT",
1493 &a->expr->where,f->sym->name);
1497 if ((f->sym->attr.intent == INTENT_OUT
1498 || f->sym->attr.intent == INTENT_INOUT
1499 || f->sym->attr.volatile_)
1500 && has_vector_subscript (a->expr))
1503 gfc_error ("Array-section actual argument with vector subscripts "
1504 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1505 "or VOLATILE attribute of the dummy argument '%s'",
1506 &a->expr->where, f->sym->name);
1510 /* C1232 (R1221) For an actual argument which is an array section or
1511 an assumed-shape array, the dummy argument shall be an assumed-
1512 shape array, if the dummy argument has the VOLATILE attribute. */
1514 if (f->sym->attr.volatile_
1515 && a->expr->symtree->n.sym->as
1516 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1517 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1520 gfc_error ("Assumed-shape actual argument at %L is "
1521 "incompatible with the non-assumed-shape "
1522 "dummy argument '%s' due to VOLATILE attribute",
1523 &a->expr->where,f->sym->name);
1527 if (f->sym->attr.volatile_
1528 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1529 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1532 gfc_error ("Array-section actual argument at %L is "
1533 "incompatible with the non-assumed-shape "
1534 "dummy argument '%s' due to VOLATILE attribute",
1535 &a->expr->where,f->sym->name);
1539 /* C1233 (R1221) For an actual argument which is a pointer array, the
1540 dummy argument shall be an assumed-shape or pointer array, if the
1541 dummy argument has the VOLATILE attribute. */
1543 if (f->sym->attr.volatile_
1544 && a->expr->symtree->n.sym->attr.pointer
1545 && a->expr->symtree->n.sym->as
1547 && (f->sym->as->type == AS_ASSUMED_SHAPE
1548 || f->sym->attr.pointer)))
1551 gfc_error ("Pointer-array actual argument at %L requires "
1552 "an assumed-shape or pointer-array dummy "
1553 "argument '%s' due to VOLATILE attribute",
1554 &a->expr->where,f->sym->name);
1565 /* Make sure missing actual arguments are optional. */
1567 for (f = formal; f; f = f->next, i++)
1574 gfc_error ("Missing alternate return spec in subroutine call "
1578 if (!f->sym->attr.optional)
1581 gfc_error ("Missing actual argument for argument '%s' at %L",
1582 f->sym->name, where);
1587 /* The argument lists are compatible. We now relink a new actual
1588 argument list with null arguments in the right places. The head
1589 of the list remains the head. */
1590 for (i = 0; i < n; i++)
1592 new[i] = gfc_get_actual_arglist ();
1605 for (i = 0; i < n - 1; i++)
1606 new[i]->next = new[i + 1];
1608 new[i]->next = NULL;
1610 if (*ap == NULL && n > 0)
1613 /* Note the types of omitted optional arguments. */
1614 for (a = actual, f = formal; a; a = a->next, f = f->next)
1615 if (a->expr == NULL && a->label == NULL)
1616 a->missing_arg_type = f->sym->ts.type;
1624 gfc_formal_arglist *f;
1625 gfc_actual_arglist *a;
1629 /* qsort comparison function for argument pairs, with the following
1631 - p->a->expr == NULL
1632 - p->a->expr->expr_type != EXPR_VARIABLE
1633 - growing p->a->expr->symbol. */
1636 pair_cmp (const void *p1, const void *p2)
1638 const gfc_actual_arglist *a1, *a2;
1640 /* *p1 and *p2 are elements of the to-be-sorted array. */
1641 a1 = ((const argpair *) p1)->a;
1642 a2 = ((const argpair *) p2)->a;
1651 if (a1->expr->expr_type != EXPR_VARIABLE)
1653 if (a2->expr->expr_type != EXPR_VARIABLE)
1657 if (a2->expr->expr_type != EXPR_VARIABLE)
1659 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1663 /* Given two expressions from some actual arguments, test whether they
1664 refer to the same expression. The analysis is conservative.
1665 Returning FAILURE will produce no warning. */
1668 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
1670 const gfc_ref *r1, *r2;
1673 || e1->expr_type != EXPR_VARIABLE
1674 || e2->expr_type != EXPR_VARIABLE
1675 || e1->symtree->n.sym != e2->symtree->n.sym)
1678 /* TODO: improve comparison, see expr.c:show_ref(). */
1679 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1681 if (r1->type != r2->type)
1686 if (r1->u.ar.type != r2->u.ar.type)
1688 /* TODO: At the moment, consider only full arrays;
1689 we could do better. */
1690 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1695 if (r1->u.c.component != r2->u.c.component)
1703 gfc_internal_error ("compare_actual_expr(): Bad component code");
1712 /* Given formal and actual argument lists that correspond to one
1713 another, check that identical actual arguments aren't not
1714 associated with some incompatible INTENTs. */
1717 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
1719 sym_intent f1_intent, f2_intent;
1720 gfc_formal_arglist *f1;
1721 gfc_actual_arglist *a1;
1727 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1729 if (f1 == NULL && a1 == NULL)
1731 if (f1 == NULL || a1 == NULL)
1732 gfc_internal_error ("check_some_aliasing(): List mismatch");
1737 p = (argpair *) alloca (n * sizeof (argpair));
1739 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1745 qsort (p, n, sizeof (argpair), pair_cmp);
1747 for (i = 0; i < n; i++)
1750 || p[i].a->expr->expr_type != EXPR_VARIABLE
1751 || p[i].a->expr->ts.type == BT_PROCEDURE)
1753 f1_intent = p[i].f->sym->attr.intent;
1754 for (j = i + 1; j < n; j++)
1756 /* Expected order after the sort. */
1757 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1758 gfc_internal_error ("check_some_aliasing(): corrupted data");
1760 /* Are the expression the same? */
1761 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1763 f2_intent = p[j].f->sym->attr.intent;
1764 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1765 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1767 gfc_warning ("Same actual argument associated with INTENT(%s) "
1768 "argument '%s' and INTENT(%s) argument '%s' at %L",
1769 gfc_intent_string (f1_intent), p[i].f->sym->name,
1770 gfc_intent_string (f2_intent), p[j].f->sym->name,
1771 &p[i].a->expr->where);
1781 /* Given a symbol of a formal argument list and an expression,
1782 return non-zero if their intents are compatible, zero otherwise. */
1785 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
1787 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
1790 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
1793 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
1800 /* Given formal and actual argument lists that correspond to one
1801 another, check that they are compatible in the sense that intents
1802 are not mismatched. */
1805 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
1807 sym_intent f_intent;
1809 for (;; f = f->next, a = a->next)
1811 if (f == NULL && a == NULL)
1813 if (f == NULL || a == NULL)
1814 gfc_internal_error ("check_intents(): List mismatch");
1816 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1819 f_intent = f->sym->attr.intent;
1821 if (!compare_parameter_intent(f->sym, a->expr))
1823 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1824 "specifies INTENT(%s)", &a->expr->where,
1825 gfc_intent_string (f_intent));
1829 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1831 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1833 gfc_error ("Procedure argument at %L is local to a PURE "
1834 "procedure and is passed to an INTENT(%s) argument",
1835 &a->expr->where, gfc_intent_string (f_intent));
1839 if (a->expr->symtree->n.sym->attr.pointer)
1841 gfc_error ("Procedure argument at %L is local to a PURE "
1842 "procedure and has the POINTER attribute",
1853 /* Check how a procedure is used against its interface. If all goes
1854 well, the actual argument list will also end up being properly
1858 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
1861 /* Warn about calls with an implicit interface. */
1862 if (gfc_option.warn_implicit_interface
1863 && sym->attr.if_source == IFSRC_UNKNOWN)
1864 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1867 if (sym->attr.if_source == IFSRC_UNKNOWN
1868 || !compare_actual_formal (ap, sym->formal, 0,
1869 sym->attr.elemental, where))
1872 check_intents (sym->formal, *ap);
1873 if (gfc_option.warn_aliasing)
1874 check_some_aliasing (sym->formal, *ap);
1878 /* Given an interface pointer and an actual argument list, search for
1879 a formal argument list that matches the actual. If found, returns
1880 a pointer to the symbol of the correct interface. Returns NULL if
1884 gfc_search_interface (gfc_interface *intr, int sub_flag,
1885 gfc_actual_arglist **ap)
1889 for (; intr; intr = intr->next)
1891 if (sub_flag && intr->sym->attr.function)
1893 if (!sub_flag && intr->sym->attr.subroutine)
1896 r = !intr->sym->attr.elemental;
1898 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1900 check_intents (intr->sym->formal, *ap);
1901 if (gfc_option.warn_aliasing)
1902 check_some_aliasing (intr->sym->formal, *ap);
1911 /* Do a brute force recursive search for a symbol. */
1913 static gfc_symtree *
1914 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
1918 if (root->n.sym == sym)
1923 st = find_symtree0 (root->left, sym);
1924 if (root->right && ! st)
1925 st = find_symtree0 (root->right, sym);
1930 /* Find a symtree for a symbol. */
1932 static gfc_symtree *
1933 find_sym_in_symtree (gfc_symbol *sym)
1938 /* First try to find it by name. */
1939 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1940 if (st && st->n.sym == sym)
1943 /* If it's been renamed, resort to a brute-force search. */
1944 /* TODO: avoid having to do this search. If the symbol doesn't exist
1945 in the symtree for the current namespace, it should probably be added. */
1946 for (ns = gfc_current_ns; ns; ns = ns->parent)
1948 st = find_symtree0 (ns->sym_root, sym);
1952 gfc_internal_error ("Unable to find symbol %s", sym->name);
1957 /* This subroutine is called when an expression is being resolved.
1958 The expression node in question is either a user defined operator
1959 or an intrinsic operator with arguments that aren't compatible
1960 with the operator. This subroutine builds an actual argument list
1961 corresponding to the operands, then searches for a compatible
1962 interface. If one is found, the expression node is replaced with
1963 the appropriate function call. */
1966 gfc_extend_expr (gfc_expr *e)
1968 gfc_actual_arglist *actual;
1976 actual = gfc_get_actual_arglist ();
1977 actual->expr = e->value.op.op1;
1979 if (e->value.op.op2 != NULL)
1981 actual->next = gfc_get_actual_arglist ();
1982 actual->next->expr = e->value.op.op2;
1985 i = fold_unary (e->value.op.operator);
1987 if (i == INTRINSIC_USER)
1989 for (ns = gfc_current_ns; ns; ns = ns->parent)
1991 uop = gfc_find_uop (e->value.op.uop->name, ns);
1995 sym = gfc_search_interface (uop->operator, 0, &actual);
2002 for (ns = gfc_current_ns; ns; ns = ns->parent)
2004 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2012 /* Don't use gfc_free_actual_arglist(). */
2013 if (actual->next != NULL)
2014 gfc_free (actual->next);
2020 /* Change the expression node to a function call. */
2021 e->expr_type = EXPR_FUNCTION;
2022 e->symtree = find_sym_in_symtree (sym);
2023 e->value.function.actual = actual;
2024 e->value.function.esym = NULL;
2025 e->value.function.isym = NULL;
2026 e->value.function.name = NULL;
2028 if (gfc_pure (NULL) && !gfc_pure (sym))
2030 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2031 "be PURE", sym->name, &e->where);
2035 if (gfc_resolve_expr (e) == FAILURE)
2042 /* Tries to replace an assignment code node with a subroutine call to
2043 the subroutine associated with the assignment operator. Return
2044 SUCCESS if the node was replaced. On FAILURE, no error is
2048 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2050 gfc_actual_arglist *actual;
2051 gfc_expr *lhs, *rhs;
2057 /* Don't allow an intrinsic assignment to be replaced. */
2058 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2059 && (lhs->ts.type == rhs->ts.type
2060 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2063 actual = gfc_get_actual_arglist ();
2066 actual->next = gfc_get_actual_arglist ();
2067 actual->next->expr = rhs;
2071 for (; ns; ns = ns->parent)
2073 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2080 gfc_free (actual->next);
2085 /* Replace the assignment with the call. */
2086 c->op = EXEC_ASSIGN_CALL;
2087 c->symtree = find_sym_in_symtree (sym);
2090 c->ext.actual = actual;
2096 /* Make sure that the interface just parsed is not already present in
2097 the given interface list. Ambiguity isn't checked yet since module
2098 procedures can be present without interfaces. */
2101 check_new_interface (gfc_interface *base, gfc_symbol *new)
2105 for (ip = base; ip; ip = ip->next)
2109 gfc_error ("Entity '%s' at %C is already present in the interface",
2119 /* Add a symbol to the current interface. */
2122 gfc_add_interface (gfc_symbol *new)
2124 gfc_interface **head, *intr;
2128 switch (current_interface.type)
2130 case INTERFACE_NAMELESS:
2133 case INTERFACE_INTRINSIC_OP:
2134 for (ns = current_interface.ns; ns; ns = ns->parent)
2135 if (check_new_interface (ns->operator[current_interface.op], new)
2139 head = ¤t_interface.ns->operator[current_interface.op];
2142 case INTERFACE_GENERIC:
2143 for (ns = current_interface.ns; ns; ns = ns->parent)
2145 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2149 if (check_new_interface (sym->generic, new) == FAILURE)
2153 head = ¤t_interface.sym->generic;
2156 case INTERFACE_USER_OP:
2157 if (check_new_interface (current_interface.uop->operator, new)
2161 head = ¤t_interface.uop->operator;
2165 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2168 intr = gfc_get_interface ();
2170 intr->where = gfc_current_locus;
2179 /* Gets rid of a formal argument list. We do not free symbols.
2180 Symbols are freed when a namespace is freed. */
2183 gfc_free_formal_arglist (gfc_formal_arglist *p)
2185 gfc_formal_arglist *q;