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 /* Make sure that link lists do not put this function into an
411 endless recursive loop! */
412 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
413 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
414 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
417 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
418 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
421 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
422 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
428 if (dt1 == NULL && dt2 == NULL)
430 if (dt1 == NULL || dt2 == NULL)
438 /* Compare two typespecs, recursively if necessary. */
441 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
443 /* See if one of the typespecs is a BT_VOID, which is what is being used
444 to allow the funcs like c_f_pointer to accept any pointer type.
445 TODO: Possibly should narrow this to just the one typespec coming in
446 that is for the formal arg, but oh well. */
447 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
450 if (ts1->type != ts2->type)
452 if (ts1->type != BT_DERIVED)
453 return (ts1->kind == ts2->kind);
455 /* Compare derived types. */
456 if (ts1->derived == ts2->derived)
459 return gfc_compare_derived_types (ts1->derived ,ts2->derived);
463 /* Given two symbols that are formal arguments, compare their ranks
464 and types. Returns nonzero if they have the same rank and type,
468 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
472 r1 = (s1->as != NULL) ? s1->as->rank : 0;
473 r2 = (s2->as != NULL) ? s2->as->rank : 0;
476 return 0; /* Ranks differ. */
478 return gfc_compare_types (&s1->ts, &s2->ts);
482 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
483 static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
485 /* Given two symbols that are formal arguments, compare their types
486 and rank and their formal interfaces if they are both dummy
487 procedures. Returns nonzero if the same, zero if different. */
490 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
492 if (s1 == NULL || s2 == NULL)
493 return s1 == s2 ? 1 : 0;
495 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
496 return compare_type_rank (s1, s2);
498 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
501 /* At this point, both symbols are procedures. */
502 if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
503 || (s2->attr.function == 0 && s2->attr.subroutine == 0))
506 if (s1->attr.function != s2->attr.function
507 || s1->attr.subroutine != s2->attr.subroutine)
510 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
513 /* Originally, gfortran recursed here to check the interfaces of passed
514 procedures. This is explicitly not required by the standard. */
519 /* Given a formal argument list and a keyword name, search the list
520 for that keyword. Returns the correct symbol node if found, NULL
524 find_keyword_arg (const char *name, gfc_formal_arglist *f)
526 for (; f; f = f->next)
527 if (strcmp (f->sym->name, name) == 0)
534 /******** Interface checking subroutines **********/
537 /* Given an operator interface and the operator, make sure that all
538 interfaces for that operator are legal. */
541 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
543 gfc_formal_arglist *formal;
547 int args, r1, r2, k1, k2;
553 t1 = t2 = BT_UNKNOWN;
554 i1 = i2 = INTENT_UNKNOWN;
558 for (formal = intr->sym->formal; formal; formal = formal->next)
563 gfc_error ("Alternate return cannot appear in operator "
564 "interface at %L", &intr->where);
570 i1 = sym->attr.intent;
571 r1 = (sym->as != NULL) ? sym->as->rank : 0;
577 i2 = sym->attr.intent;
578 r2 = (sym->as != NULL) ? sym->as->rank : 0;
586 /* Only +, - and .not. can be unary operators.
587 .not. cannot be a binary operator. */
588 if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
589 && operator != INTRINSIC_MINUS
590 && operator != INTRINSIC_NOT)
591 || (args == 2 && operator == INTRINSIC_NOT))
593 gfc_error ("Operator interface at %L has the wrong number of arguments",
598 /* Check that intrinsics are mapped to functions, except
599 INTRINSIC_ASSIGN which should map to a subroutine. */
600 if (operator == INTRINSIC_ASSIGN)
602 if (!sym->attr.subroutine)
604 gfc_error ("Assignment operator interface at %L must be "
605 "a SUBROUTINE", &intr->where);
610 gfc_error ("Assignment operator interface at %L must have "
611 "two arguments", &intr->where);
614 if (sym->formal->sym->ts.type != BT_DERIVED
615 && sym->formal->next->sym->ts.type != BT_DERIVED
616 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
617 || (gfc_numeric_ts (&sym->formal->sym->ts)
618 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
620 gfc_error ("Assignment operator interface at %L must not redefine "
621 "an INTRINSIC type assignment", &intr->where);
627 if (!sym->attr.function)
629 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
635 /* Check intents on operator interfaces. */
636 if (operator == INTRINSIC_ASSIGN)
638 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
639 gfc_error ("First argument of defined assignment at %L must be "
640 "INTENT(IN) or INTENT(INOUT)", &intr->where);
643 gfc_error ("Second argument of defined assignment at %L must be "
644 "INTENT(IN)", &intr->where);
649 gfc_error ("First argument of operator interface at %L must be "
650 "INTENT(IN)", &intr->where);
652 if (args == 2 && i2 != INTENT_IN)
653 gfc_error ("Second argument of operator interface at %L must be "
654 "INTENT(IN)", &intr->where);
657 /* From now on, all we have to do is check that the operator definition
658 doesn't conflict with an intrinsic operator. The rules for this
659 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
660 as well as 12.3.2.1.1 of Fortran 2003:
662 "If the operator is an intrinsic-operator (R310), the number of
663 function arguments shall be consistent with the intrinsic uses of
664 that operator, and the types, kind type parameters, or ranks of the
665 dummy arguments shall differ from those required for the intrinsic
666 operation (7.1.2)." */
668 #define IS_NUMERIC_TYPE(t) \
669 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
671 /* Unary ops are easy, do them first. */
672 if (operator == INTRINSIC_NOT)
674 if (t1 == BT_LOGICAL)
680 if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
682 if (IS_NUMERIC_TYPE (t1))
688 /* Character intrinsic operators have same character kind, thus
689 operator definitions with operands of different character kinds
691 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
694 /* Intrinsic operators always perform on arguments of same rank,
695 so different ranks is also always safe. (rank == 0) is an exception
696 to that, because all intrinsic operators are elemental. */
697 if (r1 != r2 && r1 != 0 && r2 != 0)
703 case INTRINSIC_EQ_OS:
705 case INTRINSIC_NE_OS:
706 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
711 case INTRINSIC_MINUS:
712 case INTRINSIC_TIMES:
713 case INTRINSIC_DIVIDE:
714 case INTRINSIC_POWER:
715 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
720 case INTRINSIC_GT_OS:
722 case INTRINSIC_GE_OS:
724 case INTRINSIC_LT_OS:
726 case INTRINSIC_LE_OS:
727 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
729 if ((t1 == BT_INTEGER || t1 == BT_REAL)
730 && (t2 == BT_INTEGER || t2 == BT_REAL))
734 case INTRINSIC_CONCAT:
735 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
743 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
753 #undef IS_NUMERIC_TYPE
756 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
762 /* Given a pair of formal argument lists, we see if the two lists can
763 be distinguished by counting the number of nonoptional arguments of
764 a given type/rank in f1 and seeing if there are less then that
765 number of those arguments in f2 (including optional arguments).
766 Since this test is asymmetric, it has to be called twice to make it
767 symmetric. Returns nonzero if the argument lists are incompatible
768 by this test. This subroutine implements rule 1 of section
772 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
774 int rc, ac1, ac2, i, j, k, n1;
775 gfc_formal_arglist *f;
788 for (f = f1; f; f = f->next)
791 /* Build an array of integers that gives the same integer to
792 arguments of the same type/rank. */
793 arg = gfc_getmem (n1 * sizeof (arginfo));
796 for (i = 0; i < n1; i++, f = f->next)
804 for (i = 0; i < n1; i++)
806 if (arg[i].flag != -1)
809 if (arg[i].sym && arg[i].sym->attr.optional)
810 continue; /* Skip optional arguments. */
814 /* Find other nonoptional arguments of the same type/rank. */
815 for (j = i + 1; j < n1; j++)
816 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
817 && compare_type_rank_if (arg[i].sym, arg[j].sym))
823 /* Now loop over each distinct type found in f1. */
827 for (i = 0; i < n1; i++)
829 if (arg[i].flag != k)
833 for (j = i + 1; j < n1; j++)
834 if (arg[j].flag == k)
837 /* Count the number of arguments in f2 with that type, including
838 those that are optional. */
841 for (f = f2; f; f = f->next)
842 if (compare_type_rank_if (arg[i].sym, f->sym))
860 /* Perform the abbreviated correspondence test for operators. The
861 arguments cannot be optional and are always ordered correctly,
862 which makes this test much easier than that for generic tests.
864 This subroutine is also used when comparing a formal and actual
865 argument list when an actual parameter is a dummy procedure. At
866 that point, two formal interfaces must be compared for equality
867 which is what happens here. */
870 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
874 if (f1 == NULL && f2 == NULL)
876 if (f1 == NULL || f2 == NULL)
879 if (!compare_type_rank (f1->sym, f2->sym))
890 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
891 Returns zero if no argument is found that satisfies rule 2, nonzero
894 This test is also not symmetric in f1 and f2 and must be called
895 twice. This test finds problems caused by sorting the actual
896 argument list with keywords. For example:
900 INTEGER :: A ; REAL :: B
904 INTEGER :: A ; REAL :: B
908 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
911 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
913 gfc_formal_arglist *f2_save, *g;
920 if (f1->sym->attr.optional)
923 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
926 /* Now search for a disambiguating keyword argument starting at
927 the current non-match. */
928 for (g = f1; g; g = g->next)
930 if (g->sym->attr.optional)
933 sym = find_keyword_arg (g->sym->name, f2_save);
934 if (sym == NULL || !compare_type_rank (g->sym, sym))
948 /* 'Compare' two formal interfaces associated with a pair of symbols.
949 We return nonzero if there exists an actual argument list that
950 would be ambiguous between the two interfaces, zero otherwise. */
953 compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
955 gfc_formal_arglist *f1, *f2;
957 if (s1->attr.function != s2->attr.function
958 || s1->attr.subroutine != s2->attr.subroutine)
959 return 0; /* Disagreement between function/subroutine. */
964 if (f1 == NULL && f2 == NULL)
965 return 1; /* Special case. */
967 if (count_types_test (f1, f2))
969 if (count_types_test (f2, f1))
974 if (generic_correspondence (f1, f2))
976 if (generic_correspondence (f2, f1))
981 if (operator_correspondence (f1, f2))
990 compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
992 gfc_formal_arglist *f, *f1;
993 gfc_intrinsic_arg *fi, *f2;
994 gfc_intrinsic_sym *isym;
996 if (s1->attr.function != s2->attr.function
997 || s1->attr.subroutine != s2->attr.subroutine)
998 return 0; /* Disagreement between function/subroutine. */
1000 /* If the arguments are functions, check type and kind. */
1002 if (s1->attr.dummy && s1->attr.function && s2->attr.function)
1004 if (s1->ts.type != s2->ts.type)
1006 if (s1->ts.kind != s2->ts.kind)
1008 if (s1->attr.if_source == IFSRC_DECL)
1012 isym = gfc_find_function (s2->name);
1014 /* This should already have been checked in
1015 resolve.c (resolve_actual_arglist). */
1022 if (f1 == NULL && f2 == NULL)
1025 /* First scan through the formal argument list and check the intrinsic. */
1027 for (f = f1; f; f = f->next)
1031 if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
1036 /* Now scan through the intrinsic argument list and check the formal. */
1038 for (fi = f2; fi; fi = fi->next)
1042 if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
1051 /* Compare an actual argument list with an intrinsic argument list. */
1054 compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
1056 gfc_actual_arglist *a;
1057 gfc_intrinsic_arg *fi, *f2;
1058 gfc_intrinsic_sym *isym;
1060 isym = gfc_find_function (s2->name);
1062 /* This should already have been checked in
1063 resolve.c (resolve_actual_arglist). */
1069 if (*ap == NULL && f2 == NULL)
1072 /* First scan through the actual argument list and check the intrinsic. */
1074 for (a = *ap; a; a = a->next)
1078 if ((fi->ts.type != a->expr->ts.type)
1079 || (fi->ts.kind != a->expr->ts.kind))
1084 /* Now scan through the intrinsic argument list and check the formal. */
1086 for (fi = f2; fi; fi = fi->next)
1090 if ((fi->ts.type != a->expr->ts.type)
1091 || (fi->ts.kind != a->expr->ts.kind))
1100 /* Given a pointer to an interface pointer, remove duplicate
1101 interfaces and make sure that all symbols are either functions or
1102 subroutines. Returns nonzero if something goes wrong. */
1105 check_interface0 (gfc_interface *p, const char *interface_name)
1107 gfc_interface *psave, *q, *qlast;
1110 /* Make sure all symbols in the interface have been defined as
1111 functions or subroutines. */
1112 for (; p; p = p->next)
1113 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1114 || !p->sym->attr.if_source)
1116 if (p->sym->attr.external)
1117 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1118 p->sym->name, interface_name, &p->sym->declared_at);
1120 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1121 "subroutine", p->sym->name, interface_name,
1122 &p->sym->declared_at);
1127 /* Remove duplicate interfaces in this interface list. */
1128 for (; p; p = p->next)
1132 for (q = p->next; q;)
1134 if (p->sym != q->sym)
1141 /* Duplicate interface. */
1142 qlast->next = q->next;
1153 /* Check lists of interfaces to make sure that no two interfaces are
1154 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1157 check_interface1 (gfc_interface *p, gfc_interface *q0,
1158 int generic_flag, const char *interface_name,
1162 for (; p; p = p->next)
1163 for (q = q0; q; q = q->next)
1165 if (p->sym == q->sym)
1166 continue; /* Duplicates OK here. */
1168 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1171 if (compare_interfaces (p->sym, q->sym, generic_flag))
1175 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1176 p->sym->name, q->sym->name, interface_name,
1180 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1181 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1182 p->sym->name, q->sym->name, interface_name,
1191 /* Check the generic and operator interfaces of symbols to make sure
1192 that none of the interfaces conflict. The check has to be done
1193 after all of the symbols are actually loaded. */
1196 check_sym_interfaces (gfc_symbol *sym)
1198 char interface_name[100];
1202 if (sym->ns != gfc_current_ns)
1205 if (sym->generic != NULL)
1207 sprintf (interface_name, "generic interface '%s'", sym->name);
1208 if (check_interface0 (sym->generic, interface_name))
1211 for (p = sym->generic; p; p = p->next)
1213 if (p->sym->attr.mod_proc
1214 && (p->sym->attr.if_source != IFSRC_DECL
1215 || p->sym->attr.procedure))
1217 gfc_error ("'%s' at %L is not a module procedure",
1218 p->sym->name, &p->where);
1223 /* Originally, this test was applied to host interfaces too;
1224 this is incorrect since host associated symbols, from any
1225 source, cannot be ambiguous with local symbols. */
1226 k = sym->attr.referenced || !sym->attr.use_assoc;
1227 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1228 sym->attr.ambiguous_interfaces = 1;
1234 check_uop_interfaces (gfc_user_op *uop)
1236 char interface_name[100];
1240 sprintf (interface_name, "operator interface '%s'", uop->name);
1241 if (check_interface0 (uop->operator, interface_name))
1244 for (ns = gfc_current_ns; ns; ns = ns->parent)
1246 uop2 = gfc_find_uop (uop->name, ns);
1250 check_interface1 (uop->operator, uop2->operator, 0,
1251 interface_name, true);
1256 /* For the namespace, check generic, user operator and intrinsic
1257 operator interfaces for consistency and to remove duplicate
1258 interfaces. We traverse the whole namespace, counting on the fact
1259 that most symbols will not have generic or operator interfaces. */
1262 gfc_check_interfaces (gfc_namespace *ns)
1264 gfc_namespace *old_ns, *ns2;
1265 char interface_name[100];
1268 old_ns = gfc_current_ns;
1269 gfc_current_ns = ns;
1271 gfc_traverse_ns (ns, check_sym_interfaces);
1273 gfc_traverse_user_op (ns, check_uop_interfaces);
1275 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1277 if (i == INTRINSIC_USER)
1280 if (i == INTRINSIC_ASSIGN)
1281 strcpy (interface_name, "intrinsic assignment operator");
1283 sprintf (interface_name, "intrinsic '%s' operator",
1286 if (check_interface0 (ns->operator[i], interface_name))
1289 check_operator_interface (ns->operator[i], i);
1291 for (ns2 = ns; ns2; ns2 = ns2->parent)
1293 if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1294 interface_name, true))
1300 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
1301 0, interface_name, true)) goto done;
1304 case INTRINSIC_EQ_OS:
1305 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
1306 0, interface_name, true)) goto done;
1310 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
1311 0, interface_name, true)) goto done;
1314 case INTRINSIC_NE_OS:
1315 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
1316 0, interface_name, true)) goto done;
1320 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
1321 0, interface_name, true)) goto done;
1324 case INTRINSIC_GT_OS:
1325 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
1326 0, interface_name, true)) goto done;
1330 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
1331 0, interface_name, true)) goto done;
1334 case INTRINSIC_GE_OS:
1335 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
1336 0, interface_name, true)) goto done;
1340 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
1341 0, interface_name, true)) goto done;
1344 case INTRINSIC_LT_OS:
1345 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
1346 0, interface_name, true)) goto done;
1350 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
1351 0, interface_name, true)) goto done;
1354 case INTRINSIC_LE_OS:
1355 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
1356 0, interface_name, true)) goto done;
1366 gfc_current_ns = old_ns;
1371 symbol_rank (gfc_symbol *sym)
1373 return (sym->as == NULL) ? 0 : sym->as->rank;
1377 /* Given a symbol of a formal argument list and an expression, if the
1378 formal argument is allocatable, check that the actual argument is
1379 allocatable. Returns nonzero if compatible, zero if not compatible. */
1382 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1384 symbol_attribute attr;
1386 if (formal->attr.allocatable)
1388 attr = gfc_expr_attr (actual);
1389 if (!attr.allocatable)
1397 /* Given a symbol of a formal argument list and an expression, if the
1398 formal argument is a pointer, see if the actual argument is a
1399 pointer. Returns nonzero if compatible, zero if not compatible. */
1402 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1404 symbol_attribute attr;
1406 if (formal->attr.pointer)
1408 attr = gfc_expr_attr (actual);
1417 /* Given a symbol of a formal argument list and an expression, see if
1418 the two are compatible as arguments. Returns nonzero if
1419 compatible, zero if not compatible. */
1422 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1423 int ranks_must_agree, int is_elemental, locus *where)
1428 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1429 procs c_f_pointer or c_f_procpointer, and we need to accept most
1430 pointers the user could give us. This should allow that. */
1431 if (formal->ts.type == BT_VOID)
1434 if (formal->ts.type == BT_DERIVED
1435 && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1436 && actual->ts.type == BT_DERIVED
1437 && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1440 if (actual->ts.type == BT_PROCEDURE)
1442 if (formal->attr.flavor != FL_PROCEDURE)
1445 if (formal->attr.function
1446 && !compare_type_rank (formal, actual->symtree->n.sym))
1449 if (formal->attr.if_source == IFSRC_UNKNOWN
1450 || actual->symtree->n.sym->attr.external)
1451 return 1; /* Assume match. */
1453 if (actual->symtree->n.sym->attr.intrinsic)
1455 if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
1458 else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
1465 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1466 formal->name, &actual->where);
1470 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1471 && !gfc_compare_types (&formal->ts, &actual->ts))
1474 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1475 formal->name, &actual->where, gfc_typename (&actual->ts),
1476 gfc_typename (&formal->ts));
1480 if (symbol_rank (formal) == actual->rank)
1483 rank_check = where != NULL && !is_elemental && formal->as
1484 && (formal->as->type == AS_ASSUMED_SHAPE
1485 || formal->as->type == AS_DEFERRED);
1487 if (rank_check || ranks_must_agree || formal->attr.pointer
1488 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1489 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
1492 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1493 formal->name, &actual->where, symbol_rank (formal),
1497 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1500 /* At this point, we are considering a scalar passed to an array. This
1501 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1502 - if the actual argument is (a substring of) an element of a
1503 non-assumed-shape/non-pointer array;
1504 - (F2003) if the actual argument is of type character. */
1506 for (ref = actual->ref; ref; ref = ref->next)
1507 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1510 /* Not an array element. */
1511 if (formal->ts.type == BT_CHARACTER
1513 || (actual->expr_type == EXPR_VARIABLE
1514 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1515 || actual->symtree->n.sym->attr.pointer))))
1517 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1519 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1520 "array dummy argument '%s' at %L",
1521 formal->name, &actual->where);
1524 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1529 else if (ref == NULL)
1532 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1533 formal->name, &actual->where, symbol_rank (formal),
1538 if (actual->expr_type == EXPR_VARIABLE
1539 && actual->symtree->n.sym->as
1540 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1541 || actual->symtree->n.sym->attr.pointer))
1544 gfc_error ("Element of assumed-shaped array passed to dummy "
1545 "argument '%s' at %L", formal->name, &actual->where);
1553 /* Given a symbol of a formal argument list and an expression, see if
1554 the two are compatible as arguments. Returns nonzero if
1555 compatible, zero if not compatible. */
1558 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1560 if (actual->expr_type != EXPR_VARIABLE)
1563 if (!actual->symtree->n.sym->attr.protected)
1566 if (!actual->symtree->n.sym->attr.use_assoc)
1569 if (formal->attr.intent == INTENT_IN
1570 || formal->attr.intent == INTENT_UNKNOWN)
1573 if (!actual->symtree->n.sym->attr.pointer)
1576 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1583 /* Returns the storage size of a symbol (formal argument) or
1584 zero if it cannot be determined. */
1586 static unsigned long
1587 get_sym_storage_size (gfc_symbol *sym)
1590 unsigned long strlen, elements;
1592 if (sym->ts.type == BT_CHARACTER)
1594 if (sym->ts.cl && sym->ts.cl->length
1595 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1596 strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1603 if (symbol_rank (sym) == 0)
1607 if (sym->as->type != AS_EXPLICIT)
1609 for (i = 0; i < sym->as->rank; i++)
1611 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1612 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1615 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1616 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1619 return strlen*elements;
1623 /* Returns the storage size of an expression (actual argument) or
1624 zero if it cannot be determined. For an array element, it returns
1625 the remaining size as the element sequence consists of all storage
1626 units of the actual argument up to the end of the array. */
1628 static unsigned long
1629 get_expr_storage_size (gfc_expr *e)
1632 long int strlen, elements;
1633 long int substrlen = 0;
1634 bool is_str_storage = false;
1640 if (e->ts.type == BT_CHARACTER)
1642 if (e->ts.cl && e->ts.cl->length
1643 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1644 strlen = mpz_get_si (e->ts.cl->length->value.integer);
1645 else if (e->expr_type == EXPR_CONSTANT
1646 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1647 strlen = e->value.character.length;
1652 strlen = 1; /* Length per element. */
1654 if (e->rank == 0 && !e->ref)
1662 for (i = 0; i < e->rank; i++)
1663 elements *= mpz_get_si (e->shape[i]);
1664 return elements*strlen;
1667 for (ref = e->ref; ref; ref = ref->next)
1669 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1670 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1674 /* The string length is the substring length.
1675 Set now to full string length. */
1676 if (ref->u.ss.length == NULL
1677 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1680 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1682 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1686 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1687 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1688 && ref->u.ar.as->upper)
1689 for (i = 0; i < ref->u.ar.dimen; i++)
1691 long int start, end, stride;
1694 if (ref->u.ar.stride[i])
1696 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1697 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1702 if (ref->u.ar.start[i])
1704 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1705 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1709 else if (ref->u.ar.as->lower[i]
1710 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1711 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1715 if (ref->u.ar.end[i])
1717 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1718 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1722 else if (ref->u.ar.as->upper[i]
1723 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1724 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1728 elements *= (end - start)/stride + 1L;
1730 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1731 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1732 for (i = 0; i < ref->u.ar.as->rank; i++)
1734 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1735 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1736 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1737 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1738 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1743 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1744 && e->expr_type == EXPR_VARIABLE)
1746 if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1747 || e->symtree->n.sym->attr.pointer)
1753 /* Determine the number of remaining elements in the element
1754 sequence for array element designators. */
1755 is_str_storage = true;
1756 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1758 if (ref->u.ar.start[i] == NULL
1759 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1760 || ref->u.ar.as->upper[i] == NULL
1761 || ref->u.ar.as->lower[i] == NULL
1762 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1763 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1768 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1769 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1771 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1772 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1780 return (is_str_storage) ? substrlen + (elements-1)*strlen
1783 return elements*strlen;
1787 /* Given an expression, check whether it is an array section
1788 which has a vector subscript. If it has, one is returned,
1792 has_vector_subscript (gfc_expr *e)
1797 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1800 for (ref = e->ref; ref; ref = ref->next)
1801 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1802 for (i = 0; i < ref->u.ar.dimen; i++)
1803 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1810 /* Given formal and actual argument lists, see if they are compatible.
1811 If they are compatible, the actual argument list is sorted to
1812 correspond with the formal list, and elements for missing optional
1813 arguments are inserted. If WHERE pointer is nonnull, then we issue
1814 errors when things don't match instead of just returning the status
1818 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1819 int ranks_must_agree, int is_elemental, locus *where)
1821 gfc_actual_arglist **new, *a, *actual, temp;
1822 gfc_formal_arglist *f;
1824 unsigned long actual_size, formal_size;
1828 if (actual == NULL && formal == NULL)
1832 for (f = formal; f; f = f->next)
1835 new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1837 for (i = 0; i < n; i++)
1844 for (a = actual; a; a = a->next, f = f->next)
1846 /* Look for keywords but ignore g77 extensions like %VAL. */
1847 if (a->name != NULL && a->name[0] != '%')
1850 for (f = formal; f; f = f->next, i++)
1854 if (strcmp (f->sym->name, a->name) == 0)
1861 gfc_error ("Keyword argument '%s' at %L is not in "
1862 "the procedure", a->name, &a->expr->where);
1869 gfc_error ("Keyword argument '%s' at %L is already associated "
1870 "with another actual argument", a->name,
1879 gfc_error ("More actual than formal arguments in procedure "
1880 "call at %L", where);
1885 if (f->sym == NULL && a->expr == NULL)
1891 gfc_error ("Missing alternate return spec in subroutine call "
1896 if (a->expr == NULL)
1899 gfc_error ("Unexpected alternate return spec in subroutine "
1900 "call at %L", where);
1904 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1905 is_elemental, where))
1908 /* Special case for character arguments. For allocatable, pointer
1909 and assumed-shape dummies, the string length needs to match
1911 if (a->expr->ts.type == BT_CHARACTER
1912 && a->expr->ts.cl && a->expr->ts.cl->length
1913 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1914 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1915 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
1916 && (f->sym->attr.pointer || f->sym->attr.allocatable
1917 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1918 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1919 f->sym->ts.cl->length->value.integer) != 0))
1921 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1922 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1923 "argument and pointer or allocatable dummy argument "
1925 mpz_get_si (a->expr->ts.cl->length->value.integer),
1926 mpz_get_si (f->sym->ts.cl->length->value.integer),
1927 f->sym->name, &a->expr->where);
1929 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1930 "argument and assumed-shape dummy argument '%s' "
1932 mpz_get_si (a->expr->ts.cl->length->value.integer),
1933 mpz_get_si (f->sym->ts.cl->length->value.integer),
1934 f->sym->name, &a->expr->where);
1938 actual_size = get_expr_storage_size (a->expr);
1939 formal_size = get_sym_storage_size (f->sym);
1940 if (actual_size != 0 && actual_size < formal_size)
1942 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1943 gfc_warning ("Character length of actual argument shorter "
1944 "than of dummy argument '%s' (%lu/%lu) at %L",
1945 f->sym->name, actual_size, formal_size,
1948 gfc_warning ("Actual argument contains too few "
1949 "elements for dummy argument '%s' (%lu/%lu) at %L",
1950 f->sym->name, actual_size, formal_size,
1955 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1956 provided for a procedure formal argument. */
1957 if (a->expr->ts.type != BT_PROCEDURE
1958 && a->expr->expr_type == EXPR_VARIABLE
1959 && f->sym->attr.flavor == FL_PROCEDURE)
1962 gfc_error ("Expected a procedure for argument '%s' at %L",
1963 f->sym->name, &a->expr->where);
1967 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1968 && a->expr->ts.type == BT_PROCEDURE
1969 && !a->expr->symtree->n.sym->attr.pure)
1972 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1973 f->sym->name, &a->expr->where);
1977 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1978 && a->expr->expr_type == EXPR_VARIABLE
1979 && a->expr->symtree->n.sym->as
1980 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1981 && (a->expr->ref == NULL
1982 || (a->expr->ref->type == REF_ARRAY
1983 && a->expr->ref->u.ar.type == AR_FULL)))
1986 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1987 " array at %L", f->sym->name, where);
1991 if (a->expr->expr_type != EXPR_NULL
1992 && compare_pointer (f->sym, a->expr) == 0)
1995 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1996 f->sym->name, &a->expr->where);
2000 if (a->expr->expr_type != EXPR_NULL
2001 && compare_allocatable (f->sym, a->expr) == 0)
2004 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2005 f->sym->name, &a->expr->where);
2009 /* Check intent = OUT/INOUT for definable actual argument. */
2010 if ((a->expr->expr_type != EXPR_VARIABLE
2011 || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
2012 && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
2013 && (f->sym->attr.intent == INTENT_OUT
2014 || f->sym->attr.intent == INTENT_INOUT))
2017 gfc_error ("Actual argument at %L must be definable as "
2018 "the dummy argument '%s' is INTENT = OUT/INOUT",
2019 &a->expr->where, f->sym->name);
2023 if (!compare_parameter_protected(f->sym, a->expr))
2026 gfc_error ("Actual argument at %L is use-associated with "
2027 "PROTECTED attribute and dummy argument '%s' is "
2028 "INTENT = OUT/INOUT",
2029 &a->expr->where,f->sym->name);
2033 if ((f->sym->attr.intent == INTENT_OUT
2034 || f->sym->attr.intent == INTENT_INOUT
2035 || f->sym->attr.volatile_)
2036 && has_vector_subscript (a->expr))
2039 gfc_error ("Array-section actual argument with vector subscripts "
2040 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2041 "or VOLATILE attribute of the dummy argument '%s'",
2042 &a->expr->where, f->sym->name);
2046 /* C1232 (R1221) For an actual argument which is an array section or
2047 an assumed-shape array, the dummy argument shall be an assumed-
2048 shape array, if the dummy argument has the VOLATILE attribute. */
2050 if (f->sym->attr.volatile_
2051 && a->expr->symtree->n.sym->as
2052 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2053 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2056 gfc_error ("Assumed-shape actual argument at %L is "
2057 "incompatible with the non-assumed-shape "
2058 "dummy argument '%s' due to VOLATILE attribute",
2059 &a->expr->where,f->sym->name);
2063 if (f->sym->attr.volatile_
2064 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2065 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2068 gfc_error ("Array-section actual argument at %L is "
2069 "incompatible with the non-assumed-shape "
2070 "dummy argument '%s' due to VOLATILE attribute",
2071 &a->expr->where,f->sym->name);
2075 /* C1233 (R1221) For an actual argument which is a pointer array, the
2076 dummy argument shall be an assumed-shape or pointer array, if the
2077 dummy argument has the VOLATILE attribute. */
2079 if (f->sym->attr.volatile_
2080 && a->expr->symtree->n.sym->attr.pointer
2081 && a->expr->symtree->n.sym->as
2083 && (f->sym->as->type == AS_ASSUMED_SHAPE
2084 || f->sym->attr.pointer)))
2087 gfc_error ("Pointer-array actual argument at %L requires "
2088 "an assumed-shape or pointer-array dummy "
2089 "argument '%s' due to VOLATILE attribute",
2090 &a->expr->where,f->sym->name);
2101 /* Make sure missing actual arguments are optional. */
2103 for (f = formal; f; f = f->next, i++)
2110 gfc_error ("Missing alternate return spec in subroutine call "
2114 if (!f->sym->attr.optional)
2117 gfc_error ("Missing actual argument for argument '%s' at %L",
2118 f->sym->name, where);
2123 /* The argument lists are compatible. We now relink a new actual
2124 argument list with null arguments in the right places. The head
2125 of the list remains the head. */
2126 for (i = 0; i < n; i++)
2128 new[i] = gfc_get_actual_arglist ();
2141 for (i = 0; i < n - 1; i++)
2142 new[i]->next = new[i + 1];
2144 new[i]->next = NULL;
2146 if (*ap == NULL && n > 0)
2149 /* Note the types of omitted optional arguments. */
2150 for (a = actual, f = formal; a; a = a->next, f = f->next)
2151 if (a->expr == NULL && a->label == NULL)
2152 a->missing_arg_type = f->sym->ts.type;
2160 gfc_formal_arglist *f;
2161 gfc_actual_arglist *a;
2165 /* qsort comparison function for argument pairs, with the following
2167 - p->a->expr == NULL
2168 - p->a->expr->expr_type != EXPR_VARIABLE
2169 - growing p->a->expr->symbol. */
2172 pair_cmp (const void *p1, const void *p2)
2174 const gfc_actual_arglist *a1, *a2;
2176 /* *p1 and *p2 are elements of the to-be-sorted array. */
2177 a1 = ((const argpair *) p1)->a;
2178 a2 = ((const argpair *) p2)->a;
2187 if (a1->expr->expr_type != EXPR_VARIABLE)
2189 if (a2->expr->expr_type != EXPR_VARIABLE)
2193 if (a2->expr->expr_type != EXPR_VARIABLE)
2195 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2199 /* Given two expressions from some actual arguments, test whether they
2200 refer to the same expression. The analysis is conservative.
2201 Returning FAILURE will produce no warning. */
2204 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2206 const gfc_ref *r1, *r2;
2209 || e1->expr_type != EXPR_VARIABLE
2210 || e2->expr_type != EXPR_VARIABLE
2211 || e1->symtree->n.sym != e2->symtree->n.sym)
2214 /* TODO: improve comparison, see expr.c:show_ref(). */
2215 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2217 if (r1->type != r2->type)
2222 if (r1->u.ar.type != r2->u.ar.type)
2224 /* TODO: At the moment, consider only full arrays;
2225 we could do better. */
2226 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2231 if (r1->u.c.component != r2->u.c.component)
2239 gfc_internal_error ("compare_actual_expr(): Bad component code");
2248 /* Given formal and actual argument lists that correspond to one
2249 another, check that identical actual arguments aren't not
2250 associated with some incompatible INTENTs. */
2253 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2255 sym_intent f1_intent, f2_intent;
2256 gfc_formal_arglist *f1;
2257 gfc_actual_arglist *a1;
2263 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2265 if (f1 == NULL && a1 == NULL)
2267 if (f1 == NULL || a1 == NULL)
2268 gfc_internal_error ("check_some_aliasing(): List mismatch");
2273 p = (argpair *) alloca (n * sizeof (argpair));
2275 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2281 qsort (p, n, sizeof (argpair), pair_cmp);
2283 for (i = 0; i < n; i++)
2286 || p[i].a->expr->expr_type != EXPR_VARIABLE
2287 || p[i].a->expr->ts.type == BT_PROCEDURE)
2289 f1_intent = p[i].f->sym->attr.intent;
2290 for (j = i + 1; j < n; j++)
2292 /* Expected order after the sort. */
2293 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2294 gfc_internal_error ("check_some_aliasing(): corrupted data");
2296 /* Are the expression the same? */
2297 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2299 f2_intent = p[j].f->sym->attr.intent;
2300 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2301 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2303 gfc_warning ("Same actual argument associated with INTENT(%s) "
2304 "argument '%s' and INTENT(%s) argument '%s' at %L",
2305 gfc_intent_string (f1_intent), p[i].f->sym->name,
2306 gfc_intent_string (f2_intent), p[j].f->sym->name,
2307 &p[i].a->expr->where);
2317 /* Given a symbol of a formal argument list and an expression,
2318 return nonzero if their intents are compatible, zero otherwise. */
2321 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2323 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2326 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2329 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2336 /* Given formal and actual argument lists that correspond to one
2337 another, check that they are compatible in the sense that intents
2338 are not mismatched. */
2341 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2343 sym_intent f_intent;
2345 for (;; f = f->next, a = a->next)
2347 if (f == NULL && a == NULL)
2349 if (f == NULL || a == NULL)
2350 gfc_internal_error ("check_intents(): List mismatch");
2352 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2355 f_intent = f->sym->attr.intent;
2357 if (!compare_parameter_intent(f->sym, a->expr))
2359 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2360 "specifies INTENT(%s)", &a->expr->where,
2361 gfc_intent_string (f_intent));
2365 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2367 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2369 gfc_error ("Procedure argument at %L is local to a PURE "
2370 "procedure and is passed to an INTENT(%s) argument",
2371 &a->expr->where, gfc_intent_string (f_intent));
2375 if (a->expr->symtree->n.sym->attr.pointer)
2377 gfc_error ("Procedure argument at %L is local to a PURE "
2378 "procedure and has the POINTER attribute",
2389 /* Check how a procedure is used against its interface. If all goes
2390 well, the actual argument list will also end up being properly
2394 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2397 /* Warn about calls with an implicit interface. */
2398 if (gfc_option.warn_implicit_interface
2399 && sym->attr.if_source == IFSRC_UNKNOWN)
2400 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2403 if (sym->interface && sym->interface->attr.intrinsic)
2405 gfc_intrinsic_sym *isym;
2406 isym = gfc_find_function (sym->interface->name);
2409 if (compare_actual_formal_intr (ap, sym->interface))
2411 gfc_error ("Type/rank mismatch in argument '%s' at %L",
2417 if (sym->attr.if_source == IFSRC_UNKNOWN
2418 || !compare_actual_formal (ap, sym->formal, 0,
2419 sym->attr.elemental, where))
2422 check_intents (sym->formal, *ap);
2423 if (gfc_option.warn_aliasing)
2424 check_some_aliasing (sym->formal, *ap);
2428 /* Given an interface pointer and an actual argument list, search for
2429 a formal argument list that matches the actual. If found, returns
2430 a pointer to the symbol of the correct interface. Returns NULL if
2434 gfc_search_interface (gfc_interface *intr, int sub_flag,
2435 gfc_actual_arglist **ap)
2439 for (; intr; intr = intr->next)
2441 if (sub_flag && intr->sym->attr.function)
2443 if (!sub_flag && intr->sym->attr.subroutine)
2446 r = !intr->sym->attr.elemental;
2448 if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
2450 check_intents (intr->sym->formal, *ap);
2451 if (gfc_option.warn_aliasing)
2452 check_some_aliasing (intr->sym->formal, *ap);
2461 /* Do a brute force recursive search for a symbol. */
2463 static gfc_symtree *
2464 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2468 if (root->n.sym == sym)
2473 st = find_symtree0 (root->left, sym);
2474 if (root->right && ! st)
2475 st = find_symtree0 (root->right, sym);
2480 /* Find a symtree for a symbol. */
2482 static gfc_symtree *
2483 find_sym_in_symtree (gfc_symbol *sym)
2488 /* First try to find it by name. */
2489 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2490 if (st && st->n.sym == sym)
2493 /* If it's been renamed, resort to a brute-force search. */
2494 /* TODO: avoid having to do this search. If the symbol doesn't exist
2495 in the symtree for the current namespace, it should probably be added. */
2496 for (ns = gfc_current_ns; ns; ns = ns->parent)
2498 st = find_symtree0 (ns->sym_root, sym);
2502 gfc_internal_error ("Unable to find symbol %s", sym->name);
2507 /* This subroutine is called when an expression is being resolved.
2508 The expression node in question is either a user defined operator
2509 or an intrinsic operator with arguments that aren't compatible
2510 with the operator. This subroutine builds an actual argument list
2511 corresponding to the operands, then searches for a compatible
2512 interface. If one is found, the expression node is replaced with
2513 the appropriate function call. */
2516 gfc_extend_expr (gfc_expr *e)
2518 gfc_actual_arglist *actual;
2526 actual = gfc_get_actual_arglist ();
2527 actual->expr = e->value.op.op1;
2529 if (e->value.op.op2 != NULL)
2531 actual->next = gfc_get_actual_arglist ();
2532 actual->next->expr = e->value.op.op2;
2535 i = fold_unary (e->value.op.operator);
2537 if (i == INTRINSIC_USER)
2539 for (ns = gfc_current_ns; ns; ns = ns->parent)
2541 uop = gfc_find_uop (e->value.op.uop->name, ns);
2545 sym = gfc_search_interface (uop->operator, 0, &actual);
2552 for (ns = gfc_current_ns; ns; ns = ns->parent)
2554 /* Due to the distinction between '==' and '.eq.' and friends, one has
2555 to check if either is defined. */
2559 case INTRINSIC_EQ_OS:
2560 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
2562 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
2566 case INTRINSIC_NE_OS:
2567 sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
2569 sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
2573 case INTRINSIC_GT_OS:
2574 sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
2576 sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
2580 case INTRINSIC_GE_OS:
2581 sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
2583 sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
2587 case INTRINSIC_LT_OS:
2588 sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
2590 sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
2594 case INTRINSIC_LE_OS:
2595 sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
2597 sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
2601 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2611 /* Don't use gfc_free_actual_arglist(). */
2612 if (actual->next != NULL)
2613 gfc_free (actual->next);
2619 /* Change the expression node to a function call. */
2620 e->expr_type = EXPR_FUNCTION;
2621 e->symtree = find_sym_in_symtree (sym);
2622 e->value.function.actual = actual;
2623 e->value.function.esym = NULL;
2624 e->value.function.isym = NULL;
2625 e->value.function.name = NULL;
2627 if (gfc_pure (NULL) && !gfc_pure (sym))
2629 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2630 "be PURE", sym->name, &e->where);
2634 if (gfc_resolve_expr (e) == FAILURE)
2641 /* Tries to replace an assignment code node with a subroutine call to
2642 the subroutine associated with the assignment operator. Return
2643 SUCCESS if the node was replaced. On FAILURE, no error is
2647 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2649 gfc_actual_arglist *actual;
2650 gfc_expr *lhs, *rhs;
2656 /* Don't allow an intrinsic assignment to be replaced. */
2657 if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2658 && (lhs->ts.type == rhs->ts.type
2659 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2662 actual = gfc_get_actual_arglist ();
2665 actual->next = gfc_get_actual_arglist ();
2666 actual->next->expr = rhs;
2670 for (; ns; ns = ns->parent)
2672 sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2679 gfc_free (actual->next);
2684 /* Replace the assignment with the call. */
2685 c->op = EXEC_ASSIGN_CALL;
2686 c->symtree = find_sym_in_symtree (sym);
2689 c->ext.actual = actual;
2695 /* Make sure that the interface just parsed is not already present in
2696 the given interface list. Ambiguity isn't checked yet since module
2697 procedures can be present without interfaces. */
2700 check_new_interface (gfc_interface *base, gfc_symbol *new)
2704 for (ip = base; ip; ip = ip->next)
2708 gfc_error ("Entity '%s' at %C is already present in the interface",
2718 /* Add a symbol to the current interface. */
2721 gfc_add_interface (gfc_symbol *new)
2723 gfc_interface **head, *intr;
2727 switch (current_interface.type)
2729 case INTERFACE_NAMELESS:
2730 case INTERFACE_ABSTRACT:
2733 case INTERFACE_INTRINSIC_OP:
2734 for (ns = current_interface.ns; ns; ns = ns->parent)
2735 switch (current_interface.op)
2738 case INTRINSIC_EQ_OS:
2739 if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
2740 check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
2745 case INTRINSIC_NE_OS:
2746 if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
2747 check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
2752 case INTRINSIC_GT_OS:
2753 if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
2754 check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
2759 case INTRINSIC_GE_OS:
2760 if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
2761 check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
2766 case INTRINSIC_LT_OS:
2767 if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
2768 check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
2773 case INTRINSIC_LE_OS:
2774 if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
2775 check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
2780 if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
2784 head = ¤t_interface.ns->operator[current_interface.op];
2787 case INTERFACE_GENERIC:
2788 for (ns = current_interface.ns; ns; ns = ns->parent)
2790 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2794 if (check_new_interface (sym->generic, new) == FAILURE)
2798 head = ¤t_interface.sym->generic;
2801 case INTERFACE_USER_OP:
2802 if (check_new_interface (current_interface.uop->operator, new)
2806 head = ¤t_interface.uop->operator;
2810 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2813 intr = gfc_get_interface ();
2815 intr->where = gfc_current_locus;
2825 gfc_current_interface_head (void)
2827 switch (current_interface.type)
2829 case INTERFACE_INTRINSIC_OP:
2830 return current_interface.ns->operator[current_interface.op];
2833 case INTERFACE_GENERIC:
2834 return current_interface.sym->generic;
2837 case INTERFACE_USER_OP:
2838 return current_interface.uop->operator;
2848 gfc_set_current_interface_head (gfc_interface *i)
2850 switch (current_interface.type)
2852 case INTERFACE_INTRINSIC_OP:
2853 current_interface.ns->operator[current_interface.op] = i;
2856 case INTERFACE_GENERIC:
2857 current_interface.sym->generic = i;
2860 case INTERFACE_USER_OP:
2861 current_interface.uop->operator = i;
2870 /* Gets rid of a formal argument list. We do not free symbols.
2871 Symbols are freed when a namespace is freed. */
2874 gfc_free_formal_arglist (gfc_formal_arglist *p)
2876 gfc_formal_arglist *q;