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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
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. */
72 /* The current_interface structure holds information about the
73 interface currently being parsed. This structure is saved and
74 restored during recursive interfaces. */
76 gfc_interface_info current_interface;
79 /* Free a singly linked list of gfc_interface structures. */
82 gfc_free_interface (gfc_interface *intr)
86 for (; intr; intr = next)
94 /* Change the operators unary plus and minus into binary plus and
95 minus respectively, leaving the rest unchanged. */
97 static gfc_intrinsic_op
98 fold_unary (gfc_intrinsic_op operator)
102 case INTRINSIC_UPLUS:
103 operator = INTRINSIC_PLUS;
105 case INTRINSIC_UMINUS:
106 operator = INTRINSIC_MINUS;
116 /* Match a generic specification. Depending on which type of
117 interface is found, the 'name' or 'operator' pointers may be set.
118 This subroutine doesn't return MATCH_NO. */
121 gfc_match_generic_spec (interface_type *type,
123 gfc_intrinsic_op *operator)
125 char buffer[GFC_MAX_SYMBOL_LEN + 1];
129 if (gfc_match (" assignment ( = )") == MATCH_YES)
131 *type = INTERFACE_INTRINSIC_OP;
132 *operator = INTRINSIC_ASSIGN;
136 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
138 *type = INTERFACE_INTRINSIC_OP;
139 *operator = fold_unary (i);
143 if (gfc_match (" operator ( ") == MATCH_YES)
145 m = gfc_match_defined_op_name (buffer, 1);
151 m = gfc_match_char (')');
157 strcpy (name, buffer);
158 *type = INTERFACE_USER_OP;
162 if (gfc_match_name (buffer) == MATCH_YES)
164 strcpy (name, buffer);
165 *type = INTERFACE_GENERIC;
169 *type = INTERFACE_NAMELESS;
173 gfc_error ("Syntax error in generic specification at %C");
178 /* Match one of the five F95 forms of an interface statement. The
179 matcher for the abstract interface follows. */
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:
236 case INTERFACE_ABSTRACT:
245 /* Match a F2003 abstract interface. */
248 gfc_match_abstract_interface (void)
252 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
256 m = gfc_match_eos ();
260 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
264 current_interface.type = INTERFACE_ABSTRACT;
270 /* Match the different sort of generic-specs that can be present after
271 the END INTERFACE itself. */
274 gfc_match_end_interface (void)
276 char name[GFC_MAX_SYMBOL_LEN + 1];
278 gfc_intrinsic_op operator;
281 m = gfc_match_space ();
283 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
286 /* If we're not looking at the end of the statement now, or if this
287 is not a nameless interface but we did not see a space, punt. */
288 if (gfc_match_eos () != MATCH_YES
289 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
291 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
298 switch (current_interface.type)
300 case INTERFACE_NAMELESS:
301 case INTERFACE_ABSTRACT:
302 if (type != INTERFACE_NAMELESS)
304 gfc_error ("Expected a nameless interface at %C");
310 case INTERFACE_INTRINSIC_OP:
311 if (type != current_interface.type || operator != current_interface.op)
314 if (current_interface.op == INTRINSIC_ASSIGN)
315 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
317 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
318 gfc_op2string (current_interface.op));
325 case INTERFACE_USER_OP:
326 /* Comparing the symbol node names is OK because only use-associated
327 symbols can be renamed. */
328 if (type != current_interface.type
329 || strcmp (current_interface.uop->name, name) != 0)
331 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
332 current_interface.uop->name);
338 case INTERFACE_GENERIC:
339 if (type != current_interface.type
340 || strcmp (current_interface.sym->name, name) != 0)
342 gfc_error ("Expecting 'END INTERFACE %s' at %C",
343 current_interface.sym->name);
354 /* Compare two derived types using the criteria in 4.4.2 of the standard,
355 recursing through gfc_compare_types for the components. */
358 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
360 gfc_component *dt1, *dt2;
362 /* Special case for comparing derived types across namespaces. If the
363 true names and module names are the same and the module name is
364 nonnull, then they are equal. */
365 if (derived1 != NULL && derived2 != NULL
366 && strcmp (derived1->name, derived2->name) == 0
367 && derived1->module != NULL && derived2->module != NULL
368 && strcmp (derived1->module, derived2->module) == 0)
371 /* Compare type via the rules of the standard. Both types must have
372 the SEQUENCE attribute to be equal. */
374 if (strcmp (derived1->name, derived2->name))
377 if (derived1->component_access == ACCESS_PRIVATE
378 || derived2->component_access == ACCESS_PRIVATE)
381 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
384 dt1 = derived1->components;
385 dt2 = derived2->components;
387 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
388 simple test can speed things up. Otherwise, lots of things have to
392 if (strcmp (dt1->name, dt2->name) != 0)
395 if (dt1->access != dt2->access)
398 if (dt1->pointer != dt2->pointer)
401 if (dt1->dimension != dt2->dimension)
404 if (dt1->allocatable != dt2->allocatable)
407 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
410 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
416 if (dt1 == NULL && dt2 == NULL)
418 if (dt1 == NULL || dt2 == NULL)
426 /* Compare two typespecs, recursively if necessary. */
429 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
431 /* See if one of the typespecs is a BT_VOID, which is what is being used
432 to allow the funcs like c_f_pointer to accept any pointer type.
433 TODO: Possibly should narrow this to just the one typespec coming in
434 that is for the formal arg, but oh well. */
435 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
438 if (ts1->type != ts2->type)
440 if (ts1->type != BT_DERIVED)
441 return (ts1->kind == ts2->kind);
443 /* Compare derived types. */
444 if (ts1->derived == ts2->derived)
447 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
451 /* Given two symbols that are formal arguments, compare their ranks
452 and types. Returns nonzero if they have the same rank and type,
456 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
460 r1 = (s1->as != NULL) ? s1->as->rank : 0;
461 r2 = (s2->as != NULL) ? s2->as->rank : 0;
464 return 0; /* Ranks differ. */
466 return gfc_compare_types (&s1->ts, &s2->ts);
470 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
472 /* Given two symbols that are formal arguments, compare their types
473 and rank and their formal interfaces if they are both dummy
474 procedures. Returns nonzero if the same, zero if different. */
477 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
479 if (s1 == NULL || s2 == NULL)
480 return s1 == s2 ? 1 : 0;
482 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
483 return compare_type_rank (s1, s2);
485 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
488 /* At this point, both symbols are procedures. */
489 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
490 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
493 if (s1->attr.function != s2->attr.function
494 || s1->attr.subroutine != s2->attr.subroutine)
497 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
500 /* Originally, gfortran recursed here to check the interfaces of passed
501 procedures. This is explicitly not required by the standard. */
506 /* Given a formal argument list and a keyword name, search the list
507 for that keyword. Returns the correct symbol node if found, NULL
511 find_keyword_arg (const char *name, gfc_formal_arglist *f)
513 for (; f; f = f->next)
514 if (strcmp (f->sym->name, name) == 0)
521 /******** Interface checking subroutines **********/
524 /* Given an operator interface and the operator, make sure that all
525 interfaces for that operator are legal. */
528 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
530 gfc_formal_arglist *formal;
534 int args, r1, r2, k1, k2;
540 t1 = t2 = BT_UNKNOWN;
541 i1 = i2 = INTENT_UNKNOWN;
545 for (formal = intr->sym->formal; formal; formal = formal->next)
550 gfc_error ("Alternate return cannot appear in operator "
551 "interface at %L", &intr->where);
557 i1 = sym->attr.intent;
558 r1 = (sym->as != NULL) ? sym->as->rank : 0;
564 i2 = sym->attr.intent;
565 r2 = (sym->as != NULL) ? sym->as->rank : 0;
573 /* Only +, - and .not. can be unary operators.
574 .not. cannot be a binary operator. */
575 if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
576 && operator != INTRINSIC_MINUS
577 && operator != INTRINSIC_NOT)
578 || (args == 2 && operator == INTRINSIC_NOT))
580 gfc_error ("Operator interface at %L has the wrong number of arguments",
585 /* Check that intrinsics are mapped to functions, except
586 INTRINSIC_ASSIGN which should map to a subroutine. */
587 if (operator == INTRINSIC_ASSIGN)
589 if (!sym->attr.subroutine)
591 gfc_error ("Assignment operator interface at %L must be "
592 "a SUBROUTINE", &intr->where);
597 gfc_error ("Assignment operator interface at %L must have "
598 "two arguments", &intr->where);
601 if (sym->formal->sym->ts.type != BT_DERIVED
602 && sym->formal->next->sym->ts.type != BT_DERIVED
603 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
604 || (gfc_numeric_ts (&sym->formal->sym->ts)
605 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
607 gfc_error ("Assignment operator interface at %L must not redefine "
608 "an INTRINSIC type assignment", &intr->where);
614 if (!sym->attr.function)
616 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
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);
644 /* From now on, all we have to do is check that the operator definition
645 doesn't conflict with an intrinsic operator. The rules for this
646 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
647 as well as 12.3.2.1.1 of Fortran 2003:
649 "If the operator is an intrinsic-operator (R310), the number of
650 function arguments shall be consistent with the intrinsic uses of
651 that operator, and the types, kind type parameters, or ranks of the
652 dummy arguments shall differ from those required for the intrinsic
653 operation (7.1.2)." */
655 #define IS_NUMERIC_TYPE(t) \
656 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
658 /* Unary ops are easy, do them first. */
659 if (operator == INTRINSIC_NOT)
661 if (t1 == BT_LOGICAL)
667 if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
669 if (IS_NUMERIC_TYPE (t1))
675 /* Character intrinsic operators have same character kind, thus
676 operator definitions with operands of different character kinds
678 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
681 /* Intrinsic operators always perform on arguments of same rank,
682 so different ranks is also always safe. (rank == 0) is an exception
683 to that, because all intrinsic operators are elemental. */
684 if (r1 != r2 && r1 != 0 && r2 != 0)
690 case INTRINSIC_EQ_OS:
692 case INTRINSIC_NE_OS:
693 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
698 case INTRINSIC_MINUS:
699 case INTRINSIC_TIMES:
700 case INTRINSIC_DIVIDE:
701 case INTRINSIC_POWER:
702 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
707 case INTRINSIC_GT_OS:
709 case INTRINSIC_GE_OS:
711 case INTRINSIC_LT_OS:
713 case INTRINSIC_LE_OS:
714 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
716 if ((t1 == BT_INTEGER || t1 == BT_REAL)
717 && (t2 == BT_INTEGER || t2 == BT_REAL))
721 case INTRINSIC_CONCAT:
722 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
730 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
740 #undef IS_NUMERIC_TYPE
743 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
749 /* Given a pair of formal argument lists, we see if the two lists can
750 be distinguished by counting the number of nonoptional arguments of
751 a given type/rank in f1 and seeing if there are less then that
752 number of those arguments in f2 (including optional arguments).
753 Since this test is asymmetric, it has to be called twice to make it
754 symmetric. Returns nonzero if the argument lists are incompatible
755 by this test. This subroutine implements rule 1 of section
759 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
761 int rc, ac1, ac2, i, j, k, n1;
762 gfc_formal_arglist *f;
775 for (f = f1; f; f = f->next)
778 /* Build an array of integers that gives the same integer to
779 arguments of the same type/rank. */
780 arg = gfc_getmem (n1 * sizeof (arginfo));
783 for (i = 0; i < n1; i++, f = f->next)
791 for (i = 0; i < n1; i++)
793 if (arg[i].flag != -1)
796 if (arg[i].sym && arg[i].sym->attr.optional)
797 continue; /* Skip optional arguments. */
801 /* Find other nonoptional arguments of the same type/rank. */
802 for (j = i + 1; j < n1; j++)
803 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
804 && compare_type_rank_if (arg[i].sym, arg[j].sym))
810 /* Now loop over each distinct type found in f1. */
814 for (i = 0; i < n1; i++)
816 if (arg[i].flag != k)
820 for (j = i + 1; j < n1; j++)
821 if (arg[j].flag == k)
824 /* Count the number of arguments in f2 with that type, including
825 those that are optional. */
828 for (f = f2; f; f = f->next)
829 if (compare_type_rank_if (arg[i].sym, f->sym))
847 /* Perform the abbreviated correspondence test for operators. The
848 arguments cannot be optional and are always ordered correctly,
849 which makes this test much easier than that for generic tests.
851 This subroutine is also used when comparing a formal and actual
852 argument list when an actual parameter is a dummy procedure. At
853 that point, two formal interfaces must be compared for equality
854 which is what happens here. */
857 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
861 if (f1 == NULL && f2 == NULL)
863 if (f1 == NULL || f2 == NULL)
866 if (!compare_type_rank (f1->sym, f2->sym))
877 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
878 Returns zero if no argument is found that satisfies rule 2, nonzero
881 This test is also not symmetric in f1 and f2 and must be called
882 twice. This test finds problems caused by sorting the actual
883 argument list with keywords. For example:
887 INTEGER :: A ; REAL :: B
891 INTEGER :: A ; REAL :: B
895 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
898 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
900 gfc_formal_arglist *f2_save, *g;
907 if (f1->sym->attr.optional)
910 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
913 /* Now search for a disambiguating keyword argument starting at
914 the current non-match. */
915 for (g = f1; g; g = g->next)
917 if (g->sym->attr.optional)
920 sym = find_keyword_arg (g->sym->name, f2_save);
921 if (sym == NULL || !compare_type_rank (g->sym, sym))
935 /* 'Compare' two formal interfaces associated with a pair of symbols.
936 We return nonzero if there exists an actual argument list that
937 would be ambiguous between the two interfaces, zero otherwise. */
940 compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
942 gfc_formal_arglist *f1, *f2;
944 if (s1->attr.function != s2->attr.function
945 && s1->attr.subroutine != s2->attr.subroutine)
946 return 0; /* Disagreement between function/subroutine. */
951 if (f1 == NULL && f2 == NULL)
952 return 1; /* Special case. */
954 if (count_types_test (f1, f2))
956 if (count_types_test (f2, f1))
961 if (generic_correspondence (f1, f2))
963 if (generic_correspondence (f2, f1))
968 if (operator_correspondence (f1, f2))
976 /* Given a pointer to an interface pointer, remove duplicate
977 interfaces and make sure that all symbols are either functions or
978 subroutines. Returns nonzero if something goes wrong. */
981 check_interface0 (gfc_interface *p, const char *interface_name)
983 gfc_interface *psave, *q, *qlast;
986 /* Make sure all symbols in the interface have been defined as
987 functions or subroutines. */
988 for (; p; p = p->next)
989 if (!p->sym->attr.function && !p->sym->attr.subroutine)
991 if (p->sym->attr.external)
992 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
993 p->sym->name, interface_name, &p->sym->declared_at);
995 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
996 "subroutine", p->sym->name, interface_name,
997 &p->sym->declared_at);
1002 /* Remove duplicate interfaces in this interface list. */
1003 for (; p; p = p->next)
1007 for (q = p->next; q;)
1009 if (p->sym != q->sym)
1016 /* Duplicate interface. */
1017 qlast->next = q->next;
1028 /* Check lists of interfaces to make sure that no two interfaces are
1029 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1032 check_interface1 (gfc_interface *p, gfc_interface *q0,
1033 int generic_flag, const char *interface_name,
1037 for (; p; p = p->next)
1038 for (q = q0; q; q = q->next)
1040 if (p->sym == q->sym)
1041 continue; /* Duplicates OK here. */
1043 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1046 if (compare_interfaces (p->sym, q->sym, generic_flag))
1050 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1051 p->sym->name, q->sym->name, interface_name,
1055 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1056 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1057 p->sym->name, q->sym->name, interface_name,
1066 /* Check the generic and operator interfaces of symbols to make sure
1067 that none of the interfaces conflict. The check has to be done
1068 after all of the symbols are actually loaded. */
1071 check_sym_interfaces (gfc_symbol *sym)
1073 char interface_name[100];
1077 if (sym->ns != gfc_current_ns)
1080 if (sym->generic != NULL)
1082 sprintf (interface_name, "generic interface '%s'", sym->name);
1083 if (check_interface0 (sym->generic, interface_name))
1086 for (p = sym->generic; p; p = p->next)
1088 if (p->sym->attr.mod_proc && p->sym->attr.if_source != IFSRC_DECL)
1090 gfc_error ("'%s' at %L is not a module procedure",
1091 p->sym->name, &p->where);
1096 /* Originally, this test was applied to host interfaces too;
1097 this is incorrect since host associated symbols, from any
1098 source, cannot be ambiguous with local symbols. */
1099 k = sym->attr.referenced || !sym->attr.use_assoc;
1100 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1101 sym->attr.ambiguous_interfaces = 1;
1107 check_uop_interfaces (gfc_user_op *uop)
1109 char interface_name[100];
1113 sprintf (interface_name, "operator interface '%s'", uop->name);
1114 if (check_interface0 (uop->operator, interface_name))
1117 for (ns = gfc_current_ns; ns; ns = ns->parent)
1119 uop2 = gfc_find_uop (uop->name, ns);
1123 check_interface1 (uop->operator, uop2->operator, 0,
1124 interface_name, true);
1129 /* For the namespace, check generic, user operator and intrinsic
1130 operator interfaces for consistency and to remove duplicate
1131 interfaces. We traverse the whole namespace, counting on the fact
1132 that most symbols will not have generic or operator interfaces. */
1135 gfc_check_interfaces (gfc_namespace *ns)
1137 gfc_namespace *old_ns, *ns2;
1138 char interface_name[100];
1141 old_ns = gfc_current_ns;
1142 gfc_current_ns = ns;
1144 gfc_traverse_ns (ns, check_sym_interfaces);
1146 gfc_traverse_user_op (ns, check_uop_interfaces);
1148 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1150 if (i == INTRINSIC_USER)
1153 if (i == INTRINSIC_ASSIGN)
1154 strcpy (interface_name, "intrinsic assignment operator");
1156 sprintf (interface_name, "intrinsic '%s' operator",
1159 if (check_interface0 (ns->operator[i], interface_name))
1162 check_operator_interface (ns->operator[i], i);
1164 for (ns2 = ns; ns2; ns2 = ns2->parent)
1166 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1167 interface_name, true))
1173 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
1174 0, interface_name, true)) goto done;
1177 case INTRINSIC_EQ_OS:
1178 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
1179 0, interface_name, true)) goto done;
1183 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
1184 0, interface_name, true)) goto done;
1187 case INTRINSIC_NE_OS:
1188 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
1189 0, interface_name, true)) goto done;
1193 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
1194 0, interface_name, true)) goto done;
1197 case INTRINSIC_GT_OS:
1198 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
1199 0, interface_name, true)) goto done;
1203 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
1204 0, interface_name, true)) goto done;
1207 case INTRINSIC_GE_OS:
1208 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
1209 0, interface_name, true)) goto done;
1213 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
1214 0, interface_name, true)) goto done;
1217 case INTRINSIC_LT_OS:
1218 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
1219 0, interface_name, true)) goto done;
1223 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
1224 0, interface_name, true)) goto done;
1227 case INTRINSIC_LE_OS:
1228 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
1229 0, interface_name, true)) goto done;
1239 gfc_current_ns = old_ns;
1244 symbol_rank (gfc_symbol *sym)
1246 return (sym->as == NULL) ? 0 : sym->as->rank;
1250 /* Given a symbol of a formal argument list and an expression, if the
1251 formal argument is allocatable, check that the actual argument is
1252 allocatable. Returns nonzero if compatible, zero if not compatible. */
1255 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1257 symbol_attribute attr;
1259 if (formal->attr.allocatable)
1261 attr = gfc_expr_attr (actual);
1262 if (!attr.allocatable)
1270 /* Given a symbol of a formal argument list and an expression, if the
1271 formal argument is a pointer, see if the actual argument is a
1272 pointer. Returns nonzero if compatible, zero if not compatible. */
1275 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1277 symbol_attribute attr;
1279 if (formal->attr.pointer)
1281 attr = gfc_expr_attr (actual);
1290 /* Given a symbol of a formal argument list and an expression, see if
1291 the two are compatible as arguments. Returns nonzero if
1292 compatible, zero if not compatible. */
1295 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1296 int ranks_must_agree, int is_elemental)
1300 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1301 procs c_f_pointer or c_f_procpointer, and we need to accept most
1302 pointers the user could give us. This should allow that. */
1303 if (formal->ts.type == BT_VOID)
1306 if (formal->ts.type == BT_DERIVED
1307 && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1308 && actual->ts.type == BT_DERIVED
1309 && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1312 if (actual->ts.type == BT_PROCEDURE)
1314 if (formal->attr.flavor != FL_PROCEDURE)
1317 if (formal->attr.function
1318 && !compare_type_rank (formal, actual->symtree->n.sym))
1321 if (formal->attr.if_source == IFSRC_UNKNOWN
1322 || actual->symtree->n.sym->attr.external)
1323 return 1; /* Assume match. */
1325 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1328 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1329 && !gfc_compare_types (&formal->ts, &actual->ts))
1332 if (symbol_rank (formal) == actual->rank)
1335 /* At this point the ranks didn't agree. */
1336 if (ranks_must_agree || formal->attr.pointer)
1339 if (actual->rank != 0)
1340 return is_elemental || formal->attr.dimension;
1342 /* At this point, we are considering a scalar passed to an array.
1343 This is legal if the scalar is an array element of the right sort. */
1344 if (formal->as->type == AS_ASSUMED_SHAPE)
1347 for (ref = actual->ref; ref; ref = ref->next)
1348 if (ref->type == REF_SUBSTRING)
1351 for (ref = actual->ref; ref; ref = ref->next)
1352 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1356 return 0; /* Not an array element. */
1362 /* Given a symbol of a formal argument list and an expression, see if
1363 the two are compatible as arguments. Returns nonzero if
1364 compatible, zero if not compatible. */
1367 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1369 if (actual->expr_type != EXPR_VARIABLE)
1372 if (!actual->symtree->n.sym->attr.protected)
1375 if (!actual->symtree->n.sym->attr.use_assoc)
1378 if (formal->attr.intent == INTENT_IN
1379 || formal->attr.intent == INTENT_UNKNOWN)
1382 if (!actual->symtree->n.sym->attr.pointer)
1385 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1392 /* Returns the storage size of a symbol (formal argument) or
1393 zero if it cannot be determined. */
1395 static unsigned long
1396 get_sym_storage_size (gfc_symbol *sym)
1399 unsigned long strlen, elements;
1401 if (sym->ts.type == BT_CHARACTER)
1403 if (sym->ts.cl && sym->ts.cl->length
1404 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1405 strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1412 if (symbol_rank (sym) == 0)
1416 if (sym->as->type != AS_EXPLICIT)
1418 for (i = 0; i < sym->as->rank; i++)
1420 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1421 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1424 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1425 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1428 return strlen*elements;
1432 /* Returns the storage size of an expression (actual argument) or
1433 zero if it cannot be determined. For an array element, it returns
1434 the remaining size as the element sequence consists of all storage
1435 units of the actual argument up to the end of the array. */
1437 static unsigned long
1438 get_expr_storage_size (gfc_expr *e)
1441 long int strlen, elements;
1447 if (e->ts.type == BT_CHARACTER)
1449 if (e->ts.cl && e->ts.cl->length
1450 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1451 strlen = mpz_get_si (e->ts.cl->length->value.integer);
1452 else if (e->expr_type == EXPR_CONSTANT
1453 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1454 strlen = e->value.character.length;
1459 strlen = 1; /* Length per element. */
1461 if (e->rank == 0 && !e->ref)
1469 for (i = 0; i < e->rank; i++)
1470 elements *= mpz_get_si (e->shape[i]);
1471 return elements*strlen;
1474 for (ref = e->ref; ref; ref = ref->next)
1476 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1477 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1478 && ref->u.ar.as->upper)
1479 for (i = 0; i < ref->u.ar.dimen; i++)
1481 long int start, end, stride;
1484 if (ref->u.ar.stride[i])
1486 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1487 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1492 if (ref->u.ar.start[i])
1494 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1495 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1499 else if (ref->u.ar.as->lower[i]
1500 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1501 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1505 if (ref->u.ar.end[i])
1507 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1508 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1512 else if (ref->u.ar.as->upper[i]
1513 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1514 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1518 elements *= (end - start)/stride + 1L;
1520 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1521 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1522 for (i = 0; i < ref->u.ar.as->rank; i++)
1524 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1525 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1526 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1527 elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
1528 - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
1534 /* TODO: Determine the number of remaining elements in the element
1535 sequence for array element designators.
1536 See also get_array_index in data.c. */
1540 return elements*strlen;
1544 /* Given an expression, check whether it is an array section
1545 which has a vector subscript. If it has, one is returned,
1549 has_vector_subscript (gfc_expr *e)
1554 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1557 for (ref = e->ref; ref; ref = ref->next)
1558 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1559 for (i = 0; i < ref->u.ar.dimen; i++)
1560 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1567 /* Given formal and actual argument lists, see if they are compatible.
1568 If they are compatible, the actual argument list is sorted to
1569 correspond with the formal list, and elements for missing optional
1570 arguments are inserted. If WHERE pointer is nonnull, then we issue
1571 errors when things don't match instead of just returning the status
1575 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1576 int ranks_must_agree, int is_elemental, locus *where)
1578 gfc_actual_arglist **new, *a, *actual, temp;
1579 gfc_formal_arglist *f;
1582 unsigned long actual_size, formal_size;
1586 if (actual == NULL && formal == NULL)
1590 for (f = formal; f; f = f->next)
1593 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1595 for (i = 0; i < n; i++)
1602 for (a = actual; a; a = a->next, f = f->next)
1604 /* Look for keywords but ignore g77 extensions like %VAL. */
1605 if (a->name != NULL && a->name[0] != '%')
1608 for (f = formal; f; f = f->next, i++)
1612 if (strcmp (f->sym->name, a->name) == 0)
1619 gfc_error ("Keyword argument '%s' at %L is not in "
1620 "the procedure", a->name, &a->expr->where);
1627 gfc_error ("Keyword argument '%s' at %L is already associated "
1628 "with another actual argument", a->name,
1637 gfc_error ("More actual than formal arguments in procedure "
1638 "call at %L", where);
1643 if (f->sym == NULL && a->expr == NULL)
1649 gfc_error ("Missing alternate return spec in subroutine call "
1654 if (a->expr == NULL)
1657 gfc_error ("Unexpected alternate return spec in subroutine "
1658 "call at %L", where);
1662 rank_check = where != NULL && !is_elemental && f->sym->as
1663 && (f->sym->as->type == AS_ASSUMED_SHAPE
1664 || f->sym->as->type == AS_DEFERRED);
1666 if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
1667 && a->expr->rank == 0
1668 && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
1670 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1672 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
1673 "with array dummy argument '%s' at %L",
1674 f->sym->name, &a->expr->where);
1677 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1681 else if (!compare_parameter (f->sym, a->expr,
1682 ranks_must_agree || rank_check, is_elemental))
1685 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1686 f->sym->name, &a->expr->where);
1690 if (a->expr->ts.type == BT_CHARACTER
1691 && a->expr->ts.cl && a->expr->ts.cl->length
1692 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1693 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1694 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1696 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
1697 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1698 f->sym->ts.cl->length->value.integer) != 0))
1701 gfc_warning ("Character length mismatch between actual "
1702 "argument and pointer or allocatable dummy "
1703 "argument '%s' at %L",
1704 f->sym->name, &a->expr->where);
1709 actual_size = get_expr_storage_size (a->expr);
1710 formal_size = get_sym_storage_size (f->sym);
1711 if (actual_size != 0 && actual_size < formal_size)
1713 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1714 gfc_warning ("Character length of actual argument shorter "
1715 "than of dummy argument '%s' (%lu/%lu) at %L",
1716 f->sym->name, actual_size, formal_size,
1719 gfc_warning ("Actual argument contains too few "
1720 "elements for dummy argument '%s' (%lu/%lu) at %L",
1721 f->sym->name, actual_size, formal_size,
1726 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1727 provided for a procedure formal argument. */
1728 if (a->expr->ts.type != BT_PROCEDURE
1729 && a->expr->expr_type == EXPR_VARIABLE
1730 && f->sym->attr.flavor == FL_PROCEDURE)
1733 gfc_error ("Expected a procedure for argument '%s' at %L",
1734 f->sym->name, &a->expr->where);
1738 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1739 && a->expr->ts.type == BT_PROCEDURE
1740 && !a->expr->symtree->n.sym->attr.pure)
1743 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1744 f->sym->name, &a->expr->where);
1748 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1749 && a->expr->expr_type == EXPR_VARIABLE
1750 && a->expr->symtree->n.sym->as
1751 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1752 && (a->expr->ref == NULL
1753 || (a->expr->ref->type == REF_ARRAY
1754 && a->expr->ref->u.ar.type == AR_FULL)))
1757 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1758 " array at %L", f->sym->name, where);
1762 if (a->expr->expr_type != EXPR_NULL
1763 && compare_pointer (f->sym, a->expr) == 0)
1766 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1767 f->sym->name, &a->expr->where);
1771 if (a->expr->expr_type != EXPR_NULL
1772 && compare_allocatable (f->sym, a->expr) == 0)
1775 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1776 f->sym->name, &a->expr->where);
1780 /* Check intent = OUT/INOUT for definable actual argument. */
1781 if (a->expr->expr_type != EXPR_VARIABLE
1782 && (f->sym->attr.intent == INTENT_OUT
1783 || f->sym->attr.intent == INTENT_INOUT))
1786 gfc_error ("Actual argument at %L must be definable to "
1787 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1791 if (!compare_parameter_protected(f->sym, a->expr))
1794 gfc_error ("Actual argument at %L is use-associated with "
1795 "PROTECTED attribute and dummy argument '%s' is "
1796 "INTENT = OUT/INOUT",
1797 &a->expr->where,f->sym->name);
1801 if ((f->sym->attr.intent == INTENT_OUT
1802 || f->sym->attr.intent == INTENT_INOUT
1803 || f->sym->attr.volatile_)
1804 && has_vector_subscript (a->expr))
1807 gfc_error ("Array-section actual argument with vector subscripts "
1808 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1809 "or VOLATILE attribute of the dummy argument '%s'",
1810 &a->expr->where, f->sym->name);
1814 /* C1232 (R1221) For an actual argument which is an array section or
1815 an assumed-shape array, the dummy argument shall be an assumed-
1816 shape array, if the dummy argument has the VOLATILE attribute. */
1818 if (f->sym->attr.volatile_
1819 && a->expr->symtree->n.sym->as
1820 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1821 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1824 gfc_error ("Assumed-shape actual argument at %L is "
1825 "incompatible with the non-assumed-shape "
1826 "dummy argument '%s' due to VOLATILE attribute",
1827 &a->expr->where,f->sym->name);
1831 if (f->sym->attr.volatile_
1832 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1833 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1836 gfc_error ("Array-section actual argument at %L is "
1837 "incompatible with the non-assumed-shape "
1838 "dummy argument '%s' due to VOLATILE attribute",
1839 &a->expr->where,f->sym->name);
1843 /* C1233 (R1221) For an actual argument which is a pointer array, the
1844 dummy argument shall be an assumed-shape or pointer array, if the
1845 dummy argument has the VOLATILE attribute. */
1847 if (f->sym->attr.volatile_
1848 && a->expr->symtree->n.sym->attr.pointer
1849 && a->expr->symtree->n.sym->as
1851 && (f->sym->as->type == AS_ASSUMED_SHAPE
1852 || f->sym->attr.pointer)))
1855 gfc_error ("Pointer-array actual argument at %L requires "
1856 "an assumed-shape or pointer-array dummy "
1857 "argument '%s' due to VOLATILE attribute",
1858 &a->expr->where,f->sym->name);
1869 /* Make sure missing actual arguments are optional. */
1871 for (f = formal; f; f = f->next, i++)
1878 gfc_error ("Missing alternate return spec in subroutine call "
1882 if (!f->sym->attr.optional)
1885 gfc_error ("Missing actual argument for argument '%s' at %L",
1886 f->sym->name, where);
1891 /* The argument lists are compatible. We now relink a new actual
1892 argument list with null arguments in the right places. The head
1893 of the list remains the head. */
1894 for (i = 0; i < n; i++)
1896 new[i] = gfc_get_actual_arglist ();
1909 for (i = 0; i < n - 1; i++)
1910 new[i]->next = new[i + 1];
1912 new[i]->next = NULL;
1914 if (*ap == NULL && n > 0)
1917 /* Note the types of omitted optional arguments. */
1918 for (a = actual, f = formal; a; a = a->next, f = f->next)
1919 if (a->expr == NULL && a->label == NULL)
1920 a->missing_arg_type = f->sym->ts.type;
1928 gfc_formal_arglist *f;
1929 gfc_actual_arglist *a;
1933 /* qsort comparison function for argument pairs, with the following
1935 - p->a->expr == NULL
1936 - p->a->expr->expr_type != EXPR_VARIABLE
1937 - growing p->a->expr->symbol. */
1940 pair_cmp (const void *p1, const void *p2)
1942 const gfc_actual_arglist *a1, *a2;
1944 /* *p1 and *p2 are elements of the to-be-sorted array. */
1945 a1 = ((const argpair *) p1)->a;
1946 a2 = ((const argpair *) p2)->a;
1955 if (a1->expr->expr_type != EXPR_VARIABLE)
1957 if (a2->expr->expr_type != EXPR_VARIABLE)
1961 if (a2->expr->expr_type != EXPR_VARIABLE)
1963 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1967 /* Given two expressions from some actual arguments, test whether they
1968 refer to the same expression. The analysis is conservative.
1969 Returning FAILURE will produce no warning. */
1972 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
1974 const gfc_ref *r1, *r2;
1977 || e1->expr_type != EXPR_VARIABLE
1978 || e2->expr_type != EXPR_VARIABLE
1979 || e1->symtree->n.sym != e2->symtree->n.sym)
1982 /* TODO: improve comparison, see expr.c:show_ref(). */
1983 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1985 if (r1->type != r2->type)
1990 if (r1->u.ar.type != r2->u.ar.type)
1992 /* TODO: At the moment, consider only full arrays;
1993 we could do better. */
1994 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1999 if (r1->u.c.component != r2->u.c.component)
2007 gfc_internal_error ("compare_actual_expr(): Bad component code");
2016 /* Given formal and actual argument lists that correspond to one
2017 another, check that identical actual arguments aren't not
2018 associated with some incompatible INTENTs. */
2021 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2023 sym_intent f1_intent, f2_intent;
2024 gfc_formal_arglist *f1;
2025 gfc_actual_arglist *a1;
2031 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2033 if (f1 == NULL && a1 == NULL)
2035 if (f1 == NULL || a1 == NULL)
2036 gfc_internal_error ("check_some_aliasing(): List mismatch");
2041 p = (argpair *) alloca (n * sizeof (argpair));
2043 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2049 qsort (p, n, sizeof (argpair), pair_cmp);
2051 for (i = 0; i < n; i++)
2054 || p[i].a->expr->expr_type != EXPR_VARIABLE
2055 || p[i].a->expr->ts.type == BT_PROCEDURE)
2057 f1_intent = p[i].f->sym->attr.intent;
2058 for (j = i + 1; j < n; j++)
2060 /* Expected order after the sort. */
2061 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2062 gfc_internal_error ("check_some_aliasing(): corrupted data");
2064 /* Are the expression the same? */
2065 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2067 f2_intent = p[j].f->sym->attr.intent;
2068 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2069 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2071 gfc_warning ("Same actual argument associated with INTENT(%s) "
2072 "argument '%s' and INTENT(%s) argument '%s' at %L",
2073 gfc_intent_string (f1_intent), p[i].f->sym->name,
2074 gfc_intent_string (f2_intent), p[j].f->sym->name,
2075 &p[i].a->expr->where);
2085 /* Given a symbol of a formal argument list and an expression,
2086 return nonzero if their intents are compatible, zero otherwise. */
2089 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2091 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2094 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2097 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2104 /* Given formal and actual argument lists that correspond to one
2105 another, check that they are compatible in the sense that intents
2106 are not mismatched. */
2109 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2111 sym_intent f_intent;
2113 for (;; f = f->next, a = a->next)
2115 if (f == NULL && a == NULL)
2117 if (f == NULL || a == NULL)
2118 gfc_internal_error ("check_intents(): List mismatch");
2120 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2123 f_intent = f->sym->attr.intent;
2125 if (!compare_parameter_intent(f->sym, a->expr))
2127 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2128 "specifies INTENT(%s)", &a->expr->where,
2129 gfc_intent_string (f_intent));
2133 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2135 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2137 gfc_error ("Procedure argument at %L is local to a PURE "
2138 "procedure and is passed to an INTENT(%s) argument",
2139 &a->expr->where, gfc_intent_string (f_intent));
2143 if (a->expr->symtree->n.sym->attr.pointer)
2145 gfc_error ("Procedure argument at %L is local to a PURE "
2146 "procedure and has the POINTER attribute",
2157 /* Check how a procedure is used against its interface. If all goes
2158 well, the actual argument list will also end up being properly
2162 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2165 /* Warn about calls with an implicit interface. */
2166 if (gfc_option.warn_implicit_interface
2167 && sym->attr.if_source == IFSRC_UNKNOWN)
2168 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2171 if (sym->attr.if_source == IFSRC_UNKNOWN
2172 || !compare_actual_formal (ap, sym->formal, 0,
2173 sym->attr.elemental, where))
2176 check_intents (sym->formal, *ap);
2177 if (gfc_option.warn_aliasing)
2178 check_some_aliasing (sym->formal, *ap);
2182 /* Given an interface pointer and an actual argument list, search for
2183 a formal argument list that matches the actual. If found, returns
2184 a pointer to the symbol of the correct interface. Returns NULL if
2188 gfc_search_interface (gfc_interface *intr, int sub_flag,
2189 gfc_actual_arglist **ap)
2193 for (; intr; intr = intr->next)
2195 if (sub_flag && intr->sym->attr.function)
2197 if (!sub_flag && intr->sym->attr.subroutine)
2200 r = !intr->sym->attr.elemental;
2202 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
2204 check_intents (intr->sym->formal, *ap);
2205 if (gfc_option.warn_aliasing)
2206 check_some_aliasing (intr->sym->formal, *ap);
2215 /* Do a brute force recursive search for a symbol. */
2217 static gfc_symtree *
2218 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2222 if (root->n.sym == sym)
2227 st = find_symtree0 (root->left, sym);
2228 if (root->right && ! st)
2229 st = find_symtree0 (root->right, sym);
2234 /* Find a symtree for a symbol. */
2236 static gfc_symtree *
2237 find_sym_in_symtree (gfc_symbol *sym)
2242 /* First try to find it by name. */
2243 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2244 if (st && st->n.sym == sym)
2247 /* If it's been renamed, resort to a brute-force search. */
2248 /* TODO: avoid having to do this search. If the symbol doesn't exist
2249 in the symtree for the current namespace, it should probably be added. */
2250 for (ns = gfc_current_ns; ns; ns = ns->parent)
2252 st = find_symtree0 (ns->sym_root, sym);
2256 gfc_internal_error ("Unable to find symbol %s", sym->name);
2261 /* This subroutine is called when an expression is being resolved.
2262 The expression node in question is either a user defined operator
2263 or an intrinsic operator with arguments that aren't compatible
2264 with the operator. This subroutine builds an actual argument list
2265 corresponding to the operands, then searches for a compatible
2266 interface. If one is found, the expression node is replaced with
2267 the appropriate function call. */
2270 gfc_extend_expr (gfc_expr *e)
2272 gfc_actual_arglist *actual;
2280 actual = gfc_get_actual_arglist ();
2281 actual->expr = e->value.op.op1;
2283 if (e->value.op.op2 != NULL)
2285 actual->next = gfc_get_actual_arglist ();
2286 actual->next->expr = e->value.op.op2;
2289 i = fold_unary (e->value.op.operator);
2291 if (i == INTRINSIC_USER)
2293 for (ns = gfc_current_ns; ns; ns = ns->parent)
2295 uop = gfc_find_uop (e->value.op.uop->name, ns);
2299 sym = gfc_search_interface (uop->operator, 0, &actual);
2306 for (ns = gfc_current_ns; ns; ns = ns->parent)
2308 /* Due to the distinction between '==' and '.eq.' and friends, one has
2309 to check if either is defined. */
2313 case INTRINSIC_EQ_OS:
2314 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
2316 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
2320 case INTRINSIC_NE_OS:
2321 sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
2323 sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
2327 case INTRINSIC_GT_OS:
2328 sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
2330 sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
2334 case INTRINSIC_GE_OS:
2335 sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
2337 sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
2341 case INTRINSIC_LT_OS:
2342 sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
2344 sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
2348 case INTRINSIC_LE_OS:
2349 sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
2351 sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
2355 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2365 /* Don't use gfc_free_actual_arglist(). */
2366 if (actual->next != NULL)
2367 gfc_free (actual->next);
2373 /* Change the expression node to a function call. */
2374 e->expr_type = EXPR_FUNCTION;
2375 e->symtree = find_sym_in_symtree (sym);
2376 e->value.function.actual = actual;
2377 e->value.function.esym = NULL;
2378 e->value.function.isym = NULL;
2379 e->value.function.name = NULL;
2381 if (gfc_pure (NULL) && !gfc_pure (sym))
2383 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2384 "be PURE", sym->name, &e->where);
2388 if (gfc_resolve_expr (e) == FAILURE)
2395 /* Tries to replace an assignment code node with a subroutine call to
2396 the subroutine associated with the assignment operator. Return
2397 SUCCESS if the node was replaced. On FAILURE, no error is
2401 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2403 gfc_actual_arglist *actual;
2404 gfc_expr *lhs, *rhs;
2410 /* Don't allow an intrinsic assignment to be replaced. */
2411 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2412 && (lhs->ts.type == rhs->ts.type
2413 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2416 actual = gfc_get_actual_arglist ();
2419 actual->next = gfc_get_actual_arglist ();
2420 actual->next->expr = rhs;
2424 for (; ns; ns = ns->parent)
2426 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2433 gfc_free (actual->next);
2438 /* Replace the assignment with the call. */
2439 c->op = EXEC_ASSIGN_CALL;
2440 c->symtree = find_sym_in_symtree (sym);
2443 c->ext.actual = actual;
2449 /* Make sure that the interface just parsed is not already present in
2450 the given interface list. Ambiguity isn't checked yet since module
2451 procedures can be present without interfaces. */
2454 check_new_interface (gfc_interface *base, gfc_symbol *new)
2458 for (ip = base; ip; ip = ip->next)
2462 gfc_error ("Entity '%s' at %C is already present in the interface",
2472 /* Add a symbol to the current interface. */
2475 gfc_add_interface (gfc_symbol *new)
2477 gfc_interface **head, *intr;
2481 switch (current_interface.type)
2483 case INTERFACE_NAMELESS:
2484 case INTERFACE_ABSTRACT:
2487 case INTERFACE_INTRINSIC_OP:
2488 for (ns = current_interface.ns; ns; ns = ns->parent)
2489 switch (current_interface.op)
2492 case INTRINSIC_EQ_OS:
2493 if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
2494 check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
2499 case INTRINSIC_NE_OS:
2500 if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
2501 check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
2506 case INTRINSIC_GT_OS:
2507 if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
2508 check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
2513 case INTRINSIC_GE_OS:
2514 if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
2515 check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
2520 case INTRINSIC_LT_OS:
2521 if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
2522 check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
2527 case INTRINSIC_LE_OS:
2528 if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
2529 check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
2534 if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
2538 head = ¤t_interface.ns->operator[current_interface.op];
2541 case INTERFACE_GENERIC:
2542 for (ns = current_interface.ns; ns; ns = ns->parent)
2544 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2548 if (check_new_interface (sym->generic, new) == FAILURE)
2552 head = ¤t_interface.sym->generic;
2555 case INTERFACE_USER_OP:
2556 if (check_new_interface (current_interface.uop->operator, new)
2560 head = ¤t_interface.uop->operator;
2564 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2567 intr = gfc_get_interface ();
2569 intr->where = gfc_current_locus;
2578 /* Gets rid of a formal argument list. We do not free symbols.
2579 Symbols are freed when a namespace is freed. */
2582 gfc_free_formal_arglist (gfc_formal_arglist *p)
2584 gfc_formal_arglist *q;