1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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. */
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface * intr)
87 for (; intr; intr = next)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary (gfc_intrinsic_op operator)
104 case INTRINSIC_UPLUS:
105 operator = INTRINSIC_PLUS;
107 case INTRINSIC_UMINUS:
108 operator = INTRINSIC_MINUS;
118 /* Match a generic specification. Depending on which type of
119 interface is found, the 'name' or 'operator' pointers may be set.
120 This subroutine doesn't return MATCH_NO. */
123 gfc_match_generic_spec (interface_type * type,
125 gfc_intrinsic_op *operator)
127 char buffer[GFC_MAX_SYMBOL_LEN + 1];
131 if (gfc_match (" assignment ( = )") == MATCH_YES)
133 *type = INTERFACE_INTRINSIC_OP;
134 *operator = INTRINSIC_ASSIGN;
138 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
140 *type = INTERFACE_INTRINSIC_OP;
141 *operator = fold_unary (i);
145 if (gfc_match (" operator ( ") == MATCH_YES)
147 m = gfc_match_defined_op_name (buffer, 1);
153 m = gfc_match_char (')');
159 strcpy (name, buffer);
160 *type = INTERFACE_USER_OP;
164 if (gfc_match_name (buffer) == MATCH_YES)
166 strcpy (name, buffer);
167 *type = INTERFACE_GENERIC;
171 *type = INTERFACE_NAMELESS;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five forms of an interface statement. */
183 gfc_match_interface (void)
185 char name[GFC_MAX_SYMBOL_LEN + 1];
188 gfc_intrinsic_op operator;
191 m = gfc_match_space ();
193 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type != INTERFACE_NAMELESS
204 ("Syntax error: Trailing garbage in INTERFACE statement at %C");
208 current_interface.type = type;
212 case INTERFACE_GENERIC:
213 if (gfc_get_symbol (name, NULL, &sym))
216 if (!sym->attr.generic
217 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
220 current_interface.sym = gfc_new_block = sym;
223 case INTERFACE_USER_OP:
224 current_interface.uop = gfc_get_uop (name);
227 case INTERFACE_INTRINSIC_OP:
228 current_interface.op = operator;
231 case INTERFACE_NAMELESS:
239 /* Match the different sort of generic-specs that can be present after
240 the END INTERFACE itself. */
243 gfc_match_end_interface (void)
245 char name[GFC_MAX_SYMBOL_LEN + 1];
247 gfc_intrinsic_op operator;
250 m = gfc_match_space ();
252 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
255 /* If we're not looking at the end of the statement now, or if this
256 is not a nameless interface but we did not see a space, punt. */
257 if (gfc_match_eos () != MATCH_YES
258 || (type != INTERFACE_NAMELESS
262 ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
268 switch (current_interface.type)
270 case INTERFACE_NAMELESS:
271 if (type != current_interface.type)
273 gfc_error ("Expected a nameless interface at %C");
279 case INTERFACE_INTRINSIC_OP:
280 if (type != current_interface.type || operator != current_interface.op)
283 if (current_interface.op == INTRINSIC_ASSIGN)
284 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
286 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
287 gfc_op2string (current_interface.op));
294 case INTERFACE_USER_OP:
295 /* Comparing the symbol node names is OK because only use-associated
296 symbols can be renamed. */
297 if (type != current_interface.type
298 || strcmp (current_interface.uop->name, name) != 0)
300 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
301 current_interface.uop->name);
307 case INTERFACE_GENERIC:
308 if (type != current_interface.type
309 || strcmp (current_interface.sym->name, name) != 0)
311 gfc_error ("Expecting 'END INTERFACE %s' at %C",
312 current_interface.sym->name);
323 /* Compare two derived types using the criteria in 4.4.2 of the standard,
324 recursing through gfc_compare_types for the components. */
327 gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
329 gfc_component *dt1, *dt2;
331 /* Special case for comparing derived types across namespaces. If the
332 true names and module names are the same and the module name is
333 nonnull, then they are equal. */
334 if (strcmp (derived1->name, derived2->name) == 0
335 && derived1 != NULL && derived2 != NULL
336 && derived1->module != NULL && derived2->module != NULL
337 && strcmp (derived1->module, derived2->module) == 0)
340 /* Compare type via the rules of the standard. Both types must have
341 the SEQUENCE attribute to be equal. */
343 if (strcmp (derived1->name, derived2->name))
346 if (derived1->component_access == ACCESS_PRIVATE
347 || derived2->component_access == ACCESS_PRIVATE)
350 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
353 dt1 = derived1->components;
354 dt2 = derived2->components;
356 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
357 simple test can speed things up. Otherwise, lots of things have to
361 if (strcmp (dt1->name, dt2->name) != 0)
364 if (dt1->pointer != dt2->pointer)
367 if (dt1->dimension != dt2->dimension)
370 if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
373 if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
379 if (dt1 == NULL && dt2 == NULL)
381 if (dt1 == NULL || dt2 == NULL)
388 /* Compare two typespecs, recursively if necessary. */
391 gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
394 if (ts1->type != ts2->type)
396 if (ts1->type != BT_DERIVED)
397 return (ts1->kind == ts2->kind);
399 /* Compare derived types. */
400 if (ts1->derived == ts2->derived)
403 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
407 /* Given two symbols that are formal arguments, compare their ranks
408 and types. Returns nonzero if they have the same rank and type,
412 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
416 r1 = (s1->as != NULL) ? s1->as->rank : 0;
417 r2 = (s2->as != NULL) ? s2->as->rank : 0;
420 return 0; /* Ranks differ */
422 return gfc_compare_types (&s1->ts, &s2->ts);
426 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
428 /* Given two symbols that are formal arguments, compare their types
429 and rank and their formal interfaces if they are both dummy
430 procedures. Returns nonzero if the same, zero if different. */
433 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
436 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
437 return compare_type_rank (s1, s2);
439 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
442 /* At this point, both symbols are procedures. */
443 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
444 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
447 if (s1->attr.function != s2->attr.function
448 || s1->attr.subroutine != s2->attr.subroutine)
451 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
454 return compare_interfaces (s1, s2, 0); /* Recurse! */
458 /* Given a formal argument list and a keyword name, search the list
459 for that keyword. Returns the correct symbol node if found, NULL
463 find_keyword_arg (const char *name, gfc_formal_arglist * f)
466 for (; f; f = f->next)
467 if (strcmp (f->sym->name, name) == 0)
474 /******** Interface checking subroutines **********/
477 /* Given an operator interface and the operator, make sure that all
478 interfaces for that operator are legal. */
481 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
483 gfc_formal_arglist *formal;
493 t1 = t2 = BT_UNKNOWN;
494 i1 = i2 = INTENT_UNKNOWN;
496 for (formal = intr->sym->formal; formal; formal = formal->next)
503 i1 = sym->attr.intent;
508 i2 = sym->attr.intent;
513 if (args == 0 || args > 2)
518 if (operator == INTRINSIC_ASSIGN)
520 if (!sym->attr.subroutine)
523 ("Assignment operator interface at %L must be a SUBROUTINE",
530 if (!sym->attr.function)
532 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
540 case INTRINSIC_PLUS: /* Numeric unary or binary */
541 case INTRINSIC_MINUS:
545 || t1 == BT_COMPLEX))
549 && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
550 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
555 case INTRINSIC_POWER: /* Binary numeric */
556 case INTRINSIC_TIMES:
557 case INTRINSIC_DIVIDE:
564 if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
565 && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
570 case INTRINSIC_GE: /* Binary numeric operators that do not support */
571 case INTRINSIC_LE: /* complex numbers */
577 if ((t1 == BT_INTEGER || t1 == BT_REAL)
578 && (t2 == BT_INTEGER || t2 == BT_REAL))
583 case INTRINSIC_OR: /* Binary logical */
589 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
593 case INTRINSIC_NOT: /* Unary logical */
596 if (t1 == BT_LOGICAL)
600 case INTRINSIC_CONCAT: /* Binary string */
603 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
607 case INTRINSIC_ASSIGN: /* Class by itself */
612 gfc_internal_error ("check_operator_interface(): Bad operator");
615 /* Check intents on operator interfaces. */
616 if (operator == INTRINSIC_ASSIGN)
618 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
619 gfc_error ("First argument of defined assignment at %L must be "
620 "INTENT(IN) or INTENT(INOUT)", &intr->where);
623 gfc_error ("Second argument of defined assignment at %L must be "
624 "INTENT(IN)", &intr->where);
629 gfc_error ("First argument of operator interface at %L must be "
630 "INTENT(IN)", &intr->where);
632 if (args == 2 && i2 != INTENT_IN)
633 gfc_error ("Second argument of operator interface at %L must be "
634 "INTENT(IN)", &intr->where);
640 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
645 gfc_error ("Operator interface at %L has the wrong number of arguments",
651 /* Given a pair of formal argument lists, we see if the two lists can
652 be distinguished by counting the number of nonoptional arguments of
653 a given type/rank in f1 and seeing if there are less then that
654 number of those arguments in f2 (including optional arguments).
655 Since this test is asymmetric, it has to be called twice to make it
656 symmetric. Returns nonzero if the argument lists are incompatible
657 by this test. This subroutine implements rule 1 of section
661 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
663 int rc, ac1, ac2, i, j, k, n1;
664 gfc_formal_arglist *f;
677 for (f = f1; f; f = f->next)
680 /* Build an array of integers that gives the same integer to
681 arguments of the same type/rank. */
682 arg = gfc_getmem (n1 * sizeof (arginfo));
685 for (i = 0; i < n1; i++, f = f->next)
693 for (i = 0; i < n1; i++)
695 if (arg[i].flag != -1)
698 if (arg[i].sym->attr.optional)
699 continue; /* Skip optional arguments */
703 /* Find other nonoptional arguments of the same type/rank. */
704 for (j = i + 1; j < n1; j++)
705 if (!arg[j].sym->attr.optional
706 && compare_type_rank_if (arg[i].sym, arg[j].sym))
712 /* Now loop over each distinct type found in f1. */
716 for (i = 0; i < n1; i++)
718 if (arg[i].flag != k)
722 for (j = i + 1; j < n1; j++)
723 if (arg[j].flag == k)
726 /* Count the number of arguments in f2 with that type, including
727 those that are optional. */
730 for (f = f2; f; f = f->next)
731 if (compare_type_rank_if (arg[i].sym, f->sym))
749 /* Perform the abbreviated correspondence test for operators. The
750 arguments cannot be optional and are always ordered correctly,
751 which makes this test much easier than that for generic tests.
753 This subroutine is also used when comparing a formal and actual
754 argument list when an actual parameter is a dummy procedure. At
755 that point, two formal interfaces must be compared for equality
756 which is what happens here. */
759 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
763 if (f1 == NULL && f2 == NULL)
765 if (f1 == NULL || f2 == NULL)
768 if (!compare_type_rank (f1->sym, f2->sym))
779 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
780 Returns zero if no argument is found that satisfies rule 2, nonzero
783 This test is also not symmetric in f1 and f2 and must be called
784 twice. This test finds problems caused by sorting the actual
785 argument list with keywords. For example:
789 INTEGER :: A ; REAL :: B
793 INTEGER :: A ; REAL :: B
797 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
800 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
803 gfc_formal_arglist *f2_save, *g;
810 if (f1->sym->attr.optional)
813 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
816 /* Now search for a disambiguating keyword argument starting at
817 the current non-match. */
818 for (g = f1; g; g = g->next)
820 if (g->sym->attr.optional)
823 sym = find_keyword_arg (g->sym->name, f2_save);
824 if (sym == NULL || !compare_type_rank (g->sym, sym))
838 /* 'Compare' two formal interfaces associated with a pair of symbols.
839 We return nonzero if there exists an actual argument list that
840 would be ambiguous between the two interfaces, zero otherwise. */
843 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
845 gfc_formal_arglist *f1, *f2;
847 if (s1->attr.function != s2->attr.function
848 && s1->attr.subroutine != s2->attr.subroutine)
849 return 0; /* disagreement between function/subroutine */
854 if (f1 == NULL && f2 == NULL)
855 return 1; /* Special case */
857 if (count_types_test (f1, f2))
859 if (count_types_test (f2, f1))
864 if (generic_correspondence (f1, f2))
866 if (generic_correspondence (f2, f1))
871 if (operator_correspondence (f1, f2))
879 /* Given a pointer to an interface pointer, remove duplicate
880 interfaces and make sure that all symbols are either functions or
881 subroutines. Returns nonzero if something goes wrong. */
884 check_interface0 (gfc_interface * p, const char *interface_name)
886 gfc_interface *psave, *q, *qlast;
889 /* Make sure all symbols in the interface have been defined as
890 functions or subroutines. */
891 for (; p; p = p->next)
892 if (!p->sym->attr.function && !p->sym->attr.subroutine)
894 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
895 "subroutine", p->sym->name, interface_name,
896 &p->sym->declared_at);
901 /* Remove duplicate interfaces in this interface list. */
902 for (; p; p = p->next)
906 for (q = p->next; q;)
908 if (p->sym != q->sym)
916 /* Duplicate interface */
917 qlast->next = q->next;
928 /* Check lists of interfaces to make sure that no two interfaces are
929 ambiguous. Duplicate interfaces (from the same symbol) are OK
933 check_interface1 (gfc_interface * p, gfc_interface * q,
934 int generic_flag, const char *interface_name)
937 for (; p; p = p->next)
938 for (; q; q = q->next)
940 if (p->sym == q->sym)
941 continue; /* Duplicates OK here */
943 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
946 if (compare_interfaces (p->sym, q->sym, generic_flag))
948 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
949 p->sym->name, q->sym->name, interface_name, &p->where);
958 /* Check the generic and operator interfaces of symbols to make sure
959 that none of the interfaces conflict. The check has to be done
960 after all of the symbols are actually loaded. */
963 check_sym_interfaces (gfc_symbol * sym)
965 char interface_name[100];
968 if (sym->ns != gfc_current_ns)
971 if (sym->generic != NULL)
973 sprintf (interface_name, "generic interface '%s'", sym->name);
974 if (check_interface0 (sym->generic, interface_name))
980 if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
983 if (s2->ns->parent == NULL)
985 if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
993 check_uop_interfaces (gfc_user_op * uop)
995 char interface_name[100];
999 sprintf (interface_name, "operator interface '%s'", uop->name);
1000 if (check_interface0 (uop->operator, interface_name))
1003 for (ns = gfc_current_ns; ns; ns = ns->parent)
1005 uop2 = gfc_find_uop (uop->name, ns);
1009 check_interface1 (uop->operator, uop2->operator, 0, interface_name);
1014 /* For the namespace, check generic, user operator and intrinsic
1015 operator interfaces for consistency and to remove duplicate
1016 interfaces. We traverse the whole namespace, counting on the fact
1017 that most symbols will not have generic or operator interfaces. */
1020 gfc_check_interfaces (gfc_namespace * ns)
1022 gfc_namespace *old_ns, *ns2;
1023 char interface_name[100];
1026 old_ns = gfc_current_ns;
1027 gfc_current_ns = ns;
1029 gfc_traverse_ns (ns, check_sym_interfaces);
1031 gfc_traverse_user_op (ns, check_uop_interfaces);
1033 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1035 if (i == INTRINSIC_USER)
1038 if (i == INTRINSIC_ASSIGN)
1039 strcpy (interface_name, "intrinsic assignment operator");
1041 sprintf (interface_name, "intrinsic '%s' operator",
1044 if (check_interface0 (ns->operator[i], interface_name))
1047 check_operator_interface (ns->operator[i], i);
1049 for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1050 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1055 gfc_current_ns = old_ns;
1060 symbol_rank (gfc_symbol * sym)
1063 return (sym->as == NULL) ? 0 : sym->as->rank;
1067 /* Given a symbol of a formal argument list and an expression, if the
1068 formal argument is allocatable, check that the actual argument is
1069 allocatable. Returns nonzero if compatible, zero if not compatible. */
1072 compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
1074 symbol_attribute attr;
1076 if (formal->attr.allocatable)
1078 attr = gfc_expr_attr (actual);
1079 if (!attr.allocatable)
1087 /* Given a symbol of a formal argument list and an expression, if the
1088 formal argument is a pointer, see if the actual argument is a
1089 pointer. Returns nonzero if compatible, zero if not compatible. */
1092 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1094 symbol_attribute attr;
1096 if (formal->attr.pointer)
1098 attr = gfc_expr_attr (actual);
1107 /* Given a symbol of a formal argument list and an expression, see if
1108 the two are compatible as arguments. Returns nonzero if
1109 compatible, zero if not compatible. */
1112 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1113 int ranks_must_agree, int is_elemental)
1117 if (actual->ts.type == BT_PROCEDURE)
1119 if (formal->attr.flavor != FL_PROCEDURE)
1122 if (formal->attr.function
1123 && !compare_type_rank (formal, actual->symtree->n.sym))
1126 if (formal->attr.if_source == IFSRC_UNKNOWN)
1127 return 1; /* Assume match */
1129 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1132 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1133 && !gfc_compare_types (&formal->ts, &actual->ts))
1136 if (symbol_rank (formal) == actual->rank)
1139 /* At this point the ranks didn't agree. */
1140 if (ranks_must_agree || formal->attr.pointer)
1143 if (actual->rank != 0)
1144 return is_elemental || formal->attr.dimension;
1146 /* At this point, we are considering a scalar passed to an array.
1147 This is legal if the scalar is an array element of the right sort. */
1148 if (formal->as->type == AS_ASSUMED_SHAPE)
1151 for (ref = actual->ref; ref; ref = ref->next)
1152 if (ref->type == REF_SUBSTRING)
1155 for (ref = actual->ref; ref; ref = ref->next)
1156 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1160 return 0; /* Not an array element */
1166 /* Given formal and actual argument lists, see if they are compatible.
1167 If they are compatible, the actual argument list is sorted to
1168 correspond with the formal list, and elements for missing optional
1169 arguments are inserted. If WHERE pointer is nonnull, then we issue
1170 errors when things don't match instead of just returning the status
1174 compare_actual_formal (gfc_actual_arglist ** ap,
1175 gfc_formal_arglist * formal,
1176 int ranks_must_agree, int is_elemental, locus * where)
1178 gfc_actual_arglist **new, *a, *actual, temp;
1179 gfc_formal_arglist *f;
1185 if (actual == NULL && formal == NULL)
1189 for (f = formal; f; f = f->next)
1192 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1194 for (i = 0; i < n; i++)
1201 for (a = actual; a; a = a->next, f = f->next)
1203 if (a->name != NULL)
1206 for (f = formal; f; f = f->next, i++)
1210 if (strcmp (f->sym->name, a->name) == 0)
1218 ("Keyword argument '%s' at %L is not in the procedure",
1219 a->name, &a->expr->where);
1227 ("Keyword argument '%s' at %L is already associated "
1228 "with another actual argument", a->name, &a->expr->where);
1237 ("More actual than formal arguments in procedure call at %L",
1243 if (f->sym == NULL && a->expr == NULL)
1250 ("Missing alternate return spec in subroutine call at %L",
1255 if (a->expr == NULL)
1259 ("Unexpected alternate return spec in subroutine call at %L",
1264 rank_check = where != NULL
1267 && (f->sym->as->type == AS_ASSUMED_SHAPE
1268 || f->sym->as->type == AS_DEFERRED);
1270 if (!compare_parameter
1271 (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
1274 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1275 f->sym->name, &a->expr->where);
1280 && f->sym->as->type == AS_ASSUMED_SHAPE
1281 && a->expr->expr_type == EXPR_VARIABLE
1282 && a->expr->symtree->n.sym->as
1283 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1284 && (a->expr->ref == NULL
1285 || (a->expr->ref->type == REF_ARRAY
1286 && a->expr->ref->u.ar.type == AR_FULL)))
1289 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1290 " array at %L", f->sym->name, where);
1294 if (a->expr->expr_type != EXPR_NULL
1295 && compare_pointer (f->sym, a->expr) == 0)
1298 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1299 f->sym->name, &a->expr->where);
1303 if (a->expr->expr_type != EXPR_NULL
1304 && compare_allocatable (f->sym, a->expr) == 0)
1307 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1308 f->sym->name, &a->expr->where);
1312 /* Check intent = OUT/INOUT for definable actual argument. */
1313 if (a->expr->expr_type != EXPR_VARIABLE
1314 && (f->sym->attr.intent == INTENT_OUT
1315 || f->sym->attr.intent == INTENT_INOUT))
1317 gfc_error ("Actual argument at %L must be definable to "
1318 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1329 /* Make sure missing actual arguments are optional. */
1331 for (f = formal; f; f = f->next, i++)
1335 if (!f->sym->attr.optional)
1338 gfc_error ("Missing actual argument for argument '%s' at %L",
1339 f->sym->name, where);
1344 /* The argument lists are compatible. We now relink a new actual
1345 argument list with null arguments in the right places. The head
1346 of the list remains the head. */
1347 for (i = 0; i < n; i++)
1349 new[i] = gfc_get_actual_arglist ();
1362 for (i = 0; i < n - 1; i++)
1363 new[i]->next = new[i + 1];
1365 new[i]->next = NULL;
1367 if (*ap == NULL && n > 0)
1370 /* Note the types of omitted optional arguments. */
1371 for (a = actual, f = formal; a; a = a->next, f = f->next)
1372 if (a->expr == NULL && a->label == NULL)
1373 a->missing_arg_type = f->sym->ts.type;
1381 gfc_formal_arglist *f;
1382 gfc_actual_arglist *a;
1386 /* qsort comparison function for argument pairs, with the following
1388 - p->a->expr == NULL
1389 - p->a->expr->expr_type != EXPR_VARIABLE
1390 - growing p->a->expr->symbol. */
1393 pair_cmp (const void *p1, const void *p2)
1395 const gfc_actual_arglist *a1, *a2;
1397 /* *p1 and *p2 are elements of the to-be-sorted array. */
1398 a1 = ((const argpair *) p1)->a;
1399 a2 = ((const argpair *) p2)->a;
1408 if (a1->expr->expr_type != EXPR_VARIABLE)
1410 if (a2->expr->expr_type != EXPR_VARIABLE)
1414 if (a2->expr->expr_type != EXPR_VARIABLE)
1416 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1420 /* Given two expressions from some actual arguments, test whether they
1421 refer to the same expression. The analysis is conservative.
1422 Returning FAILURE will produce no warning. */
1425 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1427 const gfc_ref *r1, *r2;
1430 || e1->expr_type != EXPR_VARIABLE
1431 || e2->expr_type != EXPR_VARIABLE
1432 || e1->symtree->n.sym != e2->symtree->n.sym)
1435 /* TODO: improve comparison, see expr.c:show_ref(). */
1436 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1438 if (r1->type != r2->type)
1443 if (r1->u.ar.type != r2->u.ar.type)
1445 /* TODO: At the moment, consider only full arrays;
1446 we could do better. */
1447 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1452 if (r1->u.c.component != r2->u.c.component)
1460 gfc_internal_error ("compare_actual_expr(): Bad component code");
1468 /* Given formal and actual argument lists that correspond to one
1469 another, check that identical actual arguments aren't not
1470 associated with some incompatible INTENTs. */
1473 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1475 sym_intent f1_intent, f2_intent;
1476 gfc_formal_arglist *f1;
1477 gfc_actual_arglist *a1;
1483 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1485 if (f1 == NULL && a1 == NULL)
1487 if (f1 == NULL || a1 == NULL)
1488 gfc_internal_error ("check_some_aliasing(): List mismatch");
1493 p = (argpair *) alloca (n * sizeof (argpair));
1495 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1501 qsort (p, n, sizeof (argpair), pair_cmp);
1503 for (i = 0; i < n; i++)
1506 || p[i].a->expr->expr_type != EXPR_VARIABLE
1507 || p[i].a->expr->ts.type == BT_PROCEDURE)
1509 f1_intent = p[i].f->sym->attr.intent;
1510 for (j = i + 1; j < n; j++)
1512 /* Expected order after the sort. */
1513 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1514 gfc_internal_error ("check_some_aliasing(): corrupted data");
1516 /* Are the expression the same? */
1517 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1519 f2_intent = p[j].f->sym->attr.intent;
1520 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1521 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1523 gfc_warning ("Same actual argument associated with INTENT(%s) "
1524 "argument '%s' and INTENT(%s) argument '%s' at %L",
1525 gfc_intent_string (f1_intent), p[i].f->sym->name,
1526 gfc_intent_string (f2_intent), p[j].f->sym->name,
1527 &p[i].a->expr->where);
1537 /* Given formal and actual argument lists that correspond to one
1538 another, check that they are compatible in the sense that intents
1539 are not mismatched. */
1542 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1544 sym_intent a_intent, f_intent;
1546 for (;; f = f->next, a = a->next)
1548 if (f == NULL && a == NULL)
1550 if (f == NULL || a == NULL)
1551 gfc_internal_error ("check_intents(): List mismatch");
1553 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1556 a_intent = a->expr->symtree->n.sym->attr.intent;
1557 f_intent = f->sym->attr.intent;
1559 if (a_intent == INTENT_IN
1560 && (f_intent == INTENT_INOUT
1561 || f_intent == INTENT_OUT))
1564 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1565 "specifies INTENT(%s)", &a->expr->where,
1566 gfc_intent_string (f_intent));
1570 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1572 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1575 ("Procedure argument at %L is local to a PURE procedure and "
1576 "is passed to an INTENT(%s) argument", &a->expr->where,
1577 gfc_intent_string (f_intent));
1581 if (a->expr->symtree->n.sym->attr.pointer)
1584 ("Procedure argument at %L is local to a PURE procedure and "
1585 "has the POINTER attribute", &a->expr->where);
1595 /* Check how a procedure is used against its interface. If all goes
1596 well, the actual argument list will also end up being properly
1600 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1603 /* Warn about calls with an implicit interface. */
1604 if (gfc_option.warn_implicit_interface
1605 && sym->attr.if_source == IFSRC_UNKNOWN)
1606 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1609 if (sym->attr.if_source == IFSRC_UNKNOWN
1610 || !compare_actual_formal (ap, sym->formal, 0,
1611 sym->attr.elemental, where))
1614 check_intents (sym->formal, *ap);
1615 if (gfc_option.warn_aliasing)
1616 check_some_aliasing (sym->formal, *ap);
1620 /* Given an interface pointer and an actual argument list, search for
1621 a formal argument list that matches the actual. If found, returns
1622 a pointer to the symbol of the correct interface. Returns NULL if
1626 gfc_search_interface (gfc_interface * intr, int sub_flag,
1627 gfc_actual_arglist ** ap)
1631 for (; intr; intr = intr->next)
1633 if (sub_flag && intr->sym->attr.function)
1635 if (!sub_flag && intr->sym->attr.subroutine)
1638 r = !intr->sym->attr.elemental;
1640 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1642 check_intents (intr->sym->formal, *ap);
1643 if (gfc_option.warn_aliasing)
1644 check_some_aliasing (intr->sym->formal, *ap);
1653 /* Do a brute force recursive search for a symbol. */
1655 static gfc_symtree *
1656 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1660 if (root->n.sym == sym)
1665 st = find_symtree0 (root->left, sym);
1666 if (root->right && ! st)
1667 st = find_symtree0 (root->right, sym);
1672 /* Find a symtree for a symbol. */
1674 static gfc_symtree *
1675 find_sym_in_symtree (gfc_symbol * sym)
1680 /* First try to find it by name. */
1681 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1682 if (st && st->n.sym == sym)
1685 /* if it's been renamed, resort to a brute-force search. */
1686 /* TODO: avoid having to do this search. If the symbol doesn't exist
1687 in the symtree for the current namespace, it should probably be added. */
1688 for (ns = gfc_current_ns; ns; ns = ns->parent)
1690 st = find_symtree0 (ns->sym_root, sym);
1694 gfc_internal_error ("Unable to find symbol %s", sym->name);
1699 /* This subroutine is called when an expression is being resolved.
1700 The expression node in question is either a user defined operator
1701 or an intrinsic operator with arguments that aren't compatible
1702 with the operator. This subroutine builds an actual argument list
1703 corresponding to the operands, then searches for a compatible
1704 interface. If one is found, the expression node is replaced with
1705 the appropriate function call. */
1708 gfc_extend_expr (gfc_expr * e)
1710 gfc_actual_arglist *actual;
1718 actual = gfc_get_actual_arglist ();
1719 actual->expr = e->value.op.op1;
1721 if (e->value.op.op2 != NULL)
1723 actual->next = gfc_get_actual_arglist ();
1724 actual->next->expr = e->value.op.op2;
1727 i = fold_unary (e->value.op.operator);
1729 if (i == INTRINSIC_USER)
1731 for (ns = gfc_current_ns; ns; ns = ns->parent)
1733 uop = gfc_find_uop (e->value.op.uop->name, ns);
1737 sym = gfc_search_interface (uop->operator, 0, &actual);
1744 for (ns = gfc_current_ns; ns; ns = ns->parent)
1746 sym = gfc_search_interface (ns->operator[i], 0, &actual);
1754 /* Don't use gfc_free_actual_arglist() */
1755 if (actual->next != NULL)
1756 gfc_free (actual->next);
1762 /* Change the expression node to a function call. */
1763 e->expr_type = EXPR_FUNCTION;
1764 e->symtree = find_sym_in_symtree (sym);
1765 e->value.function.actual = actual;
1766 e->value.function.esym = NULL;
1767 e->value.function.isym = NULL;
1768 e->value.function.name = NULL;
1770 if (gfc_pure (NULL) && !gfc_pure (sym))
1773 ("Function '%s' called in lieu of an operator at %L must be PURE",
1774 sym->name, &e->where);
1778 if (gfc_resolve_expr (e) == FAILURE)
1785 /* Tries to replace an assignment code node with a subroutine call to
1786 the subroutine associated with the assignment operator. Return
1787 SUCCESS if the node was replaced. On FAILURE, no error is
1791 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1793 gfc_actual_arglist *actual;
1794 gfc_expr *lhs, *rhs;
1800 /* Don't allow an intrinsic assignment to be replaced. */
1801 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1802 && (lhs->ts.type == rhs->ts.type
1803 || (gfc_numeric_ts (&lhs->ts)
1804 && gfc_numeric_ts (&rhs->ts))))
1807 actual = gfc_get_actual_arglist ();
1810 actual->next = gfc_get_actual_arglist ();
1811 actual->next->expr = rhs;
1815 for (; ns; ns = ns->parent)
1817 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1824 gfc_free (actual->next);
1829 /* Replace the assignment with the call. */
1831 c->symtree = find_sym_in_symtree (sym);
1834 c->ext.actual = actual;
1840 /* Make sure that the interface just parsed is not already present in
1841 the given interface list. Ambiguity isn't checked yet since module
1842 procedures can be present without interfaces. */
1845 check_new_interface (gfc_interface * base, gfc_symbol * new)
1849 for (ip = base; ip; ip = ip->next)
1853 gfc_error ("Entity '%s' at %C is already present in the interface",
1863 /* Add a symbol to the current interface. */
1866 gfc_add_interface (gfc_symbol * new)
1868 gfc_interface **head, *intr;
1872 switch (current_interface.type)
1874 case INTERFACE_NAMELESS:
1877 case INTERFACE_INTRINSIC_OP:
1878 for (ns = current_interface.ns; ns; ns = ns->parent)
1879 if (check_new_interface (ns->operator[current_interface.op], new)
1883 head = ¤t_interface.ns->operator[current_interface.op];
1886 case INTERFACE_GENERIC:
1887 for (ns = current_interface.ns; ns; ns = ns->parent)
1889 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1893 if (check_new_interface (sym->generic, new) == FAILURE)
1897 head = ¤t_interface.sym->generic;
1900 case INTERFACE_USER_OP:
1901 if (check_new_interface (current_interface.uop->operator, new) ==
1905 head = ¤t_interface.uop->operator;
1909 gfc_internal_error ("gfc_add_interface(): Bad interface type");
1912 intr = gfc_get_interface ();
1914 intr->where = gfc_current_locus;
1923 /* Gets rid of a formal argument list. We do not free symbols.
1924 Symbols are freed when a namespace is freed. */
1927 gfc_free_formal_arglist (gfc_formal_arglist * p)
1929 gfc_formal_arglist *q;