1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* Deal with interfaces. An explicit interface is represented as a
25 singly linked list of formal argument structures attached to the
26 relevant symbols. For an implicit interface, the arguments don't
27 point to symbols. Explicit interfaces point to namespaces that
28 contain the symbols within that interface.
30 Implicit interfaces are linked together in a singly linked list
31 along the next_if member of symbol nodes. Since a particular
32 symbol can only have a single explicit interface, the symbol cannot
33 be part of multiple lists and a single next-member suffices.
35 This is not the case for general classes, though. An operator
36 definition is independent of just about all other uses and has it's
40 Nameless interfaces create symbols with explicit interfaces within
41 the current namespace. They are otherwise unlinked.
44 The generic name points to a linked list of symbols. Each symbol
45 has an explicit interface. Each explicit interface has its own
46 namespace containing the arguments. Module procedures are symbols in
47 which the interface is added later when the module procedure is parsed.
50 User-defined operators are stored in a their own set of symtrees
51 separate from regular symbols. The symtrees point to gfc_user_op
52 structures which in turn head up a list of relevant interfaces.
54 Extended intrinsics and assignment:
55 The head of these interface lists are stored in the containing namespace.
58 An implicit interface is represented as a singly linked list of
59 formal argument list structures that don't point to any symbol
60 nodes -- they just contain types.
63 When a subprogram is defined, the program unit's name points to an
64 interface as usual, but the link to the namespace is NULL and the
65 formal argument list points to symbols within the same namespace as
66 the program unit name. */
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface * intr)
88 for (; intr; intr = next)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary (gfc_intrinsic_op operator)
105 case INTRINSIC_UPLUS:
106 operator = INTRINSIC_PLUS;
108 case INTRINSIC_UMINUS:
109 operator = INTRINSIC_MINUS;
119 /* Match a generic specification. Depending on which type of
120 interface is found, the 'name' or 'operator' pointers may be set.
121 This subroutine doesn't return MATCH_NO. */
124 gfc_match_generic_spec (interface_type * type,
126 gfc_intrinsic_op *operator)
128 char buffer[GFC_MAX_SYMBOL_LEN + 1];
132 if (gfc_match (" assignment ( = )") == MATCH_YES)
134 *type = INTERFACE_INTRINSIC_OP;
135 *operator = INTRINSIC_ASSIGN;
139 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
141 *type = INTERFACE_INTRINSIC_OP;
142 *operator = fold_unary (i);
146 if (gfc_match (" operator ( ") == MATCH_YES)
148 m = gfc_match_defined_op_name (buffer, 1);
154 m = gfc_match_char (')');
160 strcpy (name, buffer);
161 *type = INTERFACE_USER_OP;
165 if (gfc_match_name (buffer) == MATCH_YES)
167 strcpy (name, buffer);
168 *type = INTERFACE_GENERIC;
172 *type = INTERFACE_NAMELESS;
176 gfc_error ("Syntax error in generic specification at %C");
181 /* Match one of the five forms of an interface statement. */
184 gfc_match_interface (void)
186 char name[GFC_MAX_SYMBOL_LEN + 1];
189 gfc_intrinsic_op operator;
192 m = gfc_match_space ();
194 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
198 /* If we're not looking at the end of the statement now, or if this
199 is not a nameless interface but we did not see a space, punt. */
200 if (gfc_match_eos () != MATCH_YES
201 || (type != INTERFACE_NAMELESS
205 ("Syntax error: Trailing garbage in INTERFACE statement at %C");
209 current_interface.type = type;
213 case INTERFACE_GENERIC:
214 if (gfc_get_symbol (name, NULL, &sym))
217 if (!sym->attr.generic
218 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
223 gfc_error ("Dummy procedure '%s' at %C cannot have a "
224 "generic interface", sym->name);
228 current_interface.sym = gfc_new_block = sym;
231 case INTERFACE_USER_OP:
232 current_interface.uop = gfc_get_uop (name);
235 case INTERFACE_INTRINSIC_OP:
236 current_interface.op = operator;
239 case INTERFACE_NAMELESS:
247 /* Match the different sort of generic-specs that can be present after
248 the END INTERFACE itself. */
251 gfc_match_end_interface (void)
253 char name[GFC_MAX_SYMBOL_LEN + 1];
255 gfc_intrinsic_op operator;
258 m = gfc_match_space ();
260 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
263 /* If we're not looking at the end of the statement now, or if this
264 is not a nameless interface but we did not see a space, punt. */
265 if (gfc_match_eos () != MATCH_YES
266 || (type != INTERFACE_NAMELESS
270 ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
276 switch (current_interface.type)
278 case INTERFACE_NAMELESS:
279 if (type != current_interface.type)
281 gfc_error ("Expected a nameless interface at %C");
287 case INTERFACE_INTRINSIC_OP:
288 if (type != current_interface.type || operator != current_interface.op)
291 if (current_interface.op == INTRINSIC_ASSIGN)
292 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
294 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
295 gfc_op2string (current_interface.op));
302 case INTERFACE_USER_OP:
303 /* Comparing the symbol node names is OK because only use-associated
304 symbols can be renamed. */
305 if (type != current_interface.type
306 || strcmp (current_interface.uop->name, name) != 0)
308 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
309 current_interface.uop->name);
315 case INTERFACE_GENERIC:
316 if (type != current_interface.type
317 || strcmp (current_interface.sym->name, name) != 0)
319 gfc_error ("Expecting 'END INTERFACE %s' at %C",
320 current_interface.sym->name);
331 /* Compare two derived types using the criteria in 4.4.2 of the standard,
332 recursing through gfc_compare_types for the components. */
335 gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
337 gfc_component *dt1, *dt2;
339 /* Special case for comparing derived types across namespaces. If the
340 true names and module names are the same and the module name is
341 nonnull, then they are equal. */
342 if (strcmp (derived1->name, derived2->name) == 0
343 && derived1 != NULL && derived2 != NULL
344 && derived1->module != NULL && derived2->module != NULL
345 && strcmp (derived1->module, derived2->module) == 0)
348 /* Compare type via the rules of the standard. Both types must have
349 the SEQUENCE attribute to be equal. */
351 if (strcmp (derived1->name, derived2->name))
354 if (derived1->component_access == ACCESS_PRIVATE
355 || derived2->component_access == ACCESS_PRIVATE)
358 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
361 dt1 = derived1->components;
362 dt2 = derived2->components;
364 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
365 simple test can speed things up. Otherwise, lots of things have to
369 if (strcmp (dt1->name, dt2->name) != 0)
372 if (dt1->pointer != dt2->pointer)
375 if (dt1->dimension != dt2->dimension)
378 if (dt1->allocatable != dt2->allocatable)
381 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
384 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
390 if (dt1 == NULL && dt2 == NULL)
392 if (dt1 == NULL || dt2 == NULL)
399 /* Compare two typespecs, recursively if necessary. */
402 gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
405 if (ts1->type != ts2->type)
407 if (ts1->type != BT_DERIVED)
408 return (ts1->kind == ts2->kind);
410 /* Compare derived types. */
411 if (ts1->derived == ts2->derived)
414 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
418 /* Given two symbols that are formal arguments, compare their ranks
419 and types. Returns nonzero if they have the same rank and type,
423 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
427 r1 = (s1->as != NULL) ? s1->as->rank : 0;
428 r2 = (s2->as != NULL) ? s2->as->rank : 0;
431 return 0; /* Ranks differ */
433 return gfc_compare_types (&s1->ts, &s2->ts);
437 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
439 /* Given two symbols that are formal arguments, compare their types
440 and rank and their formal interfaces if they are both dummy
441 procedures. Returns nonzero if the same, zero if different. */
444 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
446 if (s1 == NULL || s2 == NULL)
447 return s1 == s2 ? 1 : 0;
449 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
450 return compare_type_rank (s1, s2);
452 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
455 /* At this point, both symbols are procedures. */
456 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
457 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
460 if (s1->attr.function != s2->attr.function
461 || s1->attr.subroutine != s2->attr.subroutine)
464 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
467 /* Originally, gfortran recursed here to check the interfaces of passed
468 procedures. This is explicitly not required by the standard. */
473 /* Given a formal argument list and a keyword name, search the list
474 for that keyword. Returns the correct symbol node if found, NULL
478 find_keyword_arg (const char *name, gfc_formal_arglist * f)
481 for (; f; f = f->next)
482 if (strcmp (f->sym->name, name) == 0)
489 /******** Interface checking subroutines **********/
492 /* Given an operator interface and the operator, make sure that all
493 interfaces for that operator are legal. */
496 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
498 gfc_formal_arglist *formal;
508 t1 = t2 = BT_UNKNOWN;
509 i1 = i2 = INTENT_UNKNOWN;
511 for (formal = intr->sym->formal; formal; formal = formal->next)
516 gfc_error ("Alternate return cannot appear in operator "
517 "interface at %L", &intr->where);
523 i1 = sym->attr.intent;
528 i2 = sym->attr.intent;
533 if (args == 0 || args > 2)
538 if (operator == INTRINSIC_ASSIGN)
540 if (!sym->attr.subroutine)
543 ("Assignment operator interface at %L must be a SUBROUTINE",
550 ("Assignment operator interface at %L must have two arguments",
554 if (sym->formal->sym->ts.type != BT_DERIVED
555 && sym->formal->next->sym->ts.type != BT_DERIVED
556 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
557 || (gfc_numeric_ts (&sym->formal->sym->ts)
558 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
561 ("Assignment operator interface at %L must not redefine "
562 "an INTRINSIC type assignment", &intr->where);
568 if (!sym->attr.function)
570 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
578 case INTRINSIC_PLUS: /* Numeric unary or binary */
579 case INTRINSIC_MINUS:
583 || t1 == BT_COMPLEX))
587 && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
588 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
593 case INTRINSIC_POWER: /* Binary numeric */
594 case INTRINSIC_TIMES:
595 case INTRINSIC_DIVIDE:
602 if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
603 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
608 case INTRINSIC_GE: /* Binary numeric operators that do not support */
609 case INTRINSIC_LE: /* complex numbers */
615 if ((t1 == BT_INTEGER || t1 == BT_REAL)
616 && (t2 == BT_INTEGER || t2 == BT_REAL))
621 case INTRINSIC_OR: /* Binary logical */
627 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
631 case INTRINSIC_NOT: /* Unary logical */
634 if (t1 == BT_LOGICAL)
638 case INTRINSIC_CONCAT: /* Binary string */
641 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
645 case INTRINSIC_ASSIGN: /* Class by itself */
650 gfc_internal_error ("check_operator_interface(): Bad operator");
653 /* Check intents on operator interfaces. */
654 if (operator == INTRINSIC_ASSIGN)
656 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
657 gfc_error ("First argument of defined assignment at %L must be "
658 "INTENT(IN) or INTENT(INOUT)", &intr->where);
661 gfc_error ("Second argument of defined assignment at %L must be "
662 "INTENT(IN)", &intr->where);
667 gfc_error ("First argument of operator interface at %L must be "
668 "INTENT(IN)", &intr->where);
670 if (args == 2 && i2 != INTENT_IN)
671 gfc_error ("Second argument of operator interface at %L must be "
672 "INTENT(IN)", &intr->where);
678 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
683 gfc_error ("Operator interface at %L has the wrong number of arguments",
689 /* Given a pair of formal argument lists, we see if the two lists can
690 be distinguished by counting the number of nonoptional arguments of
691 a given type/rank in f1 and seeing if there are less then that
692 number of those arguments in f2 (including optional arguments).
693 Since this test is asymmetric, it has to be called twice to make it
694 symmetric. Returns nonzero if the argument lists are incompatible
695 by this test. This subroutine implements rule 1 of section
699 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
701 int rc, ac1, ac2, i, j, k, n1;
702 gfc_formal_arglist *f;
715 for (f = f1; f; f = f->next)
718 /* Build an array of integers that gives the same integer to
719 arguments of the same type/rank. */
720 arg = gfc_getmem (n1 * sizeof (arginfo));
723 for (i = 0; i < n1; i++, f = f->next)
731 for (i = 0; i < n1; i++)
733 if (arg[i].flag != -1)
736 if (arg[i].sym && arg[i].sym->attr.optional)
737 continue; /* Skip optional arguments */
741 /* Find other nonoptional arguments of the same type/rank. */
742 for (j = i + 1; j < n1; j++)
743 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
744 && compare_type_rank_if (arg[i].sym, arg[j].sym))
750 /* Now loop over each distinct type found in f1. */
754 for (i = 0; i < n1; i++)
756 if (arg[i].flag != k)
760 for (j = i + 1; j < n1; j++)
761 if (arg[j].flag == k)
764 /* Count the number of arguments in f2 with that type, including
765 those that are optional. */
768 for (f = f2; f; f = f->next)
769 if (compare_type_rank_if (arg[i].sym, f->sym))
787 /* Perform the abbreviated correspondence test for operators. The
788 arguments cannot be optional and are always ordered correctly,
789 which makes this test much easier than that for generic tests.
791 This subroutine is also used when comparing a formal and actual
792 argument list when an actual parameter is a dummy procedure. At
793 that point, two formal interfaces must be compared for equality
794 which is what happens here. */
797 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
801 if (f1 == NULL && f2 == NULL)
803 if (f1 == NULL || f2 == NULL)
806 if (!compare_type_rank (f1->sym, f2->sym))
817 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
818 Returns zero if no argument is found that satisfies rule 2, nonzero
821 This test is also not symmetric in f1 and f2 and must be called
822 twice. This test finds problems caused by sorting the actual
823 argument list with keywords. For example:
827 INTEGER :: A ; REAL :: B
831 INTEGER :: A ; REAL :: B
835 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
838 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
841 gfc_formal_arglist *f2_save, *g;
848 if (f1->sym->attr.optional)
851 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
854 /* Now search for a disambiguating keyword argument starting at
855 the current non-match. */
856 for (g = f1; g; g = g->next)
858 if (g->sym->attr.optional)
861 sym = find_keyword_arg (g->sym->name, f2_save);
862 if (sym == NULL || !compare_type_rank (g->sym, sym))
876 /* 'Compare' two formal interfaces associated with a pair of symbols.
877 We return nonzero if there exists an actual argument list that
878 would be ambiguous between the two interfaces, zero otherwise. */
881 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
883 gfc_formal_arglist *f1, *f2;
885 if (s1->attr.function != s2->attr.function
886 && s1->attr.subroutine != s2->attr.subroutine)
887 return 0; /* disagreement between function/subroutine */
892 if (f1 == NULL && f2 == NULL)
893 return 1; /* Special case */
895 if (count_types_test (f1, f2))
897 if (count_types_test (f2, f1))
902 if (generic_correspondence (f1, f2))
904 if (generic_correspondence (f2, f1))
909 if (operator_correspondence (f1, f2))
917 /* Given a pointer to an interface pointer, remove duplicate
918 interfaces and make sure that all symbols are either functions or
919 subroutines. Returns nonzero if something goes wrong. */
922 check_interface0 (gfc_interface * p, const char *interface_name)
924 gfc_interface *psave, *q, *qlast;
927 /* Make sure all symbols in the interface have been defined as
928 functions or subroutines. */
929 for (; p; p = p->next)
930 if (!p->sym->attr.function && !p->sym->attr.subroutine)
932 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
933 "subroutine", p->sym->name, interface_name,
934 &p->sym->declared_at);
939 /* Remove duplicate interfaces in this interface list. */
940 for (; p; p = p->next)
944 for (q = p->next; q;)
946 if (p->sym != q->sym)
954 /* Duplicate interface */
955 qlast->next = q->next;
966 /* Check lists of interfaces to make sure that no two interfaces are
967 ambiguous. Duplicate interfaces (from the same symbol) are OK
971 check_interface1 (gfc_interface * p, gfc_interface * q0,
972 int generic_flag, const char *interface_name,
976 for (; p; p = p->next)
977 for (q = q0; q; q = q->next)
979 if (p->sym == q->sym)
980 continue; /* Duplicates OK here */
982 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
985 if (compare_interfaces (p->sym, q->sym, generic_flag))
989 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
990 p->sym->name, q->sym->name, interface_name,
994 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
995 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
996 p->sym->name, q->sym->name, interface_name,
1005 /* Check the generic and operator interfaces of symbols to make sure
1006 that none of the interfaces conflict. The check has to be done
1007 after all of the symbols are actually loaded. */
1010 check_sym_interfaces (gfc_symbol * sym)
1012 char interface_name[100];
1016 if (sym->ns != gfc_current_ns)
1019 if (sym->attr.if_source == IFSRC_IFBODY
1020 && sym->attr.flavor == FL_PROCEDURE
1021 && !sym->attr.mod_proc)
1022 resolve_global_procedure (sym, &sym->declared_at, sym->attr.subroutine);
1024 if (sym->generic != NULL)
1026 sprintf (interface_name, "generic interface '%s'", sym->name);
1027 if (check_interface0 (sym->generic, interface_name))
1030 for (p = sym->generic; p; p = p->next)
1032 if (!p->sym->attr.use_assoc
1033 && p->sym->attr.mod_proc
1034 && p->sym->attr.if_source != IFSRC_DECL)
1036 gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1037 "from a module", p->sym->name, &p->where);
1042 /* Originally, this test was applied to host interfaces too;
1043 this is incorrect since host associated symbols, from any
1044 source, cannot be ambiguous with local symbols. */
1045 k = sym->attr.referenced || !sym->attr.use_assoc;
1046 if (check_interface1 (sym->generic, sym->generic, 1,
1048 sym->attr.ambiguous_interfaces = 1;
1054 check_uop_interfaces (gfc_user_op * uop)
1056 char interface_name[100];
1060 sprintf (interface_name, "operator interface '%s'", uop->name);
1061 if (check_interface0 (uop->operator, interface_name))
1064 for (ns = gfc_current_ns; ns; ns = ns->parent)
1066 uop2 = gfc_find_uop (uop->name, ns);
1070 check_interface1 (uop->operator, uop2->operator, 0,
1071 interface_name, true);
1076 /* For the namespace, check generic, user operator and intrinsic
1077 operator interfaces for consistency and to remove duplicate
1078 interfaces. We traverse the whole namespace, counting on the fact
1079 that most symbols will not have generic or operator interfaces. */
1082 gfc_check_interfaces (gfc_namespace * ns)
1084 gfc_namespace *old_ns, *ns2;
1085 char interface_name[100];
1088 old_ns = gfc_current_ns;
1089 gfc_current_ns = ns;
1091 gfc_traverse_ns (ns, check_sym_interfaces);
1093 gfc_traverse_user_op (ns, check_uop_interfaces);
1095 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1097 if (i == INTRINSIC_USER)
1100 if (i == INTRINSIC_ASSIGN)
1101 strcpy (interface_name, "intrinsic assignment operator");
1103 sprintf (interface_name, "intrinsic '%s' operator",
1106 if (check_interface0 (ns->operator[i], interface_name))
1109 check_operator_interface (ns->operator[i], i);
1111 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1112 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1113 interface_name, true))
1117 gfc_current_ns = old_ns;
1122 symbol_rank (gfc_symbol * sym)
1125 return (sym->as == NULL) ? 0 : sym->as->rank;
1129 /* Given a symbol of a formal argument list and an expression, if the
1130 formal argument is allocatable, check that the actual argument is
1131 allocatable. Returns nonzero if compatible, zero if not compatible. */
1134 compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
1136 symbol_attribute attr;
1138 if (formal->attr.allocatable)
1140 attr = gfc_expr_attr (actual);
1141 if (!attr.allocatable)
1149 /* Given a symbol of a formal argument list and an expression, if the
1150 formal argument is a pointer, see if the actual argument is a
1151 pointer. Returns nonzero if compatible, zero if not compatible. */
1154 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1156 symbol_attribute attr;
1158 if (formal->attr.pointer)
1160 attr = gfc_expr_attr (actual);
1169 /* Given a symbol of a formal argument list and an expression, see if
1170 the two are compatible as arguments. Returns nonzero if
1171 compatible, zero if not compatible. */
1174 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1175 int ranks_must_agree, int is_elemental)
1179 if (actual->ts.type == BT_PROCEDURE)
1181 if (formal->attr.flavor != FL_PROCEDURE)
1184 if (formal->attr.function
1185 && !compare_type_rank (formal, actual->symtree->n.sym))
1188 if (formal->attr.if_source == IFSRC_UNKNOWN
1189 || actual->symtree->n.sym->attr.external)
1190 return 1; /* Assume match */
1192 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1195 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1196 && !gfc_compare_types (&formal->ts, &actual->ts))
1199 if (symbol_rank (formal) == actual->rank)
1202 /* At this point the ranks didn't agree. */
1203 if (ranks_must_agree || formal->attr.pointer)
1206 if (actual->rank != 0)
1207 return is_elemental || formal->attr.dimension;
1209 /* At this point, we are considering a scalar passed to an array.
1210 This is legal if the scalar is an array element of the right sort. */
1211 if (formal->as->type == AS_ASSUMED_SHAPE)
1214 for (ref = actual->ref; ref; ref = ref->next)
1215 if (ref->type == REF_SUBSTRING)
1218 for (ref = actual->ref; ref; ref = ref->next)
1219 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1223 return 0; /* Not an array element */
1229 /* Given a symbol of a formal argument list and an expression, see if
1230 the two are compatible as arguments. Returns nonzero if
1231 compatible, zero if not compatible. */
1234 compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
1236 if (actual->expr_type != EXPR_VARIABLE)
1239 if (!actual->symtree->n.sym->attr.protected)
1242 if (!actual->symtree->n.sym->attr.use_assoc)
1245 if (formal->attr.intent == INTENT_IN
1246 || formal->attr.intent == INTENT_UNKNOWN)
1249 if (!actual->symtree->n.sym->attr.pointer)
1252 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1259 /* Given formal and actual argument lists, see if they are compatible.
1260 If they are compatible, the actual argument list is sorted to
1261 correspond with the formal list, and elements for missing optional
1262 arguments are inserted. If WHERE pointer is nonnull, then we issue
1263 errors when things don't match instead of just returning the status
1267 compare_actual_formal (gfc_actual_arglist ** ap,
1268 gfc_formal_arglist * formal,
1269 int ranks_must_agree, int is_elemental, locus * where)
1271 gfc_actual_arglist **new, *a, *actual, temp;
1272 gfc_formal_arglist *f;
1278 if (actual == NULL && formal == NULL)
1282 for (f = formal; f; f = f->next)
1285 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1287 for (i = 0; i < n; i++)
1294 for (a = actual; a; a = a->next, f = f->next)
1296 if (a->name != NULL)
1299 for (f = formal; f; f = f->next, i++)
1303 if (strcmp (f->sym->name, a->name) == 0)
1311 ("Keyword argument '%s' at %L is not in the procedure",
1312 a->name, &a->expr->where);
1320 ("Keyword argument '%s' at %L is already associated "
1321 "with another actual argument", a->name, &a->expr->where);
1330 ("More actual than formal arguments in procedure call at %L",
1336 if (f->sym == NULL && a->expr == NULL)
1343 ("Missing alternate return spec in subroutine call at %L",
1348 if (a->expr == NULL)
1352 ("Unexpected alternate return spec in subroutine call at %L",
1357 rank_check = where != NULL
1360 && (f->sym->as->type == AS_ASSUMED_SHAPE
1361 || f->sym->as->type == AS_DEFERRED);
1363 if (!compare_parameter
1364 (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
1367 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1368 f->sym->name, &a->expr->where);
1372 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1373 provided for a procedure formal argument. */
1374 if (a->expr->ts.type != BT_PROCEDURE
1375 && a->expr->expr_type == EXPR_VARIABLE
1376 && f->sym->attr.flavor == FL_PROCEDURE)
1379 gfc_error ("Expected a procedure for argument '%s' at %L",
1380 f->sym->name, &a->expr->where);
1384 if (f->sym->attr.flavor == FL_PROCEDURE
1385 && f->sym->attr.pure
1386 && a->expr->ts.type == BT_PROCEDURE
1387 && !a->expr->symtree->n.sym->attr.pure)
1390 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1391 f->sym->name, &a->expr->where);
1396 && f->sym->as->type == AS_ASSUMED_SHAPE
1397 && a->expr->expr_type == EXPR_VARIABLE
1398 && a->expr->symtree->n.sym->as
1399 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1400 && (a->expr->ref == NULL
1401 || (a->expr->ref->type == REF_ARRAY
1402 && a->expr->ref->u.ar.type == AR_FULL)))
1405 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1406 " array at %L", f->sym->name, where);
1410 if (a->expr->expr_type != EXPR_NULL
1411 && compare_pointer (f->sym, a->expr) == 0)
1414 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1415 f->sym->name, &a->expr->where);
1419 if (a->expr->expr_type != EXPR_NULL
1420 && compare_allocatable (f->sym, a->expr) == 0)
1423 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1424 f->sym->name, &a->expr->where);
1428 /* Check intent = OUT/INOUT for definable actual argument. */
1429 if (a->expr->expr_type != EXPR_VARIABLE
1430 && (f->sym->attr.intent == INTENT_OUT
1431 || f->sym->attr.intent == INTENT_INOUT))
1434 gfc_error ("Actual argument at %L must be definable to "
1435 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1439 if (!compare_parameter_protected(f->sym, a->expr))
1442 gfc_error ("Actual argument at %L is use-associated with "
1443 "PROTECTED attribute and dummy argument '%s' is "
1444 "INTENT = OUT/INOUT",
1445 &a->expr->where,f->sym->name);
1456 /* Make sure missing actual arguments are optional. */
1458 for (f = formal; f; f = f->next, i++)
1462 if (!f->sym->attr.optional)
1465 gfc_error ("Missing actual argument for argument '%s' at %L",
1466 f->sym->name, where);
1471 /* The argument lists are compatible. We now relink a new actual
1472 argument list with null arguments in the right places. The head
1473 of the list remains the head. */
1474 for (i = 0; i < n; i++)
1476 new[i] = gfc_get_actual_arglist ();
1489 for (i = 0; i < n - 1; i++)
1490 new[i]->next = new[i + 1];
1492 new[i]->next = NULL;
1494 if (*ap == NULL && n > 0)
1497 /* Note the types of omitted optional arguments. */
1498 for (a = actual, f = formal; a; a = a->next, f = f->next)
1499 if (a->expr == NULL && a->label == NULL)
1500 a->missing_arg_type = f->sym->ts.type;
1508 gfc_formal_arglist *f;
1509 gfc_actual_arglist *a;
1513 /* qsort comparison function for argument pairs, with the following
1515 - p->a->expr == NULL
1516 - p->a->expr->expr_type != EXPR_VARIABLE
1517 - growing p->a->expr->symbol. */
1520 pair_cmp (const void *p1, const void *p2)
1522 const gfc_actual_arglist *a1, *a2;
1524 /* *p1 and *p2 are elements of the to-be-sorted array. */
1525 a1 = ((const argpair *) p1)->a;
1526 a2 = ((const argpair *) p2)->a;
1535 if (a1->expr->expr_type != EXPR_VARIABLE)
1537 if (a2->expr->expr_type != EXPR_VARIABLE)
1541 if (a2->expr->expr_type != EXPR_VARIABLE)
1543 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1547 /* Given two expressions from some actual arguments, test whether they
1548 refer to the same expression. The analysis is conservative.
1549 Returning FAILURE will produce no warning. */
1552 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1554 const gfc_ref *r1, *r2;
1557 || e1->expr_type != EXPR_VARIABLE
1558 || e2->expr_type != EXPR_VARIABLE
1559 || e1->symtree->n.sym != e2->symtree->n.sym)
1562 /* TODO: improve comparison, see expr.c:show_ref(). */
1563 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1565 if (r1->type != r2->type)
1570 if (r1->u.ar.type != r2->u.ar.type)
1572 /* TODO: At the moment, consider only full arrays;
1573 we could do better. */
1574 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1579 if (r1->u.c.component != r2->u.c.component)
1587 gfc_internal_error ("compare_actual_expr(): Bad component code");
1595 /* Given formal and actual argument lists that correspond to one
1596 another, check that identical actual arguments aren't not
1597 associated with some incompatible INTENTs. */
1600 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1602 sym_intent f1_intent, f2_intent;
1603 gfc_formal_arglist *f1;
1604 gfc_actual_arglist *a1;
1610 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1612 if (f1 == NULL && a1 == NULL)
1614 if (f1 == NULL || a1 == NULL)
1615 gfc_internal_error ("check_some_aliasing(): List mismatch");
1620 p = (argpair *) alloca (n * sizeof (argpair));
1622 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1628 qsort (p, n, sizeof (argpair), pair_cmp);
1630 for (i = 0; i < n; i++)
1633 || p[i].a->expr->expr_type != EXPR_VARIABLE
1634 || p[i].a->expr->ts.type == BT_PROCEDURE)
1636 f1_intent = p[i].f->sym->attr.intent;
1637 for (j = i + 1; j < n; j++)
1639 /* Expected order after the sort. */
1640 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1641 gfc_internal_error ("check_some_aliasing(): corrupted data");
1643 /* Are the expression the same? */
1644 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1646 f2_intent = p[j].f->sym->attr.intent;
1647 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1648 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1650 gfc_warning ("Same actual argument associated with INTENT(%s) "
1651 "argument '%s' and INTENT(%s) argument '%s' at %L",
1652 gfc_intent_string (f1_intent), p[i].f->sym->name,
1653 gfc_intent_string (f2_intent), p[j].f->sym->name,
1654 &p[i].a->expr->where);
1664 /* Given formal and actual argument lists that correspond to one
1665 another, check that they are compatible in the sense that intents
1666 are not mismatched. */
1669 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1671 sym_intent a_intent, f_intent;
1673 for (;; f = f->next, a = a->next)
1675 if (f == NULL && a == NULL)
1677 if (f == NULL || a == NULL)
1678 gfc_internal_error ("check_intents(): List mismatch");
1680 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1683 a_intent = a->expr->symtree->n.sym->attr.intent;
1684 f_intent = f->sym->attr.intent;
1686 if (a_intent == INTENT_IN
1687 && (f_intent == INTENT_INOUT
1688 || f_intent == INTENT_OUT))
1691 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1692 "specifies INTENT(%s)", &a->expr->where,
1693 gfc_intent_string (f_intent));
1697 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1699 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1702 ("Procedure argument at %L is local to a PURE procedure and "
1703 "is passed to an INTENT(%s) argument", &a->expr->where,
1704 gfc_intent_string (f_intent));
1708 if (a->expr->symtree->n.sym->attr.pointer)
1711 ("Procedure argument at %L is local to a PURE procedure and "
1712 "has the POINTER attribute", &a->expr->where);
1722 /* Check how a procedure is used against its interface. If all goes
1723 well, the actual argument list will also end up being properly
1727 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1730 /* Warn about calls with an implicit interface. */
1731 if (gfc_option.warn_implicit_interface
1732 && sym->attr.if_source == IFSRC_UNKNOWN)
1733 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1736 if (sym->attr.if_source == IFSRC_UNKNOWN
1737 || !compare_actual_formal (ap, sym->formal, 0,
1738 sym->attr.elemental, where))
1741 check_intents (sym->formal, *ap);
1742 if (gfc_option.warn_aliasing)
1743 check_some_aliasing (sym->formal, *ap);
1747 /* Given an interface pointer and an actual argument list, search for
1748 a formal argument list that matches the actual. If found, returns
1749 a pointer to the symbol of the correct interface. Returns NULL if
1753 gfc_search_interface (gfc_interface * intr, int sub_flag,
1754 gfc_actual_arglist ** ap)
1758 for (; intr; intr = intr->next)
1760 if (sub_flag && intr->sym->attr.function)
1762 if (!sub_flag && intr->sym->attr.subroutine)
1765 r = !intr->sym->attr.elemental;
1767 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1769 check_intents (intr->sym->formal, *ap);
1770 if (gfc_option.warn_aliasing)
1771 check_some_aliasing (intr->sym->formal, *ap);
1780 /* Do a brute force recursive search for a symbol. */
1782 static gfc_symtree *
1783 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1787 if (root->n.sym == sym)
1792 st = find_symtree0 (root->left, sym);
1793 if (root->right && ! st)
1794 st = find_symtree0 (root->right, sym);
1799 /* Find a symtree for a symbol. */
1801 static gfc_symtree *
1802 find_sym_in_symtree (gfc_symbol * sym)
1807 /* First try to find it by name. */
1808 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1809 if (st && st->n.sym == sym)
1812 /* if it's been renamed, resort to a brute-force search. */
1813 /* TODO: avoid having to do this search. If the symbol doesn't exist
1814 in the symtree for the current namespace, it should probably be added. */
1815 for (ns = gfc_current_ns; ns; ns = ns->parent)
1817 st = find_symtree0 (ns->sym_root, sym);
1821 gfc_internal_error ("Unable to find symbol %s", sym->name);
1826 /* This subroutine is called when an expression is being resolved.
1827 The expression node in question is either a user defined operator
1828 or an intrinsic operator with arguments that aren't compatible
1829 with the operator. This subroutine builds an actual argument list
1830 corresponding to the operands, then searches for a compatible
1831 interface. If one is found, the expression node is replaced with
1832 the appropriate function call. */
1835 gfc_extend_expr (gfc_expr * e)
1837 gfc_actual_arglist *actual;
1845 actual = gfc_get_actual_arglist ();
1846 actual->expr = e->value.op.op1;
1848 if (e->value.op.op2 != NULL)
1850 actual->next = gfc_get_actual_arglist ();
1851 actual->next->expr = e->value.op.op2;
1854 i = fold_unary (e->value.op.operator);
1856 if (i == INTRINSIC_USER)
1858 for (ns = gfc_current_ns; ns; ns = ns->parent)
1860 uop = gfc_find_uop (e->value.op.uop->name, ns);
1864 sym = gfc_search_interface (uop->operator, 0, &actual);
1871 for (ns = gfc_current_ns; ns; ns = ns->parent)
1873 sym = gfc_search_interface (ns->operator[i], 0, &actual);
1881 /* Don't use gfc_free_actual_arglist() */
1882 if (actual->next != NULL)
1883 gfc_free (actual->next);
1889 /* Change the expression node to a function call. */
1890 e->expr_type = EXPR_FUNCTION;
1891 e->symtree = find_sym_in_symtree (sym);
1892 e->value.function.actual = actual;
1893 e->value.function.esym = NULL;
1894 e->value.function.isym = NULL;
1895 e->value.function.name = NULL;
1897 if (gfc_pure (NULL) && !gfc_pure (sym))
1900 ("Function '%s' called in lieu of an operator at %L must be PURE",
1901 sym->name, &e->where);
1905 if (gfc_resolve_expr (e) == FAILURE)
1912 /* Tries to replace an assignment code node with a subroutine call to
1913 the subroutine associated with the assignment operator. Return
1914 SUCCESS if the node was replaced. On FAILURE, no error is
1918 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1920 gfc_actual_arglist *actual;
1921 gfc_expr *lhs, *rhs;
1927 /* Don't allow an intrinsic assignment to be replaced. */
1928 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1929 && (lhs->ts.type == rhs->ts.type
1930 || (gfc_numeric_ts (&lhs->ts)
1931 && gfc_numeric_ts (&rhs->ts))))
1934 actual = gfc_get_actual_arglist ();
1937 actual->next = gfc_get_actual_arglist ();
1938 actual->next->expr = rhs;
1942 for (; ns; ns = ns->parent)
1944 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1951 gfc_free (actual->next);
1956 /* Replace the assignment with the call. */
1957 c->op = EXEC_ASSIGN_CALL;
1958 c->symtree = find_sym_in_symtree (sym);
1961 c->ext.actual = actual;
1967 /* Make sure that the interface just parsed is not already present in
1968 the given interface list. Ambiguity isn't checked yet since module
1969 procedures can be present without interfaces. */
1972 check_new_interface (gfc_interface * base, gfc_symbol * new)
1976 for (ip = base; ip; ip = ip->next)
1980 gfc_error ("Entity '%s' at %C is already present in the interface",
1990 /* Add a symbol to the current interface. */
1993 gfc_add_interface (gfc_symbol * new)
1995 gfc_interface **head, *intr;
1999 switch (current_interface.type)
2001 case INTERFACE_NAMELESS:
2004 case INTERFACE_INTRINSIC_OP:
2005 for (ns = current_interface.ns; ns; ns = ns->parent)
2006 if (check_new_interface (ns->operator[current_interface.op], new)
2010 head = ¤t_interface.ns->operator[current_interface.op];
2013 case INTERFACE_GENERIC:
2014 for (ns = current_interface.ns; ns; ns = ns->parent)
2016 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2020 if (check_new_interface (sym->generic, new) == FAILURE)
2024 head = ¤t_interface.sym->generic;
2027 case INTERFACE_USER_OP:
2028 if (check_new_interface (current_interface.uop->operator, new) ==
2032 head = ¤t_interface.uop->operator;
2036 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2039 intr = gfc_get_interface ();
2041 intr->where = gfc_current_locus;
2050 /* Gets rid of a formal argument list. We do not free symbols.
2051 Symbols are freed when a namespace is freed. */
2054 gfc_free_formal_arglist (gfc_formal_arglist * p)
2056 gfc_formal_arglist *q;