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)
990 || !p->sym->attr.if_source)
992 if (p->sym->attr.external)
993 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
994 p->sym->name, interface_name, &p->sym->declared_at);
996 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
997 "subroutine", p->sym->name, interface_name,
998 &p->sym->declared_at);
1003 /* Remove duplicate interfaces in this interface list. */
1004 for (; p; p = p->next)
1008 for (q = p->next; q;)
1010 if (p->sym != q->sym)
1017 /* Duplicate interface. */
1018 qlast->next = q->next;
1029 /* Check lists of interfaces to make sure that no two interfaces are
1030 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1033 check_interface1 (gfc_interface *p, gfc_interface *q0,
1034 int generic_flag, const char *interface_name,
1038 for (; p; p = p->next)
1039 for (q = q0; q; q = q->next)
1041 if (p->sym == q->sym)
1042 continue; /* Duplicates OK here. */
1044 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1047 if (compare_interfaces (p->sym, q->sym, generic_flag))
1051 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1052 p->sym->name, q->sym->name, interface_name,
1056 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1057 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1058 p->sym->name, q->sym->name, interface_name,
1067 /* Check the generic and operator interfaces of symbols to make sure
1068 that none of the interfaces conflict. The check has to be done
1069 after all of the symbols are actually loaded. */
1072 check_sym_interfaces (gfc_symbol *sym)
1074 char interface_name[100];
1078 if (sym->ns != gfc_current_ns)
1081 if (sym->generic != NULL)
1083 sprintf (interface_name, "generic interface '%s'", sym->name);
1084 if (check_interface0 (sym->generic, interface_name))
1087 for (p = sym->generic; p; p = p->next)
1089 if (p->sym->attr.mod_proc && p->sym->attr.if_source != IFSRC_DECL)
1091 gfc_error ("'%s' at %L is not a module procedure",
1092 p->sym->name, &p->where);
1097 /* Originally, this test was applied to host interfaces too;
1098 this is incorrect since host associated symbols, from any
1099 source, cannot be ambiguous with local symbols. */
1100 k = sym->attr.referenced || !sym->attr.use_assoc;
1101 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1102 sym->attr.ambiguous_interfaces = 1;
1108 check_uop_interfaces (gfc_user_op *uop)
1110 char interface_name[100];
1114 sprintf (interface_name, "operator interface '%s'", uop->name);
1115 if (check_interface0 (uop->operator, interface_name))
1118 for (ns = gfc_current_ns; ns; ns = ns->parent)
1120 uop2 = gfc_find_uop (uop->name, ns);
1124 check_interface1 (uop->operator, uop2->operator, 0,
1125 interface_name, true);
1130 /* For the namespace, check generic, user operator and intrinsic
1131 operator interfaces for consistency and to remove duplicate
1132 interfaces. We traverse the whole namespace, counting on the fact
1133 that most symbols will not have generic or operator interfaces. */
1136 gfc_check_interfaces (gfc_namespace *ns)
1138 gfc_namespace *old_ns, *ns2;
1139 char interface_name[100];
1142 old_ns = gfc_current_ns;
1143 gfc_current_ns = ns;
1145 gfc_traverse_ns (ns, check_sym_interfaces);
1147 gfc_traverse_user_op (ns, check_uop_interfaces);
1149 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1151 if (i == INTRINSIC_USER)
1154 if (i == INTRINSIC_ASSIGN)
1155 strcpy (interface_name, "intrinsic assignment operator");
1157 sprintf (interface_name, "intrinsic '%s' operator",
1160 if (check_interface0 (ns->operator[i], interface_name))
1163 check_operator_interface (ns->operator[i], i);
1165 for (ns2 = ns; ns2; ns2 = ns2->parent)
1167 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1168 interface_name, true))
1174 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
1175 0, interface_name, true)) goto done;
1178 case INTRINSIC_EQ_OS:
1179 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
1180 0, interface_name, true)) goto done;
1184 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
1185 0, interface_name, true)) goto done;
1188 case INTRINSIC_NE_OS:
1189 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
1190 0, interface_name, true)) goto done;
1194 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
1195 0, interface_name, true)) goto done;
1198 case INTRINSIC_GT_OS:
1199 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
1200 0, interface_name, true)) goto done;
1204 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
1205 0, interface_name, true)) goto done;
1208 case INTRINSIC_GE_OS:
1209 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
1210 0, interface_name, true)) goto done;
1214 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
1215 0, interface_name, true)) goto done;
1218 case INTRINSIC_LT_OS:
1219 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
1220 0, interface_name, true)) goto done;
1224 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
1225 0, interface_name, true)) goto done;
1228 case INTRINSIC_LE_OS:
1229 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
1230 0, interface_name, true)) goto done;
1240 gfc_current_ns = old_ns;
1245 symbol_rank (gfc_symbol *sym)
1247 return (sym->as == NULL) ? 0 : sym->as->rank;
1251 /* Given a symbol of a formal argument list and an expression, if the
1252 formal argument is allocatable, check that the actual argument is
1253 allocatable. Returns nonzero if compatible, zero if not compatible. */
1256 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1258 symbol_attribute attr;
1260 if (formal->attr.allocatable)
1262 attr = gfc_expr_attr (actual);
1263 if (!attr.allocatable)
1271 /* Given a symbol of a formal argument list and an expression, if the
1272 formal argument is a pointer, see if the actual argument is a
1273 pointer. Returns nonzero if compatible, zero if not compatible. */
1276 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1278 symbol_attribute attr;
1280 if (formal->attr.pointer)
1282 attr = gfc_expr_attr (actual);
1291 /* Given a symbol of a formal argument list and an expression, see if
1292 the two are compatible as arguments. Returns nonzero if
1293 compatible, zero if not compatible. */
1296 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1297 int ranks_must_agree, int is_elemental)
1301 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1302 procs c_f_pointer or c_f_procpointer, and we need to accept most
1303 pointers the user could give us. This should allow that. */
1304 if (formal->ts.type == BT_VOID)
1307 if (formal->ts.type == BT_DERIVED
1308 && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1309 && actual->ts.type == BT_DERIVED
1310 && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1313 if (actual->ts.type == BT_PROCEDURE)
1315 if (formal->attr.flavor != FL_PROCEDURE)
1318 if (formal->attr.function
1319 && !compare_type_rank (formal, actual->symtree->n.sym))
1322 if (formal->attr.if_source == IFSRC_UNKNOWN
1323 || actual->symtree->n.sym->attr.external)
1324 return 1; /* Assume match. */
1326 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1329 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1330 && !gfc_compare_types (&formal->ts, &actual->ts))
1333 if (symbol_rank (formal) == actual->rank)
1336 /* At this point the ranks didn't agree. */
1337 if (ranks_must_agree || formal->attr.pointer)
1340 if (actual->rank != 0)
1341 return is_elemental || formal->attr.dimension;
1343 /* At this point, we are considering a scalar passed to an array.
1344 This is legal if the scalar is an array element of the right sort. */
1345 if (formal->as->type == AS_ASSUMED_SHAPE)
1348 for (ref = actual->ref; ref; ref = ref->next)
1349 if (ref->type == REF_SUBSTRING)
1352 for (ref = actual->ref; ref; ref = ref->next)
1353 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1357 return 0; /* Not an array element. */
1363 /* Given a symbol of a formal argument list and an expression, see if
1364 the two are compatible as arguments. Returns nonzero if
1365 compatible, zero if not compatible. */
1368 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1370 if (actual->expr_type != EXPR_VARIABLE)
1373 if (!actual->symtree->n.sym->attr.protected)
1376 if (!actual->symtree->n.sym->attr.use_assoc)
1379 if (formal->attr.intent == INTENT_IN
1380 || formal->attr.intent == INTENT_UNKNOWN)
1383 if (!actual->symtree->n.sym->attr.pointer)
1386 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1393 /* Returns the storage size of a symbol (formal argument) or
1394 zero if it cannot be determined. */
1396 static unsigned long
1397 get_sym_storage_size (gfc_symbol *sym)
1400 unsigned long strlen, elements;
1402 if (sym->ts.type == BT_CHARACTER)
1404 if (sym->ts.cl && sym->ts.cl->length
1405 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1406 strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1413 if (symbol_rank (sym) == 0)
1417 if (sym->as->type != AS_EXPLICIT)
1419 for (i = 0; i < sym->as->rank; i++)
1421 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1422 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1425 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1426 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1429 return strlen*elements;
1433 /* Returns the storage size of an expression (actual argument) or
1434 zero if it cannot be determined. For an array element, it returns
1435 the remaining size as the element sequence consists of all storage
1436 units of the actual argument up to the end of the array. */
1438 static unsigned long
1439 get_expr_storage_size (gfc_expr *e)
1442 long int strlen, elements;
1448 if (e->ts.type == BT_CHARACTER)
1450 if (e->ts.cl && e->ts.cl->length
1451 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1452 strlen = mpz_get_si (e->ts.cl->length->value.integer);
1453 else if (e->expr_type == EXPR_CONSTANT
1454 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1455 strlen = e->value.character.length;
1460 strlen = 1; /* Length per element. */
1462 if (e->rank == 0 && !e->ref)
1470 for (i = 0; i < e->rank; i++)
1471 elements *= mpz_get_si (e->shape[i]);
1472 return elements*strlen;
1475 for (ref = e->ref; ref; ref = ref->next)
1477 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1478 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1479 && ref->u.ar.as->upper)
1480 for (i = 0; i < ref->u.ar.dimen; i++)
1482 long int start, end, stride;
1485 if (ref->u.ar.stride[i])
1487 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1488 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1493 if (ref->u.ar.start[i])
1495 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1496 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1500 else if (ref->u.ar.as->lower[i]
1501 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1502 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1506 if (ref->u.ar.end[i])
1508 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1509 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1513 else if (ref->u.ar.as->upper[i]
1514 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1515 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1519 elements *= (end - start)/stride + 1L;
1521 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1522 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1523 for (i = 0; i < ref->u.ar.as->rank; i++)
1525 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1526 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1527 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1528 elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
1529 - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
1535 /* TODO: Determine the number of remaining elements in the element
1536 sequence for array element designators.
1537 See also get_array_index in data.c. */
1541 return elements*strlen;
1545 /* Given an expression, check whether it is an array section
1546 which has a vector subscript. If it has, one is returned,
1550 has_vector_subscript (gfc_expr *e)
1555 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1558 for (ref = e->ref; ref; ref = ref->next)
1559 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1560 for (i = 0; i < ref->u.ar.dimen; i++)
1561 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1568 /* Given formal and actual argument lists, see if they are compatible.
1569 If they are compatible, the actual argument list is sorted to
1570 correspond with the formal list, and elements for missing optional
1571 arguments are inserted. If WHERE pointer is nonnull, then we issue
1572 errors when things don't match instead of just returning the status
1576 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1577 int ranks_must_agree, int is_elemental, locus *where)
1579 gfc_actual_arglist **new, *a, *actual, temp;
1580 gfc_formal_arglist *f;
1583 unsigned long actual_size, formal_size;
1587 if (actual == NULL && formal == NULL)
1591 for (f = formal; f; f = f->next)
1594 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1596 for (i = 0; i < n; i++)
1603 for (a = actual; a; a = a->next, f = f->next)
1605 /* Look for keywords but ignore g77 extensions like %VAL. */
1606 if (a->name != NULL && a->name[0] != '%')
1609 for (f = formal; f; f = f->next, i++)
1613 if (strcmp (f->sym->name, a->name) == 0)
1620 gfc_error ("Keyword argument '%s' at %L is not in "
1621 "the procedure", a->name, &a->expr->where);
1628 gfc_error ("Keyword argument '%s' at %L is already associated "
1629 "with another actual argument", a->name,
1638 gfc_error ("More actual than formal arguments in procedure "
1639 "call at %L", where);
1644 if (f->sym == NULL && a->expr == NULL)
1650 gfc_error ("Missing alternate return spec in subroutine call "
1655 if (a->expr == NULL)
1658 gfc_error ("Unexpected alternate return spec in subroutine "
1659 "call at %L", where);
1663 rank_check = where != NULL && !is_elemental && f->sym->as
1664 && (f->sym->as->type == AS_ASSUMED_SHAPE
1665 || f->sym->as->type == AS_DEFERRED);
1667 if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
1668 && a->expr->rank == 0
1669 && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
1671 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1673 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
1674 "with array dummy argument '%s' at %L",
1675 f->sym->name, &a->expr->where);
1678 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1682 else if (!compare_parameter (f->sym, a->expr,
1683 ranks_must_agree || rank_check, is_elemental))
1686 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1687 f->sym->name, &a->expr->where);
1691 if (a->expr->ts.type == BT_CHARACTER
1692 && a->expr->ts.cl && a->expr->ts.cl->length
1693 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1694 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1695 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1697 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
1698 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1699 f->sym->ts.cl->length->value.integer) != 0))
1702 gfc_warning ("Character length mismatch between actual "
1703 "argument and pointer or allocatable dummy "
1704 "argument '%s' at %L",
1705 f->sym->name, &a->expr->where);
1710 actual_size = get_expr_storage_size (a->expr);
1711 formal_size = get_sym_storage_size (f->sym);
1712 if (actual_size != 0 && actual_size < formal_size)
1714 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1715 gfc_warning ("Character length of actual argument shorter "
1716 "than of dummy argument '%s' (%lu/%lu) at %L",
1717 f->sym->name, actual_size, formal_size,
1720 gfc_warning ("Actual argument contains too few "
1721 "elements for dummy argument '%s' (%lu/%lu) at %L",
1722 f->sym->name, actual_size, formal_size,
1727 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1728 provided for a procedure formal argument. */
1729 if (a->expr->ts.type != BT_PROCEDURE
1730 && a->expr->expr_type == EXPR_VARIABLE
1731 && f->sym->attr.flavor == FL_PROCEDURE)
1734 gfc_error ("Expected a procedure for argument '%s' at %L",
1735 f->sym->name, &a->expr->where);
1739 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1740 && a->expr->ts.type == BT_PROCEDURE
1741 && !a->expr->symtree->n.sym->attr.pure)
1744 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1745 f->sym->name, &a->expr->where);
1749 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1750 && a->expr->expr_type == EXPR_VARIABLE
1751 && a->expr->symtree->n.sym->as
1752 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1753 && (a->expr->ref == NULL
1754 || (a->expr->ref->type == REF_ARRAY
1755 && a->expr->ref->u.ar.type == AR_FULL)))
1758 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1759 " array at %L", f->sym->name, where);
1763 if (a->expr->expr_type != EXPR_NULL
1764 && compare_pointer (f->sym, a->expr) == 0)
1767 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1768 f->sym->name, &a->expr->where);
1772 if (a->expr->expr_type != EXPR_NULL
1773 && compare_allocatable (f->sym, a->expr) == 0)
1776 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1777 f->sym->name, &a->expr->where);
1781 /* Check intent = OUT/INOUT for definable actual argument. */
1782 if (a->expr->expr_type != EXPR_VARIABLE
1783 && (f->sym->attr.intent == INTENT_OUT
1784 || f->sym->attr.intent == INTENT_INOUT))
1787 gfc_error ("Actual argument at %L must be definable to "
1788 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1792 if (!compare_parameter_protected(f->sym, a->expr))
1795 gfc_error ("Actual argument at %L is use-associated with "
1796 "PROTECTED attribute and dummy argument '%s' is "
1797 "INTENT = OUT/INOUT",
1798 &a->expr->where,f->sym->name);
1802 if ((f->sym->attr.intent == INTENT_OUT
1803 || f->sym->attr.intent == INTENT_INOUT
1804 || f->sym->attr.volatile_)
1805 && has_vector_subscript (a->expr))
1808 gfc_error ("Array-section actual argument with vector subscripts "
1809 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1810 "or VOLATILE attribute of the dummy argument '%s'",
1811 &a->expr->where, f->sym->name);
1815 /* C1232 (R1221) For an actual argument which is an array section or
1816 an assumed-shape array, the dummy argument shall be an assumed-
1817 shape array, if the dummy argument has the VOLATILE attribute. */
1819 if (f->sym->attr.volatile_
1820 && a->expr->symtree->n.sym->as
1821 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1822 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1825 gfc_error ("Assumed-shape actual argument at %L is "
1826 "incompatible with the non-assumed-shape "
1827 "dummy argument '%s' due to VOLATILE attribute",
1828 &a->expr->where,f->sym->name);
1832 if (f->sym->attr.volatile_
1833 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1834 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1837 gfc_error ("Array-section actual argument at %L is "
1838 "incompatible with the non-assumed-shape "
1839 "dummy argument '%s' due to VOLATILE attribute",
1840 &a->expr->where,f->sym->name);
1844 /* C1233 (R1221) For an actual argument which is a pointer array, the
1845 dummy argument shall be an assumed-shape or pointer array, if the
1846 dummy argument has the VOLATILE attribute. */
1848 if (f->sym->attr.volatile_
1849 && a->expr->symtree->n.sym->attr.pointer
1850 && a->expr->symtree->n.sym->as
1852 && (f->sym->as->type == AS_ASSUMED_SHAPE
1853 || f->sym->attr.pointer)))
1856 gfc_error ("Pointer-array actual argument at %L requires "
1857 "an assumed-shape or pointer-array dummy "
1858 "argument '%s' due to VOLATILE attribute",
1859 &a->expr->where,f->sym->name);
1870 /* Make sure missing actual arguments are optional. */
1872 for (f = formal; f; f = f->next, i++)
1879 gfc_error ("Missing alternate return spec in subroutine call "
1883 if (!f->sym->attr.optional)
1886 gfc_error ("Missing actual argument for argument '%s' at %L",
1887 f->sym->name, where);
1892 /* The argument lists are compatible. We now relink a new actual
1893 argument list with null arguments in the right places. The head
1894 of the list remains the head. */
1895 for (i = 0; i < n; i++)
1897 new[i] = gfc_get_actual_arglist ();
1910 for (i = 0; i < n - 1; i++)
1911 new[i]->next = new[i + 1];
1913 new[i]->next = NULL;
1915 if (*ap == NULL && n > 0)
1918 /* Note the types of omitted optional arguments. */
1919 for (a = actual, f = formal; a; a = a->next, f = f->next)
1920 if (a->expr == NULL && a->label == NULL)
1921 a->missing_arg_type = f->sym->ts.type;
1929 gfc_formal_arglist *f;
1930 gfc_actual_arglist *a;
1934 /* qsort comparison function for argument pairs, with the following
1936 - p->a->expr == NULL
1937 - p->a->expr->expr_type != EXPR_VARIABLE
1938 - growing p->a->expr->symbol. */
1941 pair_cmp (const void *p1, const void *p2)
1943 const gfc_actual_arglist *a1, *a2;
1945 /* *p1 and *p2 are elements of the to-be-sorted array. */
1946 a1 = ((const argpair *) p1)->a;
1947 a2 = ((const argpair *) p2)->a;
1956 if (a1->expr->expr_type != EXPR_VARIABLE)
1958 if (a2->expr->expr_type != EXPR_VARIABLE)
1962 if (a2->expr->expr_type != EXPR_VARIABLE)
1964 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1968 /* Given two expressions from some actual arguments, test whether they
1969 refer to the same expression. The analysis is conservative.
1970 Returning FAILURE will produce no warning. */
1973 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
1975 const gfc_ref *r1, *r2;
1978 || e1->expr_type != EXPR_VARIABLE
1979 || e2->expr_type != EXPR_VARIABLE
1980 || e1->symtree->n.sym != e2->symtree->n.sym)
1983 /* TODO: improve comparison, see expr.c:show_ref(). */
1984 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1986 if (r1->type != r2->type)
1991 if (r1->u.ar.type != r2->u.ar.type)
1993 /* TODO: At the moment, consider only full arrays;
1994 we could do better. */
1995 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2000 if (r1->u.c.component != r2->u.c.component)
2008 gfc_internal_error ("compare_actual_expr(): Bad component code");
2017 /* Given formal and actual argument lists that correspond to one
2018 another, check that identical actual arguments aren't not
2019 associated with some incompatible INTENTs. */
2022 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2024 sym_intent f1_intent, f2_intent;
2025 gfc_formal_arglist *f1;
2026 gfc_actual_arglist *a1;
2032 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2034 if (f1 == NULL && a1 == NULL)
2036 if (f1 == NULL || a1 == NULL)
2037 gfc_internal_error ("check_some_aliasing(): List mismatch");
2042 p = (argpair *) alloca (n * sizeof (argpair));
2044 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2050 qsort (p, n, sizeof (argpair), pair_cmp);
2052 for (i = 0; i < n; i++)
2055 || p[i].a->expr->expr_type != EXPR_VARIABLE
2056 || p[i].a->expr->ts.type == BT_PROCEDURE)
2058 f1_intent = p[i].f->sym->attr.intent;
2059 for (j = i + 1; j < n; j++)
2061 /* Expected order after the sort. */
2062 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2063 gfc_internal_error ("check_some_aliasing(): corrupted data");
2065 /* Are the expression the same? */
2066 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2068 f2_intent = p[j].f->sym->attr.intent;
2069 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2070 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2072 gfc_warning ("Same actual argument associated with INTENT(%s) "
2073 "argument '%s' and INTENT(%s) argument '%s' at %L",
2074 gfc_intent_string (f1_intent), p[i].f->sym->name,
2075 gfc_intent_string (f2_intent), p[j].f->sym->name,
2076 &p[i].a->expr->where);
2086 /* Given a symbol of a formal argument list and an expression,
2087 return nonzero if their intents are compatible, zero otherwise. */
2090 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2092 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2095 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2098 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2105 /* Given formal and actual argument lists that correspond to one
2106 another, check that they are compatible in the sense that intents
2107 are not mismatched. */
2110 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2112 sym_intent f_intent;
2114 for (;; f = f->next, a = a->next)
2116 if (f == NULL && a == NULL)
2118 if (f == NULL || a == NULL)
2119 gfc_internal_error ("check_intents(): List mismatch");
2121 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2124 f_intent = f->sym->attr.intent;
2126 if (!compare_parameter_intent(f->sym, a->expr))
2128 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2129 "specifies INTENT(%s)", &a->expr->where,
2130 gfc_intent_string (f_intent));
2134 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2136 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2138 gfc_error ("Procedure argument at %L is local to a PURE "
2139 "procedure and is passed to an INTENT(%s) argument",
2140 &a->expr->where, gfc_intent_string (f_intent));
2144 if (a->expr->symtree->n.sym->attr.pointer)
2146 gfc_error ("Procedure argument at %L is local to a PURE "
2147 "procedure and has the POINTER attribute",
2158 /* Check how a procedure is used against its interface. If all goes
2159 well, the actual argument list will also end up being properly
2163 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2166 /* Warn about calls with an implicit interface. */
2167 if (gfc_option.warn_implicit_interface
2168 && sym->attr.if_source == IFSRC_UNKNOWN)
2169 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2172 if (sym->attr.if_source == IFSRC_UNKNOWN
2173 || !compare_actual_formal (ap, sym->formal, 0,
2174 sym->attr.elemental, where))
2177 check_intents (sym->formal, *ap);
2178 if (gfc_option.warn_aliasing)
2179 check_some_aliasing (sym->formal, *ap);
2183 /* Given an interface pointer and an actual argument list, search for
2184 a formal argument list that matches the actual. If found, returns
2185 a pointer to the symbol of the correct interface. Returns NULL if
2189 gfc_search_interface (gfc_interface *intr, int sub_flag,
2190 gfc_actual_arglist **ap)
2194 for (; intr; intr = intr->next)
2196 if (sub_flag && intr->sym->attr.function)
2198 if (!sub_flag && intr->sym->attr.subroutine)
2201 r = !intr->sym->attr.elemental;
2203 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
2205 check_intents (intr->sym->formal, *ap);
2206 if (gfc_option.warn_aliasing)
2207 check_some_aliasing (intr->sym->formal, *ap);
2216 /* Do a brute force recursive search for a symbol. */
2218 static gfc_symtree *
2219 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2223 if (root->n.sym == sym)
2228 st = find_symtree0 (root->left, sym);
2229 if (root->right && ! st)
2230 st = find_symtree0 (root->right, sym);
2235 /* Find a symtree for a symbol. */
2237 static gfc_symtree *
2238 find_sym_in_symtree (gfc_symbol *sym)
2243 /* First try to find it by name. */
2244 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2245 if (st && st->n.sym == sym)
2248 /* If it's been renamed, resort to a brute-force search. */
2249 /* TODO: avoid having to do this search. If the symbol doesn't exist
2250 in the symtree for the current namespace, it should probably be added. */
2251 for (ns = gfc_current_ns; ns; ns = ns->parent)
2253 st = find_symtree0 (ns->sym_root, sym);
2257 gfc_internal_error ("Unable to find symbol %s", sym->name);
2262 /* This subroutine is called when an expression is being resolved.
2263 The expression node in question is either a user defined operator
2264 or an intrinsic operator with arguments that aren't compatible
2265 with the operator. This subroutine builds an actual argument list
2266 corresponding to the operands, then searches for a compatible
2267 interface. If one is found, the expression node is replaced with
2268 the appropriate function call. */
2271 gfc_extend_expr (gfc_expr *e)
2273 gfc_actual_arglist *actual;
2281 actual = gfc_get_actual_arglist ();
2282 actual->expr = e->value.op.op1;
2284 if (e->value.op.op2 != NULL)
2286 actual->next = gfc_get_actual_arglist ();
2287 actual->next->expr = e->value.op.op2;
2290 i = fold_unary (e->value.op.operator);
2292 if (i == INTRINSIC_USER)
2294 for (ns = gfc_current_ns; ns; ns = ns->parent)
2296 uop = gfc_find_uop (e->value.op.uop->name, ns);
2300 sym = gfc_search_interface (uop->operator, 0, &actual);
2307 for (ns = gfc_current_ns; ns; ns = ns->parent)
2309 /* Due to the distinction between '==' and '.eq.' and friends, one has
2310 to check if either is defined. */
2314 case INTRINSIC_EQ_OS:
2315 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
2317 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
2321 case INTRINSIC_NE_OS:
2322 sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
2324 sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
2328 case INTRINSIC_GT_OS:
2329 sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
2331 sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
2335 case INTRINSIC_GE_OS:
2336 sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
2338 sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
2342 case INTRINSIC_LT_OS:
2343 sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
2345 sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
2349 case INTRINSIC_LE_OS:
2350 sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
2352 sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
2356 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2366 /* Don't use gfc_free_actual_arglist(). */
2367 if (actual->next != NULL)
2368 gfc_free (actual->next);
2374 /* Change the expression node to a function call. */
2375 e->expr_type = EXPR_FUNCTION;
2376 e->symtree = find_sym_in_symtree (sym);
2377 e->value.function.actual = actual;
2378 e->value.function.esym = NULL;
2379 e->value.function.isym = NULL;
2380 e->value.function.name = NULL;
2382 if (gfc_pure (NULL) && !gfc_pure (sym))
2384 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2385 "be PURE", sym->name, &e->where);
2389 if (gfc_resolve_expr (e) == FAILURE)
2396 /* Tries to replace an assignment code node with a subroutine call to
2397 the subroutine associated with the assignment operator. Return
2398 SUCCESS if the node was replaced. On FAILURE, no error is
2402 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2404 gfc_actual_arglist *actual;
2405 gfc_expr *lhs, *rhs;
2411 /* Don't allow an intrinsic assignment to be replaced. */
2412 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2413 && (lhs->ts.type == rhs->ts.type
2414 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2417 actual = gfc_get_actual_arglist ();
2420 actual->next = gfc_get_actual_arglist ();
2421 actual->next->expr = rhs;
2425 for (; ns; ns = ns->parent)
2427 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2434 gfc_free (actual->next);
2439 /* Replace the assignment with the call. */
2440 c->op = EXEC_ASSIGN_CALL;
2441 c->symtree = find_sym_in_symtree (sym);
2444 c->ext.actual = actual;
2450 /* Make sure that the interface just parsed is not already present in
2451 the given interface list. Ambiguity isn't checked yet since module
2452 procedures can be present without interfaces. */
2455 check_new_interface (gfc_interface *base, gfc_symbol *new)
2459 for (ip = base; ip; ip = ip->next)
2463 gfc_error ("Entity '%s' at %C is already present in the interface",
2473 /* Add a symbol to the current interface. */
2476 gfc_add_interface (gfc_symbol *new)
2478 gfc_interface **head, *intr;
2482 switch (current_interface.type)
2484 case INTERFACE_NAMELESS:
2485 case INTERFACE_ABSTRACT:
2488 case INTERFACE_INTRINSIC_OP:
2489 for (ns = current_interface.ns; ns; ns = ns->parent)
2490 switch (current_interface.op)
2493 case INTRINSIC_EQ_OS:
2494 if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
2495 check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
2500 case INTRINSIC_NE_OS:
2501 if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
2502 check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
2507 case INTRINSIC_GT_OS:
2508 if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
2509 check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
2514 case INTRINSIC_GE_OS:
2515 if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
2516 check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
2521 case INTRINSIC_LT_OS:
2522 if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
2523 check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
2528 case INTRINSIC_LE_OS:
2529 if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
2530 check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
2535 if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
2539 head = ¤t_interface.ns->operator[current_interface.op];
2542 case INTERFACE_GENERIC:
2543 for (ns = current_interface.ns; ns; ns = ns->parent)
2545 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2549 if (check_new_interface (sym->generic, new) == FAILURE)
2553 head = ¤t_interface.sym->generic;
2556 case INTERFACE_USER_OP:
2557 if (check_new_interface (current_interface.uop->operator, new)
2561 head = ¤t_interface.uop->operator;
2565 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2568 intr = gfc_get_interface ();
2570 intr->where = gfc_current_locus;
2579 /* Gets rid of a formal argument list. We do not free symbols.
2580 Symbols are freed when a namespace is freed. */
2583 gfc_free_formal_arglist (gfc_formal_arglist *p)
2585 gfc_formal_arglist *q;