1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
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 op)
102 case INTRINSIC_UPLUS:
105 case INTRINSIC_UMINUS:
106 op = INTRINSIC_MINUS;
116 /* Match a generic specification. Depending on which type of
117 interface is found, the 'name' or 'op' pointers may be set.
118 This subroutine doesn't return MATCH_NO. */
121 gfc_match_generic_spec (interface_type *type,
123 gfc_intrinsic_op *op)
125 char buffer[GFC_MAX_SYMBOL_LEN + 1];
129 if (gfc_match (" assignment ( = )") == MATCH_YES)
131 *type = INTERFACE_INTRINSIC_OP;
132 *op = INTRINSIC_ASSIGN;
136 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
138 *type = INTERFACE_INTRINSIC_OP;
139 *op = 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];
190 m = gfc_match_space ();
192 if (gfc_match_generic_spec (&type, name, &op) == 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 = op;
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];
281 m = gfc_match_space ();
283 if (gfc_match_generic_spec (&type, name, &op) == 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 || op != 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->attr.access != dt2->attr.access)
398 if (dt1->attr.pointer != dt2->attr.pointer)
401 if (dt1->attr.dimension != dt2->attr.dimension)
404 if (dt1->attr.allocatable != dt2->attr.allocatable)
407 if (dt1->attr.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_intr_interfaces (gfc_symbol *, gfc_symbol *);
484 /* Given two symbols that are formal arguments, compare their types
485 and rank and their formal interfaces if they are both dummy
486 procedures. Returns nonzero if the same, zero if different. */
489 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
491 if (s1 == NULL || s2 == NULL)
492 return s1 == s2 ? 1 : 0;
497 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
498 return compare_type_rank (s1, s2);
500 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
503 /* At this point, both symbols are procedures. It can happen that
504 external procedures are compared, where one is identified by usage
505 to be a function or subroutine but the other is not. Check TKR
506 nonetheless for these cases. */
507 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
508 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
510 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
511 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
513 /* Now the type of procedure has been identified. */
514 if (s1->attr.function != s2->attr.function
515 || s1->attr.subroutine != s2->attr.subroutine)
518 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
521 /* Originally, gfortran recursed here to check the interfaces of passed
522 procedures. This is explicitly not required by the standard. */
527 /* Given a formal argument list and a keyword name, search the list
528 for that keyword. Returns the correct symbol node if found, NULL
532 find_keyword_arg (const char *name, gfc_formal_arglist *f)
534 for (; f; f = f->next)
535 if (strcmp (f->sym->name, name) == 0)
542 /******** Interface checking subroutines **********/
545 /* Given an operator interface and the operator, make sure that all
546 interfaces for that operator are legal. */
549 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
551 gfc_formal_arglist *formal;
555 int args, r1, r2, k1, k2;
561 t1 = t2 = BT_UNKNOWN;
562 i1 = i2 = INTENT_UNKNOWN;
566 for (formal = intr->sym->formal; formal; formal = formal->next)
571 gfc_error ("Alternate return cannot appear in operator "
572 "interface at %L", &intr->sym->declared_at);
578 i1 = sym->attr.intent;
579 r1 = (sym->as != NULL) ? sym->as->rank : 0;
585 i2 = sym->attr.intent;
586 r2 = (sym->as != NULL) ? sym->as->rank : 0;
594 /* Only +, - and .not. can be unary operators.
595 .not. cannot be a binary operator. */
596 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
597 && op != INTRINSIC_MINUS
598 && op != INTRINSIC_NOT)
599 || (args == 2 && op == INTRINSIC_NOT))
601 gfc_error ("Operator interface at %L has the wrong number of arguments",
602 &intr->sym->declared_at);
606 /* Check that intrinsics are mapped to functions, except
607 INTRINSIC_ASSIGN which should map to a subroutine. */
608 if (op == INTRINSIC_ASSIGN)
610 if (!sym->attr.subroutine)
612 gfc_error ("Assignment operator interface at %L must be "
613 "a SUBROUTINE", &intr->sym->declared_at);
618 gfc_error ("Assignment operator interface at %L must have "
619 "two arguments", &intr->sym->declared_at);
623 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
624 - First argument an array with different rank than second,
625 - Types and kinds do not conform, and
626 - First argument is of derived type. */
627 if (sym->formal->sym->ts.type != BT_DERIVED
628 && (r1 == 0 || r1 == r2)
629 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
630 || (gfc_numeric_ts (&sym->formal->sym->ts)
631 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
633 gfc_error ("Assignment operator interface at %L must not redefine "
634 "an INTRINSIC type assignment", &intr->sym->declared_at);
640 if (!sym->attr.function)
642 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
643 &intr->sym->declared_at);
648 /* Check intents on operator interfaces. */
649 if (op == INTRINSIC_ASSIGN)
651 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
652 gfc_error ("First argument of defined assignment at %L must be "
653 "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
656 gfc_error ("Second argument of defined assignment at %L must be "
657 "INTENT(IN)", &intr->sym->declared_at);
662 gfc_error ("First argument of operator interface at %L must be "
663 "INTENT(IN)", &intr->sym->declared_at);
665 if (args == 2 && i2 != INTENT_IN)
666 gfc_error ("Second argument of operator interface at %L must be "
667 "INTENT(IN)", &intr->sym->declared_at);
670 /* From now on, all we have to do is check that the operator definition
671 doesn't conflict with an intrinsic operator. The rules for this
672 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
673 as well as 12.3.2.1.1 of Fortran 2003:
675 "If the operator is an intrinsic-operator (R310), the number of
676 function arguments shall be consistent with the intrinsic uses of
677 that operator, and the types, kind type parameters, or ranks of the
678 dummy arguments shall differ from those required for the intrinsic
679 operation (7.1.2)." */
681 #define IS_NUMERIC_TYPE(t) \
682 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
684 /* Unary ops are easy, do them first. */
685 if (op == INTRINSIC_NOT)
687 if (t1 == BT_LOGICAL)
693 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
695 if (IS_NUMERIC_TYPE (t1))
701 /* Character intrinsic operators have same character kind, thus
702 operator definitions with operands of different character kinds
704 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
707 /* Intrinsic operators always perform on arguments of same rank,
708 so different ranks is also always safe. (rank == 0) is an exception
709 to that, because all intrinsic operators are elemental. */
710 if (r1 != r2 && r1 != 0 && r2 != 0)
716 case INTRINSIC_EQ_OS:
718 case INTRINSIC_NE_OS:
719 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
724 case INTRINSIC_MINUS:
725 case INTRINSIC_TIMES:
726 case INTRINSIC_DIVIDE:
727 case INTRINSIC_POWER:
728 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
733 case INTRINSIC_GT_OS:
735 case INTRINSIC_GE_OS:
737 case INTRINSIC_LT_OS:
739 case INTRINSIC_LE_OS:
740 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
742 if ((t1 == BT_INTEGER || t1 == BT_REAL)
743 && (t2 == BT_INTEGER || t2 == BT_REAL))
747 case INTRINSIC_CONCAT:
748 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
756 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
766 #undef IS_NUMERIC_TYPE
769 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
775 /* Given a pair of formal argument lists, we see if the two lists can
776 be distinguished by counting the number of nonoptional arguments of
777 a given type/rank in f1 and seeing if there are less then that
778 number of those arguments in f2 (including optional arguments).
779 Since this test is asymmetric, it has to be called twice to make it
780 symmetric. Returns nonzero if the argument lists are incompatible
781 by this test. This subroutine implements rule 1 of section
785 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
787 int rc, ac1, ac2, i, j, k, n1;
788 gfc_formal_arglist *f;
801 for (f = f1; f; f = f->next)
804 /* Build an array of integers that gives the same integer to
805 arguments of the same type/rank. */
806 arg = XCNEWVEC (arginfo, n1);
809 for (i = 0; i < n1; i++, f = f->next)
817 for (i = 0; i < n1; i++)
819 if (arg[i].flag != -1)
822 if (arg[i].sym && arg[i].sym->attr.optional)
823 continue; /* Skip optional arguments. */
827 /* Find other nonoptional arguments of the same type/rank. */
828 for (j = i + 1; j < n1; j++)
829 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
830 && compare_type_rank_if (arg[i].sym, arg[j].sym))
836 /* Now loop over each distinct type found in f1. */
840 for (i = 0; i < n1; i++)
842 if (arg[i].flag != k)
846 for (j = i + 1; j < n1; j++)
847 if (arg[j].flag == k)
850 /* Count the number of arguments in f2 with that type, including
851 those that are optional. */
854 for (f = f2; f; f = f->next)
855 if (compare_type_rank_if (arg[i].sym, f->sym))
873 /* Perform the abbreviated correspondence test for operators. The
874 arguments cannot be optional and are always ordered correctly,
875 which makes this test much easier than that for generic tests.
877 This subroutine is also used when comparing a formal and actual
878 argument list when an actual parameter is a dummy procedure. At
879 that point, two formal interfaces must be compared for equality
880 which is what happens here. */
883 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
887 if (f1 == NULL && f2 == NULL)
889 if (f1 == NULL || f2 == NULL)
892 if (!compare_type_rank (f1->sym, f2->sym))
903 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
904 Returns zero if no argument is found that satisfies rule 2, nonzero
907 This test is also not symmetric in f1 and f2 and must be called
908 twice. This test finds problems caused by sorting the actual
909 argument list with keywords. For example:
913 INTEGER :: A ; REAL :: B
917 INTEGER :: A ; REAL :: B
921 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
924 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
926 gfc_formal_arglist *f2_save, *g;
933 if (f1->sym->attr.optional)
936 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
939 /* Now search for a disambiguating keyword argument starting at
940 the current non-match. */
941 for (g = f1; g; g = g->next)
943 if (g->sym->attr.optional)
946 sym = find_keyword_arg (g->sym->name, f2_save);
947 if (sym == NULL || !compare_type_rank (g->sym, sym))
961 /* 'Compare' two formal interfaces associated with a pair of symbols.
962 We return nonzero if there exists an actual argument list that
963 would be ambiguous between the two interfaces, zero otherwise. */
966 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
968 gfc_formal_arglist *f1, *f2;
970 if (s1->attr.function != s2->attr.function
971 || s1->attr.subroutine != s2->attr.subroutine)
972 return 0; /* Disagreement between function/subroutine. */
977 if (f1 == NULL && f2 == NULL)
978 return 1; /* Special case. */
980 if (count_types_test (f1, f2))
982 if (count_types_test (f2, f1))
987 if (generic_correspondence (f1, f2))
989 if (generic_correspondence (f2, f1))
994 if (operator_correspondence (f1, f2))
1003 compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
1005 gfc_formal_arglist *f, *f1;
1006 gfc_intrinsic_arg *fi, *f2;
1007 gfc_intrinsic_sym *isym;
1009 if (s1->attr.function != s2->attr.function
1010 || s1->attr.subroutine != s2->attr.subroutine)
1011 return 0; /* Disagreement between function/subroutine. */
1013 /* If the arguments are functions, check type and kind. */
1015 if (s1->attr.dummy && s1->attr.function && s2->attr.function)
1017 if (s1->ts.type != s2->ts.type)
1019 if (s1->ts.kind != s2->ts.kind)
1021 if (s1->attr.if_source == IFSRC_DECL)
1025 isym = gfc_find_function (s2->name);
1027 /* This should already have been checked in
1028 resolve.c (resolve_actual_arglist). */
1035 if (f1 == NULL && f2 == NULL)
1038 /* First scan through the formal argument list and check the intrinsic. */
1040 for (f = f1; f; f = f->next)
1044 if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
1049 /* Now scan through the intrinsic argument list and check the formal. */
1051 for (fi = f2; fi; fi = fi->next)
1055 if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
1064 /* Compare an actual argument list with an intrinsic argument list. */
1067 compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
1069 gfc_actual_arglist *a;
1070 gfc_intrinsic_arg *fi, *f2;
1071 gfc_intrinsic_sym *isym;
1073 isym = gfc_find_function (s2->name);
1075 /* This should already have been checked in
1076 resolve.c (resolve_actual_arglist). */
1082 if (*ap == NULL && f2 == NULL)
1085 /* First scan through the actual argument list and check the intrinsic. */
1087 for (a = *ap; a; a = a->next)
1091 if ((fi->ts.type != a->expr->ts.type)
1092 || (fi->ts.kind != a->expr->ts.kind))
1097 /* Now scan through the intrinsic argument list and check the formal. */
1099 for (fi = f2; fi; fi = fi->next)
1103 if ((fi->ts.type != a->expr->ts.type)
1104 || (fi->ts.kind != a->expr->ts.kind))
1113 /* Given a pointer to an interface pointer, remove duplicate
1114 interfaces and make sure that all symbols are either functions or
1115 subroutines. Returns nonzero if something goes wrong. */
1118 check_interface0 (gfc_interface *p, const char *interface_name)
1120 gfc_interface *psave, *q, *qlast;
1123 /* Make sure all symbols in the interface have been defined as
1124 functions or subroutines. */
1125 for (; p; p = p->next)
1126 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1127 || !p->sym->attr.if_source)
1129 if (p->sym->attr.external)
1130 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1131 p->sym->name, interface_name, &p->sym->declared_at);
1133 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1134 "subroutine", p->sym->name, interface_name,
1135 &p->sym->declared_at);
1140 /* Remove duplicate interfaces in this interface list. */
1141 for (; p; p = p->next)
1145 for (q = p->next; q;)
1147 if (p->sym != q->sym)
1154 /* Duplicate interface. */
1155 qlast->next = q->next;
1166 /* Check lists of interfaces to make sure that no two interfaces are
1167 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1170 check_interface1 (gfc_interface *p, gfc_interface *q0,
1171 int generic_flag, const char *interface_name,
1175 for (; p; p = p->next)
1176 for (q = q0; q; q = q->next)
1178 if (p->sym == q->sym)
1179 continue; /* Duplicates OK here. */
1181 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1184 if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
1188 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1189 p->sym->name, q->sym->name, interface_name,
1193 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1194 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1195 p->sym->name, q->sym->name, interface_name,
1204 /* Check the generic and operator interfaces of symbols to make sure
1205 that none of the interfaces conflict. The check has to be done
1206 after all of the symbols are actually loaded. */
1209 check_sym_interfaces (gfc_symbol *sym)
1211 char interface_name[100];
1215 if (sym->ns != gfc_current_ns)
1218 if (sym->generic != NULL)
1220 sprintf (interface_name, "generic interface '%s'", sym->name);
1221 if (check_interface0 (sym->generic, interface_name))
1224 for (p = sym->generic; p; p = p->next)
1226 if (p->sym->attr.mod_proc
1227 && (p->sym->attr.if_source != IFSRC_DECL
1228 || p->sym->attr.procedure))
1230 gfc_error ("'%s' at %L is not a module procedure",
1231 p->sym->name, &p->where);
1236 /* Originally, this test was applied to host interfaces too;
1237 this is incorrect since host associated symbols, from any
1238 source, cannot be ambiguous with local symbols. */
1239 k = sym->attr.referenced || !sym->attr.use_assoc;
1240 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1241 sym->attr.ambiguous_interfaces = 1;
1247 check_uop_interfaces (gfc_user_op *uop)
1249 char interface_name[100];
1253 sprintf (interface_name, "operator interface '%s'", uop->name);
1254 if (check_interface0 (uop->op, interface_name))
1257 for (ns = gfc_current_ns; ns; ns = ns->parent)
1259 uop2 = gfc_find_uop (uop->name, ns);
1263 check_interface1 (uop->op, uop2->op, 0,
1264 interface_name, true);
1269 /* For the namespace, check generic, user operator and intrinsic
1270 operator interfaces for consistency and to remove duplicate
1271 interfaces. We traverse the whole namespace, counting on the fact
1272 that most symbols will not have generic or operator interfaces. */
1275 gfc_check_interfaces (gfc_namespace *ns)
1277 gfc_namespace *old_ns, *ns2;
1278 char interface_name[100];
1281 old_ns = gfc_current_ns;
1282 gfc_current_ns = ns;
1284 gfc_traverse_ns (ns, check_sym_interfaces);
1286 gfc_traverse_user_op (ns, check_uop_interfaces);
1288 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1290 if (i == INTRINSIC_USER)
1293 if (i == INTRINSIC_ASSIGN)
1294 strcpy (interface_name, "intrinsic assignment operator");
1296 sprintf (interface_name, "intrinsic '%s' operator",
1299 if (check_interface0 (ns->op[i], interface_name))
1302 check_operator_interface (ns->op[i], i);
1304 for (ns2 = ns; ns2; ns2 = ns2->parent)
1306 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1307 interface_name, true))
1313 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
1314 0, interface_name, true)) goto done;
1317 case INTRINSIC_EQ_OS:
1318 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
1319 0, interface_name, true)) goto done;
1323 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
1324 0, interface_name, true)) goto done;
1327 case INTRINSIC_NE_OS:
1328 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
1329 0, interface_name, true)) goto done;
1333 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
1334 0, interface_name, true)) goto done;
1337 case INTRINSIC_GT_OS:
1338 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
1339 0, interface_name, true)) goto done;
1343 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
1344 0, interface_name, true)) goto done;
1347 case INTRINSIC_GE_OS:
1348 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
1349 0, interface_name, true)) goto done;
1353 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
1354 0, interface_name, true)) goto done;
1357 case INTRINSIC_LT_OS:
1358 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
1359 0, interface_name, true)) goto done;
1363 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
1364 0, interface_name, true)) goto done;
1367 case INTRINSIC_LE_OS:
1368 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
1369 0, interface_name, true)) goto done;
1379 gfc_current_ns = old_ns;
1384 symbol_rank (gfc_symbol *sym)
1386 return (sym->as == NULL) ? 0 : sym->as->rank;
1390 /* Given a symbol of a formal argument list and an expression, if the
1391 formal argument is allocatable, check that the actual argument is
1392 allocatable. Returns nonzero if compatible, zero if not compatible. */
1395 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1397 symbol_attribute attr;
1399 if (formal->attr.allocatable)
1401 attr = gfc_expr_attr (actual);
1402 if (!attr.allocatable)
1410 /* Given a symbol of a formal argument list and an expression, if the
1411 formal argument is a pointer, see if the actual argument is a
1412 pointer. Returns nonzero if compatible, zero if not compatible. */
1415 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1417 symbol_attribute attr;
1419 if (formal->attr.pointer)
1421 attr = gfc_expr_attr (actual);
1430 /* Given a symbol of a formal argument list and an expression, see if
1431 the two are compatible as arguments. Returns nonzero if
1432 compatible, zero if not compatible. */
1435 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1436 int ranks_must_agree, int is_elemental, locus *where)
1441 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1442 procs c_f_pointer or c_f_procpointer, and we need to accept most
1443 pointers the user could give us. This should allow that. */
1444 if (formal->ts.type == BT_VOID)
1447 if (formal->ts.type == BT_DERIVED
1448 && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1449 && actual->ts.type == BT_DERIVED
1450 && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1453 if (actual->ts.type == BT_PROCEDURE)
1455 if (formal->attr.flavor != FL_PROCEDURE)
1458 if (formal->attr.function
1459 && !compare_type_rank (formal, actual->symtree->n.sym))
1462 if (formal->attr.if_source == IFSRC_UNKNOWN
1463 || actual->symtree->n.sym->attr.external)
1464 return 1; /* Assume match. */
1466 if (actual->symtree->n.sym->attr.intrinsic)
1468 if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
1471 else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
1478 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1479 formal->name, &actual->where);
1483 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1484 && !gfc_compare_types (&formal->ts, &actual->ts))
1487 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1488 formal->name, &actual->where, gfc_typename (&actual->ts),
1489 gfc_typename (&formal->ts));
1493 if (symbol_rank (formal) == actual->rank)
1496 rank_check = where != NULL && !is_elemental && formal->as
1497 && (formal->as->type == AS_ASSUMED_SHAPE
1498 || formal->as->type == AS_DEFERRED);
1500 if (rank_check || ranks_must_agree || formal->attr.pointer
1501 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1502 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
1505 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1506 formal->name, &actual->where, symbol_rank (formal),
1510 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1513 /* At this point, we are considering a scalar passed to an array. This
1514 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1515 - if the actual argument is (a substring of) an element of a
1516 non-assumed-shape/non-pointer array;
1517 - (F2003) if the actual argument is of type character. */
1519 for (ref = actual->ref; ref; ref = ref->next)
1520 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1523 /* Not an array element. */
1524 if (formal->ts.type == BT_CHARACTER
1526 || (actual->expr_type == EXPR_VARIABLE
1527 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1528 || actual->symtree->n.sym->attr.pointer))))
1530 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1532 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1533 "array dummy argument '%s' at %L",
1534 formal->name, &actual->where);
1537 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1542 else if (ref == NULL)
1545 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1546 formal->name, &actual->where, symbol_rank (formal),
1551 if (actual->expr_type == EXPR_VARIABLE
1552 && actual->symtree->n.sym->as
1553 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1554 || actual->symtree->n.sym->attr.pointer))
1557 gfc_error ("Element of assumed-shaped array passed to dummy "
1558 "argument '%s' at %L", formal->name, &actual->where);
1566 /* Given a symbol of a formal argument list and an expression, see if
1567 the two are compatible as arguments. Returns nonzero if
1568 compatible, zero if not compatible. */
1571 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1573 if (actual->expr_type != EXPR_VARIABLE)
1576 if (!actual->symtree->n.sym->attr.is_protected)
1579 if (!actual->symtree->n.sym->attr.use_assoc)
1582 if (formal->attr.intent == INTENT_IN
1583 || formal->attr.intent == INTENT_UNKNOWN)
1586 if (!actual->symtree->n.sym->attr.pointer)
1589 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1596 /* Returns the storage size of a symbol (formal argument) or
1597 zero if it cannot be determined. */
1599 static unsigned long
1600 get_sym_storage_size (gfc_symbol *sym)
1603 unsigned long strlen, elements;
1605 if (sym->ts.type == BT_CHARACTER)
1607 if (sym->ts.cl && sym->ts.cl->length
1608 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1609 strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1616 if (symbol_rank (sym) == 0)
1620 if (sym->as->type != AS_EXPLICIT)
1622 for (i = 0; i < sym->as->rank; i++)
1624 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1625 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1628 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1629 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1632 return strlen*elements;
1636 /* Returns the storage size of an expression (actual argument) or
1637 zero if it cannot be determined. For an array element, it returns
1638 the remaining size as the element sequence consists of all storage
1639 units of the actual argument up to the end of the array. */
1641 static unsigned long
1642 get_expr_storage_size (gfc_expr *e)
1645 long int strlen, elements;
1646 long int substrlen = 0;
1647 bool is_str_storage = false;
1653 if (e->ts.type == BT_CHARACTER)
1655 if (e->ts.cl && e->ts.cl->length
1656 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1657 strlen = mpz_get_si (e->ts.cl->length->value.integer);
1658 else if (e->expr_type == EXPR_CONSTANT
1659 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1660 strlen = e->value.character.length;
1665 strlen = 1; /* Length per element. */
1667 if (e->rank == 0 && !e->ref)
1675 for (i = 0; i < e->rank; i++)
1676 elements *= mpz_get_si (e->shape[i]);
1677 return elements*strlen;
1680 for (ref = e->ref; ref; ref = ref->next)
1682 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1683 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1687 /* The string length is the substring length.
1688 Set now to full string length. */
1689 if (ref->u.ss.length == NULL
1690 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1693 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1695 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1699 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1700 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1701 && ref->u.ar.as->upper)
1702 for (i = 0; i < ref->u.ar.dimen; i++)
1704 long int start, end, stride;
1707 if (ref->u.ar.stride[i])
1709 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1710 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1715 if (ref->u.ar.start[i])
1717 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1718 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1722 else if (ref->u.ar.as->lower[i]
1723 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1724 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1728 if (ref->u.ar.end[i])
1730 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1731 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1735 else if (ref->u.ar.as->upper[i]
1736 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1737 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1741 elements *= (end - start)/stride + 1L;
1743 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1744 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1745 for (i = 0; i < ref->u.ar.as->rank; i++)
1747 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1748 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1749 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1750 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1751 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1756 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1757 && e->expr_type == EXPR_VARIABLE)
1759 if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1760 || e->symtree->n.sym->attr.pointer)
1766 /* Determine the number of remaining elements in the element
1767 sequence for array element designators. */
1768 is_str_storage = true;
1769 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1771 if (ref->u.ar.start[i] == NULL
1772 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1773 || ref->u.ar.as->upper[i] == NULL
1774 || ref->u.ar.as->lower[i] == NULL
1775 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1776 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1781 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1782 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1784 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1785 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1793 return (is_str_storage) ? substrlen + (elements-1)*strlen
1796 return elements*strlen;
1800 /* Given an expression, check whether it is an array section
1801 which has a vector subscript. If it has, one is returned,
1805 has_vector_subscript (gfc_expr *e)
1810 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1813 for (ref = e->ref; ref; ref = ref->next)
1814 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1815 for (i = 0; i < ref->u.ar.dimen; i++)
1816 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1823 /* Given formal and actual argument lists, see if they are compatible.
1824 If they are compatible, the actual argument list is sorted to
1825 correspond with the formal list, and elements for missing optional
1826 arguments are inserted. If WHERE pointer is nonnull, then we issue
1827 errors when things don't match instead of just returning the status
1831 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1832 int ranks_must_agree, int is_elemental, locus *where)
1834 gfc_actual_arglist **new_arg, *a, *actual, temp;
1835 gfc_formal_arglist *f;
1837 unsigned long actual_size, formal_size;
1841 if (actual == NULL && formal == NULL)
1845 for (f = formal; f; f = f->next)
1848 new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1850 for (i = 0; i < n; i++)
1857 for (a = actual; a; a = a->next, f = f->next)
1859 /* Look for keywords but ignore g77 extensions like %VAL. */
1860 if (a->name != NULL && a->name[0] != '%')
1863 for (f = formal; f; f = f->next, i++)
1867 if (strcmp (f->sym->name, a->name) == 0)
1874 gfc_error ("Keyword argument '%s' at %L is not in "
1875 "the procedure", a->name, &a->expr->where);
1879 if (new_arg[i] != NULL)
1882 gfc_error ("Keyword argument '%s' at %L is already associated "
1883 "with another actual argument", a->name,
1892 gfc_error ("More actual than formal arguments in procedure "
1893 "call at %L", where);
1898 if (f->sym == NULL && a->expr == NULL)
1904 gfc_error ("Missing alternate return spec in subroutine call "
1909 if (a->expr == NULL)
1912 gfc_error ("Unexpected alternate return spec in subroutine "
1913 "call at %L", where);
1917 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1918 is_elemental, where))
1921 /* Special case for character arguments. For allocatable, pointer
1922 and assumed-shape dummies, the string length needs to match
1924 if (a->expr->ts.type == BT_CHARACTER
1925 && a->expr->ts.cl && a->expr->ts.cl->length
1926 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1927 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1928 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
1929 && (f->sym->attr.pointer || f->sym->attr.allocatable
1930 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1931 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1932 f->sym->ts.cl->length->value.integer) != 0))
1934 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1935 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1936 "argument and pointer or allocatable dummy argument "
1938 mpz_get_si (a->expr->ts.cl->length->value.integer),
1939 mpz_get_si (f->sym->ts.cl->length->value.integer),
1940 f->sym->name, &a->expr->where);
1942 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1943 "argument and assumed-shape dummy argument '%s' "
1945 mpz_get_si (a->expr->ts.cl->length->value.integer),
1946 mpz_get_si (f->sym->ts.cl->length->value.integer),
1947 f->sym->name, &a->expr->where);
1951 actual_size = get_expr_storage_size (a->expr);
1952 formal_size = get_sym_storage_size (f->sym);
1953 if (actual_size != 0
1954 && actual_size < formal_size
1955 && a->expr->ts.type != BT_PROCEDURE)
1957 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1958 gfc_warning ("Character length of actual argument shorter "
1959 "than of dummy argument '%s' (%lu/%lu) at %L",
1960 f->sym->name, actual_size, formal_size,
1963 gfc_warning ("Actual argument contains too few "
1964 "elements for dummy argument '%s' (%lu/%lu) at %L",
1965 f->sym->name, actual_size, formal_size,
1970 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1971 is provided for a procedure pointer formal argument. */
1972 if (f->sym->attr.proc_pointer
1973 && !a->expr->symtree->n.sym->attr.proc_pointer)
1976 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1977 f->sym->name, &a->expr->where);
1981 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1982 provided for a procedure formal argument. */
1983 if (a->expr->ts.type != BT_PROCEDURE
1984 && a->expr->expr_type == EXPR_VARIABLE
1985 && f->sym->attr.flavor == FL_PROCEDURE)
1988 gfc_error ("Expected a procedure for argument '%s' at %L",
1989 f->sym->name, &a->expr->where);
1993 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1994 && a->expr->ts.type == BT_PROCEDURE
1995 && !a->expr->symtree->n.sym->attr.pure)
1998 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1999 f->sym->name, &a->expr->where);
2003 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2004 && a->expr->expr_type == EXPR_VARIABLE
2005 && a->expr->symtree->n.sym->as
2006 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2007 && (a->expr->ref == NULL
2008 || (a->expr->ref->type == REF_ARRAY
2009 && a->expr->ref->u.ar.type == AR_FULL)))
2012 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2013 " array at %L", f->sym->name, where);
2017 if (a->expr->expr_type != EXPR_NULL
2018 && compare_pointer (f->sym, a->expr) == 0)
2021 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2022 f->sym->name, &a->expr->where);
2026 if (a->expr->expr_type != EXPR_NULL
2027 && compare_allocatable (f->sym, a->expr) == 0)
2030 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2031 f->sym->name, &a->expr->where);
2035 /* Check intent = OUT/INOUT for definable actual argument. */
2036 if ((a->expr->expr_type != EXPR_VARIABLE
2037 || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
2038 && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
2039 && (f->sym->attr.intent == INTENT_OUT
2040 || f->sym->attr.intent == INTENT_INOUT))
2043 gfc_error ("Actual argument at %L must be definable as "
2044 "the dummy argument '%s' is INTENT = OUT/INOUT",
2045 &a->expr->where, f->sym->name);
2049 if (!compare_parameter_protected(f->sym, a->expr))
2052 gfc_error ("Actual argument at %L is use-associated with "
2053 "PROTECTED attribute and dummy argument '%s' is "
2054 "INTENT = OUT/INOUT",
2055 &a->expr->where,f->sym->name);
2059 if ((f->sym->attr.intent == INTENT_OUT
2060 || f->sym->attr.intent == INTENT_INOUT
2061 || f->sym->attr.volatile_)
2062 && has_vector_subscript (a->expr))
2065 gfc_error ("Array-section actual argument with vector subscripts "
2066 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2067 "or VOLATILE attribute of the dummy argument '%s'",
2068 &a->expr->where, f->sym->name);
2072 /* C1232 (R1221) For an actual argument which is an array section or
2073 an assumed-shape array, the dummy argument shall be an assumed-
2074 shape array, if the dummy argument has the VOLATILE attribute. */
2076 if (f->sym->attr.volatile_
2077 && a->expr->symtree->n.sym->as
2078 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2079 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2082 gfc_error ("Assumed-shape actual argument at %L is "
2083 "incompatible with the non-assumed-shape "
2084 "dummy argument '%s' due to VOLATILE attribute",
2085 &a->expr->where,f->sym->name);
2089 if (f->sym->attr.volatile_
2090 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2091 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2094 gfc_error ("Array-section actual argument at %L is "
2095 "incompatible with the non-assumed-shape "
2096 "dummy argument '%s' due to VOLATILE attribute",
2097 &a->expr->where,f->sym->name);
2101 /* C1233 (R1221) For an actual argument which is a pointer array, the
2102 dummy argument shall be an assumed-shape or pointer array, if the
2103 dummy argument has the VOLATILE attribute. */
2105 if (f->sym->attr.volatile_
2106 && a->expr->symtree->n.sym->attr.pointer
2107 && a->expr->symtree->n.sym->as
2109 && (f->sym->as->type == AS_ASSUMED_SHAPE
2110 || f->sym->attr.pointer)))
2113 gfc_error ("Pointer-array actual argument at %L requires "
2114 "an assumed-shape or pointer-array dummy "
2115 "argument '%s' due to VOLATILE attribute",
2116 &a->expr->where,f->sym->name);
2127 /* Make sure missing actual arguments are optional. */
2129 for (f = formal; f; f = f->next, i++)
2131 if (new_arg[i] != NULL)
2136 gfc_error ("Missing alternate return spec in subroutine call "
2140 if (!f->sym->attr.optional)
2143 gfc_error ("Missing actual argument for argument '%s' at %L",
2144 f->sym->name, where);
2149 /* The argument lists are compatible. We now relink a new actual
2150 argument list with null arguments in the right places. The head
2151 of the list remains the head. */
2152 for (i = 0; i < n; i++)
2153 if (new_arg[i] == NULL)
2154 new_arg[i] = gfc_get_actual_arglist ();
2159 *new_arg[0] = *actual;
2163 new_arg[0] = new_arg[na];
2167 for (i = 0; i < n - 1; i++)
2168 new_arg[i]->next = new_arg[i + 1];
2170 new_arg[i]->next = NULL;
2172 if (*ap == NULL && n > 0)
2175 /* Note the types of omitted optional arguments. */
2176 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2177 if (a->expr == NULL && a->label == NULL)
2178 a->missing_arg_type = f->sym->ts.type;
2186 gfc_formal_arglist *f;
2187 gfc_actual_arglist *a;
2191 /* qsort comparison function for argument pairs, with the following
2193 - p->a->expr == NULL
2194 - p->a->expr->expr_type != EXPR_VARIABLE
2195 - growing p->a->expr->symbol. */
2198 pair_cmp (const void *p1, const void *p2)
2200 const gfc_actual_arglist *a1, *a2;
2202 /* *p1 and *p2 are elements of the to-be-sorted array. */
2203 a1 = ((const argpair *) p1)->a;
2204 a2 = ((const argpair *) p2)->a;
2213 if (a1->expr->expr_type != EXPR_VARIABLE)
2215 if (a2->expr->expr_type != EXPR_VARIABLE)
2219 if (a2->expr->expr_type != EXPR_VARIABLE)
2221 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2225 /* Given two expressions from some actual arguments, test whether they
2226 refer to the same expression. The analysis is conservative.
2227 Returning FAILURE will produce no warning. */
2230 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2232 const gfc_ref *r1, *r2;
2235 || e1->expr_type != EXPR_VARIABLE
2236 || e2->expr_type != EXPR_VARIABLE
2237 || e1->symtree->n.sym != e2->symtree->n.sym)
2240 /* TODO: improve comparison, see expr.c:show_ref(). */
2241 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2243 if (r1->type != r2->type)
2248 if (r1->u.ar.type != r2->u.ar.type)
2250 /* TODO: At the moment, consider only full arrays;
2251 we could do better. */
2252 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2257 if (r1->u.c.component != r2->u.c.component)
2265 gfc_internal_error ("compare_actual_expr(): Bad component code");
2274 /* Given formal and actual argument lists that correspond to one
2275 another, check that identical actual arguments aren't not
2276 associated with some incompatible INTENTs. */
2279 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2281 sym_intent f1_intent, f2_intent;
2282 gfc_formal_arglist *f1;
2283 gfc_actual_arglist *a1;
2286 gfc_try t = SUCCESS;
2289 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2291 if (f1 == NULL && a1 == NULL)
2293 if (f1 == NULL || a1 == NULL)
2294 gfc_internal_error ("check_some_aliasing(): List mismatch");
2299 p = (argpair *) alloca (n * sizeof (argpair));
2301 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2307 qsort (p, n, sizeof (argpair), pair_cmp);
2309 for (i = 0; i < n; i++)
2312 || p[i].a->expr->expr_type != EXPR_VARIABLE
2313 || p[i].a->expr->ts.type == BT_PROCEDURE)
2315 f1_intent = p[i].f->sym->attr.intent;
2316 for (j = i + 1; j < n; j++)
2318 /* Expected order after the sort. */
2319 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2320 gfc_internal_error ("check_some_aliasing(): corrupted data");
2322 /* Are the expression the same? */
2323 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2325 f2_intent = p[j].f->sym->attr.intent;
2326 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2327 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2329 gfc_warning ("Same actual argument associated with INTENT(%s) "
2330 "argument '%s' and INTENT(%s) argument '%s' at %L",
2331 gfc_intent_string (f1_intent), p[i].f->sym->name,
2332 gfc_intent_string (f2_intent), p[j].f->sym->name,
2333 &p[i].a->expr->where);
2343 /* Given a symbol of a formal argument list and an expression,
2344 return nonzero if their intents are compatible, zero otherwise. */
2347 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2349 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2352 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2355 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2362 /* Given formal and actual argument lists that correspond to one
2363 another, check that they are compatible in the sense that intents
2364 are not mismatched. */
2367 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2369 sym_intent f_intent;
2371 for (;; f = f->next, a = a->next)
2373 if (f == NULL && a == NULL)
2375 if (f == NULL || a == NULL)
2376 gfc_internal_error ("check_intents(): List mismatch");
2378 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2381 f_intent = f->sym->attr.intent;
2383 if (!compare_parameter_intent(f->sym, a->expr))
2385 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2386 "specifies INTENT(%s)", &a->expr->where,
2387 gfc_intent_string (f_intent));
2391 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2393 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2395 gfc_error ("Procedure argument at %L is local to a PURE "
2396 "procedure and is passed to an INTENT(%s) argument",
2397 &a->expr->where, gfc_intent_string (f_intent));
2401 if (f->sym->attr.pointer)
2403 gfc_error ("Procedure argument at %L is local to a PURE "
2404 "procedure and has the POINTER attribute",
2415 /* Check how a procedure is used against its interface. If all goes
2416 well, the actual argument list will also end up being properly
2420 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2423 /* Warn about calls with an implicit interface. Special case
2424 for calling a ISO_C_BINDING becase c_loc and c_funloc
2425 are pseudo-unknown. */
2426 if (gfc_option.warn_implicit_interface
2427 && sym->attr.if_source == IFSRC_UNKNOWN
2428 && ! sym->attr.is_iso_c)
2429 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2432 if (sym->ts.interface && sym->ts.interface->attr.intrinsic)
2434 gfc_intrinsic_sym *isym;
2435 isym = gfc_find_function (sym->ts.interface->name);
2438 if (compare_actual_formal_intr (ap, sym->ts.interface))
2440 gfc_error ("Type/rank mismatch in argument '%s' at %L",
2446 if (sym->attr.if_source == IFSRC_UNKNOWN)
2448 gfc_actual_arglist *a;
2449 for (a = *ap; a; a = a->next)
2451 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2452 if (a->name != NULL && a->name[0] != '%')
2454 gfc_error("Keyword argument requires explicit interface "
2455 "for procedure '%s' at %L", sym->name, &a->expr->where);
2463 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2466 check_intents (sym->formal, *ap);
2467 if (gfc_option.warn_aliasing)
2468 check_some_aliasing (sym->formal, *ap);
2472 /* Try if an actual argument list matches the formal list of a symbol,
2473 respecting the symbol's attributes like ELEMENTAL. This is used for
2474 GENERIC resolution. */
2477 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2481 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2483 r = !sym->attr.elemental;
2484 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2486 check_intents (sym->formal, *args);
2487 if (gfc_option.warn_aliasing)
2488 check_some_aliasing (sym->formal, *args);
2496 /* Given an interface pointer and an actual argument list, search for
2497 a formal argument list that matches the actual. If found, returns
2498 a pointer to the symbol of the correct interface. Returns NULL if
2502 gfc_search_interface (gfc_interface *intr, int sub_flag,
2503 gfc_actual_arglist **ap)
2505 for (; intr; intr = intr->next)
2507 if (sub_flag && intr->sym->attr.function)
2509 if (!sub_flag && intr->sym->attr.subroutine)
2512 if (gfc_arglist_matches_symbol (ap, intr->sym))
2520 /* Do a brute force recursive search for a symbol. */
2522 static gfc_symtree *
2523 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2527 if (root->n.sym == sym)
2532 st = find_symtree0 (root->left, sym);
2533 if (root->right && ! st)
2534 st = find_symtree0 (root->right, sym);
2539 /* Find a symtree for a symbol. */
2542 gfc_find_sym_in_symtree (gfc_symbol *sym)
2547 /* First try to find it by name. */
2548 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2549 if (st && st->n.sym == sym)
2552 /* If it's been renamed, resort to a brute-force search. */
2553 /* TODO: avoid having to do this search. If the symbol doesn't exist
2554 in the symtree for the current namespace, it should probably be added. */
2555 for (ns = gfc_current_ns; ns; ns = ns->parent)
2557 st = find_symtree0 (ns->sym_root, sym);
2561 gfc_internal_error ("Unable to find symbol %s", sym->name);
2566 /* This subroutine is called when an expression is being resolved.
2567 The expression node in question is either a user defined operator
2568 or an intrinsic operator with arguments that aren't compatible
2569 with the operator. This subroutine builds an actual argument list
2570 corresponding to the operands, then searches for a compatible
2571 interface. If one is found, the expression node is replaced with
2572 the appropriate function call. */
2575 gfc_extend_expr (gfc_expr *e)
2577 gfc_actual_arglist *actual;
2585 actual = gfc_get_actual_arglist ();
2586 actual->expr = e->value.op.op1;
2588 if (e->value.op.op2 != NULL)
2590 actual->next = gfc_get_actual_arglist ();
2591 actual->next->expr = e->value.op.op2;
2594 i = fold_unary (e->value.op.op);
2596 if (i == INTRINSIC_USER)
2598 for (ns = gfc_current_ns; ns; ns = ns->parent)
2600 uop = gfc_find_uop (e->value.op.uop->name, ns);
2604 sym = gfc_search_interface (uop->op, 0, &actual);
2611 for (ns = gfc_current_ns; ns; ns = ns->parent)
2613 /* Due to the distinction between '==' and '.eq.' and friends, one has
2614 to check if either is defined. */
2618 case INTRINSIC_EQ_OS:
2619 sym = gfc_search_interface (ns->op[INTRINSIC_EQ], 0, &actual);
2621 sym = gfc_search_interface (ns->op[INTRINSIC_EQ_OS], 0, &actual);
2625 case INTRINSIC_NE_OS:
2626 sym = gfc_search_interface (ns->op[INTRINSIC_NE], 0, &actual);
2628 sym = gfc_search_interface (ns->op[INTRINSIC_NE_OS], 0, &actual);
2632 case INTRINSIC_GT_OS:
2633 sym = gfc_search_interface (ns->op[INTRINSIC_GT], 0, &actual);
2635 sym = gfc_search_interface (ns->op[INTRINSIC_GT_OS], 0, &actual);
2639 case INTRINSIC_GE_OS:
2640 sym = gfc_search_interface (ns->op[INTRINSIC_GE], 0, &actual);
2642 sym = gfc_search_interface (ns->op[INTRINSIC_GE_OS], 0, &actual);
2646 case INTRINSIC_LT_OS:
2647 sym = gfc_search_interface (ns->op[INTRINSIC_LT], 0, &actual);
2649 sym = gfc_search_interface (ns->op[INTRINSIC_LT_OS], 0, &actual);
2653 case INTRINSIC_LE_OS:
2654 sym = gfc_search_interface (ns->op[INTRINSIC_LE], 0, &actual);
2656 sym = gfc_search_interface (ns->op[INTRINSIC_LE_OS], 0, &actual);
2660 sym = gfc_search_interface (ns->op[i], 0, &actual);
2670 /* Don't use gfc_free_actual_arglist(). */
2671 if (actual->next != NULL)
2672 gfc_free (actual->next);
2678 /* Change the expression node to a function call. */
2679 e->expr_type = EXPR_FUNCTION;
2680 e->symtree = gfc_find_sym_in_symtree (sym);
2681 e->value.function.actual = actual;
2682 e->value.function.esym = NULL;
2683 e->value.function.isym = NULL;
2684 e->value.function.name = NULL;
2685 e->user_operator = 1;
2687 if (gfc_pure (NULL) && !gfc_pure (sym))
2689 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2690 "be PURE", sym->name, &e->where);
2694 if (gfc_resolve_expr (e) == FAILURE)
2701 /* Tries to replace an assignment code node with a subroutine call to
2702 the subroutine associated with the assignment operator. Return
2703 SUCCESS if the node was replaced. On FAILURE, no error is
2707 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2709 gfc_actual_arglist *actual;
2710 gfc_expr *lhs, *rhs;
2716 /* Don't allow an intrinsic assignment to be replaced. */
2717 if (lhs->ts.type != BT_DERIVED
2718 && (rhs->rank == 0 || rhs->rank == lhs->rank)
2719 && (lhs->ts.type == rhs->ts.type
2720 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2723 actual = gfc_get_actual_arglist ();
2726 actual->next = gfc_get_actual_arglist ();
2727 actual->next->expr = rhs;
2731 for (; ns; ns = ns->parent)
2733 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
2740 gfc_free (actual->next);
2745 /* Replace the assignment with the call. */
2746 c->op = EXEC_ASSIGN_CALL;
2747 c->symtree = gfc_find_sym_in_symtree (sym);
2750 c->ext.actual = actual;
2756 /* Make sure that the interface just parsed is not already present in
2757 the given interface list. Ambiguity isn't checked yet since module
2758 procedures can be present without interfaces. */
2761 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
2765 for (ip = base; ip; ip = ip->next)
2767 if (ip->sym == new_sym)
2769 gfc_error ("Entity '%s' at %C is already present in the interface",
2779 /* Add a symbol to the current interface. */
2782 gfc_add_interface (gfc_symbol *new_sym)
2784 gfc_interface **head, *intr;
2788 switch (current_interface.type)
2790 case INTERFACE_NAMELESS:
2791 case INTERFACE_ABSTRACT:
2794 case INTERFACE_INTRINSIC_OP:
2795 for (ns = current_interface.ns; ns; ns = ns->parent)
2796 switch (current_interface.op)
2799 case INTRINSIC_EQ_OS:
2800 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
2801 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
2806 case INTRINSIC_NE_OS:
2807 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
2808 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
2813 case INTRINSIC_GT_OS:
2814 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
2815 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
2820 case INTRINSIC_GE_OS:
2821 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
2822 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
2827 case INTRINSIC_LT_OS:
2828 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
2829 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
2834 case INTRINSIC_LE_OS:
2835 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
2836 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
2841 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
2845 head = ¤t_interface.ns->op[current_interface.op];
2848 case INTERFACE_GENERIC:
2849 for (ns = current_interface.ns; ns; ns = ns->parent)
2851 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2855 if (check_new_interface (sym->generic, new_sym) == FAILURE)
2859 head = ¤t_interface.sym->generic;
2862 case INTERFACE_USER_OP:
2863 if (check_new_interface (current_interface.uop->op, new_sym)
2867 head = ¤t_interface.uop->op;
2871 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2874 intr = gfc_get_interface ();
2875 intr->sym = new_sym;
2876 intr->where = gfc_current_locus;
2886 gfc_current_interface_head (void)
2888 switch (current_interface.type)
2890 case INTERFACE_INTRINSIC_OP:
2891 return current_interface.ns->op[current_interface.op];
2894 case INTERFACE_GENERIC:
2895 return current_interface.sym->generic;
2898 case INTERFACE_USER_OP:
2899 return current_interface.uop->op;
2909 gfc_set_current_interface_head (gfc_interface *i)
2911 switch (current_interface.type)
2913 case INTERFACE_INTRINSIC_OP:
2914 current_interface.ns->op[current_interface.op] = i;
2917 case INTERFACE_GENERIC:
2918 current_interface.sym->generic = i;
2921 case INTERFACE_USER_OP:
2922 current_interface.uop->op = i;
2931 /* Gets rid of a formal argument list. We do not free symbols.
2932 Symbols are freed when a namespace is freed. */
2935 gfc_free_formal_arglist (gfc_formal_arglist *p)
2937 gfc_formal_arglist *q;