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 /* Given two symbols that are formal arguments, compare their types
483 and rank and their formal interfaces if they are both dummy
484 procedures. Returns nonzero if the same, zero if different. */
487 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
489 if (s1 == NULL || s2 == NULL)
490 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. It can happen that
502 external procedures are compared, where one is identified by usage
503 to be a function or subroutine but the other is not. Check TKR
504 nonetheless for these cases. */
505 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
506 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
508 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
509 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
511 /* Now the type of procedure has been identified. */
512 if (s1->attr.function != s2->attr.function
513 || s1->attr.subroutine != s2->attr.subroutine)
516 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
519 /* Originally, gfortran recursed here to check the interfaces of passed
520 procedures. This is explicitly not required by the standard. */
525 /* Given a formal argument list and a keyword name, search the list
526 for that keyword. Returns the correct symbol node if found, NULL
530 find_keyword_arg (const char *name, gfc_formal_arglist *f)
532 for (; f; f = f->next)
533 if (strcmp (f->sym->name, name) == 0)
540 /******** Interface checking subroutines **********/
543 /* Given an operator interface and the operator, make sure that all
544 interfaces for that operator are legal. */
547 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
549 gfc_formal_arglist *formal;
553 int args, r1, r2, k1, k2;
559 t1 = t2 = BT_UNKNOWN;
560 i1 = i2 = INTENT_UNKNOWN;
564 for (formal = intr->sym->formal; formal; formal = formal->next)
569 gfc_error ("Alternate return cannot appear in operator "
570 "interface at %L", &intr->sym->declared_at);
576 i1 = sym->attr.intent;
577 r1 = (sym->as != NULL) ? sym->as->rank : 0;
583 i2 = sym->attr.intent;
584 r2 = (sym->as != NULL) ? sym->as->rank : 0;
592 /* Only +, - and .not. can be unary operators.
593 .not. cannot be a binary operator. */
594 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
595 && op != INTRINSIC_MINUS
596 && op != INTRINSIC_NOT)
597 || (args == 2 && op == INTRINSIC_NOT))
599 gfc_error ("Operator interface at %L has the wrong number of arguments",
600 &intr->sym->declared_at);
604 /* Check that intrinsics are mapped to functions, except
605 INTRINSIC_ASSIGN which should map to a subroutine. */
606 if (op == INTRINSIC_ASSIGN)
608 if (!sym->attr.subroutine)
610 gfc_error ("Assignment operator interface at %L must be "
611 "a SUBROUTINE", &intr->sym->declared_at);
616 gfc_error ("Assignment operator interface at %L must have "
617 "two arguments", &intr->sym->declared_at);
621 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
622 - First argument an array with different rank than second,
623 - Types and kinds do not conform, and
624 - First argument is of derived type. */
625 if (sym->formal->sym->ts.type != BT_DERIVED
626 && (r1 == 0 || r1 == r2)
627 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
628 || (gfc_numeric_ts (&sym->formal->sym->ts)
629 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
631 gfc_error ("Assignment operator interface at %L must not redefine "
632 "an INTRINSIC type assignment", &intr->sym->declared_at);
638 if (!sym->attr.function)
640 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
641 &intr->sym->declared_at);
646 /* Check intents on operator interfaces. */
647 if (op == INTRINSIC_ASSIGN)
649 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
650 gfc_error ("First argument of defined assignment at %L must be "
651 "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
654 gfc_error ("Second argument of defined assignment at %L must be "
655 "INTENT(IN)", &intr->sym->declared_at);
660 gfc_error ("First argument of operator interface at %L must be "
661 "INTENT(IN)", &intr->sym->declared_at);
663 if (args == 2 && i2 != INTENT_IN)
664 gfc_error ("Second argument of operator interface at %L must be "
665 "INTENT(IN)", &intr->sym->declared_at);
668 /* From now on, all we have to do is check that the operator definition
669 doesn't conflict with an intrinsic operator. The rules for this
670 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
671 as well as 12.3.2.1.1 of Fortran 2003:
673 "If the operator is an intrinsic-operator (R310), the number of
674 function arguments shall be consistent with the intrinsic uses of
675 that operator, and the types, kind type parameters, or ranks of the
676 dummy arguments shall differ from those required for the intrinsic
677 operation (7.1.2)." */
679 #define IS_NUMERIC_TYPE(t) \
680 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
682 /* Unary ops are easy, do them first. */
683 if (op == INTRINSIC_NOT)
685 if (t1 == BT_LOGICAL)
691 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
693 if (IS_NUMERIC_TYPE (t1))
699 /* Character intrinsic operators have same character kind, thus
700 operator definitions with operands of different character kinds
702 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
705 /* Intrinsic operators always perform on arguments of same rank,
706 so different ranks is also always safe. (rank == 0) is an exception
707 to that, because all intrinsic operators are elemental. */
708 if (r1 != r2 && r1 != 0 && r2 != 0)
714 case INTRINSIC_EQ_OS:
716 case INTRINSIC_NE_OS:
717 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
722 case INTRINSIC_MINUS:
723 case INTRINSIC_TIMES:
724 case INTRINSIC_DIVIDE:
725 case INTRINSIC_POWER:
726 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
731 case INTRINSIC_GT_OS:
733 case INTRINSIC_GE_OS:
735 case INTRINSIC_LT_OS:
737 case INTRINSIC_LE_OS:
738 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
740 if ((t1 == BT_INTEGER || t1 == BT_REAL)
741 && (t2 == BT_INTEGER || t2 == BT_REAL))
745 case INTRINSIC_CONCAT:
746 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
754 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
764 #undef IS_NUMERIC_TYPE
767 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
773 /* Given a pair of formal argument lists, we see if the two lists can
774 be distinguished by counting the number of nonoptional arguments of
775 a given type/rank in f1 and seeing if there are less then that
776 number of those arguments in f2 (including optional arguments).
777 Since this test is asymmetric, it has to be called twice to make it
778 symmetric. Returns nonzero if the argument lists are incompatible
779 by this test. This subroutine implements rule 1 of section
783 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
785 int rc, ac1, ac2, i, j, k, n1;
786 gfc_formal_arglist *f;
799 for (f = f1; f; f = f->next)
802 /* Build an array of integers that gives the same integer to
803 arguments of the same type/rank. */
804 arg = XCNEWVEC (arginfo, n1);
807 for (i = 0; i < n1; i++, f = f->next)
815 for (i = 0; i < n1; i++)
817 if (arg[i].flag != -1)
820 if (arg[i].sym && arg[i].sym->attr.optional)
821 continue; /* Skip optional arguments. */
825 /* Find other nonoptional arguments of the same type/rank. */
826 for (j = i + 1; j < n1; j++)
827 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
828 && compare_type_rank_if (arg[i].sym, arg[j].sym))
834 /* Now loop over each distinct type found in f1. */
838 for (i = 0; i < n1; i++)
840 if (arg[i].flag != k)
844 for (j = i + 1; j < n1; j++)
845 if (arg[j].flag == k)
848 /* Count the number of arguments in f2 with that type, including
849 those that are optional. */
852 for (f = f2; f; f = f->next)
853 if (compare_type_rank_if (arg[i].sym, f->sym))
871 /* Perform the abbreviated correspondence test for operators. The
872 arguments cannot be optional and are always ordered correctly,
873 which makes this test much easier than that for generic tests.
875 This subroutine is also used when comparing a formal and actual
876 argument list when an actual parameter is a dummy procedure. At
877 that point, two formal interfaces must be compared for equality
878 which is what happens here. */
881 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
885 if (f1 == NULL && f2 == NULL)
887 if (f1 == NULL || f2 == NULL)
890 if (!compare_type_rank (f1->sym, f2->sym))
901 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
902 Returns zero if no argument is found that satisfies rule 2, nonzero
905 This test is also not symmetric in f1 and f2 and must be called
906 twice. This test finds problems caused by sorting the actual
907 argument list with keywords. For example:
911 INTEGER :: A ; REAL :: B
915 INTEGER :: A ; REAL :: B
919 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
922 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
924 gfc_formal_arglist *f2_save, *g;
931 if (f1->sym->attr.optional)
934 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
937 /* Now search for a disambiguating keyword argument starting at
938 the current non-match. */
939 for (g = f1; g; g = g->next)
941 if (g->sym->attr.optional)
944 sym = find_keyword_arg (g->sym->name, f2_save);
945 if (sym == NULL || !compare_type_rank (g->sym, sym))
959 /* 'Compare' two formal interfaces associated with a pair of symbols.
960 We return nonzero if there exists an actual argument list that
961 would be ambiguous between the two interfaces, zero otherwise. */
964 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
966 gfc_formal_arglist *f1, *f2;
968 if ((s1->attr.function && !s2->attr.function)
969 || (s1->attr.subroutine && s2->attr.function))
972 /* If the arguments are functions, check type and kind
973 (only for dummy procedures and procedure pointer assignments). */
974 if ((s1->attr.dummy || s1->attr.proc_pointer)
975 && s1->attr.function && s2->attr.function)
977 if (s1->ts.type == BT_UNKNOWN)
979 if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
981 if (s1->attr.if_source == IFSRC_DECL)
985 if (s1->attr.if_source == IFSRC_UNKNOWN)
991 if (f1 == NULL && f2 == NULL)
992 return 1; /* Special case. */
994 if (count_types_test (f1, f2) || count_types_test (f2, f1))
999 if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1004 if (operator_correspondence (f1, f2))
1012 /* Given a pointer to an interface pointer, remove duplicate
1013 interfaces and make sure that all symbols are either functions or
1014 subroutines. Returns nonzero if something goes wrong. */
1017 check_interface0 (gfc_interface *p, const char *interface_name)
1019 gfc_interface *psave, *q, *qlast;
1022 /* Make sure all symbols in the interface have been defined as
1023 functions or subroutines. */
1024 for (; p; p = p->next)
1025 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1026 || !p->sym->attr.if_source)
1028 if (p->sym->attr.external)
1029 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1030 p->sym->name, interface_name, &p->sym->declared_at);
1032 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1033 "subroutine", p->sym->name, interface_name,
1034 &p->sym->declared_at);
1039 /* Remove duplicate interfaces in this interface list. */
1040 for (; p; p = p->next)
1044 for (q = p->next; q;)
1046 if (p->sym != q->sym)
1053 /* Duplicate interface. */
1054 qlast->next = q->next;
1065 /* Check lists of interfaces to make sure that no two interfaces are
1066 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1069 check_interface1 (gfc_interface *p, gfc_interface *q0,
1070 int generic_flag, const char *interface_name,
1074 for (; p; p = p->next)
1075 for (q = q0; q; q = q->next)
1077 if (p->sym == q->sym)
1078 continue; /* Duplicates OK here. */
1080 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1083 if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
1087 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1088 p->sym->name, q->sym->name, interface_name,
1092 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1093 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1094 p->sym->name, q->sym->name, interface_name,
1103 /* Check the generic and operator interfaces of symbols to make sure
1104 that none of the interfaces conflict. The check has to be done
1105 after all of the symbols are actually loaded. */
1108 check_sym_interfaces (gfc_symbol *sym)
1110 char interface_name[100];
1114 if (sym->ns != gfc_current_ns)
1117 if (sym->generic != NULL)
1119 sprintf (interface_name, "generic interface '%s'", sym->name);
1120 if (check_interface0 (sym->generic, interface_name))
1123 for (p = sym->generic; p; p = p->next)
1125 if (p->sym->attr.mod_proc
1126 && (p->sym->attr.if_source != IFSRC_DECL
1127 || p->sym->attr.procedure))
1129 gfc_error ("'%s' at %L is not a module procedure",
1130 p->sym->name, &p->where);
1135 /* Originally, this test was applied to host interfaces too;
1136 this is incorrect since host associated symbols, from any
1137 source, cannot be ambiguous with local symbols. */
1138 k = sym->attr.referenced || !sym->attr.use_assoc;
1139 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1140 sym->attr.ambiguous_interfaces = 1;
1146 check_uop_interfaces (gfc_user_op *uop)
1148 char interface_name[100];
1152 sprintf (interface_name, "operator interface '%s'", uop->name);
1153 if (check_interface0 (uop->op, interface_name))
1156 for (ns = gfc_current_ns; ns; ns = ns->parent)
1158 uop2 = gfc_find_uop (uop->name, ns);
1162 check_interface1 (uop->op, uop2->op, 0,
1163 interface_name, true);
1168 /* For the namespace, check generic, user operator and intrinsic
1169 operator interfaces for consistency and to remove duplicate
1170 interfaces. We traverse the whole namespace, counting on the fact
1171 that most symbols will not have generic or operator interfaces. */
1174 gfc_check_interfaces (gfc_namespace *ns)
1176 gfc_namespace *old_ns, *ns2;
1177 char interface_name[100];
1180 old_ns = gfc_current_ns;
1181 gfc_current_ns = ns;
1183 gfc_traverse_ns (ns, check_sym_interfaces);
1185 gfc_traverse_user_op (ns, check_uop_interfaces);
1187 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1189 if (i == INTRINSIC_USER)
1192 if (i == INTRINSIC_ASSIGN)
1193 strcpy (interface_name, "intrinsic assignment operator");
1195 sprintf (interface_name, "intrinsic '%s' operator",
1196 gfc_op2string ((gfc_intrinsic_op) i));
1198 if (check_interface0 (ns->op[i], interface_name))
1201 check_operator_interface (ns->op[i], (gfc_intrinsic_op) i);
1203 for (ns2 = ns; ns2; ns2 = ns2->parent)
1205 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1206 interface_name, true))
1212 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
1213 0, interface_name, true)) goto done;
1216 case INTRINSIC_EQ_OS:
1217 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
1218 0, interface_name, true)) goto done;
1222 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
1223 0, interface_name, true)) goto done;
1226 case INTRINSIC_NE_OS:
1227 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
1228 0, interface_name, true)) goto done;
1232 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
1233 0, interface_name, true)) goto done;
1236 case INTRINSIC_GT_OS:
1237 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
1238 0, interface_name, true)) goto done;
1242 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
1243 0, interface_name, true)) goto done;
1246 case INTRINSIC_GE_OS:
1247 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
1248 0, interface_name, true)) goto done;
1252 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
1253 0, interface_name, true)) goto done;
1256 case INTRINSIC_LT_OS:
1257 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
1258 0, interface_name, true)) goto done;
1262 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
1263 0, interface_name, true)) goto done;
1266 case INTRINSIC_LE_OS:
1267 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
1268 0, interface_name, true)) goto done;
1278 gfc_current_ns = old_ns;
1283 symbol_rank (gfc_symbol *sym)
1285 return (sym->as == NULL) ? 0 : sym->as->rank;
1289 /* Given a symbol of a formal argument list and an expression, if the
1290 formal argument is allocatable, check that the actual argument is
1291 allocatable. Returns nonzero if compatible, zero if not compatible. */
1294 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1296 symbol_attribute attr;
1298 if (formal->attr.allocatable)
1300 attr = gfc_expr_attr (actual);
1301 if (!attr.allocatable)
1309 /* Given a symbol of a formal argument list and an expression, if the
1310 formal argument is a pointer, see if the actual argument is a
1311 pointer. Returns nonzero if compatible, zero if not compatible. */
1314 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1316 symbol_attribute attr;
1318 if (formal->attr.pointer)
1320 attr = gfc_expr_attr (actual);
1329 /* Given a symbol of a formal argument list and an expression, see if
1330 the two are compatible as arguments. Returns nonzero if
1331 compatible, zero if not compatible. */
1334 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1335 int ranks_must_agree, int is_elemental, locus *where)
1340 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1341 procs c_f_pointer or c_f_procpointer, and we need to accept most
1342 pointers the user could give us. This should allow that. */
1343 if (formal->ts.type == BT_VOID)
1346 if (formal->ts.type == BT_DERIVED
1347 && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1348 && actual->ts.type == BT_DERIVED
1349 && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1352 if (actual->ts.type == BT_PROCEDURE)
1354 if (formal->attr.flavor != FL_PROCEDURE)
1357 if (formal->attr.function
1358 && !compare_type_rank (formal, actual->symtree->n.sym))
1361 if (formal->attr.if_source == IFSRC_UNKNOWN
1362 || actual->symtree->n.sym->attr.external)
1363 return 1; /* Assume match. */
1365 if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
1372 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1373 formal->name, &actual->where);
1377 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1378 && !gfc_compare_types (&formal->ts, &actual->ts))
1381 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1382 formal->name, &actual->where, gfc_typename (&actual->ts),
1383 gfc_typename (&formal->ts));
1387 if (symbol_rank (formal) == actual->rank)
1390 rank_check = where != NULL && !is_elemental && formal->as
1391 && (formal->as->type == AS_ASSUMED_SHAPE
1392 || formal->as->type == AS_DEFERRED);
1394 if (rank_check || ranks_must_agree || formal->attr.pointer
1395 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1396 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
1399 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1400 formal->name, &actual->where, symbol_rank (formal),
1404 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1407 /* At this point, we are considering a scalar passed to an array. This
1408 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1409 - if the actual argument is (a substring of) an element of a
1410 non-assumed-shape/non-pointer array;
1411 - (F2003) if the actual argument is of type character. */
1413 for (ref = actual->ref; ref; ref = ref->next)
1414 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1417 /* Not an array element. */
1418 if (formal->ts.type == BT_CHARACTER
1420 || (actual->expr_type == EXPR_VARIABLE
1421 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1422 || actual->symtree->n.sym->attr.pointer))))
1424 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1426 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1427 "array dummy argument '%s' at %L",
1428 formal->name, &actual->where);
1431 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1436 else if (ref == NULL)
1439 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1440 formal->name, &actual->where, symbol_rank (formal),
1445 if (actual->expr_type == EXPR_VARIABLE
1446 && actual->symtree->n.sym->as
1447 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1448 || actual->symtree->n.sym->attr.pointer))
1451 gfc_error ("Element of assumed-shaped array passed to dummy "
1452 "argument '%s' at %L", formal->name, &actual->where);
1460 /* Given a symbol of a formal argument list and an expression, see if
1461 the two are compatible as arguments. Returns nonzero if
1462 compatible, zero if not compatible. */
1465 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1467 if (actual->expr_type != EXPR_VARIABLE)
1470 if (!actual->symtree->n.sym->attr.is_protected)
1473 if (!actual->symtree->n.sym->attr.use_assoc)
1476 if (formal->attr.intent == INTENT_IN
1477 || formal->attr.intent == INTENT_UNKNOWN)
1480 if (!actual->symtree->n.sym->attr.pointer)
1483 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1490 /* Returns the storage size of a symbol (formal argument) or
1491 zero if it cannot be determined. */
1493 static unsigned long
1494 get_sym_storage_size (gfc_symbol *sym)
1497 unsigned long strlen, elements;
1499 if (sym->ts.type == BT_CHARACTER)
1501 if (sym->ts.cl && sym->ts.cl->length
1502 && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1503 strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1510 if (symbol_rank (sym) == 0)
1514 if (sym->as->type != AS_EXPLICIT)
1516 for (i = 0; i < sym->as->rank; i++)
1518 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1519 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1522 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1523 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1526 return strlen*elements;
1530 /* Returns the storage size of an expression (actual argument) or
1531 zero if it cannot be determined. For an array element, it returns
1532 the remaining size as the element sequence consists of all storage
1533 units of the actual argument up to the end of the array. */
1535 static unsigned long
1536 get_expr_storage_size (gfc_expr *e)
1539 long int strlen, elements;
1540 long int substrlen = 0;
1541 bool is_str_storage = false;
1547 if (e->ts.type == BT_CHARACTER)
1549 if (e->ts.cl && e->ts.cl->length
1550 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1551 strlen = mpz_get_si (e->ts.cl->length->value.integer);
1552 else if (e->expr_type == EXPR_CONSTANT
1553 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1554 strlen = e->value.character.length;
1559 strlen = 1; /* Length per element. */
1561 if (e->rank == 0 && !e->ref)
1569 for (i = 0; i < e->rank; i++)
1570 elements *= mpz_get_si (e->shape[i]);
1571 return elements*strlen;
1574 for (ref = e->ref; ref; ref = ref->next)
1576 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1577 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1581 /* The string length is the substring length.
1582 Set now to full string length. */
1583 if (ref->u.ss.length == NULL
1584 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1587 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1589 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1593 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1594 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1595 && ref->u.ar.as->upper)
1596 for (i = 0; i < ref->u.ar.dimen; i++)
1598 long int start, end, stride;
1601 if (ref->u.ar.stride[i])
1603 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1604 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1609 if (ref->u.ar.start[i])
1611 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1612 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1616 else if (ref->u.ar.as->lower[i]
1617 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1618 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1622 if (ref->u.ar.end[i])
1624 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1625 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1629 else if (ref->u.ar.as->upper[i]
1630 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1631 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1635 elements *= (end - start)/stride + 1L;
1637 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1638 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1639 for (i = 0; i < ref->u.ar.as->rank; i++)
1641 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1642 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1643 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1644 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1645 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1650 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1651 && e->expr_type == EXPR_VARIABLE)
1653 if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1654 || e->symtree->n.sym->attr.pointer)
1660 /* Determine the number of remaining elements in the element
1661 sequence for array element designators. */
1662 is_str_storage = true;
1663 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1665 if (ref->u.ar.start[i] == NULL
1666 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1667 || ref->u.ar.as->upper[i] == NULL
1668 || ref->u.ar.as->lower[i] == NULL
1669 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1670 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1675 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1676 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1678 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1679 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1687 return (is_str_storage) ? substrlen + (elements-1)*strlen
1690 return elements*strlen;
1694 /* Given an expression, check whether it is an array section
1695 which has a vector subscript. If it has, one is returned,
1699 has_vector_subscript (gfc_expr *e)
1704 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1707 for (ref = e->ref; ref; ref = ref->next)
1708 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1709 for (i = 0; i < ref->u.ar.dimen; i++)
1710 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1717 /* Given formal and actual argument lists, see if they are compatible.
1718 If they are compatible, the actual argument list is sorted to
1719 correspond with the formal list, and elements for missing optional
1720 arguments are inserted. If WHERE pointer is nonnull, then we issue
1721 errors when things don't match instead of just returning the status
1725 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1726 int ranks_must_agree, int is_elemental, locus *where)
1728 gfc_actual_arglist **new_arg, *a, *actual, temp;
1729 gfc_formal_arglist *f;
1731 unsigned long actual_size, formal_size;
1735 if (actual == NULL && formal == NULL)
1739 for (f = formal; f; f = f->next)
1742 new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1744 for (i = 0; i < n; i++)
1751 for (a = actual; a; a = a->next, f = f->next)
1753 /* Look for keywords but ignore g77 extensions like %VAL. */
1754 if (a->name != NULL && a->name[0] != '%')
1757 for (f = formal; f; f = f->next, i++)
1761 if (strcmp (f->sym->name, a->name) == 0)
1768 gfc_error ("Keyword argument '%s' at %L is not in "
1769 "the procedure", a->name, &a->expr->where);
1773 if (new_arg[i] != NULL)
1776 gfc_error ("Keyword argument '%s' at %L is already associated "
1777 "with another actual argument", a->name,
1786 gfc_error ("More actual than formal arguments in procedure "
1787 "call at %L", where);
1792 if (f->sym == NULL && a->expr == NULL)
1798 gfc_error ("Missing alternate return spec in subroutine call "
1803 if (a->expr == NULL)
1806 gfc_error ("Unexpected alternate return spec in subroutine "
1807 "call at %L", where);
1811 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1812 is_elemental, where))
1815 /* Special case for character arguments. For allocatable, pointer
1816 and assumed-shape dummies, the string length needs to match
1818 if (a->expr->ts.type == BT_CHARACTER
1819 && a->expr->ts.cl && a->expr->ts.cl->length
1820 && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1821 && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1822 && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
1823 && (f->sym->attr.pointer || f->sym->attr.allocatable
1824 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1825 && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1826 f->sym->ts.cl->length->value.integer) != 0))
1828 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1829 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1830 "argument and pointer or allocatable dummy argument "
1832 mpz_get_si (a->expr->ts.cl->length->value.integer),
1833 mpz_get_si (f->sym->ts.cl->length->value.integer),
1834 f->sym->name, &a->expr->where);
1836 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1837 "argument and assumed-shape dummy argument '%s' "
1839 mpz_get_si (a->expr->ts.cl->length->value.integer),
1840 mpz_get_si (f->sym->ts.cl->length->value.integer),
1841 f->sym->name, &a->expr->where);
1845 actual_size = get_expr_storage_size (a->expr);
1846 formal_size = get_sym_storage_size (f->sym);
1847 if (actual_size != 0
1848 && actual_size < formal_size
1849 && a->expr->ts.type != BT_PROCEDURE)
1851 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1852 gfc_warning ("Character length of actual argument shorter "
1853 "than of dummy argument '%s' (%lu/%lu) at %L",
1854 f->sym->name, actual_size, formal_size,
1857 gfc_warning ("Actual argument contains too few "
1858 "elements for dummy argument '%s' (%lu/%lu) at %L",
1859 f->sym->name, actual_size, formal_size,
1864 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1865 is provided for a procedure pointer formal argument. */
1866 if (f->sym->attr.proc_pointer
1867 && !(a->expr->symtree->n.sym->attr.proc_pointer
1868 || is_proc_ptr_comp (a->expr, NULL)))
1871 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1872 f->sym->name, &a->expr->where);
1876 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1877 provided for a procedure formal argument. */
1878 if (a->expr->ts.type != BT_PROCEDURE && !is_proc_ptr_comp (a->expr, NULL)
1879 && a->expr->expr_type == EXPR_VARIABLE
1880 && f->sym->attr.flavor == FL_PROCEDURE)
1883 gfc_error ("Expected a procedure for argument '%s' at %L",
1884 f->sym->name, &a->expr->where);
1888 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1889 && a->expr->ts.type == BT_PROCEDURE
1890 && !a->expr->symtree->n.sym->attr.pure)
1893 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1894 f->sym->name, &a->expr->where);
1898 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1899 && a->expr->expr_type == EXPR_VARIABLE
1900 && a->expr->symtree->n.sym->as
1901 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1902 && (a->expr->ref == NULL
1903 || (a->expr->ref->type == REF_ARRAY
1904 && a->expr->ref->u.ar.type == AR_FULL)))
1907 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1908 " array at %L", f->sym->name, where);
1912 if (a->expr->expr_type != EXPR_NULL
1913 && compare_pointer (f->sym, a->expr) == 0)
1916 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1917 f->sym->name, &a->expr->where);
1921 if (a->expr->expr_type != EXPR_NULL
1922 && compare_allocatable (f->sym, a->expr) == 0)
1925 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1926 f->sym->name, &a->expr->where);
1930 /* Check intent = OUT/INOUT for definable actual argument. */
1931 if ((a->expr->expr_type != EXPR_VARIABLE
1932 || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
1933 && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
1934 && (f->sym->attr.intent == INTENT_OUT
1935 || f->sym->attr.intent == INTENT_INOUT))
1938 gfc_error ("Actual argument at %L must be definable as "
1939 "the dummy argument '%s' is INTENT = OUT/INOUT",
1940 &a->expr->where, f->sym->name);
1944 if (!compare_parameter_protected(f->sym, a->expr))
1947 gfc_error ("Actual argument at %L is use-associated with "
1948 "PROTECTED attribute and dummy argument '%s' is "
1949 "INTENT = OUT/INOUT",
1950 &a->expr->where,f->sym->name);
1954 if ((f->sym->attr.intent == INTENT_OUT
1955 || f->sym->attr.intent == INTENT_INOUT
1956 || f->sym->attr.volatile_)
1957 && has_vector_subscript (a->expr))
1960 gfc_error ("Array-section actual argument with vector subscripts "
1961 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
1962 "or VOLATILE attribute of the dummy argument '%s'",
1963 &a->expr->where, f->sym->name);
1967 /* C1232 (R1221) For an actual argument which is an array section or
1968 an assumed-shape array, the dummy argument shall be an assumed-
1969 shape array, if the dummy argument has the VOLATILE attribute. */
1971 if (f->sym->attr.volatile_
1972 && a->expr->symtree->n.sym->as
1973 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1974 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1977 gfc_error ("Assumed-shape actual argument at %L is "
1978 "incompatible with the non-assumed-shape "
1979 "dummy argument '%s' due to VOLATILE attribute",
1980 &a->expr->where,f->sym->name);
1984 if (f->sym->attr.volatile_
1985 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1986 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1989 gfc_error ("Array-section actual argument at %L is "
1990 "incompatible with the non-assumed-shape "
1991 "dummy argument '%s' due to VOLATILE attribute",
1992 &a->expr->where,f->sym->name);
1996 /* C1233 (R1221) For an actual argument which is a pointer array, the
1997 dummy argument shall be an assumed-shape or pointer array, if the
1998 dummy argument has the VOLATILE attribute. */
2000 if (f->sym->attr.volatile_
2001 && a->expr->symtree->n.sym->attr.pointer
2002 && a->expr->symtree->n.sym->as
2004 && (f->sym->as->type == AS_ASSUMED_SHAPE
2005 || f->sym->attr.pointer)))
2008 gfc_error ("Pointer-array actual argument at %L requires "
2009 "an assumed-shape or pointer-array dummy "
2010 "argument '%s' due to VOLATILE attribute",
2011 &a->expr->where,f->sym->name);
2022 /* Make sure missing actual arguments are optional. */
2024 for (f = formal; f; f = f->next, i++)
2026 if (new_arg[i] != NULL)
2031 gfc_error ("Missing alternate return spec in subroutine call "
2035 if (!f->sym->attr.optional)
2038 gfc_error ("Missing actual argument for argument '%s' at %L",
2039 f->sym->name, where);
2044 /* The argument lists are compatible. We now relink a new actual
2045 argument list with null arguments in the right places. The head
2046 of the list remains the head. */
2047 for (i = 0; i < n; i++)
2048 if (new_arg[i] == NULL)
2049 new_arg[i] = gfc_get_actual_arglist ();
2054 *new_arg[0] = *actual;
2058 new_arg[0] = new_arg[na];
2062 for (i = 0; i < n - 1; i++)
2063 new_arg[i]->next = new_arg[i + 1];
2065 new_arg[i]->next = NULL;
2067 if (*ap == NULL && n > 0)
2070 /* Note the types of omitted optional arguments. */
2071 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2072 if (a->expr == NULL && a->label == NULL)
2073 a->missing_arg_type = f->sym->ts.type;
2081 gfc_formal_arglist *f;
2082 gfc_actual_arglist *a;
2086 /* qsort comparison function for argument pairs, with the following
2088 - p->a->expr == NULL
2089 - p->a->expr->expr_type != EXPR_VARIABLE
2090 - growing p->a->expr->symbol. */
2093 pair_cmp (const void *p1, const void *p2)
2095 const gfc_actual_arglist *a1, *a2;
2097 /* *p1 and *p2 are elements of the to-be-sorted array. */
2098 a1 = ((const argpair *) p1)->a;
2099 a2 = ((const argpair *) p2)->a;
2108 if (a1->expr->expr_type != EXPR_VARIABLE)
2110 if (a2->expr->expr_type != EXPR_VARIABLE)
2114 if (a2->expr->expr_type != EXPR_VARIABLE)
2116 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2120 /* Given two expressions from some actual arguments, test whether they
2121 refer to the same expression. The analysis is conservative.
2122 Returning FAILURE will produce no warning. */
2125 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2127 const gfc_ref *r1, *r2;
2130 || e1->expr_type != EXPR_VARIABLE
2131 || e2->expr_type != EXPR_VARIABLE
2132 || e1->symtree->n.sym != e2->symtree->n.sym)
2135 /* TODO: improve comparison, see expr.c:show_ref(). */
2136 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2138 if (r1->type != r2->type)
2143 if (r1->u.ar.type != r2->u.ar.type)
2145 /* TODO: At the moment, consider only full arrays;
2146 we could do better. */
2147 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2152 if (r1->u.c.component != r2->u.c.component)
2160 gfc_internal_error ("compare_actual_expr(): Bad component code");
2169 /* Given formal and actual argument lists that correspond to one
2170 another, check that identical actual arguments aren't not
2171 associated with some incompatible INTENTs. */
2174 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2176 sym_intent f1_intent, f2_intent;
2177 gfc_formal_arglist *f1;
2178 gfc_actual_arglist *a1;
2181 gfc_try t = SUCCESS;
2184 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2186 if (f1 == NULL && a1 == NULL)
2188 if (f1 == NULL || a1 == NULL)
2189 gfc_internal_error ("check_some_aliasing(): List mismatch");
2194 p = (argpair *) alloca (n * sizeof (argpair));
2196 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2202 qsort (p, n, sizeof (argpair), pair_cmp);
2204 for (i = 0; i < n; i++)
2207 || p[i].a->expr->expr_type != EXPR_VARIABLE
2208 || p[i].a->expr->ts.type == BT_PROCEDURE)
2210 f1_intent = p[i].f->sym->attr.intent;
2211 for (j = i + 1; j < n; j++)
2213 /* Expected order after the sort. */
2214 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2215 gfc_internal_error ("check_some_aliasing(): corrupted data");
2217 /* Are the expression the same? */
2218 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2220 f2_intent = p[j].f->sym->attr.intent;
2221 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2222 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2224 gfc_warning ("Same actual argument associated with INTENT(%s) "
2225 "argument '%s' and INTENT(%s) argument '%s' at %L",
2226 gfc_intent_string (f1_intent), p[i].f->sym->name,
2227 gfc_intent_string (f2_intent), p[j].f->sym->name,
2228 &p[i].a->expr->where);
2238 /* Given a symbol of a formal argument list and an expression,
2239 return nonzero if their intents are compatible, zero otherwise. */
2242 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2244 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2247 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2250 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2257 /* Given formal and actual argument lists that correspond to one
2258 another, check that they are compatible in the sense that intents
2259 are not mismatched. */
2262 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2264 sym_intent f_intent;
2266 for (;; f = f->next, a = a->next)
2268 if (f == NULL && a == NULL)
2270 if (f == NULL || a == NULL)
2271 gfc_internal_error ("check_intents(): List mismatch");
2273 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2276 f_intent = f->sym->attr.intent;
2278 if (!compare_parameter_intent(f->sym, a->expr))
2280 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2281 "specifies INTENT(%s)", &a->expr->where,
2282 gfc_intent_string (f_intent));
2286 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2288 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2290 gfc_error ("Procedure argument at %L is local to a PURE "
2291 "procedure and is passed to an INTENT(%s) argument",
2292 &a->expr->where, gfc_intent_string (f_intent));
2296 if (f->sym->attr.pointer)
2298 gfc_error ("Procedure argument at %L is local to a PURE "
2299 "procedure and has the POINTER attribute",
2310 /* Check how a procedure is used against its interface. If all goes
2311 well, the actual argument list will also end up being properly
2315 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2318 /* Warn about calls with an implicit interface. Special case
2319 for calling a ISO_C_BINDING becase c_loc and c_funloc
2320 are pseudo-unknown. */
2321 if (gfc_option.warn_implicit_interface
2322 && sym->attr.if_source == IFSRC_UNKNOWN
2323 && ! sym->attr.is_iso_c)
2324 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2327 if (sym->attr.if_source == IFSRC_UNKNOWN)
2329 gfc_actual_arglist *a;
2330 for (a = *ap; a; a = a->next)
2332 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2333 if (a->name != NULL && a->name[0] != '%')
2335 gfc_error("Keyword argument requires explicit interface "
2336 "for procedure '%s' at %L", sym->name, &a->expr->where);
2344 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2347 check_intents (sym->formal, *ap);
2348 if (gfc_option.warn_aliasing)
2349 check_some_aliasing (sym->formal, *ap);
2353 /* Try if an actual argument list matches the formal list of a symbol,
2354 respecting the symbol's attributes like ELEMENTAL. This is used for
2355 GENERIC resolution. */
2358 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2362 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2364 r = !sym->attr.elemental;
2365 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2367 check_intents (sym->formal, *args);
2368 if (gfc_option.warn_aliasing)
2369 check_some_aliasing (sym->formal, *args);
2377 /* Given an interface pointer and an actual argument list, search for
2378 a formal argument list that matches the actual. If found, returns
2379 a pointer to the symbol of the correct interface. Returns NULL if
2383 gfc_search_interface (gfc_interface *intr, int sub_flag,
2384 gfc_actual_arglist **ap)
2386 for (; intr; intr = intr->next)
2388 if (sub_flag && intr->sym->attr.function)
2390 if (!sub_flag && intr->sym->attr.subroutine)
2393 if (gfc_arglist_matches_symbol (ap, intr->sym))
2401 /* Do a brute force recursive search for a symbol. */
2403 static gfc_symtree *
2404 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2408 if (root->n.sym == sym)
2413 st = find_symtree0 (root->left, sym);
2414 if (root->right && ! st)
2415 st = find_symtree0 (root->right, sym);
2420 /* Find a symtree for a symbol. */
2423 gfc_find_sym_in_symtree (gfc_symbol *sym)
2428 /* First try to find it by name. */
2429 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2430 if (st && st->n.sym == sym)
2433 /* If it's been renamed, resort to a brute-force search. */
2434 /* TODO: avoid having to do this search. If the symbol doesn't exist
2435 in the symtree for the current namespace, it should probably be added. */
2436 for (ns = gfc_current_ns; ns; ns = ns->parent)
2438 st = find_symtree0 (ns->sym_root, sym);
2442 gfc_internal_error ("Unable to find symbol %s", sym->name);
2447 /* This subroutine is called when an expression is being resolved.
2448 The expression node in question is either a user defined operator
2449 or an intrinsic operator with arguments that aren't compatible
2450 with the operator. This subroutine builds an actual argument list
2451 corresponding to the operands, then searches for a compatible
2452 interface. If one is found, the expression node is replaced with
2453 the appropriate function call. */
2456 gfc_extend_expr (gfc_expr *e)
2458 gfc_actual_arglist *actual;
2466 actual = gfc_get_actual_arglist ();
2467 actual->expr = e->value.op.op1;
2469 if (e->value.op.op2 != NULL)
2471 actual->next = gfc_get_actual_arglist ();
2472 actual->next->expr = e->value.op.op2;
2475 i = fold_unary (e->value.op.op);
2477 if (i == INTRINSIC_USER)
2479 for (ns = gfc_current_ns; ns; ns = ns->parent)
2481 uop = gfc_find_uop (e->value.op.uop->name, ns);
2485 sym = gfc_search_interface (uop->op, 0, &actual);
2492 for (ns = gfc_current_ns; ns; ns = ns->parent)
2494 /* Due to the distinction between '==' and '.eq.' and friends, one has
2495 to check if either is defined. */
2499 case INTRINSIC_EQ_OS:
2500 sym = gfc_search_interface (ns->op[INTRINSIC_EQ], 0, &actual);
2502 sym = gfc_search_interface (ns->op[INTRINSIC_EQ_OS], 0, &actual);
2506 case INTRINSIC_NE_OS:
2507 sym = gfc_search_interface (ns->op[INTRINSIC_NE], 0, &actual);
2509 sym = gfc_search_interface (ns->op[INTRINSIC_NE_OS], 0, &actual);
2513 case INTRINSIC_GT_OS:
2514 sym = gfc_search_interface (ns->op[INTRINSIC_GT], 0, &actual);
2516 sym = gfc_search_interface (ns->op[INTRINSIC_GT_OS], 0, &actual);
2520 case INTRINSIC_GE_OS:
2521 sym = gfc_search_interface (ns->op[INTRINSIC_GE], 0, &actual);
2523 sym = gfc_search_interface (ns->op[INTRINSIC_GE_OS], 0, &actual);
2527 case INTRINSIC_LT_OS:
2528 sym = gfc_search_interface (ns->op[INTRINSIC_LT], 0, &actual);
2530 sym = gfc_search_interface (ns->op[INTRINSIC_LT_OS], 0, &actual);
2534 case INTRINSIC_LE_OS:
2535 sym = gfc_search_interface (ns->op[INTRINSIC_LE], 0, &actual);
2537 sym = gfc_search_interface (ns->op[INTRINSIC_LE_OS], 0, &actual);
2541 sym = gfc_search_interface (ns->op[i], 0, &actual);
2551 /* Don't use gfc_free_actual_arglist(). */
2552 if (actual->next != NULL)
2553 gfc_free (actual->next);
2559 /* Change the expression node to a function call. */
2560 e->expr_type = EXPR_FUNCTION;
2561 e->symtree = gfc_find_sym_in_symtree (sym);
2562 e->value.function.actual = actual;
2563 e->value.function.esym = NULL;
2564 e->value.function.isym = NULL;
2565 e->value.function.name = NULL;
2566 e->user_operator = 1;
2568 if (gfc_pure (NULL) && !gfc_pure (sym))
2570 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2571 "be PURE", sym->name, &e->where);
2575 if (gfc_resolve_expr (e) == FAILURE)
2582 /* Tries to replace an assignment code node with a subroutine call to
2583 the subroutine associated with the assignment operator. Return
2584 SUCCESS if the node was replaced. On FAILURE, no error is
2588 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2590 gfc_actual_arglist *actual;
2591 gfc_expr *lhs, *rhs;
2597 /* Don't allow an intrinsic assignment to be replaced. */
2598 if (lhs->ts.type != BT_DERIVED
2599 && (rhs->rank == 0 || rhs->rank == lhs->rank)
2600 && (lhs->ts.type == rhs->ts.type
2601 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2604 actual = gfc_get_actual_arglist ();
2607 actual->next = gfc_get_actual_arglist ();
2608 actual->next->expr = rhs;
2612 for (; ns; ns = ns->parent)
2614 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
2621 gfc_free (actual->next);
2626 /* Replace the assignment with the call. */
2627 c->op = EXEC_ASSIGN_CALL;
2628 c->symtree = gfc_find_sym_in_symtree (sym);
2631 c->ext.actual = actual;
2637 /* Make sure that the interface just parsed is not already present in
2638 the given interface list. Ambiguity isn't checked yet since module
2639 procedures can be present without interfaces. */
2642 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
2646 for (ip = base; ip; ip = ip->next)
2648 if (ip->sym == new_sym)
2650 gfc_error ("Entity '%s' at %C is already present in the interface",
2660 /* Add a symbol to the current interface. */
2663 gfc_add_interface (gfc_symbol *new_sym)
2665 gfc_interface **head, *intr;
2669 switch (current_interface.type)
2671 case INTERFACE_NAMELESS:
2672 case INTERFACE_ABSTRACT:
2675 case INTERFACE_INTRINSIC_OP:
2676 for (ns = current_interface.ns; ns; ns = ns->parent)
2677 switch (current_interface.op)
2680 case INTRINSIC_EQ_OS:
2681 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
2682 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
2687 case INTRINSIC_NE_OS:
2688 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
2689 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
2694 case INTRINSIC_GT_OS:
2695 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
2696 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
2701 case INTRINSIC_GE_OS:
2702 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
2703 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
2708 case INTRINSIC_LT_OS:
2709 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
2710 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
2715 case INTRINSIC_LE_OS:
2716 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
2717 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
2722 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
2726 head = ¤t_interface.ns->op[current_interface.op];
2729 case INTERFACE_GENERIC:
2730 for (ns = current_interface.ns; ns; ns = ns->parent)
2732 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2736 if (check_new_interface (sym->generic, new_sym) == FAILURE)
2740 head = ¤t_interface.sym->generic;
2743 case INTERFACE_USER_OP:
2744 if (check_new_interface (current_interface.uop->op, new_sym)
2748 head = ¤t_interface.uop->op;
2752 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2755 intr = gfc_get_interface ();
2756 intr->sym = new_sym;
2757 intr->where = gfc_current_locus;
2767 gfc_current_interface_head (void)
2769 switch (current_interface.type)
2771 case INTERFACE_INTRINSIC_OP:
2772 return current_interface.ns->op[current_interface.op];
2775 case INTERFACE_GENERIC:
2776 return current_interface.sym->generic;
2779 case INTERFACE_USER_OP:
2780 return current_interface.uop->op;
2790 gfc_set_current_interface_head (gfc_interface *i)
2792 switch (current_interface.type)
2794 case INTERFACE_INTRINSIC_OP:
2795 current_interface.ns->op[current_interface.op] = i;
2798 case INTERFACE_GENERIC:
2799 current_interface.sym->generic = i;
2802 case INTERFACE_USER_OP:
2803 current_interface.uop->op = i;
2812 /* Gets rid of a formal argument list. We do not free symbols.
2813 Symbols are freed when a namespace is freed. */
2816 gfc_free_formal_arglist (gfc_formal_arglist *p)
2818 gfc_formal_arglist *q;