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 /* Special case for comparing derived types across namespaces. If the
364 true names and module names are the same and the module name is
365 nonnull, then they are equal. */
366 if (derived1 != NULL && derived2 != NULL
367 && strcmp (derived1->name, derived2->name) == 0
368 && derived1->module != NULL && derived2->module != NULL
369 && strcmp (derived1->module, derived2->module) == 0)
372 /* Compare type via the rules of the standard. Both types must have
373 the SEQUENCE attribute to be equal. */
375 if (strcmp (derived1->name, derived2->name))
378 if (derived1->component_access == ACCESS_PRIVATE
379 || derived2->component_access == ACCESS_PRIVATE)
382 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
385 dt1 = derived1->components;
386 dt2 = derived2->components;
388 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
389 simple test can speed things up. Otherwise, lots of things have to
393 if (strcmp (dt1->name, dt2->name) != 0)
396 if (dt1->attr.access != dt2->attr.access)
399 if (dt1->attr.pointer != dt2->attr.pointer)
402 if (dt1->attr.dimension != dt2->attr.dimension)
405 if (dt1->attr.allocatable != dt2->attr.allocatable)
408 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
411 /* Make sure that link lists do not put this function into an
412 endless recursive loop! */
413 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
414 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
415 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
418 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
419 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
422 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
423 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
429 if (dt1 == NULL && dt2 == NULL)
431 if (dt1 == NULL || dt2 == NULL)
439 /* Compare two typespecs, recursively if necessary. */
442 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
444 /* See if one of the typespecs is a BT_VOID, which is what is being used
445 to allow the funcs like c_f_pointer to accept any pointer type.
446 TODO: Possibly should narrow this to just the one typespec coming in
447 that is for the formal arg, but oh well. */
448 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
451 if (ts1->type != ts2->type)
453 if (ts1->type != BT_DERIVED)
454 return (ts1->kind == ts2->kind);
456 /* Compare derived types. */
457 if (ts1->u.derived == ts2->u.derived)
460 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
464 /* Given two symbols that are formal arguments, compare their ranks
465 and types. Returns nonzero if they have the same rank and type,
469 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
473 r1 = (s1->as != NULL) ? s1->as->rank : 0;
474 r2 = (s2->as != NULL) ? s2->as->rank : 0;
477 return 0; /* Ranks differ. */
479 return gfc_compare_types (&s1->ts, &s2->ts);
483 /* Given two symbols that are formal arguments, compare their types
484 and rank and their formal interfaces if they are both dummy
485 procedures. Returns nonzero if the same, zero if different. */
488 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
490 if (s1 == NULL || s2 == NULL)
491 return s1 == s2 ? 1 : 0;
496 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
497 return compare_type_rank (s1, s2);
499 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
502 /* At this point, both symbols are procedures. It can happen that
503 external procedures are compared, where one is identified by usage
504 to be a function or subroutine but the other is not. Check TKR
505 nonetheless for these cases. */
506 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
507 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
509 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
510 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
512 /* Now the type of procedure has been identified. */
513 if (s1->attr.function != s2->attr.function
514 || s1->attr.subroutine != s2->attr.subroutine)
517 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
520 /* Originally, gfortran recursed here to check the interfaces of passed
521 procedures. This is explicitly not required by the standard. */
526 /* Given a formal argument list and a keyword name, search the list
527 for that keyword. Returns the correct symbol node if found, NULL
531 find_keyword_arg (const char *name, gfc_formal_arglist *f)
533 for (; f; f = f->next)
534 if (strcmp (f->sym->name, name) == 0)
541 /******** Interface checking subroutines **********/
544 /* Given an operator interface and the operator, make sure that all
545 interfaces for that operator are legal. */
548 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
551 gfc_formal_arglist *formal;
554 int args, r1, r2, k1, k2;
559 t1 = t2 = BT_UNKNOWN;
560 i1 = i2 = INTENT_UNKNOWN;
564 for (formal = sym->formal; formal; formal = formal->next)
566 gfc_symbol *fsym = formal->sym;
569 gfc_error ("Alternate return cannot appear in operator "
570 "interface at %L", &sym->declared_at);
576 i1 = fsym->attr.intent;
577 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
583 i2 = fsym->attr.intent;
584 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
590 /* Only +, - and .not. can be unary operators.
591 .not. cannot be a binary operator. */
592 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
593 && op != INTRINSIC_MINUS
594 && op != INTRINSIC_NOT)
595 || (args == 2 && op == INTRINSIC_NOT))
597 gfc_error ("Operator interface at %L has the wrong number of arguments",
602 /* Check that intrinsics are mapped to functions, except
603 INTRINSIC_ASSIGN which should map to a subroutine. */
604 if (op == INTRINSIC_ASSIGN)
606 if (!sym->attr.subroutine)
608 gfc_error ("Assignment operator interface at %L must be "
609 "a SUBROUTINE", &sym->declared_at);
614 gfc_error ("Assignment operator interface at %L must have "
615 "two arguments", &sym->declared_at);
619 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
620 - First argument an array with different rank than second,
621 - Types and kinds do not conform, and
622 - First argument is of derived type. */
623 if (sym->formal->sym->ts.type != BT_DERIVED
624 && (r1 == 0 || r1 == r2)
625 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
626 || (gfc_numeric_ts (&sym->formal->sym->ts)
627 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
629 gfc_error ("Assignment operator interface at %L must not redefine "
630 "an INTRINSIC type assignment", &sym->declared_at);
636 if (!sym->attr.function)
638 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
644 /* Check intents on operator interfaces. */
645 if (op == INTRINSIC_ASSIGN)
647 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
649 gfc_error ("First argument of defined assignment at %L must be "
650 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
656 gfc_error ("Second argument of defined assignment at %L must be "
657 "INTENT(IN)", &sym->declared_at);
665 gfc_error ("First argument of operator interface at %L must be "
666 "INTENT(IN)", &sym->declared_at);
670 if (args == 2 && i2 != INTENT_IN)
672 gfc_error ("Second argument of operator interface at %L must be "
673 "INTENT(IN)", &sym->declared_at);
678 /* From now on, all we have to do is check that the operator definition
679 doesn't conflict with an intrinsic operator. The rules for this
680 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
681 as well as 12.3.2.1.1 of Fortran 2003:
683 "If the operator is an intrinsic-operator (R310), the number of
684 function arguments shall be consistent with the intrinsic uses of
685 that operator, and the types, kind type parameters, or ranks of the
686 dummy arguments shall differ from those required for the intrinsic
687 operation (7.1.2)." */
689 #define IS_NUMERIC_TYPE(t) \
690 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
692 /* Unary ops are easy, do them first. */
693 if (op == INTRINSIC_NOT)
695 if (t1 == BT_LOGICAL)
701 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
703 if (IS_NUMERIC_TYPE (t1))
709 /* Character intrinsic operators have same character kind, thus
710 operator definitions with operands of different character kinds
712 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
715 /* Intrinsic operators always perform on arguments of same rank,
716 so different ranks is also always safe. (rank == 0) is an exception
717 to that, because all intrinsic operators are elemental. */
718 if (r1 != r2 && r1 != 0 && r2 != 0)
724 case INTRINSIC_EQ_OS:
726 case INTRINSIC_NE_OS:
727 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
732 case INTRINSIC_MINUS:
733 case INTRINSIC_TIMES:
734 case INTRINSIC_DIVIDE:
735 case INTRINSIC_POWER:
736 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
741 case INTRINSIC_GT_OS:
743 case INTRINSIC_GE_OS:
745 case INTRINSIC_LT_OS:
747 case INTRINSIC_LE_OS:
748 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
750 if ((t1 == BT_INTEGER || t1 == BT_REAL)
751 && (t2 == BT_INTEGER || t2 == BT_REAL))
755 case INTRINSIC_CONCAT:
756 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
764 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
774 #undef IS_NUMERIC_TYPE
777 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
783 /* Given a pair of formal argument lists, we see if the two lists can
784 be distinguished by counting the number of nonoptional arguments of
785 a given type/rank in f1 and seeing if there are less then that
786 number of those arguments in f2 (including optional arguments).
787 Since this test is asymmetric, it has to be called twice to make it
788 symmetric. Returns nonzero if the argument lists are incompatible
789 by this test. This subroutine implements rule 1 of section
790 14.1.2.3 in the Fortran 95 standard. */
793 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
795 int rc, ac1, ac2, i, j, k, n1;
796 gfc_formal_arglist *f;
809 for (f = f1; f; f = f->next)
812 /* Build an array of integers that gives the same integer to
813 arguments of the same type/rank. */
814 arg = XCNEWVEC (arginfo, n1);
817 for (i = 0; i < n1; i++, f = f->next)
825 for (i = 0; i < n1; i++)
827 if (arg[i].flag != -1)
830 if (arg[i].sym && arg[i].sym->attr.optional)
831 continue; /* Skip optional arguments. */
835 /* Find other nonoptional arguments of the same type/rank. */
836 for (j = i + 1; j < n1; j++)
837 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
838 && compare_type_rank_if (arg[i].sym, arg[j].sym))
844 /* Now loop over each distinct type found in f1. */
848 for (i = 0; i < n1; i++)
850 if (arg[i].flag != k)
854 for (j = i + 1; j < n1; j++)
855 if (arg[j].flag == k)
858 /* Count the number of arguments in f2 with that type, including
859 those that are optional. */
862 for (f = f2; f; f = f->next)
863 if (compare_type_rank_if (arg[i].sym, f->sym))
881 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
882 Returns zero if no argument is found that satisfies rule 2, nonzero
885 This test is also not symmetric in f1 and f2 and must be called
886 twice. This test finds problems caused by sorting the actual
887 argument list with keywords. For example:
891 INTEGER :: A ; REAL :: B
895 INTEGER :: A ; REAL :: B
899 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
902 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
904 gfc_formal_arglist *f2_save, *g;
911 if (f1->sym->attr.optional)
914 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
917 /* Now search for a disambiguating keyword argument starting at
918 the current non-match. */
919 for (g = f1; g; g = g->next)
921 if (g->sym->attr.optional)
924 sym = find_keyword_arg (g->sym->name, f2_save);
925 if (sym == NULL || !compare_type_rank (g->sym, sym))
939 /* 'Compare' two formal interfaces associated with a pair of symbols.
940 We return nonzero if there exists an actual argument list that
941 would be ambiguous between the two interfaces, zero otherwise.
942 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
943 required to match, which is not the case for ambiguity checks.*/
946 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
947 int intent_flag, char *errmsg, int err_len)
949 gfc_formal_arglist *f1, *f2;
951 if (s1->attr.function && (s2->attr.subroutine
952 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
953 && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
956 snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
960 if (s1->attr.subroutine && s2->attr.function)
963 snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
967 /* If the arguments are functions, check type and kind
968 (only for dummy procedures and procedure pointer assignments). */
969 if ((s1->attr.dummy || s1->attr.proc_pointer)
970 && s1->attr.function && s2->attr.function)
972 if (s1->ts.type == BT_UNKNOWN)
974 if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
977 snprintf (errmsg, err_len, "Type/kind mismatch in return value "
978 "of '%s'", s2->name);
983 if (s1->attr.if_source == IFSRC_UNKNOWN
984 || s2->attr.if_source == IFSRC_UNKNOWN)
990 if (f1 == NULL && f2 == NULL)
991 return 1; /* Special case: No arguments. */
995 if (count_types_test (f1, f2) || count_types_test (f2, f1))
997 if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1001 /* Perform the abbreviated correspondence test for operators (the
1002 arguments cannot be optional and are always ordered correctly).
1003 This is also done when comparing interfaces for dummy procedures and in
1004 procedure pointer assignments. */
1008 /* Check existence. */
1009 if (f1 == NULL && f2 == NULL)
1011 if (f1 == NULL || f2 == NULL)
1014 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1015 "arguments", s2->name);
1019 /* Check type and rank. */
1020 if (!compare_type_rank (f1->sym, f2->sym))
1023 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1029 if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
1031 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1036 /* Check OPTIONAL. */
1037 if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
1039 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1052 /* Given a pointer to an interface pointer, remove duplicate
1053 interfaces and make sure that all symbols are either functions or
1054 subroutines. Returns nonzero if something goes wrong. */
1057 check_interface0 (gfc_interface *p, const char *interface_name)
1059 gfc_interface *psave, *q, *qlast;
1062 /* Make sure all symbols in the interface have been defined as
1063 functions or subroutines. */
1064 for (; p; p = p->next)
1065 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1066 || !p->sym->attr.if_source)
1068 if (p->sym->attr.external)
1069 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1070 p->sym->name, interface_name, &p->sym->declared_at);
1072 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1073 "subroutine", p->sym->name, interface_name,
1074 &p->sym->declared_at);
1079 /* Remove duplicate interfaces in this interface list. */
1080 for (; p; p = p->next)
1084 for (q = p->next; q;)
1086 if (p->sym != q->sym)
1093 /* Duplicate interface. */
1094 qlast->next = q->next;
1105 /* Check lists of interfaces to make sure that no two interfaces are
1106 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1109 check_interface1 (gfc_interface *p, gfc_interface *q0,
1110 int generic_flag, const char *interface_name,
1114 for (; p; p = p->next)
1115 for (q = q0; q; q = q->next)
1117 if (p->sym == q->sym)
1118 continue; /* Duplicates OK here. */
1120 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1123 if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0))
1127 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1128 p->sym->name, q->sym->name, interface_name,
1132 if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1133 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1134 p->sym->name, q->sym->name, interface_name,
1143 /* Check the generic and operator interfaces of symbols to make sure
1144 that none of the interfaces conflict. The check has to be done
1145 after all of the symbols are actually loaded. */
1148 check_sym_interfaces (gfc_symbol *sym)
1150 char interface_name[100];
1154 if (sym->ns != gfc_current_ns)
1157 if (sym->generic != NULL)
1159 sprintf (interface_name, "generic interface '%s'", sym->name);
1160 if (check_interface0 (sym->generic, interface_name))
1163 for (p = sym->generic; p; p = p->next)
1165 if (p->sym->attr.mod_proc
1166 && (p->sym->attr.if_source != IFSRC_DECL
1167 || p->sym->attr.procedure))
1169 gfc_error ("'%s' at %L is not a module procedure",
1170 p->sym->name, &p->where);
1175 /* Originally, this test was applied to host interfaces too;
1176 this is incorrect since host associated symbols, from any
1177 source, cannot be ambiguous with local symbols. */
1178 k = sym->attr.referenced || !sym->attr.use_assoc;
1179 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1180 sym->attr.ambiguous_interfaces = 1;
1186 check_uop_interfaces (gfc_user_op *uop)
1188 char interface_name[100];
1192 sprintf (interface_name, "operator interface '%s'", uop->name);
1193 if (check_interface0 (uop->op, interface_name))
1196 for (ns = gfc_current_ns; ns; ns = ns->parent)
1198 uop2 = gfc_find_uop (uop->name, ns);
1202 check_interface1 (uop->op, uop2->op, 0,
1203 interface_name, true);
1208 /* For the namespace, check generic, user operator and intrinsic
1209 operator interfaces for consistency and to remove duplicate
1210 interfaces. We traverse the whole namespace, counting on the fact
1211 that most symbols will not have generic or operator interfaces. */
1214 gfc_check_interfaces (gfc_namespace *ns)
1216 gfc_namespace *old_ns, *ns2;
1217 char interface_name[100];
1220 old_ns = gfc_current_ns;
1221 gfc_current_ns = ns;
1223 gfc_traverse_ns (ns, check_sym_interfaces);
1225 gfc_traverse_user_op (ns, check_uop_interfaces);
1227 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1229 if (i == INTRINSIC_USER)
1232 if (i == INTRINSIC_ASSIGN)
1233 strcpy (interface_name, "intrinsic assignment operator");
1235 sprintf (interface_name, "intrinsic '%s' operator",
1236 gfc_op2string ((gfc_intrinsic_op) i));
1238 if (check_interface0 (ns->op[i], interface_name))
1242 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1245 for (ns2 = ns; ns2; ns2 = ns2->parent)
1247 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1248 interface_name, true))
1254 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
1255 0, interface_name, true)) goto done;
1258 case INTRINSIC_EQ_OS:
1259 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
1260 0, interface_name, true)) goto done;
1264 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
1265 0, interface_name, true)) goto done;
1268 case INTRINSIC_NE_OS:
1269 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
1270 0, interface_name, true)) goto done;
1274 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
1275 0, interface_name, true)) goto done;
1278 case INTRINSIC_GT_OS:
1279 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
1280 0, interface_name, true)) goto done;
1284 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
1285 0, interface_name, true)) goto done;
1288 case INTRINSIC_GE_OS:
1289 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
1290 0, interface_name, true)) goto done;
1294 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
1295 0, interface_name, true)) goto done;
1298 case INTRINSIC_LT_OS:
1299 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
1300 0, interface_name, true)) goto done;
1304 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
1305 0, interface_name, true)) goto done;
1308 case INTRINSIC_LE_OS:
1309 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
1310 0, interface_name, true)) goto done;
1320 gfc_current_ns = old_ns;
1325 symbol_rank (gfc_symbol *sym)
1327 return (sym->as == NULL) ? 0 : sym->as->rank;
1331 /* Given a symbol of a formal argument list and an expression, if the
1332 formal argument is allocatable, check that the actual argument is
1333 allocatable. Returns nonzero if compatible, zero if not compatible. */
1336 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1338 symbol_attribute attr;
1340 if (formal->attr.allocatable)
1342 attr = gfc_expr_attr (actual);
1343 if (!attr.allocatable)
1351 /* Given a symbol of a formal argument list and an expression, if the
1352 formal argument is a pointer, see if the actual argument is a
1353 pointer. Returns nonzero if compatible, zero if not compatible. */
1356 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1358 symbol_attribute attr;
1360 if (formal->attr.pointer)
1362 attr = gfc_expr_attr (actual);
1371 /* Given a symbol of a formal argument list and an expression, see if
1372 the two are compatible as arguments. Returns nonzero if
1373 compatible, zero if not compatible. */
1376 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1377 int ranks_must_agree, int is_elemental, locus *where)
1382 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1383 procs c_f_pointer or c_f_procpointer, and we need to accept most
1384 pointers the user could give us. This should allow that. */
1385 if (formal->ts.type == BT_VOID)
1388 if (formal->ts.type == BT_DERIVED
1389 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1390 && actual->ts.type == BT_DERIVED
1391 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1394 if (actual->ts.type == BT_PROCEDURE)
1397 gfc_symbol *act_sym = actual->symtree->n.sym;
1399 if (formal->attr.flavor != FL_PROCEDURE)
1402 gfc_error ("Invalid procedure argument at %L", &actual->where);
1406 if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
1410 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1411 formal->name, &actual->where, err);
1415 if (formal->attr.function && !act_sym->attr.function)
1417 gfc_add_function (&act_sym->attr, act_sym->name,
1418 &act_sym->declared_at);
1419 if (act_sym->ts.type == BT_UNKNOWN
1420 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1423 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1424 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1425 &act_sym->declared_at);
1430 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1431 && !gfc_compare_types (&formal->ts, &actual->ts))
1434 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1435 formal->name, &actual->where, gfc_typename (&actual->ts),
1436 gfc_typename (&formal->ts));
1440 if (symbol_rank (formal) == actual->rank)
1443 rank_check = where != NULL && !is_elemental && formal->as
1444 && (formal->as->type == AS_ASSUMED_SHAPE
1445 || formal->as->type == AS_DEFERRED);
1447 if (rank_check || ranks_must_agree || formal->attr.pointer
1448 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1449 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
1452 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1453 formal->name, &actual->where, symbol_rank (formal),
1457 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1460 /* At this point, we are considering a scalar passed to an array. This
1461 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1462 - if the actual argument is (a substring of) an element of a
1463 non-assumed-shape/non-pointer array;
1464 - (F2003) if the actual argument is of type character. */
1466 for (ref = actual->ref; ref; ref = ref->next)
1467 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1470 /* Not an array element. */
1471 if (formal->ts.type == BT_CHARACTER
1473 || (actual->expr_type == EXPR_VARIABLE
1474 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1475 || actual->symtree->n.sym->attr.pointer))))
1477 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1479 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1480 "array dummy argument '%s' at %L",
1481 formal->name, &actual->where);
1484 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1489 else if (ref == NULL)
1492 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1493 formal->name, &actual->where, symbol_rank (formal),
1498 if (actual->expr_type == EXPR_VARIABLE
1499 && actual->symtree->n.sym->as
1500 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1501 || actual->symtree->n.sym->attr.pointer))
1504 gfc_error ("Element of assumed-shaped array passed to dummy "
1505 "argument '%s' at %L", formal->name, &actual->where);
1513 /* Given a symbol of a formal argument list and an expression, see if
1514 the two are compatible as arguments. Returns nonzero if
1515 compatible, zero if not compatible. */
1518 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1520 if (actual->expr_type != EXPR_VARIABLE)
1523 if (!actual->symtree->n.sym->attr.is_protected)
1526 if (!actual->symtree->n.sym->attr.use_assoc)
1529 if (formal->attr.intent == INTENT_IN
1530 || formal->attr.intent == INTENT_UNKNOWN)
1533 if (!actual->symtree->n.sym->attr.pointer)
1536 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1543 /* Returns the storage size of a symbol (formal argument) or
1544 zero if it cannot be determined. */
1546 static unsigned long
1547 get_sym_storage_size (gfc_symbol *sym)
1550 unsigned long strlen, elements;
1552 if (sym->ts.type == BT_CHARACTER)
1554 if (sym->ts.u.cl && sym->ts.u.cl->length
1555 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1556 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1563 if (symbol_rank (sym) == 0)
1567 if (sym->as->type != AS_EXPLICIT)
1569 for (i = 0; i < sym->as->rank; i++)
1571 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1572 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1575 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1576 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1579 return strlen*elements;
1583 /* Returns the storage size of an expression (actual argument) or
1584 zero if it cannot be determined. For an array element, it returns
1585 the remaining size as the element sequence consists of all storage
1586 units of the actual argument up to the end of the array. */
1588 static unsigned long
1589 get_expr_storage_size (gfc_expr *e)
1592 long int strlen, elements;
1593 long int substrlen = 0;
1594 bool is_str_storage = false;
1600 if (e->ts.type == BT_CHARACTER)
1602 if (e->ts.u.cl && e->ts.u.cl->length
1603 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1604 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1605 else if (e->expr_type == EXPR_CONSTANT
1606 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1607 strlen = e->value.character.length;
1612 strlen = 1; /* Length per element. */
1614 if (e->rank == 0 && !e->ref)
1622 for (i = 0; i < e->rank; i++)
1623 elements *= mpz_get_si (e->shape[i]);
1624 return elements*strlen;
1627 for (ref = e->ref; ref; ref = ref->next)
1629 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1630 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1634 /* The string length is the substring length.
1635 Set now to full string length. */
1636 if (ref->u.ss.length == NULL
1637 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1640 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1642 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1646 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1647 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1648 && ref->u.ar.as->upper)
1649 for (i = 0; i < ref->u.ar.dimen; i++)
1651 long int start, end, stride;
1654 if (ref->u.ar.stride[i])
1656 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1657 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1662 if (ref->u.ar.start[i])
1664 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1665 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1669 else if (ref->u.ar.as->lower[i]
1670 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1671 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1675 if (ref->u.ar.end[i])
1677 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1678 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1682 else if (ref->u.ar.as->upper[i]
1683 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1684 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1688 elements *= (end - start)/stride + 1L;
1690 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1691 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1692 for (i = 0; i < ref->u.ar.as->rank; i++)
1694 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1695 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1696 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1697 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1698 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1703 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1704 && e->expr_type == EXPR_VARIABLE)
1706 if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1707 || e->symtree->n.sym->attr.pointer)
1713 /* Determine the number of remaining elements in the element
1714 sequence for array element designators. */
1715 is_str_storage = true;
1716 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1718 if (ref->u.ar.start[i] == NULL
1719 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1720 || ref->u.ar.as->upper[i] == NULL
1721 || ref->u.ar.as->lower[i] == NULL
1722 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1723 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1728 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1729 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1731 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1732 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1740 return (is_str_storage) ? substrlen + (elements-1)*strlen
1743 return elements*strlen;
1747 /* Given an expression, check whether it is an array section
1748 which has a vector subscript. If it has, one is returned,
1752 has_vector_subscript (gfc_expr *e)
1757 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1760 for (ref = e->ref; ref; ref = ref->next)
1761 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1762 for (i = 0; i < ref->u.ar.dimen; i++)
1763 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1770 /* Given formal and actual argument lists, see if they are compatible.
1771 If they are compatible, the actual argument list is sorted to
1772 correspond with the formal list, and elements for missing optional
1773 arguments are inserted. If WHERE pointer is nonnull, then we issue
1774 errors when things don't match instead of just returning the status
1778 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1779 int ranks_must_agree, int is_elemental, locus *where)
1781 gfc_actual_arglist **new_arg, *a, *actual, temp;
1782 gfc_formal_arglist *f;
1784 unsigned long actual_size, formal_size;
1788 if (actual == NULL && formal == NULL)
1792 for (f = formal; f; f = f->next)
1795 new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1797 for (i = 0; i < n; i++)
1804 for (a = actual; a; a = a->next, f = f->next)
1806 /* Look for keywords but ignore g77 extensions like %VAL. */
1807 if (a->name != NULL && a->name[0] != '%')
1810 for (f = formal; f; f = f->next, i++)
1814 if (strcmp (f->sym->name, a->name) == 0)
1821 gfc_error ("Keyword argument '%s' at %L is not in "
1822 "the procedure", a->name, &a->expr->where);
1826 if (new_arg[i] != NULL)
1829 gfc_error ("Keyword argument '%s' at %L is already associated "
1830 "with another actual argument", a->name,
1839 gfc_error ("More actual than formal arguments in procedure "
1840 "call at %L", where);
1845 if (f->sym == NULL && a->expr == NULL)
1851 gfc_error ("Missing alternate return spec in subroutine call "
1856 if (a->expr == NULL)
1859 gfc_error ("Unexpected alternate return spec in subroutine "
1860 "call at %L", where);
1864 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1865 is_elemental, where))
1868 /* Special case for character arguments. For allocatable, pointer
1869 and assumed-shape dummies, the string length needs to match
1871 if (a->expr->ts.type == BT_CHARACTER
1872 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
1873 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1874 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
1875 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
1876 && (f->sym->attr.pointer || f->sym->attr.allocatable
1877 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1878 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
1879 f->sym->ts.u.cl->length->value.integer) != 0))
1881 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1882 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1883 "argument and pointer or allocatable dummy argument "
1885 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1886 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1887 f->sym->name, &a->expr->where);
1889 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1890 "argument and assumed-shape dummy argument '%s' "
1892 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1893 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1894 f->sym->name, &a->expr->where);
1898 actual_size = get_expr_storage_size (a->expr);
1899 formal_size = get_sym_storage_size (f->sym);
1900 if (actual_size != 0
1901 && actual_size < formal_size
1902 && a->expr->ts.type != BT_PROCEDURE)
1904 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1905 gfc_warning ("Character length of actual argument shorter "
1906 "than of dummy argument '%s' (%lu/%lu) at %L",
1907 f->sym->name, actual_size, formal_size,
1910 gfc_warning ("Actual argument contains too few "
1911 "elements for dummy argument '%s' (%lu/%lu) at %L",
1912 f->sym->name, actual_size, formal_size,
1917 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1918 is provided for a procedure pointer formal argument. */
1919 if (f->sym->attr.proc_pointer
1920 && !((a->expr->expr_type == EXPR_VARIABLE
1921 && a->expr->symtree->n.sym->attr.proc_pointer)
1922 || (a->expr->expr_type == EXPR_FUNCTION
1923 && a->expr->symtree->n.sym->result->attr.proc_pointer)
1924 || gfc_is_proc_ptr_comp (a->expr, NULL)))
1927 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1928 f->sym->name, &a->expr->where);
1932 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1933 provided for a procedure formal argument. */
1934 if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
1935 && a->expr->expr_type == EXPR_VARIABLE
1936 && f->sym->attr.flavor == FL_PROCEDURE)
1939 gfc_error ("Expected a procedure for argument '%s' at %L",
1940 f->sym->name, &a->expr->where);
1944 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1945 && a->expr->ts.type == BT_PROCEDURE
1946 && !a->expr->symtree->n.sym->attr.pure)
1949 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1950 f->sym->name, &a->expr->where);
1954 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1955 && a->expr->expr_type == EXPR_VARIABLE
1956 && a->expr->symtree->n.sym->as
1957 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1958 && (a->expr->ref == NULL
1959 || (a->expr->ref->type == REF_ARRAY
1960 && a->expr->ref->u.ar.type == AR_FULL)))
1963 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1964 " array at %L", f->sym->name, where);
1968 if (a->expr->expr_type != EXPR_NULL
1969 && compare_pointer (f->sym, a->expr) == 0)
1972 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1973 f->sym->name, &a->expr->where);
1977 if (a->expr->expr_type != EXPR_NULL
1978 && compare_allocatable (f->sym, a->expr) == 0)
1981 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1982 f->sym->name, &a->expr->where);
1986 /* Check intent = OUT/INOUT for definable actual argument. */
1987 if ((a->expr->expr_type != EXPR_VARIABLE
1988 || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
1989 && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
1990 && (f->sym->attr.intent == INTENT_OUT
1991 || f->sym->attr.intent == INTENT_INOUT))
1994 gfc_error ("Actual argument at %L must be definable as "
1995 "the dummy argument '%s' is INTENT = OUT/INOUT",
1996 &a->expr->where, f->sym->name);
2000 if (!compare_parameter_protected(f->sym, a->expr))
2003 gfc_error ("Actual argument at %L is use-associated with "
2004 "PROTECTED attribute and dummy argument '%s' is "
2005 "INTENT = OUT/INOUT",
2006 &a->expr->where,f->sym->name);
2010 if ((f->sym->attr.intent == INTENT_OUT
2011 || f->sym->attr.intent == INTENT_INOUT
2012 || f->sym->attr.volatile_)
2013 && has_vector_subscript (a->expr))
2016 gfc_error ("Array-section actual argument with vector subscripts "
2017 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2018 "or VOLATILE attribute of the dummy argument '%s'",
2019 &a->expr->where, f->sym->name);
2023 /* C1232 (R1221) For an actual argument which is an array section or
2024 an assumed-shape array, the dummy argument shall be an assumed-
2025 shape array, if the dummy argument has the VOLATILE attribute. */
2027 if (f->sym->attr.volatile_
2028 && a->expr->symtree->n.sym->as
2029 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2030 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2033 gfc_error ("Assumed-shape actual argument at %L is "
2034 "incompatible with the non-assumed-shape "
2035 "dummy argument '%s' due to VOLATILE attribute",
2036 &a->expr->where,f->sym->name);
2040 if (f->sym->attr.volatile_
2041 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2042 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2045 gfc_error ("Array-section actual argument at %L is "
2046 "incompatible with the non-assumed-shape "
2047 "dummy argument '%s' due to VOLATILE attribute",
2048 &a->expr->where,f->sym->name);
2052 /* C1233 (R1221) For an actual argument which is a pointer array, the
2053 dummy argument shall be an assumed-shape or pointer array, if the
2054 dummy argument has the VOLATILE attribute. */
2056 if (f->sym->attr.volatile_
2057 && a->expr->symtree->n.sym->attr.pointer
2058 && a->expr->symtree->n.sym->as
2060 && (f->sym->as->type == AS_ASSUMED_SHAPE
2061 || f->sym->attr.pointer)))
2064 gfc_error ("Pointer-array actual argument at %L requires "
2065 "an assumed-shape or pointer-array dummy "
2066 "argument '%s' due to VOLATILE attribute",
2067 &a->expr->where,f->sym->name);
2078 /* Make sure missing actual arguments are optional. */
2080 for (f = formal; f; f = f->next, i++)
2082 if (new_arg[i] != NULL)
2087 gfc_error ("Missing alternate return spec in subroutine call "
2091 if (!f->sym->attr.optional)
2094 gfc_error ("Missing actual argument for argument '%s' at %L",
2095 f->sym->name, where);
2100 /* The argument lists are compatible. We now relink a new actual
2101 argument list with null arguments in the right places. The head
2102 of the list remains the head. */
2103 for (i = 0; i < n; i++)
2104 if (new_arg[i] == NULL)
2105 new_arg[i] = gfc_get_actual_arglist ();
2110 *new_arg[0] = *actual;
2114 new_arg[0] = new_arg[na];
2118 for (i = 0; i < n - 1; i++)
2119 new_arg[i]->next = new_arg[i + 1];
2121 new_arg[i]->next = NULL;
2123 if (*ap == NULL && n > 0)
2126 /* Note the types of omitted optional arguments. */
2127 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2128 if (a->expr == NULL && a->label == NULL)
2129 a->missing_arg_type = f->sym->ts.type;
2137 gfc_formal_arglist *f;
2138 gfc_actual_arglist *a;
2142 /* qsort comparison function for argument pairs, with the following
2144 - p->a->expr == NULL
2145 - p->a->expr->expr_type != EXPR_VARIABLE
2146 - growing p->a->expr->symbol. */
2149 pair_cmp (const void *p1, const void *p2)
2151 const gfc_actual_arglist *a1, *a2;
2153 /* *p1 and *p2 are elements of the to-be-sorted array. */
2154 a1 = ((const argpair *) p1)->a;
2155 a2 = ((const argpair *) p2)->a;
2164 if (a1->expr->expr_type != EXPR_VARIABLE)
2166 if (a2->expr->expr_type != EXPR_VARIABLE)
2170 if (a2->expr->expr_type != EXPR_VARIABLE)
2172 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2176 /* Given two expressions from some actual arguments, test whether they
2177 refer to the same expression. The analysis is conservative.
2178 Returning FAILURE will produce no warning. */
2181 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2183 const gfc_ref *r1, *r2;
2186 || e1->expr_type != EXPR_VARIABLE
2187 || e2->expr_type != EXPR_VARIABLE
2188 || e1->symtree->n.sym != e2->symtree->n.sym)
2191 /* TODO: improve comparison, see expr.c:show_ref(). */
2192 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2194 if (r1->type != r2->type)
2199 if (r1->u.ar.type != r2->u.ar.type)
2201 /* TODO: At the moment, consider only full arrays;
2202 we could do better. */
2203 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2208 if (r1->u.c.component != r2->u.c.component)
2216 gfc_internal_error ("compare_actual_expr(): Bad component code");
2225 /* Given formal and actual argument lists that correspond to one
2226 another, check that identical actual arguments aren't not
2227 associated with some incompatible INTENTs. */
2230 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2232 sym_intent f1_intent, f2_intent;
2233 gfc_formal_arglist *f1;
2234 gfc_actual_arglist *a1;
2237 gfc_try t = SUCCESS;
2240 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2242 if (f1 == NULL && a1 == NULL)
2244 if (f1 == NULL || a1 == NULL)
2245 gfc_internal_error ("check_some_aliasing(): List mismatch");
2250 p = (argpair *) alloca (n * sizeof (argpair));
2252 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2258 qsort (p, n, sizeof (argpair), pair_cmp);
2260 for (i = 0; i < n; i++)
2263 || p[i].a->expr->expr_type != EXPR_VARIABLE
2264 || p[i].a->expr->ts.type == BT_PROCEDURE)
2266 f1_intent = p[i].f->sym->attr.intent;
2267 for (j = i + 1; j < n; j++)
2269 /* Expected order after the sort. */
2270 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2271 gfc_internal_error ("check_some_aliasing(): corrupted data");
2273 /* Are the expression the same? */
2274 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2276 f2_intent = p[j].f->sym->attr.intent;
2277 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2278 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2280 gfc_warning ("Same actual argument associated with INTENT(%s) "
2281 "argument '%s' and INTENT(%s) argument '%s' at %L",
2282 gfc_intent_string (f1_intent), p[i].f->sym->name,
2283 gfc_intent_string (f2_intent), p[j].f->sym->name,
2284 &p[i].a->expr->where);
2294 /* Given a symbol of a formal argument list and an expression,
2295 return nonzero if their intents are compatible, zero otherwise. */
2298 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2300 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2303 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2306 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2313 /* Given formal and actual argument lists that correspond to one
2314 another, check that they are compatible in the sense that intents
2315 are not mismatched. */
2318 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2320 sym_intent f_intent;
2322 for (;; f = f->next, a = a->next)
2324 if (f == NULL && a == NULL)
2326 if (f == NULL || a == NULL)
2327 gfc_internal_error ("check_intents(): List mismatch");
2329 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2332 f_intent = f->sym->attr.intent;
2334 if (!compare_parameter_intent(f->sym, a->expr))
2336 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2337 "specifies INTENT(%s)", &a->expr->where,
2338 gfc_intent_string (f_intent));
2342 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2344 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2346 gfc_error ("Procedure argument at %L is local to a PURE "
2347 "procedure and is passed to an INTENT(%s) argument",
2348 &a->expr->where, gfc_intent_string (f_intent));
2352 if (f->sym->attr.pointer)
2354 gfc_error ("Procedure argument at %L is local to a PURE "
2355 "procedure and has the POINTER attribute",
2366 /* Check how a procedure is used against its interface. If all goes
2367 well, the actual argument list will also end up being properly
2371 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2374 /* Warn about calls with an implicit interface. Special case
2375 for calling a ISO_C_BINDING becase c_loc and c_funloc
2376 are pseudo-unknown. */
2377 if (gfc_option.warn_implicit_interface
2378 && sym->attr.if_source == IFSRC_UNKNOWN
2379 && ! sym->attr.is_iso_c)
2380 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2383 if (sym->attr.if_source == IFSRC_UNKNOWN)
2385 gfc_actual_arglist *a;
2386 for (a = *ap; a; a = a->next)
2388 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2389 if (a->name != NULL && a->name[0] != '%')
2391 gfc_error("Keyword argument requires explicit interface "
2392 "for procedure '%s' at %L", sym->name, &a->expr->where);
2400 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2403 check_intents (sym->formal, *ap);
2404 if (gfc_option.warn_aliasing)
2405 check_some_aliasing (sym->formal, *ap);
2409 /* Check how a procedure pointer component is used against its interface.
2410 If all goes well, the actual argument list will also end up being properly
2411 sorted. Completely analogous to gfc_procedure_use. */
2414 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2417 /* Warn about calls with an implicit interface. Special case
2418 for calling a ISO_C_BINDING becase c_loc and c_funloc
2419 are pseudo-unknown. */
2420 if (gfc_option.warn_implicit_interface
2421 && comp->attr.if_source == IFSRC_UNKNOWN
2422 && !comp->attr.is_iso_c)
2423 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2424 "interface at %L", comp->name, where);
2426 if (comp->attr.if_source == IFSRC_UNKNOWN)
2428 gfc_actual_arglist *a;
2429 for (a = *ap; a; a = a->next)
2431 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2432 if (a->name != NULL && a->name[0] != '%')
2434 gfc_error("Keyword argument requires explicit interface "
2435 "for procedure pointer component '%s' at %L",
2436 comp->name, &a->expr->where);
2444 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2447 check_intents (comp->formal, *ap);
2448 if (gfc_option.warn_aliasing)
2449 check_some_aliasing (comp->formal, *ap);
2453 /* Try if an actual argument list matches the formal list of a symbol,
2454 respecting the symbol's attributes like ELEMENTAL. This is used for
2455 GENERIC resolution. */
2458 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2462 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2464 r = !sym->attr.elemental;
2465 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2467 check_intents (sym->formal, *args);
2468 if (gfc_option.warn_aliasing)
2469 check_some_aliasing (sym->formal, *args);
2477 /* Given an interface pointer and an actual argument list, search for
2478 a formal argument list that matches the actual. If found, returns
2479 a pointer to the symbol of the correct interface. Returns NULL if
2483 gfc_search_interface (gfc_interface *intr, int sub_flag,
2484 gfc_actual_arglist **ap)
2486 gfc_symbol *elem_sym = NULL;
2487 for (; intr; intr = intr->next)
2489 if (sub_flag && intr->sym->attr.function)
2491 if (!sub_flag && intr->sym->attr.subroutine)
2494 if (gfc_arglist_matches_symbol (ap, intr->sym))
2496 /* Satisfy 12.4.4.1 such that an elemental match has lower
2497 weight than a non-elemental match. */
2498 if (intr->sym->attr.elemental)
2500 elem_sym = intr->sym;
2507 return elem_sym ? elem_sym : NULL;
2511 /* Do a brute force recursive search for a symbol. */
2513 static gfc_symtree *
2514 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2518 if (root->n.sym == sym)
2523 st = find_symtree0 (root->left, sym);
2524 if (root->right && ! st)
2525 st = find_symtree0 (root->right, sym);
2530 /* Find a symtree for a symbol. */
2533 gfc_find_sym_in_symtree (gfc_symbol *sym)
2538 /* First try to find it by name. */
2539 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2540 if (st && st->n.sym == sym)
2543 /* If it's been renamed, resort to a brute-force search. */
2544 /* TODO: avoid having to do this search. If the symbol doesn't exist
2545 in the symtree for the current namespace, it should probably be added. */
2546 for (ns = gfc_current_ns; ns; ns = ns->parent)
2548 st = find_symtree0 (ns->sym_root, sym);
2552 gfc_internal_error ("Unable to find symbol %s", sym->name);
2557 /* See if the arglist to an operator-call contains a derived-type argument
2558 with a matching type-bound operator. If so, return the matching specific
2559 procedure defined as operator-target as well as the base-object to use
2560 (which is the found derived-type argument with operator). */
2562 static gfc_typebound_proc*
2563 matching_typebound_op (gfc_expr** tb_base,
2564 gfc_actual_arglist* args,
2565 gfc_intrinsic_op op, const char* uop)
2567 gfc_actual_arglist* base;
2569 for (base = args; base; base = base->next)
2570 if (base->expr->ts.type == BT_DERIVED)
2572 gfc_typebound_proc* tb;
2573 gfc_symbol* derived;
2576 derived = base->expr->ts.u.derived;
2578 if (op == INTRINSIC_USER)
2580 gfc_symtree* tb_uop;
2583 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
2592 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
2595 /* This means we hit a PRIVATE operator which is use-associated and
2596 should thus not be seen. */
2597 if (result == FAILURE)
2600 /* Look through the super-type hierarchy for a matching specific
2602 for (; tb; tb = tb->overridden)
2606 gcc_assert (tb->is_generic);
2607 for (g = tb->u.generic; g; g = g->next)
2610 gfc_actual_arglist* argcopy;
2613 gcc_assert (g->specific);
2614 if (g->specific->error)
2617 target = g->specific->u.specific->n.sym;
2619 /* Check if this arglist matches the formal. */
2620 argcopy = gfc_copy_actual_arglist (args);
2621 matches = gfc_arglist_matches_symbol (&argcopy, target);
2622 gfc_free_actual_arglist (argcopy);
2624 /* Return if we found a match. */
2627 *tb_base = base->expr;
2638 /* For the 'actual arglist' of an operator call and a specific typebound
2639 procedure that has been found the target of a type-bound operator, build the
2640 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2641 type-bound procedures rather than resolving type-bound operators 'directly'
2642 so that we can reuse the existing logic. */
2645 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
2646 gfc_expr* base, gfc_typebound_proc* target)
2648 e->expr_type = EXPR_COMPCALL;
2649 e->value.compcall.tbp = target;
2650 e->value.compcall.name = "operator"; /* Should not matter. */
2651 e->value.compcall.actual = actual;
2652 e->value.compcall.base_object = base;
2653 e->value.compcall.ignore_pass = 1;
2654 e->value.compcall.assign = 0;
2658 /* This subroutine is called when an expression is being resolved.
2659 The expression node in question is either a user defined operator
2660 or an intrinsic operator with arguments that aren't compatible
2661 with the operator. This subroutine builds an actual argument list
2662 corresponding to the operands, then searches for a compatible
2663 interface. If one is found, the expression node is replaced with
2664 the appropriate function call.
2665 real_error is an additional output argument that specifies if FAILURE
2666 is because of some real error and not because no match was found. */
2669 gfc_extend_expr (gfc_expr *e, bool *real_error)
2671 gfc_actual_arglist *actual;
2679 actual = gfc_get_actual_arglist ();
2680 actual->expr = e->value.op.op1;
2682 *real_error = false;
2684 if (e->value.op.op2 != NULL)
2686 actual->next = gfc_get_actual_arglist ();
2687 actual->next->expr = e->value.op.op2;
2690 i = fold_unary_intrinsic (e->value.op.op);
2692 if (i == INTRINSIC_USER)
2694 for (ns = gfc_current_ns; ns; ns = ns->parent)
2696 uop = gfc_find_uop (e->value.op.uop->name, ns);
2700 sym = gfc_search_interface (uop->op, 0, &actual);
2707 for (ns = gfc_current_ns; ns; ns = ns->parent)
2709 /* Due to the distinction between '==' and '.eq.' and friends, one has
2710 to check if either is defined. */
2713 #define CHECK_OS_COMPARISON(comp) \
2714 case INTRINSIC_##comp: \
2715 case INTRINSIC_##comp##_OS: \
2716 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2718 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2720 CHECK_OS_COMPARISON(EQ)
2721 CHECK_OS_COMPARISON(NE)
2722 CHECK_OS_COMPARISON(GT)
2723 CHECK_OS_COMPARISON(GE)
2724 CHECK_OS_COMPARISON(LT)
2725 CHECK_OS_COMPARISON(LE)
2726 #undef CHECK_OS_COMPARISON
2729 sym = gfc_search_interface (ns->op[i], 0, &actual);
2737 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2738 found rather than just taking the first one and not checking further. */
2742 gfc_typebound_proc* tbo;
2745 /* See if we find a matching type-bound operator. */
2746 if (i == INTRINSIC_USER)
2747 tbo = matching_typebound_op (&tb_base, actual,
2748 i, e->value.op.uop->name);
2752 #define CHECK_OS_COMPARISON(comp) \
2753 case INTRINSIC_##comp: \
2754 case INTRINSIC_##comp##_OS: \
2755 tbo = matching_typebound_op (&tb_base, actual, \
2756 INTRINSIC_##comp, NULL); \
2758 tbo = matching_typebound_op (&tb_base, actual, \
2759 INTRINSIC_##comp##_OS, NULL); \
2761 CHECK_OS_COMPARISON(EQ)
2762 CHECK_OS_COMPARISON(NE)
2763 CHECK_OS_COMPARISON(GT)
2764 CHECK_OS_COMPARISON(GE)
2765 CHECK_OS_COMPARISON(LT)
2766 CHECK_OS_COMPARISON(LE)
2767 #undef CHECK_OS_COMPARISON
2770 tbo = matching_typebound_op (&tb_base, actual, i, NULL);
2774 /* If there is a matching typebound-operator, replace the expression with
2775 a call to it and succeed. */
2780 gcc_assert (tb_base);
2781 build_compcall_for_operator (e, actual, tb_base, tbo);
2783 result = gfc_resolve_expr (e);
2784 if (result == FAILURE)
2790 /* Don't use gfc_free_actual_arglist(). */
2791 if (actual->next != NULL)
2792 gfc_free (actual->next);
2798 /* Change the expression node to a function call. */
2799 e->expr_type = EXPR_FUNCTION;
2800 e->symtree = gfc_find_sym_in_symtree (sym);
2801 e->value.function.actual = actual;
2802 e->value.function.esym = NULL;
2803 e->value.function.isym = NULL;
2804 e->value.function.name = NULL;
2805 e->user_operator = 1;
2807 if (gfc_resolve_expr (e) == FAILURE)
2817 /* Tries to replace an assignment code node with a subroutine call to
2818 the subroutine associated with the assignment operator. Return
2819 SUCCESS if the node was replaced. On FAILURE, no error is
2823 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2825 gfc_actual_arglist *actual;
2826 gfc_expr *lhs, *rhs;
2832 /* Don't allow an intrinsic assignment to be replaced. */
2833 if (lhs->ts.type != BT_DERIVED
2834 && (rhs->rank == 0 || rhs->rank == lhs->rank)
2835 && (lhs->ts.type == rhs->ts.type
2836 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2839 actual = gfc_get_actual_arglist ();
2842 actual->next = gfc_get_actual_arglist ();
2843 actual->next->expr = rhs;
2847 for (; ns; ns = ns->parent)
2849 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
2854 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
2858 gfc_typebound_proc* tbo;
2861 /* See if we find a matching type-bound assignment. */
2862 tbo = matching_typebound_op (&tb_base, actual,
2863 INTRINSIC_ASSIGN, NULL);
2865 /* If there is one, replace the expression with a call to it and
2869 gcc_assert (tb_base);
2870 c->expr1 = gfc_get_expr ();
2871 build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
2872 c->expr1->value.compcall.assign = 1;
2874 c->op = EXEC_COMPCALL;
2876 /* c is resolved from the caller, so no need to do it here. */
2881 gfc_free (actual->next);
2886 /* Replace the assignment with the call. */
2887 c->op = EXEC_ASSIGN_CALL;
2888 c->symtree = gfc_find_sym_in_symtree (sym);
2891 c->ext.actual = actual;
2897 /* Make sure that the interface just parsed is not already present in
2898 the given interface list. Ambiguity isn't checked yet since module
2899 procedures can be present without interfaces. */
2902 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
2906 for (ip = base; ip; ip = ip->next)
2908 if (ip->sym == new_sym)
2910 gfc_error ("Entity '%s' at %C is already present in the interface",
2920 /* Add a symbol to the current interface. */
2923 gfc_add_interface (gfc_symbol *new_sym)
2925 gfc_interface **head, *intr;
2929 switch (current_interface.type)
2931 case INTERFACE_NAMELESS:
2932 case INTERFACE_ABSTRACT:
2935 case INTERFACE_INTRINSIC_OP:
2936 for (ns = current_interface.ns; ns; ns = ns->parent)
2937 switch (current_interface.op)
2940 case INTRINSIC_EQ_OS:
2941 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
2942 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
2947 case INTRINSIC_NE_OS:
2948 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
2949 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
2954 case INTRINSIC_GT_OS:
2955 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
2956 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
2961 case INTRINSIC_GE_OS:
2962 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
2963 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
2968 case INTRINSIC_LT_OS:
2969 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
2970 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
2975 case INTRINSIC_LE_OS:
2976 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
2977 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
2982 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
2986 head = ¤t_interface.ns->op[current_interface.op];
2989 case INTERFACE_GENERIC:
2990 for (ns = current_interface.ns; ns; ns = ns->parent)
2992 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2996 if (check_new_interface (sym->generic, new_sym) == FAILURE)
3000 head = ¤t_interface.sym->generic;
3003 case INTERFACE_USER_OP:
3004 if (check_new_interface (current_interface.uop->op, new_sym)
3008 head = ¤t_interface.uop->op;
3012 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3015 intr = gfc_get_interface ();
3016 intr->sym = new_sym;
3017 intr->where = gfc_current_locus;
3027 gfc_current_interface_head (void)
3029 switch (current_interface.type)
3031 case INTERFACE_INTRINSIC_OP:
3032 return current_interface.ns->op[current_interface.op];
3035 case INTERFACE_GENERIC:
3036 return current_interface.sym->generic;
3039 case INTERFACE_USER_OP:
3040 return current_interface.uop->op;
3050 gfc_set_current_interface_head (gfc_interface *i)
3052 switch (current_interface.type)
3054 case INTERFACE_INTRINSIC_OP:
3055 current_interface.ns->op[current_interface.op] = i;
3058 case INTERFACE_GENERIC:
3059 current_interface.sym->generic = i;
3062 case INTERFACE_USER_OP:
3063 current_interface.uop->op = i;
3072 /* Gets rid of a formal argument list. We do not free symbols.
3073 Symbols are freed when a namespace is freed. */
3076 gfc_free_formal_arglist (gfc_formal_arglist *p)
3078 gfc_formal_arglist *q;