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_intrinsic (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_intrinsic (i);
143 *op = INTRINSIC_NONE;
144 if (gfc_match (" operator ( ") == MATCH_YES)
146 m = gfc_match_defined_op_name (buffer, 1);
152 m = gfc_match_char (')');
158 strcpy (name, buffer);
159 *type = INTERFACE_USER_OP;
163 if (gfc_match_name (buffer) == MATCH_YES)
165 strcpy (name, buffer);
166 *type = INTERFACE_GENERIC;
170 *type = INTERFACE_NAMELESS;
174 gfc_error ("Syntax error in generic specification at %C");
179 /* Match one of the five F95 forms of an interface statement. The
180 matcher for the abstract interface follows. */
183 gfc_match_interface (void)
185 char name[GFC_MAX_SYMBOL_LEN + 1];
191 m = gfc_match_space ();
193 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
196 /* If we're not looking at the end of the statement now, or if this
197 is not a nameless interface but we did not see a space, punt. */
198 if (gfc_match_eos () != MATCH_YES
199 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
201 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
206 current_interface.type = type;
210 case INTERFACE_GENERIC:
211 if (gfc_get_symbol (name, NULL, &sym))
214 if (!sym->attr.generic
215 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
220 gfc_error ("Dummy procedure '%s' at %C cannot have a "
221 "generic interface", sym->name);
225 current_interface.sym = gfc_new_block = sym;
228 case INTERFACE_USER_OP:
229 current_interface.uop = gfc_get_uop (name);
232 case INTERFACE_INTRINSIC_OP:
233 current_interface.op = op;
236 case INTERFACE_NAMELESS:
237 case INTERFACE_ABSTRACT:
246 /* Match a F2003 abstract interface. */
249 gfc_match_abstract_interface (void)
253 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
257 m = gfc_match_eos ();
261 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
265 current_interface.type = INTERFACE_ABSTRACT;
271 /* Match the different sort of generic-specs that can be present after
272 the END INTERFACE itself. */
275 gfc_match_end_interface (void)
277 char name[GFC_MAX_SYMBOL_LEN + 1];
282 m = gfc_match_space ();
284 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
287 /* If we're not looking at the end of the statement now, or if this
288 is not a nameless interface but we did not see a space, punt. */
289 if (gfc_match_eos () != MATCH_YES
290 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
292 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
299 switch (current_interface.type)
301 case INTERFACE_NAMELESS:
302 case INTERFACE_ABSTRACT:
303 if (type != INTERFACE_NAMELESS)
305 gfc_error ("Expected a nameless interface at %C");
311 case INTERFACE_INTRINSIC_OP:
312 if (type != current_interface.type || op != current_interface.op)
315 if (current_interface.op == INTRINSIC_ASSIGN)
316 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
318 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
319 gfc_op2string (current_interface.op));
326 case INTERFACE_USER_OP:
327 /* Comparing the symbol node names is OK because only use-associated
328 symbols can be renamed. */
329 if (type != current_interface.type
330 || strcmp (current_interface.uop->name, name) != 0)
332 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
333 current_interface.uop->name);
339 case INTERFACE_GENERIC:
340 if (type != current_interface.type
341 || strcmp (current_interface.sym->name, name) != 0)
343 gfc_error ("Expecting 'END INTERFACE %s' at %C",
344 current_interface.sym->name);
355 /* Compare two derived types using the criteria in 4.4.2 of the standard,
356 recursing through gfc_compare_types for the components. */
359 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
361 gfc_component *dt1, *dt2;
363 if (derived1 == derived2)
366 /* Special case for comparing derived types across namespaces. If the
367 true names and module names are the same and the module name is
368 nonnull, then they are equal. */
369 if (derived1 != NULL && derived2 != NULL
370 && strcmp (derived1->name, derived2->name) == 0
371 && derived1->module != NULL && derived2->module != NULL
372 && strcmp (derived1->module, derived2->module) == 0)
375 /* Compare type via the rules of the standard. Both types must have
376 the SEQUENCE attribute to be equal. */
378 if (strcmp (derived1->name, derived2->name))
381 if (derived1->component_access == ACCESS_PRIVATE
382 || derived2->component_access == ACCESS_PRIVATE)
385 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
388 dt1 = derived1->components;
389 dt2 = derived2->components;
391 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
392 simple test can speed things up. Otherwise, lots of things have to
396 if (strcmp (dt1->name, dt2->name) != 0)
399 if (dt1->attr.access != dt2->attr.access)
402 if (dt1->attr.pointer != dt2->attr.pointer)
405 if (dt1->attr.dimension != dt2->attr.dimension)
408 if (dt1->attr.allocatable != dt2->attr.allocatable)
411 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
414 /* Make sure that link lists do not put this function into an
415 endless recursive loop! */
416 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
417 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
418 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
421 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
422 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
425 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
426 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
432 if (dt1 == NULL && dt2 == NULL)
434 if (dt1 == NULL || dt2 == NULL)
442 /* Compare two typespecs, recursively if necessary. */
445 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
447 /* See if one of the typespecs is a BT_VOID, which is what is being used
448 to allow the funcs like c_f_pointer to accept any pointer type.
449 TODO: Possibly should narrow this to just the one typespec coming in
450 that is for the formal arg, but oh well. */
451 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
454 if (ts1->type != ts2->type
455 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
456 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
458 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
459 return (ts1->kind == ts2->kind);
461 /* Compare derived types. */
462 if (gfc_type_compatible (ts1, ts2))
465 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
469 /* Given two symbols that are formal arguments, compare their ranks
470 and types. Returns nonzero if they have the same rank and type,
474 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
478 r1 = (s1->as != NULL) ? s1->as->rank : 0;
479 r2 = (s2->as != NULL) ? s2->as->rank : 0;
482 return 0; /* Ranks differ. */
484 return gfc_compare_types (&s1->ts, &s2->ts);
488 /* Given two symbols that are formal arguments, compare their types
489 and rank and their formal interfaces if they are both dummy
490 procedures. Returns nonzero if the same, zero if different. */
493 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
495 if (s1 == NULL || s2 == NULL)
496 return s1 == s2 ? 1 : 0;
501 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
502 return compare_type_rank (s1, s2);
504 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
507 /* At this point, both symbols are procedures. It can happen that
508 external procedures are compared, where one is identified by usage
509 to be a function or subroutine but the other is not. Check TKR
510 nonetheless for these cases. */
511 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
512 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
514 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
515 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
517 /* Now the type of procedure has been identified. */
518 if (s1->attr.function != s2->attr.function
519 || s1->attr.subroutine != s2->attr.subroutine)
522 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
525 /* Originally, gfortran recursed here to check the interfaces of passed
526 procedures. This is explicitly not required by the standard. */
531 /* Given a formal argument list and a keyword name, search the list
532 for that keyword. Returns the correct symbol node if found, NULL
536 find_keyword_arg (const char *name, gfc_formal_arglist *f)
538 for (; f; f = f->next)
539 if (strcmp (f->sym->name, name) == 0)
546 /******** Interface checking subroutines **********/
549 /* Given an operator interface and the operator, make sure that all
550 interfaces for that operator are legal. */
553 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
556 gfc_formal_arglist *formal;
559 int args, r1, r2, k1, k2;
564 t1 = t2 = BT_UNKNOWN;
565 i1 = i2 = INTENT_UNKNOWN;
569 for (formal = sym->formal; formal; formal = formal->next)
571 gfc_symbol *fsym = formal->sym;
574 gfc_error ("Alternate return cannot appear in operator "
575 "interface at %L", &sym->declared_at);
581 i1 = fsym->attr.intent;
582 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
588 i2 = fsym->attr.intent;
589 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
595 /* Only +, - and .not. can be unary operators.
596 .not. cannot be a binary operator. */
597 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
598 && op != INTRINSIC_MINUS
599 && op != INTRINSIC_NOT)
600 || (args == 2 && op == INTRINSIC_NOT))
602 gfc_error ("Operator interface at %L has the wrong number of arguments",
607 /* Check that intrinsics are mapped to functions, except
608 INTRINSIC_ASSIGN which should map to a subroutine. */
609 if (op == INTRINSIC_ASSIGN)
611 if (!sym->attr.subroutine)
613 gfc_error ("Assignment operator interface at %L must be "
614 "a SUBROUTINE", &sym->declared_at);
619 gfc_error ("Assignment operator interface at %L must have "
620 "two arguments", &sym->declared_at);
624 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
625 - First argument an array with different rank than second,
626 - Types and kinds do not conform, and
627 - First argument is of derived type. */
628 if (sym->formal->sym->ts.type != BT_DERIVED
629 && sym->formal->sym->ts.type != BT_CLASS
630 && (r1 == 0 || r1 == r2)
631 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
632 || (gfc_numeric_ts (&sym->formal->sym->ts)
633 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
635 gfc_error ("Assignment operator interface at %L must not redefine "
636 "an INTRINSIC type assignment", &sym->declared_at);
642 if (!sym->attr.function)
644 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
650 /* Check intents on operator interfaces. */
651 if (op == INTRINSIC_ASSIGN)
653 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
655 gfc_error ("First argument of defined assignment at %L must be "
656 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
662 gfc_error ("Second argument of defined assignment at %L must be "
663 "INTENT(IN)", &sym->declared_at);
671 gfc_error ("First argument of operator interface at %L must be "
672 "INTENT(IN)", &sym->declared_at);
676 if (args == 2 && i2 != INTENT_IN)
678 gfc_error ("Second argument of operator interface at %L must be "
679 "INTENT(IN)", &sym->declared_at);
684 /* From now on, all we have to do is check that the operator definition
685 doesn't conflict with an intrinsic operator. The rules for this
686 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
687 as well as 12.3.2.1.1 of Fortran 2003:
689 "If the operator is an intrinsic-operator (R310), the number of
690 function arguments shall be consistent with the intrinsic uses of
691 that operator, and the types, kind type parameters, or ranks of the
692 dummy arguments shall differ from those required for the intrinsic
693 operation (7.1.2)." */
695 #define IS_NUMERIC_TYPE(t) \
696 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
698 /* Unary ops are easy, do them first. */
699 if (op == INTRINSIC_NOT)
701 if (t1 == BT_LOGICAL)
707 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
709 if (IS_NUMERIC_TYPE (t1))
715 /* Character intrinsic operators have same character kind, thus
716 operator definitions with operands of different character kinds
718 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
721 /* Intrinsic operators always perform on arguments of same rank,
722 so different ranks is also always safe. (rank == 0) is an exception
723 to that, because all intrinsic operators are elemental. */
724 if (r1 != r2 && r1 != 0 && r2 != 0)
730 case INTRINSIC_EQ_OS:
732 case INTRINSIC_NE_OS:
733 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
738 case INTRINSIC_MINUS:
739 case INTRINSIC_TIMES:
740 case INTRINSIC_DIVIDE:
741 case INTRINSIC_POWER:
742 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
747 case INTRINSIC_GT_OS:
749 case INTRINSIC_GE_OS:
751 case INTRINSIC_LT_OS:
753 case INTRINSIC_LE_OS:
754 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
756 if ((t1 == BT_INTEGER || t1 == BT_REAL)
757 && (t2 == BT_INTEGER || t2 == BT_REAL))
761 case INTRINSIC_CONCAT:
762 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
770 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
780 #undef IS_NUMERIC_TYPE
783 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
789 /* Given a pair of formal argument lists, we see if the two lists can
790 be distinguished by counting the number of nonoptional arguments of
791 a given type/rank in f1 and seeing if there are less then that
792 number of those arguments in f2 (including optional arguments).
793 Since this test is asymmetric, it has to be called twice to make it
794 symmetric. Returns nonzero if the argument lists are incompatible
795 by this test. This subroutine implements rule 1 of section
796 14.1.2.3 in the Fortran 95 standard. */
799 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
801 int rc, ac1, ac2, i, j, k, n1;
802 gfc_formal_arglist *f;
815 for (f = f1; f; f = f->next)
818 /* Build an array of integers that gives the same integer to
819 arguments of the same type/rank. */
820 arg = XCNEWVEC (arginfo, n1);
823 for (i = 0; i < n1; i++, f = f->next)
831 for (i = 0; i < n1; i++)
833 if (arg[i].flag != -1)
836 if (arg[i].sym && arg[i].sym->attr.optional)
837 continue; /* Skip optional arguments. */
841 /* Find other nonoptional arguments of the same type/rank. */
842 for (j = i + 1; j < n1; j++)
843 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
844 && compare_type_rank_if (arg[i].sym, arg[j].sym))
850 /* Now loop over each distinct type found in f1. */
854 for (i = 0; i < n1; i++)
856 if (arg[i].flag != k)
860 for (j = i + 1; j < n1; j++)
861 if (arg[j].flag == k)
864 /* Count the number of arguments in f2 with that type, including
865 those that are optional. */
868 for (f = f2; f; f = f->next)
869 if (compare_type_rank_if (arg[i].sym, f->sym))
887 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
888 Returns zero if no argument is found that satisfies rule 2, nonzero
891 This test is also not symmetric in f1 and f2 and must be called
892 twice. This test finds problems caused by sorting the actual
893 argument list with keywords. For example:
897 INTEGER :: A ; REAL :: B
901 INTEGER :: A ; REAL :: B
905 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
908 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
910 gfc_formal_arglist *f2_save, *g;
917 if (f1->sym->attr.optional)
920 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
923 /* Now search for a disambiguating keyword argument starting at
924 the current non-match. */
925 for (g = f1; g; g = g->next)
927 if (g->sym->attr.optional)
930 sym = find_keyword_arg (g->sym->name, f2_save);
931 if (sym == NULL || !compare_type_rank (g->sym, sym))
945 /* 'Compare' two formal interfaces associated with a pair of symbols.
946 We return nonzero if there exists an actual argument list that
947 would be ambiguous between the two interfaces, zero otherwise.
948 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
949 required to match, which is not the case for ambiguity checks.*/
952 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
953 int generic_flag, int intent_flag,
954 char *errmsg, int err_len)
956 gfc_formal_arglist *f1, *f2;
958 gcc_assert (name2 != NULL);
960 if (s1->attr.function && (s2->attr.subroutine
961 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
962 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
965 snprintf (errmsg, err_len, "'%s' is not a function", name2);
969 if (s1->attr.subroutine && s2->attr.function)
972 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
976 /* If the arguments are functions, check type and kind
977 (only for dummy procedures and procedure pointer assignments). */
978 if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
980 if (s1->ts.type == BT_UNKNOWN)
982 if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
985 snprintf (errmsg, err_len, "Type/kind mismatch in return value "
991 if (s1->attr.if_source == IFSRC_UNKNOWN
992 || s2->attr.if_source == IFSRC_UNKNOWN)
998 if (f1 == NULL && f2 == NULL)
999 return 1; /* Special case: No arguments. */
1003 if (count_types_test (f1, f2) || count_types_test (f2, f1))
1005 if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1009 /* Perform the abbreviated correspondence test for operators (the
1010 arguments cannot be optional and are always ordered correctly).
1011 This is also done when comparing interfaces for dummy procedures and in
1012 procedure pointer assignments. */
1016 /* Check existence. */
1017 if (f1 == NULL && f2 == NULL)
1019 if (f1 == NULL || f2 == NULL)
1022 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1023 "arguments", name2);
1027 /* Check type and rank. */
1028 if (!compare_type_rank (f1->sym, f2->sym))
1031 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1037 if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
1039 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1044 /* Check OPTIONAL. */
1045 if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
1047 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1060 /* Given a pointer to an interface pointer, remove duplicate
1061 interfaces and make sure that all symbols are either functions or
1062 subroutines. Returns nonzero if something goes wrong. */
1065 check_interface0 (gfc_interface *p, const char *interface_name)
1067 gfc_interface *psave, *q, *qlast;
1070 /* Make sure all symbols in the interface have been defined as
1071 functions or subroutines. */
1072 for (; p; p = p->next)
1073 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1074 || !p->sym->attr.if_source)
1076 if (p->sym->attr.external)
1077 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1078 p->sym->name, interface_name, &p->sym->declared_at);
1080 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1081 "subroutine", p->sym->name, interface_name,
1082 &p->sym->declared_at);
1087 /* Remove duplicate interfaces in this interface list. */
1088 for (; p; p = p->next)
1092 for (q = p->next; q;)
1094 if (p->sym != q->sym)
1101 /* Duplicate interface. */
1102 qlast->next = q->next;
1113 /* Check lists of interfaces to make sure that no two interfaces are
1114 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1117 check_interface1 (gfc_interface *p, gfc_interface *q0,
1118 int generic_flag, const char *interface_name,
1122 for (; p; p = p->next)
1123 for (q = q0; q; q = q->next)
1125 if (p->sym == q->sym)
1126 continue; /* Duplicates OK here. */
1128 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1131 if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0,
1135 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1136 p->sym->name, q->sym->name, interface_name,
1138 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1139 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1140 p->sym->name, q->sym->name, interface_name,
1143 gfc_warning ("Although not referenced, '%s' has ambiguous "
1144 "interfaces at %L", interface_name, &p->where);
1152 /* Check the generic and operator interfaces of symbols to make sure
1153 that none of the interfaces conflict. The check has to be done
1154 after all of the symbols are actually loaded. */
1157 check_sym_interfaces (gfc_symbol *sym)
1159 char interface_name[100];
1162 if (sym->ns != gfc_current_ns)
1165 if (sym->generic != NULL)
1167 sprintf (interface_name, "generic interface '%s'", sym->name);
1168 if (check_interface0 (sym->generic, interface_name))
1171 for (p = sym->generic; p; p = p->next)
1173 if (p->sym->attr.mod_proc
1174 && (p->sym->attr.if_source != IFSRC_DECL
1175 || p->sym->attr.procedure))
1177 gfc_error ("'%s' at %L is not a module procedure",
1178 p->sym->name, &p->where);
1183 /* Originally, this test was applied to host interfaces too;
1184 this is incorrect since host associated symbols, from any
1185 source, cannot be ambiguous with local symbols. */
1186 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1187 sym->attr.referenced || !sym->attr.use_assoc);
1193 check_uop_interfaces (gfc_user_op *uop)
1195 char interface_name[100];
1199 sprintf (interface_name, "operator interface '%s'", uop->name);
1200 if (check_interface0 (uop->op, interface_name))
1203 for (ns = gfc_current_ns; ns; ns = ns->parent)
1205 uop2 = gfc_find_uop (uop->name, ns);
1209 check_interface1 (uop->op, uop2->op, 0,
1210 interface_name, true);
1215 /* For the namespace, check generic, user operator and intrinsic
1216 operator interfaces for consistency and to remove duplicate
1217 interfaces. We traverse the whole namespace, counting on the fact
1218 that most symbols will not have generic or operator interfaces. */
1221 gfc_check_interfaces (gfc_namespace *ns)
1223 gfc_namespace *old_ns, *ns2;
1224 char interface_name[100];
1227 old_ns = gfc_current_ns;
1228 gfc_current_ns = ns;
1230 gfc_traverse_ns (ns, check_sym_interfaces);
1232 gfc_traverse_user_op (ns, check_uop_interfaces);
1234 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1236 if (i == INTRINSIC_USER)
1239 if (i == INTRINSIC_ASSIGN)
1240 strcpy (interface_name, "intrinsic assignment operator");
1242 sprintf (interface_name, "intrinsic '%s' operator",
1243 gfc_op2string ((gfc_intrinsic_op) i));
1245 if (check_interface0 (ns->op[i], interface_name))
1249 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1252 for (ns2 = ns; ns2; ns2 = ns2->parent)
1254 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1255 interface_name, true))
1261 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
1262 0, interface_name, true)) goto done;
1265 case INTRINSIC_EQ_OS:
1266 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
1267 0, interface_name, true)) goto done;
1271 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
1272 0, interface_name, true)) goto done;
1275 case INTRINSIC_NE_OS:
1276 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
1277 0, interface_name, true)) goto done;
1281 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
1282 0, interface_name, true)) goto done;
1285 case INTRINSIC_GT_OS:
1286 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
1287 0, interface_name, true)) goto done;
1291 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
1292 0, interface_name, true)) goto done;
1295 case INTRINSIC_GE_OS:
1296 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
1297 0, interface_name, true)) goto done;
1301 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
1302 0, interface_name, true)) goto done;
1305 case INTRINSIC_LT_OS:
1306 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
1307 0, interface_name, true)) goto done;
1311 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
1312 0, interface_name, true)) goto done;
1315 case INTRINSIC_LE_OS:
1316 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
1317 0, interface_name, true)) goto done;
1327 gfc_current_ns = old_ns;
1332 symbol_rank (gfc_symbol *sym)
1334 return (sym->as == NULL) ? 0 : sym->as->rank;
1338 /* Given a symbol of a formal argument list and an expression, if the
1339 formal argument is allocatable, check that the actual argument is
1340 allocatable. Returns nonzero if compatible, zero if not compatible. */
1343 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1345 symbol_attribute attr;
1347 if (formal->attr.allocatable)
1349 attr = gfc_expr_attr (actual);
1350 if (!attr.allocatable)
1358 /* Given a symbol of a formal argument list and an expression, if the
1359 formal argument is a pointer, see if the actual argument is a
1360 pointer. Returns nonzero if compatible, zero if not compatible. */
1363 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1365 symbol_attribute attr;
1367 if (formal->attr.pointer)
1369 attr = gfc_expr_attr (actual);
1378 /* Given a symbol of a formal argument list and an expression, see if
1379 the two are compatible as arguments. Returns nonzero if
1380 compatible, zero if not compatible. */
1383 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1384 int ranks_must_agree, int is_elemental, locus *where)
1389 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1390 procs c_f_pointer or c_f_procpointer, and we need to accept most
1391 pointers the user could give us. This should allow that. */
1392 if (formal->ts.type == BT_VOID)
1395 if (formal->ts.type == BT_DERIVED
1396 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1397 && actual->ts.type == BT_DERIVED
1398 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1401 if (actual->ts.type == BT_PROCEDURE)
1404 gfc_symbol *act_sym = actual->symtree->n.sym;
1406 if (formal->attr.flavor != FL_PROCEDURE)
1409 gfc_error ("Invalid procedure argument at %L", &actual->where);
1413 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1417 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1418 formal->name, &actual->where, err);
1422 if (formal->attr.function && !act_sym->attr.function)
1424 gfc_add_function (&act_sym->attr, act_sym->name,
1425 &act_sym->declared_at);
1426 if (act_sym->ts.type == BT_UNKNOWN
1427 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1430 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1431 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1432 &act_sym->declared_at);
1437 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1438 && !gfc_compare_types (&formal->ts, &actual->ts))
1441 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1442 formal->name, &actual->where, gfc_typename (&actual->ts),
1443 gfc_typename (&formal->ts));
1447 if (symbol_rank (formal) == actual->rank)
1450 rank_check = where != NULL && !is_elemental && formal->as
1451 && (formal->as->type == AS_ASSUMED_SHAPE
1452 || formal->as->type == AS_DEFERRED)
1453 && actual->expr_type != EXPR_NULL;
1455 if (rank_check || ranks_must_agree
1456 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1457 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1458 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
1461 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1462 formal->name, &actual->where, symbol_rank (formal),
1466 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1469 /* At this point, we are considering a scalar passed to an array. This
1470 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1471 - if the actual argument is (a substring of) an element of a
1472 non-assumed-shape/non-pointer array;
1473 - (F2003) if the actual argument is of type character. */
1475 for (ref = actual->ref; ref; ref = ref->next)
1476 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1479 /* Not an array element. */
1480 if (formal->ts.type == BT_CHARACTER
1482 || (actual->expr_type == EXPR_VARIABLE
1483 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1484 || actual->symtree->n.sym->attr.pointer))))
1486 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1488 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1489 "array dummy argument '%s' at %L",
1490 formal->name, &actual->where);
1493 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1498 else if (ref == NULL && actual->expr_type != EXPR_NULL)
1501 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1502 formal->name, &actual->where, symbol_rank (formal),
1507 if (actual->expr_type == EXPR_VARIABLE
1508 && actual->symtree->n.sym->as
1509 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1510 || actual->symtree->n.sym->attr.pointer))
1513 gfc_error ("Element of assumed-shaped array passed to dummy "
1514 "argument '%s' at %L", formal->name, &actual->where);
1522 /* Given a symbol of a formal argument list and an expression, see if
1523 the two are compatible as arguments. Returns nonzero if
1524 compatible, zero if not compatible. */
1527 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1529 if (actual->expr_type != EXPR_VARIABLE)
1532 if (!actual->symtree->n.sym->attr.is_protected)
1535 if (!actual->symtree->n.sym->attr.use_assoc)
1538 if (formal->attr.intent == INTENT_IN
1539 || formal->attr.intent == INTENT_UNKNOWN)
1542 if (!actual->symtree->n.sym->attr.pointer)
1545 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1552 /* Returns the storage size of a symbol (formal argument) or
1553 zero if it cannot be determined. */
1555 static unsigned long
1556 get_sym_storage_size (gfc_symbol *sym)
1559 unsigned long strlen, elements;
1561 if (sym->ts.type == BT_CHARACTER)
1563 if (sym->ts.u.cl && sym->ts.u.cl->length
1564 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1565 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1572 if (symbol_rank (sym) == 0)
1576 if (sym->as->type != AS_EXPLICIT)
1578 for (i = 0; i < sym->as->rank; i++)
1580 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1581 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1584 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1585 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1588 return strlen*elements;
1592 /* Returns the storage size of an expression (actual argument) or
1593 zero if it cannot be determined. For an array element, it returns
1594 the remaining size as the element sequence consists of all storage
1595 units of the actual argument up to the end of the array. */
1597 static unsigned long
1598 get_expr_storage_size (gfc_expr *e)
1601 long int strlen, elements;
1602 long int substrlen = 0;
1603 bool is_str_storage = false;
1609 if (e->ts.type == BT_CHARACTER)
1611 if (e->ts.u.cl && e->ts.u.cl->length
1612 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1613 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1614 else if (e->expr_type == EXPR_CONSTANT
1615 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1616 strlen = e->value.character.length;
1621 strlen = 1; /* Length per element. */
1623 if (e->rank == 0 && !e->ref)
1631 for (i = 0; i < e->rank; i++)
1632 elements *= mpz_get_si (e->shape[i]);
1633 return elements*strlen;
1636 for (ref = e->ref; ref; ref = ref->next)
1638 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1639 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1643 /* The string length is the substring length.
1644 Set now to full string length. */
1645 if (ref->u.ss.length == NULL
1646 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1649 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1651 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1655 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1656 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1657 && ref->u.ar.as->upper)
1658 for (i = 0; i < ref->u.ar.dimen; i++)
1660 long int start, end, stride;
1663 if (ref->u.ar.stride[i])
1665 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1666 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1671 if (ref->u.ar.start[i])
1673 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1674 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1678 else if (ref->u.ar.as->lower[i]
1679 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1680 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1684 if (ref->u.ar.end[i])
1686 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1687 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1691 else if (ref->u.ar.as->upper[i]
1692 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1693 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1697 elements *= (end - start)/stride + 1L;
1699 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1700 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1701 for (i = 0; i < ref->u.ar.as->rank; i++)
1703 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1704 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1705 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1706 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1707 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1712 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1713 && e->expr_type == EXPR_VARIABLE)
1715 if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1716 || e->symtree->n.sym->attr.pointer)
1722 /* Determine the number of remaining elements in the element
1723 sequence for array element designators. */
1724 is_str_storage = true;
1725 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1727 if (ref->u.ar.start[i] == NULL
1728 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1729 || ref->u.ar.as->upper[i] == NULL
1730 || ref->u.ar.as->lower[i] == NULL
1731 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1732 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1737 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1738 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1740 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1741 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1749 return (is_str_storage) ? substrlen + (elements-1)*strlen
1752 return elements*strlen;
1756 /* Given an expression, check whether it is an array section
1757 which has a vector subscript. If it has, one is returned,
1761 has_vector_subscript (gfc_expr *e)
1766 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1769 for (ref = e->ref; ref; ref = ref->next)
1770 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1771 for (i = 0; i < ref->u.ar.dimen; i++)
1772 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1779 /* Given formal and actual argument lists, see if they are compatible.
1780 If they are compatible, the actual argument list is sorted to
1781 correspond with the formal list, and elements for missing optional
1782 arguments are inserted. If WHERE pointer is nonnull, then we issue
1783 errors when things don't match instead of just returning the status
1787 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1788 int ranks_must_agree, int is_elemental, locus *where)
1790 gfc_actual_arglist **new_arg, *a, *actual, temp;
1791 gfc_formal_arglist *f;
1793 unsigned long actual_size, formal_size;
1797 if (actual == NULL && formal == NULL)
1801 for (f = formal; f; f = f->next)
1804 new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1806 for (i = 0; i < n; i++)
1813 for (a = actual; a; a = a->next, f = f->next)
1815 /* Look for keywords but ignore g77 extensions like %VAL. */
1816 if (a->name != NULL && a->name[0] != '%')
1819 for (f = formal; f; f = f->next, i++)
1823 if (strcmp (f->sym->name, a->name) == 0)
1830 gfc_error ("Keyword argument '%s' at %L is not in "
1831 "the procedure", a->name, &a->expr->where);
1835 if (new_arg[i] != NULL)
1838 gfc_error ("Keyword argument '%s' at %L is already associated "
1839 "with another actual argument", a->name,
1848 gfc_error ("More actual than formal arguments in procedure "
1849 "call at %L", where);
1854 if (f->sym == NULL && a->expr == NULL)
1860 gfc_error ("Missing alternate return spec in subroutine call "
1865 if (a->expr == NULL)
1868 gfc_error ("Unexpected alternate return spec in subroutine "
1869 "call at %L", where);
1873 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1874 is_elemental, where))
1877 /* Special case for character arguments. For allocatable, pointer
1878 and assumed-shape dummies, the string length needs to match
1880 if (a->expr->ts.type == BT_CHARACTER
1881 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
1882 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1883 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
1884 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
1885 && (f->sym->attr.pointer || f->sym->attr.allocatable
1886 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1887 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
1888 f->sym->ts.u.cl->length->value.integer) != 0))
1890 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1891 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1892 "argument and pointer or allocatable dummy argument "
1894 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1895 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1896 f->sym->name, &a->expr->where);
1898 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1899 "argument and assumed-shape dummy argument '%s' "
1901 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1902 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1903 f->sym->name, &a->expr->where);
1907 actual_size = get_expr_storage_size (a->expr);
1908 formal_size = get_sym_storage_size (f->sym);
1909 if (actual_size != 0
1910 && actual_size < formal_size
1911 && a->expr->ts.type != BT_PROCEDURE)
1913 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1914 gfc_warning ("Character length of actual argument shorter "
1915 "than of dummy argument '%s' (%lu/%lu) at %L",
1916 f->sym->name, actual_size, formal_size,
1919 gfc_warning ("Actual argument contains too few "
1920 "elements for dummy argument '%s' (%lu/%lu) at %L",
1921 f->sym->name, actual_size, formal_size,
1926 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1927 is provided for a procedure pointer formal argument. */
1928 if (f->sym->attr.proc_pointer
1929 && !((a->expr->expr_type == EXPR_VARIABLE
1930 && a->expr->symtree->n.sym->attr.proc_pointer)
1931 || (a->expr->expr_type == EXPR_FUNCTION
1932 && a->expr->symtree->n.sym->result->attr.proc_pointer)
1933 || gfc_is_proc_ptr_comp (a->expr, NULL)))
1936 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1937 f->sym->name, &a->expr->where);
1941 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1942 provided for a procedure formal argument. */
1943 if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
1944 && a->expr->expr_type == EXPR_VARIABLE
1945 && f->sym->attr.flavor == FL_PROCEDURE)
1948 gfc_error ("Expected a procedure for argument '%s' at %L",
1949 f->sym->name, &a->expr->where);
1953 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1954 && a->expr->ts.type == BT_PROCEDURE
1955 && !a->expr->symtree->n.sym->attr.pure)
1958 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1959 f->sym->name, &a->expr->where);
1963 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1964 && a->expr->expr_type == EXPR_VARIABLE
1965 && a->expr->symtree->n.sym->as
1966 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1967 && (a->expr->ref == NULL
1968 || (a->expr->ref->type == REF_ARRAY
1969 && a->expr->ref->u.ar.type == AR_FULL)))
1972 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1973 " array at %L", f->sym->name, where);
1977 if (a->expr->expr_type != EXPR_NULL
1978 && compare_pointer (f->sym, a->expr) == 0)
1981 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1982 f->sym->name, &a->expr->where);
1986 if (a->expr->expr_type != EXPR_NULL
1987 && compare_allocatable (f->sym, a->expr) == 0)
1990 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1991 f->sym->name, &a->expr->where);
1995 /* Check intent = OUT/INOUT for definable actual argument. */
1996 if ((a->expr->expr_type != EXPR_VARIABLE
1997 || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
1998 && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
1999 && (f->sym->attr.intent == INTENT_OUT
2000 || f->sym->attr.intent == INTENT_INOUT))
2003 gfc_error ("Actual argument at %L must be definable as "
2004 "the dummy argument '%s' is INTENT = OUT/INOUT",
2005 &a->expr->where, f->sym->name);
2009 if (!compare_parameter_protected(f->sym, a->expr))
2012 gfc_error ("Actual argument at %L is use-associated with "
2013 "PROTECTED attribute and dummy argument '%s' is "
2014 "INTENT = OUT/INOUT",
2015 &a->expr->where,f->sym->name);
2019 if ((f->sym->attr.intent == INTENT_OUT
2020 || f->sym->attr.intent == INTENT_INOUT
2021 || f->sym->attr.volatile_)
2022 && has_vector_subscript (a->expr))
2025 gfc_error ("Array-section actual argument with vector subscripts "
2026 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2027 "or VOLATILE attribute of the dummy argument '%s'",
2028 &a->expr->where, f->sym->name);
2032 /* C1232 (R1221) For an actual argument which is an array section or
2033 an assumed-shape array, the dummy argument shall be an assumed-
2034 shape array, if the dummy argument has the VOLATILE attribute. */
2036 if (f->sym->attr.volatile_
2037 && a->expr->symtree->n.sym->as
2038 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2039 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2042 gfc_error ("Assumed-shape actual argument at %L is "
2043 "incompatible with the non-assumed-shape "
2044 "dummy argument '%s' due to VOLATILE attribute",
2045 &a->expr->where,f->sym->name);
2049 if (f->sym->attr.volatile_
2050 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2051 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2054 gfc_error ("Array-section actual argument at %L is "
2055 "incompatible with the non-assumed-shape "
2056 "dummy argument '%s' due to VOLATILE attribute",
2057 &a->expr->where,f->sym->name);
2061 /* C1233 (R1221) For an actual argument which is a pointer array, the
2062 dummy argument shall be an assumed-shape or pointer array, if the
2063 dummy argument has the VOLATILE attribute. */
2065 if (f->sym->attr.volatile_
2066 && a->expr->symtree->n.sym->attr.pointer
2067 && a->expr->symtree->n.sym->as
2069 && (f->sym->as->type == AS_ASSUMED_SHAPE
2070 || f->sym->attr.pointer)))
2073 gfc_error ("Pointer-array actual argument at %L requires "
2074 "an assumed-shape or pointer-array dummy "
2075 "argument '%s' due to VOLATILE attribute",
2076 &a->expr->where,f->sym->name);
2087 /* Make sure missing actual arguments are optional. */
2089 for (f = formal; f; f = f->next, i++)
2091 if (new_arg[i] != NULL)
2096 gfc_error ("Missing alternate return spec in subroutine call "
2100 if (!f->sym->attr.optional)
2103 gfc_error ("Missing actual argument for argument '%s' at %L",
2104 f->sym->name, where);
2109 /* The argument lists are compatible. We now relink a new actual
2110 argument list with null arguments in the right places. The head
2111 of the list remains the head. */
2112 for (i = 0; i < n; i++)
2113 if (new_arg[i] == NULL)
2114 new_arg[i] = gfc_get_actual_arglist ();
2119 *new_arg[0] = *actual;
2123 new_arg[0] = new_arg[na];
2127 for (i = 0; i < n - 1; i++)
2128 new_arg[i]->next = new_arg[i + 1];
2130 new_arg[i]->next = NULL;
2132 if (*ap == NULL && n > 0)
2135 /* Note the types of omitted optional arguments. */
2136 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2137 if (a->expr == NULL && a->label == NULL)
2138 a->missing_arg_type = f->sym->ts.type;
2146 gfc_formal_arglist *f;
2147 gfc_actual_arglist *a;
2151 /* qsort comparison function for argument pairs, with the following
2153 - p->a->expr == NULL
2154 - p->a->expr->expr_type != EXPR_VARIABLE
2155 - growing p->a->expr->symbol. */
2158 pair_cmp (const void *p1, const void *p2)
2160 const gfc_actual_arglist *a1, *a2;
2162 /* *p1 and *p2 are elements of the to-be-sorted array. */
2163 a1 = ((const argpair *) p1)->a;
2164 a2 = ((const argpair *) p2)->a;
2173 if (a1->expr->expr_type != EXPR_VARIABLE)
2175 if (a2->expr->expr_type != EXPR_VARIABLE)
2179 if (a2->expr->expr_type != EXPR_VARIABLE)
2181 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2185 /* Given two expressions from some actual arguments, test whether they
2186 refer to the same expression. The analysis is conservative.
2187 Returning FAILURE will produce no warning. */
2190 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2192 const gfc_ref *r1, *r2;
2195 || e1->expr_type != EXPR_VARIABLE
2196 || e2->expr_type != EXPR_VARIABLE
2197 || e1->symtree->n.sym != e2->symtree->n.sym)
2200 /* TODO: improve comparison, see expr.c:show_ref(). */
2201 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2203 if (r1->type != r2->type)
2208 if (r1->u.ar.type != r2->u.ar.type)
2210 /* TODO: At the moment, consider only full arrays;
2211 we could do better. */
2212 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2217 if (r1->u.c.component != r2->u.c.component)
2225 gfc_internal_error ("compare_actual_expr(): Bad component code");
2234 /* Given formal and actual argument lists that correspond to one
2235 another, check that identical actual arguments aren't not
2236 associated with some incompatible INTENTs. */
2239 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2241 sym_intent f1_intent, f2_intent;
2242 gfc_formal_arglist *f1;
2243 gfc_actual_arglist *a1;
2246 gfc_try t = SUCCESS;
2249 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2251 if (f1 == NULL && a1 == NULL)
2253 if (f1 == NULL || a1 == NULL)
2254 gfc_internal_error ("check_some_aliasing(): List mismatch");
2259 p = (argpair *) alloca (n * sizeof (argpair));
2261 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2267 qsort (p, n, sizeof (argpair), pair_cmp);
2269 for (i = 0; i < n; i++)
2272 || p[i].a->expr->expr_type != EXPR_VARIABLE
2273 || p[i].a->expr->ts.type == BT_PROCEDURE)
2275 f1_intent = p[i].f->sym->attr.intent;
2276 for (j = i + 1; j < n; j++)
2278 /* Expected order after the sort. */
2279 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2280 gfc_internal_error ("check_some_aliasing(): corrupted data");
2282 /* Are the expression the same? */
2283 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2285 f2_intent = p[j].f->sym->attr.intent;
2286 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2287 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2289 gfc_warning ("Same actual argument associated with INTENT(%s) "
2290 "argument '%s' and INTENT(%s) argument '%s' at %L",
2291 gfc_intent_string (f1_intent), p[i].f->sym->name,
2292 gfc_intent_string (f2_intent), p[j].f->sym->name,
2293 &p[i].a->expr->where);
2303 /* Given a symbol of a formal argument list and an expression,
2304 return nonzero if their intents are compatible, zero otherwise. */
2307 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2309 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2312 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2315 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2322 /* Given formal and actual argument lists that correspond to one
2323 another, check that they are compatible in the sense that intents
2324 are not mismatched. */
2327 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2329 sym_intent f_intent;
2331 for (;; f = f->next, a = a->next)
2333 if (f == NULL && a == NULL)
2335 if (f == NULL || a == NULL)
2336 gfc_internal_error ("check_intents(): List mismatch");
2338 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2341 f_intent = f->sym->attr.intent;
2343 if (!compare_parameter_intent(f->sym, a->expr))
2345 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2346 "specifies INTENT(%s)", &a->expr->where,
2347 gfc_intent_string (f_intent));
2351 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2353 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2355 gfc_error ("Procedure argument at %L is local to a PURE "
2356 "procedure and is passed to an INTENT(%s) argument",
2357 &a->expr->where, gfc_intent_string (f_intent));
2361 if (f->sym->attr.pointer)
2363 gfc_error ("Procedure argument at %L is local to a PURE "
2364 "procedure and has the POINTER attribute",
2375 /* Check how a procedure is used against its interface. If all goes
2376 well, the actual argument list will also end up being properly
2380 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2383 /* Warn about calls with an implicit interface. Special case
2384 for calling a ISO_C_BINDING becase c_loc and c_funloc
2385 are pseudo-unknown. Additionally, warn about procedures not
2386 explicitly declared at all if requested. */
2387 if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2389 if (gfc_option.warn_implicit_interface)
2390 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2392 else if (gfc_option.warn_implicit_procedure
2393 && sym->attr.proc == PROC_UNKNOWN)
2394 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2398 if (sym->attr.if_source == IFSRC_UNKNOWN)
2400 gfc_actual_arglist *a;
2401 for (a = *ap; a; a = a->next)
2403 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2404 if (a->name != NULL && a->name[0] != '%')
2406 gfc_error("Keyword argument requires explicit interface "
2407 "for procedure '%s' at %L", sym->name, &a->expr->where);
2415 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2418 check_intents (sym->formal, *ap);
2419 if (gfc_option.warn_aliasing)
2420 check_some_aliasing (sym->formal, *ap);
2424 /* Check how a procedure pointer component is used against its interface.
2425 If all goes well, the actual argument list will also end up being properly
2426 sorted. Completely analogous to gfc_procedure_use. */
2429 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2432 /* Warn about calls with an implicit interface. Special case
2433 for calling a ISO_C_BINDING becase c_loc and c_funloc
2434 are pseudo-unknown. */
2435 if (gfc_option.warn_implicit_interface
2436 && comp->attr.if_source == IFSRC_UNKNOWN
2437 && !comp->attr.is_iso_c)
2438 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2439 "interface at %L", comp->name, where);
2441 if (comp->attr.if_source == IFSRC_UNKNOWN)
2443 gfc_actual_arglist *a;
2444 for (a = *ap; a; a = a->next)
2446 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2447 if (a->name != NULL && a->name[0] != '%')
2449 gfc_error("Keyword argument requires explicit interface "
2450 "for procedure pointer component '%s' at %L",
2451 comp->name, &a->expr->where);
2459 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2462 check_intents (comp->formal, *ap);
2463 if (gfc_option.warn_aliasing)
2464 check_some_aliasing (comp->formal, *ap);
2468 /* Try if an actual argument list matches the formal list of a symbol,
2469 respecting the symbol's attributes like ELEMENTAL. This is used for
2470 GENERIC resolution. */
2473 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2477 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2479 r = !sym->attr.elemental;
2480 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2482 check_intents (sym->formal, *args);
2483 if (gfc_option.warn_aliasing)
2484 check_some_aliasing (sym->formal, *args);
2492 /* Given an interface pointer and an actual argument list, search for
2493 a formal argument list that matches the actual. If found, returns
2494 a pointer to the symbol of the correct interface. Returns NULL if
2498 gfc_search_interface (gfc_interface *intr, int sub_flag,
2499 gfc_actual_arglist **ap)
2501 gfc_symbol *elem_sym = NULL;
2502 for (; intr; intr = intr->next)
2504 if (sub_flag && intr->sym->attr.function)
2506 if (!sub_flag && intr->sym->attr.subroutine)
2509 if (gfc_arglist_matches_symbol (ap, intr->sym))
2511 /* Satisfy 12.4.4.1 such that an elemental match has lower
2512 weight than a non-elemental match. */
2513 if (intr->sym->attr.elemental)
2515 elem_sym = intr->sym;
2522 return elem_sym ? elem_sym : NULL;
2526 /* Do a brute force recursive search for a symbol. */
2528 static gfc_symtree *
2529 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2533 if (root->n.sym == sym)
2538 st = find_symtree0 (root->left, sym);
2539 if (root->right && ! st)
2540 st = find_symtree0 (root->right, sym);
2545 /* Find a symtree for a symbol. */
2548 gfc_find_sym_in_symtree (gfc_symbol *sym)
2553 /* First try to find it by name. */
2554 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2555 if (st && st->n.sym == sym)
2558 /* If it's been renamed, resort to a brute-force search. */
2559 /* TODO: avoid having to do this search. If the symbol doesn't exist
2560 in the symtree for the current namespace, it should probably be added. */
2561 for (ns = gfc_current_ns; ns; ns = ns->parent)
2563 st = find_symtree0 (ns->sym_root, sym);
2567 gfc_internal_error ("Unable to find symbol %s", sym->name);
2572 /* See if the arglist to an operator-call contains a derived-type argument
2573 with a matching type-bound operator. If so, return the matching specific
2574 procedure defined as operator-target as well as the base-object to use
2575 (which is the found derived-type argument with operator). */
2577 static gfc_typebound_proc*
2578 matching_typebound_op (gfc_expr** tb_base,
2579 gfc_actual_arglist* args,
2580 gfc_intrinsic_op op, const char* uop)
2582 gfc_actual_arglist* base;
2584 for (base = args; base; base = base->next)
2585 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
2587 gfc_typebound_proc* tb;
2588 gfc_symbol* derived;
2591 if (base->expr->ts.type == BT_CLASS)
2592 derived = base->expr->ts.u.derived->components->ts.u.derived;
2594 derived = base->expr->ts.u.derived;
2596 if (op == INTRINSIC_USER)
2598 gfc_symtree* tb_uop;
2601 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
2610 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
2613 /* This means we hit a PRIVATE operator which is use-associated and
2614 should thus not be seen. */
2615 if (result == FAILURE)
2618 /* Look through the super-type hierarchy for a matching specific
2620 for (; tb; tb = tb->overridden)
2624 gcc_assert (tb->is_generic);
2625 for (g = tb->u.generic; g; g = g->next)
2628 gfc_actual_arglist* argcopy;
2631 gcc_assert (g->specific);
2632 if (g->specific->error)
2635 target = g->specific->u.specific->n.sym;
2637 /* Check if this arglist matches the formal. */
2638 argcopy = gfc_copy_actual_arglist (args);
2639 matches = gfc_arglist_matches_symbol (&argcopy, target);
2640 gfc_free_actual_arglist (argcopy);
2642 /* Return if we found a match. */
2645 *tb_base = base->expr;
2656 /* For the 'actual arglist' of an operator call and a specific typebound
2657 procedure that has been found the target of a type-bound operator, build the
2658 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2659 type-bound procedures rather than resolving type-bound operators 'directly'
2660 so that we can reuse the existing logic. */
2663 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
2664 gfc_expr* base, gfc_typebound_proc* target)
2666 e->expr_type = EXPR_COMPCALL;
2667 e->value.compcall.tbp = target;
2668 e->value.compcall.name = "operator"; /* Should not matter. */
2669 e->value.compcall.actual = actual;
2670 e->value.compcall.base_object = base;
2671 e->value.compcall.ignore_pass = 1;
2672 e->value.compcall.assign = 0;
2676 /* This subroutine is called when an expression is being resolved.
2677 The expression node in question is either a user defined operator
2678 or an intrinsic operator with arguments that aren't compatible
2679 with the operator. This subroutine builds an actual argument list
2680 corresponding to the operands, then searches for a compatible
2681 interface. If one is found, the expression node is replaced with
2682 the appropriate function call.
2683 real_error is an additional output argument that specifies if FAILURE
2684 is because of some real error and not because no match was found. */
2687 gfc_extend_expr (gfc_expr *e, bool *real_error)
2689 gfc_actual_arglist *actual;
2697 actual = gfc_get_actual_arglist ();
2698 actual->expr = e->value.op.op1;
2700 *real_error = false;
2702 if (e->value.op.op2 != NULL)
2704 actual->next = gfc_get_actual_arglist ();
2705 actual->next->expr = e->value.op.op2;
2708 i = fold_unary_intrinsic (e->value.op.op);
2710 if (i == INTRINSIC_USER)
2712 for (ns = gfc_current_ns; ns; ns = ns->parent)
2714 uop = gfc_find_uop (e->value.op.uop->name, ns);
2718 sym = gfc_search_interface (uop->op, 0, &actual);
2725 for (ns = gfc_current_ns; ns; ns = ns->parent)
2727 /* Due to the distinction between '==' and '.eq.' and friends, one has
2728 to check if either is defined. */
2731 #define CHECK_OS_COMPARISON(comp) \
2732 case INTRINSIC_##comp: \
2733 case INTRINSIC_##comp##_OS: \
2734 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2736 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2738 CHECK_OS_COMPARISON(EQ)
2739 CHECK_OS_COMPARISON(NE)
2740 CHECK_OS_COMPARISON(GT)
2741 CHECK_OS_COMPARISON(GE)
2742 CHECK_OS_COMPARISON(LT)
2743 CHECK_OS_COMPARISON(LE)
2744 #undef CHECK_OS_COMPARISON
2747 sym = gfc_search_interface (ns->op[i], 0, &actual);
2755 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2756 found rather than just taking the first one and not checking further. */
2760 gfc_typebound_proc* tbo;
2763 /* See if we find a matching type-bound operator. */
2764 if (i == INTRINSIC_USER)
2765 tbo = matching_typebound_op (&tb_base, actual,
2766 i, e->value.op.uop->name);
2770 #define CHECK_OS_COMPARISON(comp) \
2771 case INTRINSIC_##comp: \
2772 case INTRINSIC_##comp##_OS: \
2773 tbo = matching_typebound_op (&tb_base, actual, \
2774 INTRINSIC_##comp, NULL); \
2776 tbo = matching_typebound_op (&tb_base, actual, \
2777 INTRINSIC_##comp##_OS, NULL); \
2779 CHECK_OS_COMPARISON(EQ)
2780 CHECK_OS_COMPARISON(NE)
2781 CHECK_OS_COMPARISON(GT)
2782 CHECK_OS_COMPARISON(GE)
2783 CHECK_OS_COMPARISON(LT)
2784 CHECK_OS_COMPARISON(LE)
2785 #undef CHECK_OS_COMPARISON
2788 tbo = matching_typebound_op (&tb_base, actual, i, NULL);
2792 /* If there is a matching typebound-operator, replace the expression with
2793 a call to it and succeed. */
2798 gcc_assert (tb_base);
2799 build_compcall_for_operator (e, actual, tb_base, tbo);
2801 result = gfc_resolve_expr (e);
2802 if (result == FAILURE)
2808 /* Don't use gfc_free_actual_arglist(). */
2809 if (actual->next != NULL)
2810 gfc_free (actual->next);
2816 /* Change the expression node to a function call. */
2817 e->expr_type = EXPR_FUNCTION;
2818 e->symtree = gfc_find_sym_in_symtree (sym);
2819 e->value.function.actual = actual;
2820 e->value.function.esym = NULL;
2821 e->value.function.isym = NULL;
2822 e->value.function.name = NULL;
2823 e->user_operator = 1;
2825 if (gfc_resolve_expr (e) == FAILURE)
2835 /* Tries to replace an assignment code node with a subroutine call to
2836 the subroutine associated with the assignment operator. Return
2837 SUCCESS if the node was replaced. On FAILURE, no error is
2841 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2843 gfc_actual_arglist *actual;
2844 gfc_expr *lhs, *rhs;
2850 /* Don't allow an intrinsic assignment to be replaced. */
2851 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
2852 && (rhs->rank == 0 || rhs->rank == lhs->rank)
2853 && (lhs->ts.type == rhs->ts.type
2854 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2857 actual = gfc_get_actual_arglist ();
2860 actual->next = gfc_get_actual_arglist ();
2861 actual->next->expr = rhs;
2865 for (; ns; ns = ns->parent)
2867 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
2872 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
2876 gfc_typebound_proc* tbo;
2879 /* See if we find a matching type-bound assignment. */
2880 tbo = matching_typebound_op (&tb_base, actual,
2881 INTRINSIC_ASSIGN, NULL);
2883 /* If there is one, replace the expression with a call to it and
2887 gcc_assert (tb_base);
2888 c->expr1 = gfc_get_expr ();
2889 build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
2890 c->expr1->value.compcall.assign = 1;
2892 c->op = EXEC_COMPCALL;
2894 /* c is resolved from the caller, so no need to do it here. */
2899 gfc_free (actual->next);
2904 /* Replace the assignment with the call. */
2905 c->op = EXEC_ASSIGN_CALL;
2906 c->symtree = gfc_find_sym_in_symtree (sym);
2909 c->ext.actual = actual;
2915 /* Make sure that the interface just parsed is not already present in
2916 the given interface list. Ambiguity isn't checked yet since module
2917 procedures can be present without interfaces. */
2920 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
2924 for (ip = base; ip; ip = ip->next)
2926 if (ip->sym == new_sym)
2928 gfc_error ("Entity '%s' at %C is already present in the interface",
2938 /* Add a symbol to the current interface. */
2941 gfc_add_interface (gfc_symbol *new_sym)
2943 gfc_interface **head, *intr;
2947 switch (current_interface.type)
2949 case INTERFACE_NAMELESS:
2950 case INTERFACE_ABSTRACT:
2953 case INTERFACE_INTRINSIC_OP:
2954 for (ns = current_interface.ns; ns; ns = ns->parent)
2955 switch (current_interface.op)
2958 case INTRINSIC_EQ_OS:
2959 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
2960 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
2965 case INTRINSIC_NE_OS:
2966 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
2967 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
2972 case INTRINSIC_GT_OS:
2973 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
2974 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
2979 case INTRINSIC_GE_OS:
2980 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
2981 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
2986 case INTRINSIC_LT_OS:
2987 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
2988 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
2993 case INTRINSIC_LE_OS:
2994 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
2995 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
3000 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
3004 head = ¤t_interface.ns->op[current_interface.op];
3007 case INTERFACE_GENERIC:
3008 for (ns = current_interface.ns; ns; ns = ns->parent)
3010 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3014 if (check_new_interface (sym->generic, new_sym) == FAILURE)
3018 head = ¤t_interface.sym->generic;
3021 case INTERFACE_USER_OP:
3022 if (check_new_interface (current_interface.uop->op, new_sym)
3026 head = ¤t_interface.uop->op;
3030 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3033 intr = gfc_get_interface ();
3034 intr->sym = new_sym;
3035 intr->where = gfc_current_locus;
3045 gfc_current_interface_head (void)
3047 switch (current_interface.type)
3049 case INTERFACE_INTRINSIC_OP:
3050 return current_interface.ns->op[current_interface.op];
3053 case INTERFACE_GENERIC:
3054 return current_interface.sym->generic;
3057 case INTERFACE_USER_OP:
3058 return current_interface.uop->op;
3068 gfc_set_current_interface_head (gfc_interface *i)
3070 switch (current_interface.type)
3072 case INTERFACE_INTRINSIC_OP:
3073 current_interface.ns->op[current_interface.op] = i;
3076 case INTERFACE_GENERIC:
3077 current_interface.sym->generic = i;
3080 case INTERFACE_USER_OP:
3081 current_interface.uop->op = i;
3090 /* Gets rid of a formal argument list. We do not free symbols.
3091 Symbols are freed when a namespace is freed. */
3094 gfc_free_formal_arglist (gfc_formal_arglist *p)
3096 gfc_formal_arglist *q;