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);
471 static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
473 /* Given two symbols that are formal arguments, compare their types
474 and rank and their formal interfaces if they are both dummy
475 procedures. Returns nonzero if the same, zero if different. */
478 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
480 if (s1 == NULL || s2 == NULL)
481 return s1 == s2 ? 1 : 0;
483 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
484 return compare_type_rank (s1, s2);
486 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
489 /* At this point, both symbols are procedures. */
490 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
491 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
494 if (s1->attr.function != s2->attr.function
495 || s1->attr.subroutine != s2->attr.subroutine)
498 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
501 /* Originally, gfortran recursed here to check the interfaces of passed
502 procedures. This is explicitly not required by the standard. */
507 /* Given a formal argument list and a keyword name, search the list
508 for that keyword. Returns the correct symbol node if found, NULL
512 find_keyword_arg (const char *name, gfc_formal_arglist *f)
514 for (; f; f = f->next)
515 if (strcmp (f->sym->name, name) == 0)
522 /******** Interface checking subroutines **********/
525 /* Given an operator interface and the operator, make sure that all
526 interfaces for that operator are legal. */
529 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
531 gfc_formal_arglist *formal;
535 int args, r1, r2, k1, k2;
541 t1 = t2 = BT_UNKNOWN;
542 i1 = i2 = INTENT_UNKNOWN;
546 for (formal = intr->sym->formal; formal; formal = formal->next)
551 gfc_error ("Alternate return cannot appear in operator "
552 "interface at %L", &intr->where);
558 i1 = sym->attr.intent;
559 r1 = (sym->as != NULL) ? sym->as->rank : 0;
565 i2 = sym->attr.intent;
566 r2 = (sym->as != NULL) ? sym->as->rank : 0;
574 /* Only +, - and .not. can be unary operators.
575 .not. cannot be a binary operator. */
576 if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
577 && operator != INTRINSIC_MINUS
578 && operator != INTRINSIC_NOT)
579 || (args == 2 && operator == INTRINSIC_NOT))
581 gfc_error ("Operator interface at %L has the wrong number of arguments",
586 /* Check that intrinsics are mapped to functions, except
587 INTRINSIC_ASSIGN which should map to a subroutine. */
588 if (operator == INTRINSIC_ASSIGN)
590 if (!sym->attr.subroutine)
592 gfc_error ("Assignment operator interface at %L must be "
593 "a SUBROUTINE", &intr->where);
598 gfc_error ("Assignment operator interface at %L must have "
599 "two arguments", &intr->where);
602 if (sym->formal->sym->ts.type != BT_DERIVED
603 && sym->formal->next->sym->ts.type != BT_DERIVED
604 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
605 || (gfc_numeric_ts (&sym->formal->sym->ts)
606 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
608 gfc_error ("Assignment operator interface at %L must not redefine "
609 "an INTRINSIC type assignment", &intr->where);
615 if (!sym->attr.function)
617 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
623 /* Check intents on operator interfaces. */
624 if (operator == INTRINSIC_ASSIGN)
626 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
627 gfc_error ("First argument of defined assignment at %L must be "
628 "INTENT(IN) or INTENT(INOUT)", &intr->where);
631 gfc_error ("Second argument of defined assignment at %L must be "
632 "INTENT(IN)", &intr->where);
637 gfc_error ("First argument of operator interface at %L must be "
638 "INTENT(IN)", &intr->where);
640 if (args == 2 && i2 != INTENT_IN)
641 gfc_error ("Second argument of operator interface at %L must be "
642 "INTENT(IN)", &intr->where);
645 /* From now on, all we have to do is check that the operator definition
646 doesn't conflict with an intrinsic operator. The rules for this
647 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
648 as well as 12.3.2.1.1 of Fortran 2003:
650 "If the operator is an intrinsic-operator (R310), the number of
651 function arguments shall be consistent with the intrinsic uses of
652 that operator, and the types, kind type parameters, or ranks of the
653 dummy arguments shall differ from those required for the intrinsic
654 operation (7.1.2)." */
656 #define IS_NUMERIC_TYPE(t) \
657 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
659 /* Unary ops are easy, do them first. */
660 if (operator == INTRINSIC_NOT)
662 if (t1 == BT_LOGICAL)
668 if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
670 if (IS_NUMERIC_TYPE (t1))
676 /* Character intrinsic operators have same character kind, thus
677 operator definitions with operands of different character kinds
679 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
682 /* Intrinsic operators always perform on arguments of same rank,
683 so different ranks is also always safe. (rank == 0) is an exception
684 to that, because all intrinsic operators are elemental. */
685 if (r1 != r2 && r1 != 0 && r2 != 0)
691 case INTRINSIC_EQ_OS:
693 case INTRINSIC_NE_OS:
694 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
699 case INTRINSIC_MINUS:
700 case INTRINSIC_TIMES:
701 case INTRINSIC_DIVIDE:
702 case INTRINSIC_POWER:
703 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
708 case INTRINSIC_GT_OS:
710 case INTRINSIC_GE_OS:
712 case INTRINSIC_LT_OS:
714 case INTRINSIC_LE_OS:
715 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
717 if ((t1 == BT_INTEGER || t1 == BT_REAL)
718 && (t2 == BT_INTEGER || t2 == BT_REAL))
722 case INTRINSIC_CONCAT:
723 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
731 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
741 #undef IS_NUMERIC_TYPE
744 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
750 /* Given a pair of formal argument lists, we see if the two lists can
751 be distinguished by counting the number of nonoptional arguments of
752 a given type/rank in f1 and seeing if there are less then that
753 number of those arguments in f2 (including optional arguments).
754 Since this test is asymmetric, it has to be called twice to make it
755 symmetric. Returns nonzero if the argument lists are incompatible
756 by this test. This subroutine implements rule 1 of section
760 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
762 int rc, ac1, ac2, i, j, k, n1;
763 gfc_formal_arglist *f;
776 for (f = f1; f; f = f->next)
779 /* Build an array of integers that gives the same integer to
780 arguments of the same type/rank. */
781 arg = gfc_getmem (n1 * sizeof (arginfo));
784 for (i = 0; i < n1; i++, f = f->next)
792 for (i = 0; i < n1; i++)
794 if (arg[i].flag != -1)
797 if (arg[i].sym && arg[i].sym->attr.optional)
798 continue; /* Skip optional arguments. */
802 /* Find other nonoptional arguments of the same type/rank. */
803 for (j = i + 1; j < n1; j++)
804 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
805 && compare_type_rank_if (arg[i].sym, arg[j].sym))
811 /* Now loop over each distinct type found in f1. */
815 for (i = 0; i < n1; i++)
817 if (arg[i].flag != k)
821 for (j = i + 1; j < n1; j++)
822 if (arg[j].flag == k)
825 /* Count the number of arguments in f2 with that type, including
826 those that are optional. */
829 for (f = f2; f; f = f->next)
830 if (compare_type_rank_if (arg[i].sym, f->sym))
848 /* Perform the abbreviated correspondence test for operators. The
849 arguments cannot be optional and are always ordered correctly,
850 which makes this test much easier than that for generic tests.
852 This subroutine is also used when comparing a formal and actual
853 argument list when an actual parameter is a dummy procedure. At
854 that point, two formal interfaces must be compared for equality
855 which is what happens here. */
858 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
862 if (f1 == NULL && f2 == NULL)
864 if (f1 == NULL || f2 == NULL)
867 if (!compare_type_rank (f1->sym, f2->sym))
878 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
879 Returns zero if no argument is found that satisfies rule 2, nonzero
882 This test is also not symmetric in f1 and f2 and must be called
883 twice. This test finds problems caused by sorting the actual
884 argument list with keywords. For example:
888 INTEGER :: A ; REAL :: B
892 INTEGER :: A ; REAL :: B
896 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
899 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
901 gfc_formal_arglist *f2_save, *g;
908 if (f1->sym->attr.optional)
911 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
914 /* Now search for a disambiguating keyword argument starting at
915 the current non-match. */
916 for (g = f1; g; g = g->next)
918 if (g->sym->attr.optional)
921 sym = find_keyword_arg (g->sym->name, f2_save);
922 if (sym == NULL || !compare_type_rank (g->sym, sym))
936 /* 'Compare' two formal interfaces associated with a pair of symbols.
937 We return nonzero if there exists an actual argument list that
938 would be ambiguous between the two interfaces, zero otherwise. */
941 compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
943 gfc_formal_arglist *f1, *f2;
945 if (s1->attr.function != s2->attr.function
946 || s1->attr.subroutine != s2->attr.subroutine)
947 return 0; /* Disagreement between function/subroutine. */
952 if (f1 == NULL && f2 == NULL)
953 return 1; /* Special case. */
955 if (count_types_test (f1, f2))
957 if (count_types_test (f2, f1))
962 if (generic_correspondence (f1, f2))
964 if (generic_correspondence (f2, f1))
969 if (operator_correspondence (f1, f2))
978 compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
980 gfc_formal_arglist *f, *f1;
981 gfc_intrinsic_arg *fi, *f2;
982 gfc_intrinsic_sym *isym;
984 if (s1->attr.function != s2->attr.function
985 || s1->attr.subroutine != s2->attr.subroutine)
986 return 0; /* Disagreement between function/subroutine. */
988 /* If the arguments are functions, check type and kind. */
990 if (s1->attr.dummy && s1->attr.function && s2->attr.function)
992 if (s1->ts.type != s2->ts.type)
994 if (s1->ts.kind != s2->ts.kind)
996 if (s1->attr.if_source == IFSRC_DECL)
1000 isym = gfc_find_function (s2->name);
1002 /* This should already have been checked in
1003 resolve.c (resolve_actual_arglist). */
1010 if (f1 == NULL && f2 == NULL)
1013 /* First scan through the formal argument list and check the intrinsic. */
1015 for (f = f1; f; f = f->next)
1019 if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
1024 /* Now scan through the intrinsic argument list and check the formal. */
1026 for (fi = f2; fi; fi = fi->next)
1030 if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
1039 /* Compare an actual argument list with an intrinsic argument list. */
1042 compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
1044 gfc_actual_arglist *a;
1045 gfc_intrinsic_arg *fi, *f2;
1046 gfc_intrinsic_sym *isym;
1048 isym = gfc_find_function (s2->name);
1050 /* This should already have been checked in
1051 resolve.c (resolve_actual_arglist). */
1057 if (*ap == NULL && f2 == NULL)
1060 /* First scan through the actual argument list and check the intrinsic. */
1062 for (a = *ap; a; a = a->next)
1066 if ((fi->ts.type != a->expr->ts.type)
1067 || (fi->ts.kind != a->expr->ts.kind))
1072 /* Now scan through the intrinsic argument list and check the formal. */
1074 for (fi = f2; fi; fi = fi->next)
1078 if ((fi->ts.type != a->expr->ts.type)
1079 || (fi->ts.kind != a->expr->ts.kind))
1088 /* Given a pointer to an interface pointer, remove duplicate
1089 interfaces and make sure that all symbols are either functions or
1090 subroutines. Returns nonzero if something goes wrong. */
1093 check_interface0 (gfc_interface *p, const char *interface_name)
1095 gfc_interface *psave, *q, *qlast;
1098 /* Make sure all symbols in the interface have been defined as
1099 functions or subroutines. */
1100 for (; p; p = p->next)
1101 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1102 || !p->sym->attr.if_source)
1104 if (p->sym->attr.external)
1105 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1106 p->sym->name, interface_name, &p->sym->declared_at);
1108 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1109 "subroutine", p->sym->name, interface_name,
1110 &p->sym->declared_at);
1115 /* Remove duplicate interfaces in this interface list. */
1116 for (; p; p = p->next)
1120 for (q = p->next; q;)
1122 if (p->sym != q->sym)
1129 /* Duplicate interface. */
1130 qlast->next = q->next;
1141 /* Check lists of interfaces to make sure that no two interfaces are
1142 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1145 check_interface1 (gfc_interface *p, gfc_interface *q0,
1146 int generic_flag, const char *interface_name,
1150 for (; p; p = p->next)
1151 for (q = q0; q; q = q->next)
1153 if (p->sym == q->sym)
1154 continue; /* Duplicates OK here. */
1156 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1159 if (compare_interfaces (p->sym, q->sym, generic_flag))
1163 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1164 p->sym->name, q->sym->name, interface_name,
1168 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1169 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1170 p->sym->name, q->sym->name, interface_name,
1179 /* Check the generic and operator interfaces of symbols to make sure
1180 that none of the interfaces conflict. The check has to be done
1181 after all of the symbols are actually loaded. */
1184 check_sym_interfaces (gfc_symbol *sym)
1186 char interface_name[100];
1190 if (sym->ns != gfc_current_ns)
1193 if (sym->generic != NULL)
1195 sprintf (interface_name, "generic interface '%s'", sym->name);
1196 if (check_interface0 (sym->generic, interface_name))
1199 for (p = sym->generic; p; p = p->next)
1201 if (p->sym->attr.mod_proc
1202 && (p->sym->attr.if_source != IFSRC_DECL
1203 || p->sym->attr.procedure))
1205 gfc_error ("'%s' at %L is not a module procedure",
1206 p->sym->name, &p->where);
1211 /* Originally, this test was applied to host interfaces too;
1212 this is incorrect since host associated symbols, from any
1213 source, cannot be ambiguous with local symbols. */
1214 k = sym->attr.referenced || !sym->attr.use_assoc;
1215 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1216 sym->attr.ambiguous_interfaces = 1;
1222 check_uop_interfaces (gfc_user_op *uop)
1224 char interface_name[100];
1228 sprintf (interface_name, "operator interface '%s'", uop->name);
1229 if (check_interface0 (uop->operator, interface_name))
1232 for (ns = gfc_current_ns; ns; ns = ns->parent)
1234 uop2 = gfc_find_uop (uop->name, ns);
1238 check_interface1 (uop->operator, uop2->operator, 0,
1239 interface_name, true);
1244 /* For the namespace, check generic, user operator and intrinsic
1245 operator interfaces for consistency and to remove duplicate
1246 interfaces. We traverse the whole namespace, counting on the fact
1247 that most symbols will not have generic or operator interfaces. */
1250 gfc_check_interfaces (gfc_namespace *ns)
1252 gfc_namespace *old_ns, *ns2;
1253 char interface_name[100];
1256 old_ns = gfc_current_ns;
1257 gfc_current_ns = ns;
1259 gfc_traverse_ns (ns, check_sym_interfaces);
1261 gfc_traverse_user_op (ns, check_uop_interfaces);
1263 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1265 if (i == INTRINSIC_USER)
1268 if (i == INTRINSIC_ASSIGN)
1269 strcpy (interface_name, "intrinsic assignment operator");
1271 sprintf (interface_name, "intrinsic '%s' operator",
1274 if (check_interface0 (ns->operator[i], interface_name))
1277 check_operator_interface (ns->operator[i], i);
1279 for (ns2 = ns; ns2; ns2 = ns2->parent)
1281 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1282 interface_name, true))
1288 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
1289 0, interface_name, true)) goto done;
1292 case INTRINSIC_EQ_OS:
1293 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
1294 0, interface_name, true)) goto done;
1298 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
1299 0, interface_name, true)) goto done;
1302 case INTRINSIC_NE_OS:
1303 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
1304 0, interface_name, true)) goto done;
1308 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
1309 0, interface_name, true)) goto done;
1312 case INTRINSIC_GT_OS:
1313 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
1314 0, interface_name, true)) goto done;
1318 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
1319 0, interface_name, true)) goto done;
1322 case INTRINSIC_GE_OS:
1323 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
1324 0, interface_name, true)) goto done;
1328 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
1329 0, interface_name, true)) goto done;
1332 case INTRINSIC_LT_OS:
1333 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
1334 0, interface_name, true)) goto done;
1338 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
1339 0, interface_name, true)) goto done;
1342 case INTRINSIC_LE_OS:
1343 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
1344 0, interface_name, true)) goto done;
1354 gfc_current_ns = old_ns;
1359 symbol_rank (gfc_symbol *sym)
1361 return (sym->as == NULL) ? 0 : sym->as->rank;
1365 /* Given a symbol of a formal argument list and an expression, if the
1366 formal argument is allocatable, check that the actual argument is
1367 allocatable. Returns nonzero if compatible, zero if not compatible. */
1370 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1372 symbol_attribute attr;
1374 if (formal->attr.allocatable)
1376 attr = gfc_expr_attr (actual);
1377 if (!attr.allocatable)
1385 /* Given a symbol of a formal argument list and an expression, if the
1386 formal argument is a pointer, see if the actual argument is a
1387 pointer. Returns nonzero if compatible, zero if not compatible. */
1390 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1392 symbol_attribute attr;
1394 if (formal->attr.pointer)
1396 attr = gfc_expr_attr (actual);
1405 /* Given a symbol of a formal argument list and an expression, see if
1406 the two are compatible as arguments. Returns nonzero if
1407 compatible, zero if not compatible. */
1410 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1411 int ranks_must_agree, int is_elemental)
1415 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1416 procs c_f_pointer or c_f_procpointer, and we need to accept most
1417 pointers the user could give us. This should allow that. */
1418 if (formal->ts.type == BT_VOID)
1421 if (formal->ts.type == BT_DERIVED
1422 && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1423 && actual->ts.type == BT_DERIVED
1424 && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1427 if (actual->ts.type == BT_PROCEDURE)
1429 if (formal->attr.flavor != FL_PROCEDURE)
1432 if (formal->attr.function
1433 && !compare_type_rank (formal, actual->symtree->n.sym))
1436 if (formal->attr.if_source == IFSRC_UNKNOWN
1437 || actual->symtree->n.sym->attr.external)
1438 return 1; /* Assume match. */
1440 if (actual->symtree->n.sym->attr.intrinsic)
1441 return compare_intr_interfaces (formal, actual->symtree->n.sym);
1443 return compare_interfaces (formal, actual->symtree->n.sym, 0);
1446 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1447 && !gfc_compare_types (&formal->ts, &actual->ts))
1450 if (symbol_rank (formal) == actual->rank)
1453 /* At this point the ranks didn't agree. */
1454 if (ranks_must_agree || formal->attr.pointer)
1457 if (actual->rank != 0)
1458 return is_elemental || formal->attr.dimension;
1460 /* At this point, we are considering a scalar passed to an array.
1461 This is legal if the scalar is an array element of the right sort. */
1462 if (formal->as->type == AS_ASSUMED_SHAPE)
1465 for (ref = actual->ref; ref; ref = ref->next)
1466 if (ref->type == REF_SUBSTRING)
1469 for (ref = actual->ref; ref; ref = ref->next)
1470 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1474 return 0; /* Not an array element. */
1480 /* Given a symbol of a formal argument list and an expression, see if
1481 the two are compatible as arguments. Returns nonzero if
1482 compatible, zero if not compatible. */
1485 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1487 if (actual->expr_type != EXPR_VARIABLE)
1490 if (!actual->symtree->n.sym->attr.protected)
1493 if (!actual->symtree->n.sym->attr.use_assoc)
1496 if (formal->attr.intent == INTENT_IN
1497 || formal->attr.intent == INTENT_UNKNOWN)
1500 if (!actual->symtree->n.sym->attr.pointer)
1503 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1510 /* Returns the storage size of a symbol (formal argument) or
1511 zero if it cannot be determined. */
1513 static unsigned long
1514 get_sym_storage_size (gfc_symbol *sym)
1517 unsigned long strlen, elements;
1519 if (sym->ts.type == BT_CHARACTER)
1521 if (sym->ts.cl && sym->ts.cl->length
1522 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1523 strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1530 if (symbol_rank (sym) == 0)
1534 if (sym->as->type != AS_EXPLICIT)
1536 for (i = 0; i < sym->as->rank; i++)
1538 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1539 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1542 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1543 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1546 return strlen*elements;
1550 /* Returns the storage size of an expression (actual argument) or
1551 zero if it cannot be determined. For an array element, it returns
1552 the remaining size as the element sequence consists of all storage
1553 units of the actual argument up to the end of the array. */
1555 static unsigned long
1556 get_expr_storage_size (gfc_expr *e)
1559 long int strlen, elements;
1565 if (e->ts.type == BT_CHARACTER)
1567 if (e->ts.cl && e->ts.cl->length
1568 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1569 strlen = mpz_get_si (e->ts.cl->length->value.integer);
1570 else if (e->expr_type == EXPR_CONSTANT
1571 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1572 strlen = e->value.character.length;
1577 strlen = 1; /* Length per element. */
1579 if (e->rank == 0 && !e->ref)
1587 for (i = 0; i < e->rank; i++)
1588 elements *= mpz_get_si (e->shape[i]);
1589 return elements*strlen;
1592 for (ref = e->ref; ref; ref = ref->next)
1594 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1595 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1596 && ref->u.ar.as->upper)
1597 for (i = 0; i < ref->u.ar.dimen; i++)
1599 long int start, end, stride;
1602 if (ref->u.ar.stride[i])
1604 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1605 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1610 if (ref->u.ar.start[i])
1612 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1613 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1617 else if (ref->u.ar.as->lower[i]
1618 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1619 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1623 if (ref->u.ar.end[i])
1625 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1626 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1630 else if (ref->u.ar.as->upper[i]
1631 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1632 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1636 elements *= (end - start)/stride + 1L;
1638 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1639 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1640 for (i = 0; i < ref->u.ar.as->rank; i++)
1642 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1643 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1644 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1645 elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
1646 - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
1652 /* TODO: Determine the number of remaining elements in the element
1653 sequence for array element designators.
1654 See also get_array_index in data.c. */
1658 return elements*strlen;
1662 /* Given an expression, check whether it is an array section
1663 which has a vector subscript. If it has, one is returned,
1667 has_vector_subscript (gfc_expr *e)
1672 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1675 for (ref = e->ref; ref; ref = ref->next)
1676 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1677 for (i = 0; i < ref->u.ar.dimen; i++)
1678 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1685 /* Given formal and actual argument lists, see if they are compatible.
1686 If they are compatible, the actual argument list is sorted to
1687 correspond with the formal list, and elements for missing optional
1688 arguments are inserted. If WHERE pointer is nonnull, then we issue
1689 errors when things don't match instead of just returning the status
1693 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1694 int ranks_must_agree, int is_elemental, locus *where)
1696 gfc_actual_arglist **new, *a, *actual, temp;
1697 gfc_formal_arglist *f;
1700 unsigned long actual_size, formal_size;
1704 if (actual == NULL && formal == NULL)
1708 for (f = formal; f; f = f->next)
1711 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1713 for (i = 0; i < n; i++)
1720 for (a = actual; a; a = a->next, f = f->next)
1722 /* Look for keywords but ignore g77 extensions like %VAL. */
1723 if (a->name != NULL && a->name[0] != '%')
1726 for (f = formal; f; f = f->next, i++)
1730 if (strcmp (f->sym->name, a->name) == 0)
1737 gfc_error ("Keyword argument '%s' at %L is not in "
1738 "the procedure", a->name, &a->expr->where);
1745 gfc_error ("Keyword argument '%s' at %L is already associated "
1746 "with another actual argument", a->name,
1755 gfc_error ("More actual than formal arguments in procedure "
1756 "call at %L", where);
1761 if (f->sym == NULL && a->expr == NULL)
1767 gfc_error ("Missing alternate return spec in subroutine call "
1772 if (a->expr == NULL)
1775 gfc_error ("Unexpected alternate return spec in subroutine "
1776 "call at %L", where);
1780 rank_check = where != NULL && !is_elemental && f->sym->as
1781 && (f->sym->as->type == AS_ASSUMED_SHAPE
1782 || f->sym->as->type == AS_DEFERRED);
1784 if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
1785 && a->expr->rank == 0
1786 && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
1788 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1790 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
1791 "with array dummy argument '%s' at %L",
1792 f->sym->name, &a->expr->where);
1795 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1799 else if (!compare_parameter (f->sym, a->expr,
1800 ranks_must_agree || rank_check, is_elemental))
1803 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1804 f->sym->name, &a->expr->where);
1808 if (a->expr->ts.type == BT_CHARACTER
1809 && a->expr->ts.cl && a->expr->ts.cl->length
1810 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1811 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1812 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1814 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
1815 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1816 f->sym->ts.cl->length->value.integer) != 0))
1819 gfc_warning ("Character length mismatch between actual "
1820 "argument and pointer or allocatable dummy "
1821 "argument '%s' at %L",
1822 f->sym->name, &a->expr->where);
1827 actual_size = get_expr_storage_size (a->expr);
1828 formal_size = get_sym_storage_size (f->sym);
1829 if (actual_size != 0 && actual_size < formal_size)
1831 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1832 gfc_warning ("Character length of actual argument shorter "
1833 "than of dummy argument '%s' (%lu/%lu) at %L",
1834 f->sym->name, actual_size, formal_size,
1837 gfc_warning ("Actual argument contains too few "
1838 "elements for dummy argument '%s' (%lu/%lu) at %L",
1839 f->sym->name, actual_size, formal_size,
1844 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1845 provided for a procedure formal argument. */
1846 if (a->expr->ts.type != BT_PROCEDURE
1847 && a->expr->expr_type == EXPR_VARIABLE
1848 && f->sym->attr.flavor == FL_PROCEDURE)
1851 gfc_error ("Expected a procedure for argument '%s' at %L",
1852 f->sym->name, &a->expr->where);
1856 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1857 && a->expr->ts.type == BT_PROCEDURE
1858 && !a->expr->symtree->n.sym->attr.pure)
1861 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1862 f->sym->name, &a->expr->where);
1866 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1867 && a->expr->expr_type == EXPR_VARIABLE
1868 && a->expr->symtree->n.sym->as
1869 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1870 && (a->expr->ref == NULL
1871 || (a->expr->ref->type == REF_ARRAY
1872 && a->expr->ref->u.ar.type == AR_FULL)))
1875 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1876 " array at %L", f->sym->name, where);
1880 if (a->expr->expr_type != EXPR_NULL
1881 && compare_pointer (f->sym, a->expr) == 0)
1884 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1885 f->sym->name, &a->expr->where);
1889 if (a->expr->expr_type != EXPR_NULL
1890 && compare_allocatable (f->sym, a->expr) == 0)
1893 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1894 f->sym->name, &a->expr->where);
1898 /* Check intent = OUT/INOUT for definable actual argument. */
1899 if (a->expr->expr_type != EXPR_VARIABLE
1900 && (f->sym->attr.intent == INTENT_OUT
1901 || f->sym->attr.intent == INTENT_INOUT))
1904 gfc_error ("Actual argument at %L must be definable to "
1905 "match dummy INTENT = OUT/INOUT", &a->expr->where);
1909 if (!compare_parameter_protected(f->sym, a->expr))
1912 gfc_error ("Actual argument at %L is use-associated with "
1913 "PROTECTED attribute and dummy argument '%s' is "
1914 "INTENT = OUT/INOUT",
1915 &a->expr->where,f->sym->name);
1919 if ((f->sym->attr.intent == INTENT_OUT
1920 || f->sym->attr.intent == INTENT_INOUT
1921 || f->sym->attr.volatile_)
1922 && has_vector_subscript (a->expr))
1925 gfc_error ("Array-section actual argument with vector subscripts "
1926 "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1927 "or VOLATILE attribute of the dummy argument '%s'",
1928 &a->expr->where, f->sym->name);
1932 /* C1232 (R1221) For an actual argument which is an array section or
1933 an assumed-shape array, the dummy argument shall be an assumed-
1934 shape array, if the dummy argument has the VOLATILE attribute. */
1936 if (f->sym->attr.volatile_
1937 && a->expr->symtree->n.sym->as
1938 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1939 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1942 gfc_error ("Assumed-shape actual argument at %L is "
1943 "incompatible with the non-assumed-shape "
1944 "dummy argument '%s' due to VOLATILE attribute",
1945 &a->expr->where,f->sym->name);
1949 if (f->sym->attr.volatile_
1950 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1951 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1954 gfc_error ("Array-section actual argument at %L is "
1955 "incompatible with the non-assumed-shape "
1956 "dummy argument '%s' due to VOLATILE attribute",
1957 &a->expr->where,f->sym->name);
1961 /* C1233 (R1221) For an actual argument which is a pointer array, the
1962 dummy argument shall be an assumed-shape or pointer array, if the
1963 dummy argument has the VOLATILE attribute. */
1965 if (f->sym->attr.volatile_
1966 && a->expr->symtree->n.sym->attr.pointer
1967 && a->expr->symtree->n.sym->as
1969 && (f->sym->as->type == AS_ASSUMED_SHAPE
1970 || f->sym->attr.pointer)))
1973 gfc_error ("Pointer-array actual argument at %L requires "
1974 "an assumed-shape or pointer-array dummy "
1975 "argument '%s' due to VOLATILE attribute",
1976 &a->expr->where,f->sym->name);
1987 /* Make sure missing actual arguments are optional. */
1989 for (f = formal; f; f = f->next, i++)
1996 gfc_error ("Missing alternate return spec in subroutine call "
2000 if (!f->sym->attr.optional)
2003 gfc_error ("Missing actual argument for argument '%s' at %L",
2004 f->sym->name, where);
2009 /* The argument lists are compatible. We now relink a new actual
2010 argument list with null arguments in the right places. The head
2011 of the list remains the head. */
2012 for (i = 0; i < n; i++)
2014 new[i] = gfc_get_actual_arglist ();
2027 for (i = 0; i < n - 1; i++)
2028 new[i]->next = new[i + 1];
2030 new[i]->next = NULL;
2032 if (*ap == NULL && n > 0)
2035 /* Note the types of omitted optional arguments. */
2036 for (a = actual, f = formal; a; a = a->next, f = f->next)
2037 if (a->expr == NULL && a->label == NULL)
2038 a->missing_arg_type = f->sym->ts.type;
2046 gfc_formal_arglist *f;
2047 gfc_actual_arglist *a;
2051 /* qsort comparison function for argument pairs, with the following
2053 - p->a->expr == NULL
2054 - p->a->expr->expr_type != EXPR_VARIABLE
2055 - growing p->a->expr->symbol. */
2058 pair_cmp (const void *p1, const void *p2)
2060 const gfc_actual_arglist *a1, *a2;
2062 /* *p1 and *p2 are elements of the to-be-sorted array. */
2063 a1 = ((const argpair *) p1)->a;
2064 a2 = ((const argpair *) p2)->a;
2073 if (a1->expr->expr_type != EXPR_VARIABLE)
2075 if (a2->expr->expr_type != EXPR_VARIABLE)
2079 if (a2->expr->expr_type != EXPR_VARIABLE)
2081 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2085 /* Given two expressions from some actual arguments, test whether they
2086 refer to the same expression. The analysis is conservative.
2087 Returning FAILURE will produce no warning. */
2090 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2092 const gfc_ref *r1, *r2;
2095 || e1->expr_type != EXPR_VARIABLE
2096 || e2->expr_type != EXPR_VARIABLE
2097 || e1->symtree->n.sym != e2->symtree->n.sym)
2100 /* TODO: improve comparison, see expr.c:show_ref(). */
2101 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2103 if (r1->type != r2->type)
2108 if (r1->u.ar.type != r2->u.ar.type)
2110 /* TODO: At the moment, consider only full arrays;
2111 we could do better. */
2112 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2117 if (r1->u.c.component != r2->u.c.component)
2125 gfc_internal_error ("compare_actual_expr(): Bad component code");
2134 /* Given formal and actual argument lists that correspond to one
2135 another, check that identical actual arguments aren't not
2136 associated with some incompatible INTENTs. */
2139 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2141 sym_intent f1_intent, f2_intent;
2142 gfc_formal_arglist *f1;
2143 gfc_actual_arglist *a1;
2149 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2151 if (f1 == NULL && a1 == NULL)
2153 if (f1 == NULL || a1 == NULL)
2154 gfc_internal_error ("check_some_aliasing(): List mismatch");
2159 p = (argpair *) alloca (n * sizeof (argpair));
2161 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2167 qsort (p, n, sizeof (argpair), pair_cmp);
2169 for (i = 0; i < n; i++)
2172 || p[i].a->expr->expr_type != EXPR_VARIABLE
2173 || p[i].a->expr->ts.type == BT_PROCEDURE)
2175 f1_intent = p[i].f->sym->attr.intent;
2176 for (j = i + 1; j < n; j++)
2178 /* Expected order after the sort. */
2179 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2180 gfc_internal_error ("check_some_aliasing(): corrupted data");
2182 /* Are the expression the same? */
2183 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2185 f2_intent = p[j].f->sym->attr.intent;
2186 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2187 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2189 gfc_warning ("Same actual argument associated with INTENT(%s) "
2190 "argument '%s' and INTENT(%s) argument '%s' at %L",
2191 gfc_intent_string (f1_intent), p[i].f->sym->name,
2192 gfc_intent_string (f2_intent), p[j].f->sym->name,
2193 &p[i].a->expr->where);
2203 /* Given a symbol of a formal argument list and an expression,
2204 return nonzero if their intents are compatible, zero otherwise. */
2207 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2209 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2212 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2215 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2222 /* Given formal and actual argument lists that correspond to one
2223 another, check that they are compatible in the sense that intents
2224 are not mismatched. */
2227 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2229 sym_intent f_intent;
2231 for (;; f = f->next, a = a->next)
2233 if (f == NULL && a == NULL)
2235 if (f == NULL || a == NULL)
2236 gfc_internal_error ("check_intents(): List mismatch");
2238 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2241 f_intent = f->sym->attr.intent;
2243 if (!compare_parameter_intent(f->sym, a->expr))
2245 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2246 "specifies INTENT(%s)", &a->expr->where,
2247 gfc_intent_string (f_intent));
2251 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2253 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2255 gfc_error ("Procedure argument at %L is local to a PURE "
2256 "procedure and is passed to an INTENT(%s) argument",
2257 &a->expr->where, gfc_intent_string (f_intent));
2261 if (a->expr->symtree->n.sym->attr.pointer)
2263 gfc_error ("Procedure argument at %L is local to a PURE "
2264 "procedure and has the POINTER attribute",
2275 /* Check how a procedure is used against its interface. If all goes
2276 well, the actual argument list will also end up being properly
2280 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2283 /* Warn about calls with an implicit interface. */
2284 if (gfc_option.warn_implicit_interface
2285 && sym->attr.if_source == IFSRC_UNKNOWN)
2286 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2289 if (sym->interface && sym->interface->attr.intrinsic)
2291 gfc_intrinsic_sym *isym;
2292 isym = gfc_find_function (sym->interface->name);
2295 if (compare_actual_formal_intr (ap, sym->interface))
2297 gfc_error ("Type/rank mismatch in argument '%s' at %L",
2303 if (sym->attr.if_source == IFSRC_UNKNOWN
2304 || !compare_actual_formal (ap, sym->formal, 0,
2305 sym->attr.elemental, where))
2308 check_intents (sym->formal, *ap);
2309 if (gfc_option.warn_aliasing)
2310 check_some_aliasing (sym->formal, *ap);
2314 /* Given an interface pointer and an actual argument list, search for
2315 a formal argument list that matches the actual. If found, returns
2316 a pointer to the symbol of the correct interface. Returns NULL if
2320 gfc_search_interface (gfc_interface *intr, int sub_flag,
2321 gfc_actual_arglist **ap)
2325 for (; intr; intr = intr->next)
2327 if (sub_flag && intr->sym->attr.function)
2329 if (!sub_flag && intr->sym->attr.subroutine)
2332 r = !intr->sym->attr.elemental;
2334 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
2336 check_intents (intr->sym->formal, *ap);
2337 if (gfc_option.warn_aliasing)
2338 check_some_aliasing (intr->sym->formal, *ap);
2347 /* Do a brute force recursive search for a symbol. */
2349 static gfc_symtree *
2350 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2354 if (root->n.sym == sym)
2359 st = find_symtree0 (root->left, sym);
2360 if (root->right && ! st)
2361 st = find_symtree0 (root->right, sym);
2366 /* Find a symtree for a symbol. */
2368 static gfc_symtree *
2369 find_sym_in_symtree (gfc_symbol *sym)
2374 /* First try to find it by name. */
2375 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2376 if (st && st->n.sym == sym)
2379 /* If it's been renamed, resort to a brute-force search. */
2380 /* TODO: avoid having to do this search. If the symbol doesn't exist
2381 in the symtree for the current namespace, it should probably be added. */
2382 for (ns = gfc_current_ns; ns; ns = ns->parent)
2384 st = find_symtree0 (ns->sym_root, sym);
2388 gfc_internal_error ("Unable to find symbol %s", sym->name);
2393 /* This subroutine is called when an expression is being resolved.
2394 The expression node in question is either a user defined operator
2395 or an intrinsic operator with arguments that aren't compatible
2396 with the operator. This subroutine builds an actual argument list
2397 corresponding to the operands, then searches for a compatible
2398 interface. If one is found, the expression node is replaced with
2399 the appropriate function call. */
2402 gfc_extend_expr (gfc_expr *e)
2404 gfc_actual_arglist *actual;
2412 actual = gfc_get_actual_arglist ();
2413 actual->expr = e->value.op.op1;
2415 if (e->value.op.op2 != NULL)
2417 actual->next = gfc_get_actual_arglist ();
2418 actual->next->expr = e->value.op.op2;
2421 i = fold_unary (e->value.op.operator);
2423 if (i == INTRINSIC_USER)
2425 for (ns = gfc_current_ns; ns; ns = ns->parent)
2427 uop = gfc_find_uop (e->value.op.uop->name, ns);
2431 sym = gfc_search_interface (uop->operator, 0, &actual);
2438 for (ns = gfc_current_ns; ns; ns = ns->parent)
2440 /* Due to the distinction between '==' and '.eq.' and friends, one has
2441 to check if either is defined. */
2445 case INTRINSIC_EQ_OS:
2446 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
2448 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
2452 case INTRINSIC_NE_OS:
2453 sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
2455 sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
2459 case INTRINSIC_GT_OS:
2460 sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
2462 sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
2466 case INTRINSIC_GE_OS:
2467 sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
2469 sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
2473 case INTRINSIC_LT_OS:
2474 sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
2476 sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
2480 case INTRINSIC_LE_OS:
2481 sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
2483 sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
2487 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2497 /* Don't use gfc_free_actual_arglist(). */
2498 if (actual->next != NULL)
2499 gfc_free (actual->next);
2505 /* Change the expression node to a function call. */
2506 e->expr_type = EXPR_FUNCTION;
2507 e->symtree = find_sym_in_symtree (sym);
2508 e->value.function.actual = actual;
2509 e->value.function.esym = NULL;
2510 e->value.function.isym = NULL;
2511 e->value.function.name = NULL;
2513 if (gfc_pure (NULL) && !gfc_pure (sym))
2515 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2516 "be PURE", sym->name, &e->where);
2520 if (gfc_resolve_expr (e) == FAILURE)
2527 /* Tries to replace an assignment code node with a subroutine call to
2528 the subroutine associated with the assignment operator. Return
2529 SUCCESS if the node was replaced. On FAILURE, no error is
2533 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2535 gfc_actual_arglist *actual;
2536 gfc_expr *lhs, *rhs;
2542 /* Don't allow an intrinsic assignment to be replaced. */
2543 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2544 && (lhs->ts.type == rhs->ts.type
2545 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2548 actual = gfc_get_actual_arglist ();
2551 actual->next = gfc_get_actual_arglist ();
2552 actual->next->expr = rhs;
2556 for (; ns; ns = ns->parent)
2558 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2565 gfc_free (actual->next);
2570 /* Replace the assignment with the call. */
2571 c->op = EXEC_ASSIGN_CALL;
2572 c->symtree = find_sym_in_symtree (sym);
2575 c->ext.actual = actual;
2581 /* Make sure that the interface just parsed is not already present in
2582 the given interface list. Ambiguity isn't checked yet since module
2583 procedures can be present without interfaces. */
2586 check_new_interface (gfc_interface *base, gfc_symbol *new)
2590 for (ip = base; ip; ip = ip->next)
2594 gfc_error ("Entity '%s' at %C is already present in the interface",
2604 /* Add a symbol to the current interface. */
2607 gfc_add_interface (gfc_symbol *new)
2609 gfc_interface **head, *intr;
2613 switch (current_interface.type)
2615 case INTERFACE_NAMELESS:
2616 case INTERFACE_ABSTRACT:
2619 case INTERFACE_INTRINSIC_OP:
2620 for (ns = current_interface.ns; ns; ns = ns->parent)
2621 switch (current_interface.op)
2624 case INTRINSIC_EQ_OS:
2625 if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
2626 check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
2631 case INTRINSIC_NE_OS:
2632 if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
2633 check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
2638 case INTRINSIC_GT_OS:
2639 if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
2640 check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
2645 case INTRINSIC_GE_OS:
2646 if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
2647 check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
2652 case INTRINSIC_LT_OS:
2653 if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
2654 check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
2659 case INTRINSIC_LE_OS:
2660 if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
2661 check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
2666 if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
2670 head = ¤t_interface.ns->operator[current_interface.op];
2673 case INTERFACE_GENERIC:
2674 for (ns = current_interface.ns; ns; ns = ns->parent)
2676 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2680 if (check_new_interface (sym->generic, new) == FAILURE)
2684 head = ¤t_interface.sym->generic;
2687 case INTERFACE_USER_OP:
2688 if (check_new_interface (current_interface.uop->operator, new)
2692 head = ¤t_interface.uop->operator;
2696 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2699 intr = gfc_get_interface ();
2701 intr->where = gfc_current_locus;
2711 gfc_current_interface_head (void)
2713 switch (current_interface.type)
2715 case INTERFACE_INTRINSIC_OP:
2716 return current_interface.ns->operator[current_interface.op];
2719 case INTERFACE_GENERIC:
2720 return current_interface.sym->generic;
2723 case INTERFACE_USER_OP:
2724 return current_interface.uop->operator;
2734 gfc_set_current_interface_head (gfc_interface *i)
2736 switch (current_interface.type)
2738 case INTERFACE_INTRINSIC_OP:
2739 current_interface.ns->operator[current_interface.op] = i;
2742 case INTERFACE_GENERIC:
2743 current_interface.sym->generic = i;
2746 case INTERFACE_USER_OP:
2747 current_interface.uop->operator = i;
2756 /* Gets rid of a formal argument list. We do not free symbols.
2757 Symbols are freed when a namespace is freed. */
2760 gfc_free_formal_arglist (gfc_formal_arglist *p)
2762 gfc_formal_arglist *q;