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->access != dt2->access)
370 if (dt1->pointer != dt2->pointer)
373 if (dt1->dimension != dt2->dimension)
376 if (dt1->allocatable != dt2->allocatable)
379 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
382 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
388 if (dt1 == NULL && dt2 == NULL)
390 if (dt1 == NULL || dt2 == NULL)
398 /* Compare two typespecs, recursively if necessary. */
401 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
403 if (ts1->type != ts2->type)
405 if (ts1->type != BT_DERIVED)
406 return (ts1->kind == ts2->kind);
408 /* Compare derived types. */
409 if (ts1->derived == ts2->derived)
412 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
416 /* Given two symbols that are formal arguments, compare their ranks
417 and types. Returns nonzero if they have the same rank and type,
421 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
425 r1 = (s1->as != NULL) ? s1->as->rank : 0;
426 r2 = (s2->as != NULL) ? s2->as->rank : 0;
429 return 0; /* Ranks differ. */
431 return gfc_compare_types (&s1->ts, &s2->ts);
435 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
437 /* Given two symbols that are formal arguments, compare their types
438 and rank and their formal interfaces if they are both dummy
439 procedures. Returns nonzero if the same, zero if different. */
442 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
444 if (s1 == NULL || s2 == NULL)
445 return s1 == s2 ? 1 : 0;
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 /* Originally, gfortran recursed here to check the interfaces of passed
466 procedures. This is explicitly not required by the standard. */
471 /* Given a formal argument list and a keyword name, search the list
472 for that keyword. Returns the correct symbol node if found, NULL
476 find_keyword_arg (const char *name, gfc_formal_arglist *f)
478 for (; f; f = f->next)
479 if (strcmp (f->sym->name, name) == 0)
486 /******** Interface checking subroutines **********/
489 /* Given an operator interface and the operator, make sure that all
490 interfaces for that operator are legal. */
493 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
495 gfc_formal_arglist *formal;
499 int args, r1, r2, k1, k2;
505 t1 = t2 = BT_UNKNOWN;
506 i1 = i2 = INTENT_UNKNOWN;
510 for (formal = intr->sym->formal; formal; formal = formal->next)
515 gfc_error ("Alternate return cannot appear in operator "
516 "interface at %L", &intr->where);
522 i1 = sym->attr.intent;
523 r1 = (sym->as != NULL) ? sym->as->rank : 0;
529 i2 = sym->attr.intent;
530 r2 = (sym->as != NULL) ? sym->as->rank : 0;
538 /* Only +, - and .not. can be unary operators.
539 .not. cannot be a binary operator. */
540 if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
541 && operator != INTRINSIC_MINUS
542 && operator != INTRINSIC_NOT)
543 || (args == 2 && operator == INTRINSIC_NOT))
545 gfc_error ("Operator interface at %L has the wrong number of arguments",
550 /* Check that intrinsics are mapped to functions, except
551 INTRINSIC_ASSIGN which should map to a subroutine. */
552 if (operator == INTRINSIC_ASSIGN)
554 if (!sym->attr.subroutine)
556 gfc_error ("Assignment operator interface at %L must be "
557 "a SUBROUTINE", &intr->where);
562 gfc_error ("Assignment operator interface at %L must have "
563 "two arguments", &intr->where);
566 if (sym->formal->sym->ts.type != BT_DERIVED
567 && sym->formal->next->sym->ts.type != BT_DERIVED
568 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
569 || (gfc_numeric_ts (&sym->formal->sym->ts)
570 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
572 gfc_error ("Assignment operator interface at %L must not redefine "
573 "an INTRINSIC type assignment", &intr->where);
579 if (!sym->attr.function)
581 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
587 /* Check intents on operator interfaces. */
588 if (operator == INTRINSIC_ASSIGN)
590 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
591 gfc_error ("First argument of defined assignment at %L must be "
592 "INTENT(IN) or INTENT(INOUT)", &intr->where);
595 gfc_error ("Second argument of defined assignment at %L must be "
596 "INTENT(IN)", &intr->where);
601 gfc_error ("First argument of operator interface at %L must be "
602 "INTENT(IN)", &intr->where);
604 if (args == 2 && i2 != INTENT_IN)
605 gfc_error ("Second argument of operator interface at %L must be "
606 "INTENT(IN)", &intr->where);
609 /* From now on, all we have to do is check that the operator definition
610 doesn't conflict with an intrinsic operator. The rules for this
611 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
612 as well as 12.3.2.1.1 of Fortran 2003:
614 "If the operator is an intrinsic-operator (R310), the number of
615 function arguments shall be consistent with the intrinsic uses of
616 that operator, and the types, kind type parameters, or ranks of the
617 dummy arguments shall differ from those required for the intrinsic
618 operation (7.1.2)." */
620 #define IS_NUMERIC_TYPE(t) \
621 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
623 /* Unary ops are easy, do them first. */
624 if (operator == INTRINSIC_NOT)
626 if (t1 == BT_LOGICAL)
632 if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
634 if (IS_NUMERIC_TYPE (t1))
640 /* Character intrinsic operators have same character kind, thus
641 operator definitions with operands of different character kinds
643 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
646 /* Intrinsic operators always perform on arguments of same rank,
647 so different ranks is also always safe. (rank == 0) is an exception
648 to that, because all intrinsic operators are elemental. */
649 if (r1 != r2 && r1 != 0 && r2 != 0)
656 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
661 case INTRINSIC_MINUS:
662 case INTRINSIC_TIMES:
663 case INTRINSIC_DIVIDE:
664 case INTRINSIC_POWER:
665 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
673 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
675 if ((t1 == BT_INTEGER || t1 == BT_REAL)
676 && (t2 == BT_INTEGER || t2 == BT_REAL))
680 case INTRINSIC_CONCAT:
681 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
689 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
699 #undef IS_NUMERIC_TYPE
702 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
708 /* Given a pair of formal argument lists, we see if the two lists can
709 be distinguished by counting the number of nonoptional arguments of
710 a given type/rank in f1 and seeing if there are less then that
711 number of those arguments in f2 (including optional arguments).
712 Since this test is asymmetric, it has to be called twice to make it
713 symmetric. Returns nonzero if the argument lists are incompatible
714 by this test. This subroutine implements rule 1 of section
718 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
720 int rc, ac1, ac2, i, j, k, n1;
721 gfc_formal_arglist *f;
734 for (f = f1; f; f = f->next)
737 /* Build an array of integers that gives the same integer to
738 arguments of the same type/rank. */
739 arg = gfc_getmem (n1 * sizeof (arginfo));
742 for (i = 0; i < n1; i++, f = f->next)
750 for (i = 0; i < n1; i++)
752 if (arg[i].flag != -1)
755 if (arg[i].sym && arg[i].sym->attr.optional)
756 continue; /* Skip optional arguments. */
760 /* Find other nonoptional arguments of the same type/rank. */
761 for (j = i + 1; j < n1; j++)
762 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
763 && compare_type_rank_if (arg[i].sym, arg[j].sym))
769 /* Now loop over each distinct type found in f1. */
773 for (i = 0; i < n1; i++)
775 if (arg[i].flag != k)
779 for (j = i + 1; j < n1; j++)
780 if (arg[j].flag == k)
783 /* Count the number of arguments in f2 with that type, including
784 those that are optional. */
787 for (f = f2; f; f = f->next)
788 if (compare_type_rank_if (arg[i].sym, f->sym))
806 /* Perform the abbreviated correspondence test for operators. The
807 arguments cannot be optional and are always ordered correctly,
808 which makes this test much easier than that for generic tests.
810 This subroutine is also used when comparing a formal and actual
811 argument list when an actual parameter is a dummy procedure. At
812 that point, two formal interfaces must be compared for equality
813 which is what happens here. */
816 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
820 if (f1 == NULL && f2 == NULL)
822 if (f1 == NULL || f2 == NULL)
825 if (!compare_type_rank (f1->sym, f2->sym))
836 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
837 Returns zero if no argument is found that satisfies rule 2, nonzero
840 This test is also not symmetric in f1 and f2 and must be called
841 twice. This test finds problems caused by sorting the actual
842 argument list with keywords. For example:
846 INTEGER :: A ; REAL :: B
850 INTEGER :: A ; REAL :: B
854 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
857 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
859 gfc_formal_arglist *f2_save, *g;
866 if (f1->sym->attr.optional)
869 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
872 /* Now search for a disambiguating keyword argument starting at
873 the current non-match. */
874 for (g = f1; g; g = g->next)
876 if (g->sym->attr.optional)
879 sym = find_keyword_arg (g->sym->name, f2_save);
880 if (sym == NULL || !compare_type_rank (g->sym, sym))
894 /* 'Compare' two formal interfaces associated with a pair of symbols.
895 We return nonzero if there exists an actual argument list that
896 would be ambiguous between the two interfaces, zero otherwise. */
899 compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
901 gfc_formal_arglist *f1, *f2;
903 if (s1->attr.function != s2->attr.function
904 && s1->attr.subroutine != s2->attr.subroutine)
905 return 0; /* Disagreement between function/subroutine. */
910 if (f1 == NULL && f2 == NULL)
911 return 1; /* Special case. */
913 if (count_types_test (f1, f2))
915 if (count_types_test (f2, f1))
920 if (generic_correspondence (f1, f2))
922 if (generic_correspondence (f2, f1))
927 if (operator_correspondence (f1, f2))
935 /* Given a pointer to an interface pointer, remove duplicate
936 interfaces and make sure that all symbols are either functions or
937 subroutines. Returns nonzero if something goes wrong. */
940 check_interface0 (gfc_interface *p, const char *interface_name)
942 gfc_interface *psave, *q, *qlast;
945 /* Make sure all symbols in the interface have been defined as
946 functions or subroutines. */
947 for (; p; p = p->next)
948 if (!p->sym->attr.function && !p->sym->attr.subroutine)
950 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
951 "subroutine", p->sym->name, interface_name,
952 &p->sym->declared_at);
957 /* Remove duplicate interfaces in this interface list. */
958 for (; p; p = p->next)
962 for (q = p->next; q;)
964 if (p->sym != q->sym)
971 /* Duplicate interface. */
972 qlast->next = q->next;
983 /* Check lists of interfaces to make sure that no two interfaces are
984 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
987 check_interface1 (gfc_interface *p, gfc_interface *q0,
988 int generic_flag, const char *interface_name,
992 for (; p; p = p->next)
993 for (q = q0; q; q = q->next)
995 if (p->sym == q->sym)
996 continue; /* Duplicates OK here. */
998 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1001 if (compare_interfaces (p->sym, q->sym, generic_flag))
1005 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1006 p->sym->name, q->sym->name, interface_name,
1010 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1011 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1012 p->sym->name, q->sym->name, interface_name,
1021 /* Check the generic and operator interfaces of symbols to make sure
1022 that none of the interfaces conflict. The check has to be done
1023 after all of the symbols are actually loaded. */
1026 check_sym_interfaces (gfc_symbol *sym)
1028 char interface_name[100];
1032 if (sym->ns != gfc_current_ns)
1035 if (sym->generic != NULL)
1037 sprintf (interface_name, "generic interface '%s'", sym->name);
1038 if (check_interface0 (sym->generic, interface_name))
1041 for (p = sym->generic; p; p = p->next)
1043 if (!p->sym->attr.use_assoc && p->sym->attr.mod_proc
1044 && p->sym->attr.if_source != IFSRC_DECL)
1046 gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1047 "from a module", p->sym->name, &p->where);
1052 /* Originally, this test was applied to host interfaces too;
1053 this is incorrect since host associated symbols, from any
1054 source, cannot be ambiguous with local symbols. */
1055 k = sym->attr.referenced || !sym->attr.use_assoc;
1056 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1057 sym->attr.ambiguous_interfaces = 1;
1063 check_uop_interfaces (gfc_user_op *uop)
1065 char interface_name[100];
1069 sprintf (interface_name, "operator interface '%s'", uop->name);
1070 if (check_interface0 (uop->operator, interface_name))
1073 for (ns = gfc_current_ns; ns; ns = ns->parent)
1075 uop2 = gfc_find_uop (uop->name, ns);
1079 check_interface1 (uop->operator, uop2->operator, 0,
1080 interface_name, true);
1085 /* For the namespace, check generic, user operator and intrinsic
1086 operator interfaces for consistency and to remove duplicate
1087 interfaces. We traverse the whole namespace, counting on the fact
1088 that most symbols will not have generic or operator interfaces. */
1091 gfc_check_interfaces (gfc_namespace *ns)
1093 gfc_namespace *old_ns, *ns2;
1094 char interface_name[100];
1097 old_ns = gfc_current_ns;
1098 gfc_current_ns = ns;
1100 gfc_traverse_ns (ns, check_sym_interfaces);
1102 gfc_traverse_user_op (ns, check_uop_interfaces);
1104 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1106 if (i == INTRINSIC_USER)
1109 if (i == INTRINSIC_ASSIGN)
1110 strcpy (interface_name, "intrinsic assignment operator");
1112 sprintf (interface_name, "intrinsic '%s' operator",
1115 if (check_interface0 (ns->operator[i], interface_name))
1118 check_operator_interface (ns->operator[i], i);
1120 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1121 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1122 interface_name, true))
1126 gfc_current_ns = old_ns;
1131 symbol_rank (gfc_symbol *sym)
1133 return (sym->as == NULL) ? 0 : sym->as->rank;
1137 /* Given a symbol of a formal argument list and an expression, if the
1138 formal argument is allocatable, check that the actual argument is
1139 allocatable. Returns nonzero if compatible, zero if not compatible. */
1142 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1144 symbol_attribute attr;
1146 if (formal->attr.allocatable)
1148 attr = gfc_expr_attr (actual);
1149 if (!attr.allocatable)
1157 /* Given a symbol of a formal argument list and an expression, if the
1158 formal argument is a pointer, see if the actual argument is a
1159 pointer. Returns nonzero if compatible, zero if not compatible. */
1162 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1164 symbol_attribute attr;
1166 if (formal->attr.pointer)
1168 attr = gfc_expr_attr (actual);
1177 /* Given a symbol of a formal argument list and an expression, see if
1178 the two are compatible as arguments. Returns nonzero if
1179 compatible, zero if not compatible. */
1182 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1183 int ranks_must_agree, int is_elemental)
1187 if (actual->ts.type == BT_PROCEDURE)
1189 if (formal->attr.flavor != FL_PROCEDURE)
1192 if (formal->attr.function
1193 && !compare_type_rank (formal, actual->symtree->n.sym))
1196 if (formal->attr.if_source == IFSRC_UNKNOWN
1197 || actual->symtree->n.sym->attr.external)
1198 return 1; /* Assume match. */
1200 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1203 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1204 && !gfc_compare_types (&formal->ts, &actual->ts))
1207 if (symbol_rank (formal) == actual->rank)
1210 /* At this point the ranks didn't agree. */
1211 if (ranks_must_agree || formal->attr.pointer)
1214 if (actual->rank != 0)
1215 return is_elemental || formal->attr.dimension;
1217 /* At this point, we are considering a scalar passed to an array.
1218 This is legal if the scalar is an array element of the right sort. */
1219 if (formal->as->type == AS_ASSUMED_SHAPE)
1222 for (ref = actual->ref; ref; ref = ref->next)
1223 if (ref->type == REF_SUBSTRING)
1226 for (ref = actual->ref; ref; ref = ref->next)
1227 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1231 return 0; /* Not an array element. */
1237 /* Given a symbol of a formal argument list and an expression, see if
1238 the two are compatible as arguments. Returns nonzero if
1239 compatible, zero if not compatible. */
1242 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1244 if (actual->expr_type != EXPR_VARIABLE)
1247 if (!actual->symtree->n.sym->attr.protected)
1250 if (!actual->symtree->n.sym->attr.use_assoc)
1253 if (formal->attr.intent == INTENT_IN
1254 || formal->attr.intent == INTENT_UNKNOWN)
1257 if (!actual->symtree->n.sym->attr.pointer)
1260 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1267 /* Given an expression, check whether it is an array section
1268 which has a vector subscript. If it has, one is returned,
1272 has_vector_subscript (gfc_expr *e)
1277 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1280 for (ref = e->ref; ref; ref = ref->next)
1281 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1282 for (i = 0; i < ref->u.ar.dimen; i++)
1283 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1290 /* Given formal and actual argument lists, see if they are compatible.
1291 If they are compatible, the actual argument list is sorted to
1292 correspond with the formal list, and elements for missing optional
1293 arguments are inserted. If WHERE pointer is nonnull, then we issue
1294 errors when things don't match instead of just returning the status
1298 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1299 int ranks_must_agree, int is_elemental, locus *where)
1301 gfc_actual_arglist **new, *a, *actual, temp;
1302 gfc_formal_arglist *f;
1308 if (actual == NULL && formal == NULL)
1312 for (f = formal; f; f = f->next)
1315 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1317 for (i = 0; i < n; i++)
1324 for (a = actual; a; a = a->next, f = f->next)
1326 /* Look for keywords but ignore g77 extensions like %VAL. */
1327 if (a->name != NULL && a->name[0] != '%')
1330 for (f = formal; f; f = f->next, i++)
1334 if (strcmp (f->sym->name, a->name) == 0)
1341 gfc_error ("Keyword argument '%s' at %L is not in "
1342 "the procedure", a->name, &a->expr->where);
1349 gfc_error ("Keyword argument '%s' at %L is already associated "
1350 "with another actual argument", a->name,
1359 gfc_error ("More actual than formal arguments in procedure "
1360 "call at %L", where);
1365 if (f->sym == NULL && a->expr == NULL)
1371 gfc_error ("Missing alternate return spec in subroutine call "
1376 if (a->expr == NULL)
1379 gfc_error ("Unexpected alternate return spec in subroutine "
1380 "call at %L", where);
1384 rank_check = where != NULL && !is_elemental && f->sym->as
1385 && (f->sym->as->type == AS_ASSUMED_SHAPE
1386 || f->sym->as->type == AS_DEFERRED);
1388 if (!compare_parameter (f->sym, a->expr,
1389 ranks_must_agree || rank_check, is_elemental))
1392 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1393 f->sym->name, &a->expr->where);
1397 if (a->expr->ts.type == BT_CHARACTER
1398 && a->expr->ts.cl && a->expr->ts.cl->length
1399 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1400 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1401 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1403 if (mpz_cmp (a->expr->ts.cl->length->value.integer,
1404 f->sym->ts.cl->length->value.integer) < 0)
1407 gfc_error ("Character length of actual argument shorter "
1408 "than of dummy argument '%s' at %L",
1409 f->sym->name, &a->expr->where);
1413 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
1414 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1415 f->sym->ts.cl->length->value.integer) != 0))
1418 gfc_error ("Character length mismatch between actual argument "
1419 "and pointer or allocatable dummy argument "
1420 "'%s' at %L", f->sym->name, &a->expr->where);
1425 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1426 provided for a procedure formal argument. */
1427 if (a->expr->ts.type != BT_PROCEDURE
1428 && a->expr->expr_type == EXPR_VARIABLE
1429 && f->sym->attr.flavor == FL_PROCEDURE)
1432 gfc_error ("Expected a procedure for argument '%s' at %L",
1433 f->sym->name, &a->expr->where);
1437 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1438 && a->expr->ts.type == BT_PROCEDURE
1439 && !a->expr->symtree->n.sym->attr.pure)
1442 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1443 f->sym->name, &a->expr->where);
1447 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1448 && a->expr->expr_type == EXPR_VARIABLE
1449 && a->expr->symtree->n.sym->as
1450 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1451 && (a->expr->ref == NULL
1452 || (a->expr->ref->type == REF_ARRAY
1453 && a->expr->ref->u.ar.type == AR_FULL)))
1456 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1457 " array at %L", f->sym->name, where);
1461 if (a->expr->expr_type != EXPR_NULL
1462 && compare_pointer (f->sym, a->expr) == 0)
1465 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1466 f->sym->name, &a->expr->where);
1470 if (a->expr->expr_type != EXPR_NULL
1471 && compare_allocatable (f->sym, a->expr) == 0)
1474 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1475 f->sym->name, &a->expr->where);
1479 /* Check intent = OUT/INOUT for definable actual argument. */
1480 if (a->expr->expr_type != EXPR_VARIABLE
1481 && (f->sym->attr.intent == INTENT_OUT
1482 || f->sym->attr.intent == INTENT_INOUT))
1485 gfc_error ("Actual argument at %L must be definable to "
1486 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1490 if (!compare_parameter_protected(f->sym, a->expr))
1493 gfc_error ("Actual argument at %L is use-associated with "
1494 "PROTECTED attribute and dummy argument '%s' is "
1495 "INTENT = OUT/INOUT",
1496 &a->expr->where,f->sym->name);
1500 if ((f->sym->attr.intent == INTENT_OUT
1501 || f->sym->attr.intent == INTENT_INOUT
1502 || f->sym->attr.volatile_)
1503 && has_vector_subscript (a->expr))
1506 gfc_error ("Array-section actual argument with vector subscripts "
1507 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1508 "or VOLATILE attribute of the dummy argument '%s'",
1509 &a->expr->where, f->sym->name);
1513 /* C1232 (R1221) For an actual argument which is an array section or
1514 an assumed-shape array, the dummy argument shall be an assumed-
1515 shape array, if the dummy argument has the VOLATILE attribute. */
1517 if (f->sym->attr.volatile_
1518 && a->expr->symtree->n.sym->as
1519 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1520 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1523 gfc_error ("Assumed-shape actual argument at %L is "
1524 "incompatible with the non-assumed-shape "
1525 "dummy argument '%s' due to VOLATILE attribute",
1526 &a->expr->where,f->sym->name);
1530 if (f->sym->attr.volatile_
1531 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1532 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1535 gfc_error ("Array-section actual argument at %L is "
1536 "incompatible with the non-assumed-shape "
1537 "dummy argument '%s' due to VOLATILE attribute",
1538 &a->expr->where,f->sym->name);
1542 /* C1233 (R1221) For an actual argument which is a pointer array, the
1543 dummy argument shall be an assumed-shape or pointer array, if the
1544 dummy argument has the VOLATILE attribute. */
1546 if (f->sym->attr.volatile_
1547 && a->expr->symtree->n.sym->attr.pointer
1548 && a->expr->symtree->n.sym->as
1550 && (f->sym->as->type == AS_ASSUMED_SHAPE
1551 || f->sym->attr.pointer)))
1554 gfc_error ("Pointer-array actual argument at %L requires "
1555 "an assumed-shape or pointer-array dummy "
1556 "argument '%s' due to VOLATILE attribute",
1557 &a->expr->where,f->sym->name);
1568 /* Make sure missing actual arguments are optional. */
1570 for (f = formal; f; f = f->next, i++)
1577 gfc_error ("Missing alternate return spec in subroutine call "
1581 if (!f->sym->attr.optional)
1584 gfc_error ("Missing actual argument for argument '%s' at %L",
1585 f->sym->name, where);
1590 /* The argument lists are compatible. We now relink a new actual
1591 argument list with null arguments in the right places. The head
1592 of the list remains the head. */
1593 for (i = 0; i < n; i++)
1595 new[i] = gfc_get_actual_arglist ();
1608 for (i = 0; i < n - 1; i++)
1609 new[i]->next = new[i + 1];
1611 new[i]->next = NULL;
1613 if (*ap == NULL && n > 0)
1616 /* Note the types of omitted optional arguments. */
1617 for (a = actual, f = formal; a; a = a->next, f = f->next)
1618 if (a->expr == NULL && a->label == NULL)
1619 a->missing_arg_type = f->sym->ts.type;
1627 gfc_formal_arglist *f;
1628 gfc_actual_arglist *a;
1632 /* qsort comparison function for argument pairs, with the following
1634 - p->a->expr == NULL
1635 - p->a->expr->expr_type != EXPR_VARIABLE
1636 - growing p->a->expr->symbol. */
1639 pair_cmp (const void *p1, const void *p2)
1641 const gfc_actual_arglist *a1, *a2;
1643 /* *p1 and *p2 are elements of the to-be-sorted array. */
1644 a1 = ((const argpair *) p1)->a;
1645 a2 = ((const argpair *) p2)->a;
1654 if (a1->expr->expr_type != EXPR_VARIABLE)
1656 if (a2->expr->expr_type != EXPR_VARIABLE)
1660 if (a2->expr->expr_type != EXPR_VARIABLE)
1662 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1666 /* Given two expressions from some actual arguments, test whether they
1667 refer to the same expression. The analysis is conservative.
1668 Returning FAILURE will produce no warning. */
1671 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
1673 const gfc_ref *r1, *r2;
1676 || e1->expr_type != EXPR_VARIABLE
1677 || e2->expr_type != EXPR_VARIABLE
1678 || e1->symtree->n.sym != e2->symtree->n.sym)
1681 /* TODO: improve comparison, see expr.c:show_ref(). */
1682 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1684 if (r1->type != r2->type)
1689 if (r1->u.ar.type != r2->u.ar.type)
1691 /* TODO: At the moment, consider only full arrays;
1692 we could do better. */
1693 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1698 if (r1->u.c.component != r2->u.c.component)
1706 gfc_internal_error ("compare_actual_expr(): Bad component code");
1715 /* Given formal and actual argument lists that correspond to one
1716 another, check that identical actual arguments aren't not
1717 associated with some incompatible INTENTs. */
1720 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
1722 sym_intent f1_intent, f2_intent;
1723 gfc_formal_arglist *f1;
1724 gfc_actual_arglist *a1;
1730 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1732 if (f1 == NULL && a1 == NULL)
1734 if (f1 == NULL || a1 == NULL)
1735 gfc_internal_error ("check_some_aliasing(): List mismatch");
1740 p = (argpair *) alloca (n * sizeof (argpair));
1742 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1748 qsort (p, n, sizeof (argpair), pair_cmp);
1750 for (i = 0; i < n; i++)
1753 || p[i].a->expr->expr_type != EXPR_VARIABLE
1754 || p[i].a->expr->ts.type == BT_PROCEDURE)
1756 f1_intent = p[i].f->sym->attr.intent;
1757 for (j = i + 1; j < n; j++)
1759 /* Expected order after the sort. */
1760 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1761 gfc_internal_error ("check_some_aliasing(): corrupted data");
1763 /* Are the expression the same? */
1764 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1766 f2_intent = p[j].f->sym->attr.intent;
1767 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1768 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1770 gfc_warning ("Same actual argument associated with INTENT(%s) "
1771 "argument '%s' and INTENT(%s) argument '%s' at %L",
1772 gfc_intent_string (f1_intent), p[i].f->sym->name,
1773 gfc_intent_string (f2_intent), p[j].f->sym->name,
1774 &p[i].a->expr->where);
1784 /* Given a symbol of a formal argument list and an expression,
1785 return non-zero if their intents are compatible, zero otherwise. */
1788 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
1790 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
1793 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
1796 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
1803 /* Given formal and actual argument lists that correspond to one
1804 another, check that they are compatible in the sense that intents
1805 are not mismatched. */
1808 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
1810 sym_intent f_intent;
1812 for (;; f = f->next, a = a->next)
1814 if (f == NULL && a == NULL)
1816 if (f == NULL || a == NULL)
1817 gfc_internal_error ("check_intents(): List mismatch");
1819 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1822 f_intent = f->sym->attr.intent;
1824 if (!compare_parameter_intent(f->sym, a->expr))
1826 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1827 "specifies INTENT(%s)", &a->expr->where,
1828 gfc_intent_string (f_intent));
1832 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1834 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1836 gfc_error ("Procedure argument at %L is local to a PURE "
1837 "procedure and is passed to an INTENT(%s) argument",
1838 &a->expr->where, gfc_intent_string (f_intent));
1842 if (a->expr->symtree->n.sym->attr.pointer)
1844 gfc_error ("Procedure argument at %L is local to a PURE "
1845 "procedure and has the POINTER attribute",
1856 /* Check how a procedure is used against its interface. If all goes
1857 well, the actual argument list will also end up being properly
1861 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
1864 /* Warn about calls with an implicit interface. */
1865 if (gfc_option.warn_implicit_interface
1866 && sym->attr.if_source == IFSRC_UNKNOWN)
1867 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1870 if (sym->attr.if_source == IFSRC_UNKNOWN
1871 || !compare_actual_formal (ap, sym->formal, 0,
1872 sym->attr.elemental, where))
1875 check_intents (sym->formal, *ap);
1876 if (gfc_option.warn_aliasing)
1877 check_some_aliasing (sym->formal, *ap);
1881 /* Given an interface pointer and an actual argument list, search for
1882 a formal argument list that matches the actual. If found, returns
1883 a pointer to the symbol of the correct interface. Returns NULL if
1887 gfc_search_interface (gfc_interface *intr, int sub_flag,
1888 gfc_actual_arglist **ap)
1892 for (; intr; intr = intr->next)
1894 if (sub_flag && intr->sym->attr.function)
1896 if (!sub_flag && intr->sym->attr.subroutine)
1899 r = !intr->sym->attr.elemental;
1901 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1903 check_intents (intr->sym->formal, *ap);
1904 if (gfc_option.warn_aliasing)
1905 check_some_aliasing (intr->sym->formal, *ap);
1914 /* Do a brute force recursive search for a symbol. */
1916 static gfc_symtree *
1917 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
1921 if (root->n.sym == sym)
1926 st = find_symtree0 (root->left, sym);
1927 if (root->right && ! st)
1928 st = find_symtree0 (root->right, sym);
1933 /* Find a symtree for a symbol. */
1935 static gfc_symtree *
1936 find_sym_in_symtree (gfc_symbol *sym)
1941 /* First try to find it by name. */
1942 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1943 if (st && st->n.sym == sym)
1946 /* If it's been renamed, resort to a brute-force search. */
1947 /* TODO: avoid having to do this search. If the symbol doesn't exist
1948 in the symtree for the current namespace, it should probably be added. */
1949 for (ns = gfc_current_ns; ns; ns = ns->parent)
1951 st = find_symtree0 (ns->sym_root, sym);
1955 gfc_internal_error ("Unable to find symbol %s", sym->name);
1960 /* This subroutine is called when an expression is being resolved.
1961 The expression node in question is either a user defined operator
1962 or an intrinsic operator with arguments that aren't compatible
1963 with the operator. This subroutine builds an actual argument list
1964 corresponding to the operands, then searches for a compatible
1965 interface. If one is found, the expression node is replaced with
1966 the appropriate function call. */
1969 gfc_extend_expr (gfc_expr *e)
1971 gfc_actual_arglist *actual;
1979 actual = gfc_get_actual_arglist ();
1980 actual->expr = e->value.op.op1;
1982 if (e->value.op.op2 != NULL)
1984 actual->next = gfc_get_actual_arglist ();
1985 actual->next->expr = e->value.op.op2;
1988 i = fold_unary (e->value.op.operator);
1990 if (i == INTRINSIC_USER)
1992 for (ns = gfc_current_ns; ns; ns = ns->parent)
1994 uop = gfc_find_uop (e->value.op.uop->name, ns);
1998 sym = gfc_search_interface (uop->operator, 0, &actual);
2005 for (ns = gfc_current_ns; ns; ns = ns->parent)
2007 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2015 /* Don't use gfc_free_actual_arglist(). */
2016 if (actual->next != NULL)
2017 gfc_free (actual->next);
2023 /* Change the expression node to a function call. */
2024 e->expr_type = EXPR_FUNCTION;
2025 e->symtree = find_sym_in_symtree (sym);
2026 e->value.function.actual = actual;
2027 e->value.function.esym = NULL;
2028 e->value.function.isym = NULL;
2029 e->value.function.name = NULL;
2031 if (gfc_pure (NULL) && !gfc_pure (sym))
2033 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2034 "be PURE", sym->name, &e->where);
2038 if (gfc_resolve_expr (e) == FAILURE)
2045 /* Tries to replace an assignment code node with a subroutine call to
2046 the subroutine associated with the assignment operator. Return
2047 SUCCESS if the node was replaced. On FAILURE, no error is
2051 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2053 gfc_actual_arglist *actual;
2054 gfc_expr *lhs, *rhs;
2060 /* Don't allow an intrinsic assignment to be replaced. */
2061 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2062 && (lhs->ts.type == rhs->ts.type
2063 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2066 actual = gfc_get_actual_arglist ();
2069 actual->next = gfc_get_actual_arglist ();
2070 actual->next->expr = rhs;
2074 for (; ns; ns = ns->parent)
2076 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2083 gfc_free (actual->next);
2088 /* Replace the assignment with the call. */
2089 c->op = EXEC_ASSIGN_CALL;
2090 c->symtree = find_sym_in_symtree (sym);
2093 c->ext.actual = actual;
2099 /* Make sure that the interface just parsed is not already present in
2100 the given interface list. Ambiguity isn't checked yet since module
2101 procedures can be present without interfaces. */
2104 check_new_interface (gfc_interface *base, gfc_symbol *new)
2108 for (ip = base; ip; ip = ip->next)
2112 gfc_error ("Entity '%s' at %C is already present in the interface",
2122 /* Add a symbol to the current interface. */
2125 gfc_add_interface (gfc_symbol *new)
2127 gfc_interface **head, *intr;
2131 switch (current_interface.type)
2133 case INTERFACE_NAMELESS:
2136 case INTERFACE_INTRINSIC_OP:
2137 for (ns = current_interface.ns; ns; ns = ns->parent)
2138 if (check_new_interface (ns->operator[current_interface.op], new)
2142 head = ¤t_interface.ns->operator[current_interface.op];
2145 case INTERFACE_GENERIC:
2146 for (ns = current_interface.ns; ns; ns = ns->parent)
2148 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2152 if (check_new_interface (sym->generic, new) == FAILURE)
2156 head = ¤t_interface.sym->generic;
2159 case INTERFACE_USER_OP:
2160 if (check_new_interface (current_interface.uop->operator, new)
2164 head = ¤t_interface.uop->operator;
2168 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2171 intr = gfc_get_interface ();
2173 intr->where = gfc_current_locus;
2182 /* Gets rid of a formal argument list. We do not free symbols.
2183 Symbols are freed when a namespace is freed. */
2186 gfc_free_formal_arglist (gfc_formal_arglist *p)
2188 gfc_formal_arglist *q;