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 && (r1 == 0 || r1 == r2)
630 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
631 || (gfc_numeric_ts (&sym->formal->sym->ts)
632 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
634 gfc_error ("Assignment operator interface at %L must not redefine "
635 "an INTRINSIC type assignment", &sym->declared_at);
641 if (!sym->attr.function)
643 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
649 /* Check intents on operator interfaces. */
650 if (op == INTRINSIC_ASSIGN)
652 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
654 gfc_error ("First argument of defined assignment at %L must be "
655 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
661 gfc_error ("Second argument of defined assignment at %L must be "
662 "INTENT(IN)", &sym->declared_at);
670 gfc_error ("First argument of operator interface at %L must be "
671 "INTENT(IN)", &sym->declared_at);
675 if (args == 2 && i2 != INTENT_IN)
677 gfc_error ("Second argument of operator interface at %L must be "
678 "INTENT(IN)", &sym->declared_at);
683 /* From now on, all we have to do is check that the operator definition
684 doesn't conflict with an intrinsic operator. The rules for this
685 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
686 as well as 12.3.2.1.1 of Fortran 2003:
688 "If the operator is an intrinsic-operator (R310), the number of
689 function arguments shall be consistent with the intrinsic uses of
690 that operator, and the types, kind type parameters, or ranks of the
691 dummy arguments shall differ from those required for the intrinsic
692 operation (7.1.2)." */
694 #define IS_NUMERIC_TYPE(t) \
695 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
697 /* Unary ops are easy, do them first. */
698 if (op == INTRINSIC_NOT)
700 if (t1 == BT_LOGICAL)
706 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
708 if (IS_NUMERIC_TYPE (t1))
714 /* Character intrinsic operators have same character kind, thus
715 operator definitions with operands of different character kinds
717 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
720 /* Intrinsic operators always perform on arguments of same rank,
721 so different ranks is also always safe. (rank == 0) is an exception
722 to that, because all intrinsic operators are elemental. */
723 if (r1 != r2 && r1 != 0 && r2 != 0)
729 case INTRINSIC_EQ_OS:
731 case INTRINSIC_NE_OS:
732 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
737 case INTRINSIC_MINUS:
738 case INTRINSIC_TIMES:
739 case INTRINSIC_DIVIDE:
740 case INTRINSIC_POWER:
741 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
746 case INTRINSIC_GT_OS:
748 case INTRINSIC_GE_OS:
750 case INTRINSIC_LT_OS:
752 case INTRINSIC_LE_OS:
753 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
755 if ((t1 == BT_INTEGER || t1 == BT_REAL)
756 && (t2 == BT_INTEGER || t2 == BT_REAL))
760 case INTRINSIC_CONCAT:
761 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
769 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
779 #undef IS_NUMERIC_TYPE
782 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
788 /* Given a pair of formal argument lists, we see if the two lists can
789 be distinguished by counting the number of nonoptional arguments of
790 a given type/rank in f1 and seeing if there are less then that
791 number of those arguments in f2 (including optional arguments).
792 Since this test is asymmetric, it has to be called twice to make it
793 symmetric. Returns nonzero if the argument lists are incompatible
794 by this test. This subroutine implements rule 1 of section
795 14.1.2.3 in the Fortran 95 standard. */
798 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
800 int rc, ac1, ac2, i, j, k, n1;
801 gfc_formal_arglist *f;
814 for (f = f1; f; f = f->next)
817 /* Build an array of integers that gives the same integer to
818 arguments of the same type/rank. */
819 arg = XCNEWVEC (arginfo, n1);
822 for (i = 0; i < n1; i++, f = f->next)
830 for (i = 0; i < n1; i++)
832 if (arg[i].flag != -1)
835 if (arg[i].sym && arg[i].sym->attr.optional)
836 continue; /* Skip optional arguments. */
840 /* Find other nonoptional arguments of the same type/rank. */
841 for (j = i + 1; j < n1; j++)
842 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
843 && compare_type_rank_if (arg[i].sym, arg[j].sym))
849 /* Now loop over each distinct type found in f1. */
853 for (i = 0; i < n1; i++)
855 if (arg[i].flag != k)
859 for (j = i + 1; j < n1; j++)
860 if (arg[j].flag == k)
863 /* Count the number of arguments in f2 with that type, including
864 those that are optional. */
867 for (f = f2; f; f = f->next)
868 if (compare_type_rank_if (arg[i].sym, f->sym))
886 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
887 Returns zero if no argument is found that satisfies rule 2, nonzero
890 This test is also not symmetric in f1 and f2 and must be called
891 twice. This test finds problems caused by sorting the actual
892 argument list with keywords. For example:
896 INTEGER :: A ; REAL :: B
900 INTEGER :: A ; REAL :: B
904 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
907 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
909 gfc_formal_arglist *f2_save, *g;
916 if (f1->sym->attr.optional)
919 if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
922 /* Now search for a disambiguating keyword argument starting at
923 the current non-match. */
924 for (g = f1; g; g = g->next)
926 if (g->sym->attr.optional)
929 sym = find_keyword_arg (g->sym->name, f2_save);
930 if (sym == NULL || !compare_type_rank (g->sym, sym))
944 /* 'Compare' two formal interfaces associated with a pair of symbols.
945 We return nonzero if there exists an actual argument list that
946 would be ambiguous between the two interfaces, zero otherwise.
947 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
948 required to match, which is not the case for ambiguity checks.*/
951 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
952 int generic_flag, int intent_flag,
953 char *errmsg, int err_len)
955 gfc_formal_arglist *f1, *f2;
957 if (s1->attr.function && (s2->attr.subroutine
958 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
959 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
962 snprintf (errmsg, err_len, "'%s' is not a function", name2);
966 if (s1->attr.subroutine && s2->attr.function)
969 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
973 /* If the arguments are functions, check type and kind
974 (only for dummy procedures and procedure pointer assignments). */
975 if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
977 if (s1->ts.type == BT_UNKNOWN)
979 if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
982 snprintf (errmsg, err_len, "Type/kind mismatch in return value "
988 if (s1->attr.if_source == IFSRC_UNKNOWN
989 || s2->attr.if_source == IFSRC_UNKNOWN)
995 if (f1 == NULL && f2 == NULL)
996 return 1; /* Special case: No arguments. */
1000 if (count_types_test (f1, f2) || count_types_test (f2, f1))
1002 if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1006 /* Perform the abbreviated correspondence test for operators (the
1007 arguments cannot be optional and are always ordered correctly).
1008 This is also done when comparing interfaces for dummy procedures and in
1009 procedure pointer assignments. */
1013 /* Check existence. */
1014 if (f1 == NULL && f2 == NULL)
1016 if (f1 == NULL || f2 == NULL)
1019 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1020 "arguments", name2);
1024 /* Check type and rank. */
1025 if (!compare_type_rank (f1->sym, f2->sym))
1028 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1034 if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
1036 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1041 /* Check OPTIONAL. */
1042 if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
1044 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1057 /* Given a pointer to an interface pointer, remove duplicate
1058 interfaces and make sure that all symbols are either functions or
1059 subroutines. Returns nonzero if something goes wrong. */
1062 check_interface0 (gfc_interface *p, const char *interface_name)
1064 gfc_interface *psave, *q, *qlast;
1067 /* Make sure all symbols in the interface have been defined as
1068 functions or subroutines. */
1069 for (; p; p = p->next)
1070 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1071 || !p->sym->attr.if_source)
1073 if (p->sym->attr.external)
1074 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1075 p->sym->name, interface_name, &p->sym->declared_at);
1077 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1078 "subroutine", p->sym->name, interface_name,
1079 &p->sym->declared_at);
1084 /* Remove duplicate interfaces in this interface list. */
1085 for (; p; p = p->next)
1089 for (q = p->next; q;)
1091 if (p->sym != q->sym)
1098 /* Duplicate interface. */
1099 qlast->next = q->next;
1110 /* Check lists of interfaces to make sure that no two interfaces are
1111 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1114 check_interface1 (gfc_interface *p, gfc_interface *q0,
1115 int generic_flag, const char *interface_name,
1119 for (; p; p = p->next)
1120 for (q = q0; q; q = q->next)
1122 if (p->sym == q->sym)
1123 continue; /* Duplicates OK here. */
1125 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1128 if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
1133 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1134 p->sym->name, q->sym->name, interface_name,
1138 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,
1149 /* Check the generic and operator interfaces of symbols to make sure
1150 that none of the interfaces conflict. The check has to be done
1151 after all of the symbols are actually loaded. */
1154 check_sym_interfaces (gfc_symbol *sym)
1156 char interface_name[100];
1160 if (sym->ns != gfc_current_ns)
1163 if (sym->generic != NULL)
1165 sprintf (interface_name, "generic interface '%s'", sym->name);
1166 if (check_interface0 (sym->generic, interface_name))
1169 for (p = sym->generic; p; p = p->next)
1171 if (p->sym->attr.mod_proc
1172 && (p->sym->attr.if_source != IFSRC_DECL
1173 || p->sym->attr.procedure))
1175 gfc_error ("'%s' at %L is not a module procedure",
1176 p->sym->name, &p->where);
1181 /* Originally, this test was applied to host interfaces too;
1182 this is incorrect since host associated symbols, from any
1183 source, cannot be ambiguous with local symbols. */
1184 k = sym->attr.referenced || !sym->attr.use_assoc;
1185 if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1186 sym->attr.ambiguous_interfaces = 1;
1192 check_uop_interfaces (gfc_user_op *uop)
1194 char interface_name[100];
1198 sprintf (interface_name, "operator interface '%s'", uop->name);
1199 if (check_interface0 (uop->op, interface_name))
1202 for (ns = gfc_current_ns; ns; ns = ns->parent)
1204 uop2 = gfc_find_uop (uop->name, ns);
1208 check_interface1 (uop->op, uop2->op, 0,
1209 interface_name, true);
1214 /* For the namespace, check generic, user operator and intrinsic
1215 operator interfaces for consistency and to remove duplicate
1216 interfaces. We traverse the whole namespace, counting on the fact
1217 that most symbols will not have generic or operator interfaces. */
1220 gfc_check_interfaces (gfc_namespace *ns)
1222 gfc_namespace *old_ns, *ns2;
1223 char interface_name[100];
1226 old_ns = gfc_current_ns;
1227 gfc_current_ns = ns;
1229 gfc_traverse_ns (ns, check_sym_interfaces);
1231 gfc_traverse_user_op (ns, check_uop_interfaces);
1233 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1235 if (i == INTRINSIC_USER)
1238 if (i == INTRINSIC_ASSIGN)
1239 strcpy (interface_name, "intrinsic assignment operator");
1241 sprintf (interface_name, "intrinsic '%s' operator",
1242 gfc_op2string ((gfc_intrinsic_op) i));
1244 if (check_interface0 (ns->op[i], interface_name))
1248 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1251 for (ns2 = ns; ns2; ns2 = ns2->parent)
1253 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1254 interface_name, true))
1260 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
1261 0, interface_name, true)) goto done;
1264 case INTRINSIC_EQ_OS:
1265 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
1266 0, interface_name, true)) goto done;
1270 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
1271 0, interface_name, true)) goto done;
1274 case INTRINSIC_NE_OS:
1275 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
1276 0, interface_name, true)) goto done;
1280 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
1281 0, interface_name, true)) goto done;
1284 case INTRINSIC_GT_OS:
1285 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
1286 0, interface_name, true)) goto done;
1290 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
1291 0, interface_name, true)) goto done;
1294 case INTRINSIC_GE_OS:
1295 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
1296 0, interface_name, true)) goto done;
1300 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
1301 0, interface_name, true)) goto done;
1304 case INTRINSIC_LT_OS:
1305 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
1306 0, interface_name, true)) goto done;
1310 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
1311 0, interface_name, true)) goto done;
1314 case INTRINSIC_LE_OS:
1315 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
1316 0, interface_name, true)) goto done;
1326 gfc_current_ns = old_ns;
1331 symbol_rank (gfc_symbol *sym)
1333 return (sym->as == NULL) ? 0 : sym->as->rank;
1337 /* Given a symbol of a formal argument list and an expression, if the
1338 formal argument is allocatable, check that the actual argument is
1339 allocatable. Returns nonzero if compatible, zero if not compatible. */
1342 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1344 symbol_attribute attr;
1346 if (formal->attr.allocatable)
1348 attr = gfc_expr_attr (actual);
1349 if (!attr.allocatable)
1357 /* Given a symbol of a formal argument list and an expression, if the
1358 formal argument is a pointer, see if the actual argument is a
1359 pointer. Returns nonzero if compatible, zero if not compatible. */
1362 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1364 symbol_attribute attr;
1366 if (formal->attr.pointer)
1368 attr = gfc_expr_attr (actual);
1377 /* Given a symbol of a formal argument list and an expression, see if
1378 the two are compatible as arguments. Returns nonzero if
1379 compatible, zero if not compatible. */
1382 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1383 int ranks_must_agree, int is_elemental, locus *where)
1388 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1389 procs c_f_pointer or c_f_procpointer, and we need to accept most
1390 pointers the user could give us. This should allow that. */
1391 if (formal->ts.type == BT_VOID)
1394 if (formal->ts.type == BT_DERIVED
1395 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1396 && actual->ts.type == BT_DERIVED
1397 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1400 if (actual->ts.type == BT_PROCEDURE)
1403 gfc_symbol *act_sym = actual->symtree->n.sym;
1405 if (formal->attr.flavor != FL_PROCEDURE)
1408 gfc_error ("Invalid procedure argument at %L", &actual->where);
1412 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1416 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1417 formal->name, &actual->where, err);
1421 if (formal->attr.function && !act_sym->attr.function)
1423 gfc_add_function (&act_sym->attr, act_sym->name,
1424 &act_sym->declared_at);
1425 if (act_sym->ts.type == BT_UNKNOWN
1426 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1429 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1430 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1431 &act_sym->declared_at);
1436 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1437 && !gfc_compare_types (&formal->ts, &actual->ts))
1440 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1441 formal->name, &actual->where, gfc_typename (&actual->ts),
1442 gfc_typename (&formal->ts));
1446 if (symbol_rank (formal) == actual->rank)
1449 rank_check = where != NULL && !is_elemental && formal->as
1450 && (formal->as->type == AS_ASSUMED_SHAPE
1451 || formal->as->type == AS_DEFERRED);
1453 if (rank_check || ranks_must_agree || formal->attr.pointer
1454 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1455 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
1458 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1459 formal->name, &actual->where, symbol_rank (formal),
1463 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1466 /* At this point, we are considering a scalar passed to an array. This
1467 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1468 - if the actual argument is (a substring of) an element of a
1469 non-assumed-shape/non-pointer array;
1470 - (F2003) if the actual argument is of type character. */
1472 for (ref = actual->ref; ref; ref = ref->next)
1473 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1476 /* Not an array element. */
1477 if (formal->ts.type == BT_CHARACTER
1479 || (actual->expr_type == EXPR_VARIABLE
1480 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1481 || actual->symtree->n.sym->attr.pointer))))
1483 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1485 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1486 "array dummy argument '%s' at %L",
1487 formal->name, &actual->where);
1490 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1495 else if (ref == NULL)
1498 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1499 formal->name, &actual->where, symbol_rank (formal),
1504 if (actual->expr_type == EXPR_VARIABLE
1505 && actual->symtree->n.sym->as
1506 && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1507 || actual->symtree->n.sym->attr.pointer))
1510 gfc_error ("Element of assumed-shaped array passed to dummy "
1511 "argument '%s' at %L", formal->name, &actual->where);
1519 /* Given a symbol of a formal argument list and an expression, see if
1520 the two are compatible as arguments. Returns nonzero if
1521 compatible, zero if not compatible. */
1524 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1526 if (actual->expr_type != EXPR_VARIABLE)
1529 if (!actual->symtree->n.sym->attr.is_protected)
1532 if (!actual->symtree->n.sym->attr.use_assoc)
1535 if (formal->attr.intent == INTENT_IN
1536 || formal->attr.intent == INTENT_UNKNOWN)
1539 if (!actual->symtree->n.sym->attr.pointer)
1542 if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1549 /* Returns the storage size of a symbol (formal argument) or
1550 zero if it cannot be determined. */
1552 static unsigned long
1553 get_sym_storage_size (gfc_symbol *sym)
1556 unsigned long strlen, elements;
1558 if (sym->ts.type == BT_CHARACTER)
1560 if (sym->ts.u.cl && sym->ts.u.cl->length
1561 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1562 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1569 if (symbol_rank (sym) == 0)
1573 if (sym->as->type != AS_EXPLICIT)
1575 for (i = 0; i < sym->as->rank; i++)
1577 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1578 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1581 elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1582 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1585 return strlen*elements;
1589 /* Returns the storage size of an expression (actual argument) or
1590 zero if it cannot be determined. For an array element, it returns
1591 the remaining size as the element sequence consists of all storage
1592 units of the actual argument up to the end of the array. */
1594 static unsigned long
1595 get_expr_storage_size (gfc_expr *e)
1598 long int strlen, elements;
1599 long int substrlen = 0;
1600 bool is_str_storage = false;
1606 if (e->ts.type == BT_CHARACTER)
1608 if (e->ts.u.cl && e->ts.u.cl->length
1609 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1610 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1611 else if (e->expr_type == EXPR_CONSTANT
1612 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1613 strlen = e->value.character.length;
1618 strlen = 1; /* Length per element. */
1620 if (e->rank == 0 && !e->ref)
1628 for (i = 0; i < e->rank; i++)
1629 elements *= mpz_get_si (e->shape[i]);
1630 return elements*strlen;
1633 for (ref = e->ref; ref; ref = ref->next)
1635 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1636 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1640 /* The string length is the substring length.
1641 Set now to full string length. */
1642 if (ref->u.ss.length == NULL
1643 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1646 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1648 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1652 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1653 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1654 && ref->u.ar.as->upper)
1655 for (i = 0; i < ref->u.ar.dimen; i++)
1657 long int start, end, stride;
1660 if (ref->u.ar.stride[i])
1662 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1663 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1668 if (ref->u.ar.start[i])
1670 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1671 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1675 else if (ref->u.ar.as->lower[i]
1676 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1677 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1681 if (ref->u.ar.end[i])
1683 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1684 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1688 else if (ref->u.ar.as->upper[i]
1689 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1690 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1694 elements *= (end - start)/stride + 1L;
1696 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1697 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1698 for (i = 0; i < ref->u.ar.as->rank; i++)
1700 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1701 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1702 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1703 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1704 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1709 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1710 && e->expr_type == EXPR_VARIABLE)
1712 if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1713 || e->symtree->n.sym->attr.pointer)
1719 /* Determine the number of remaining elements in the element
1720 sequence for array element designators. */
1721 is_str_storage = true;
1722 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1724 if (ref->u.ar.start[i] == NULL
1725 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1726 || ref->u.ar.as->upper[i] == NULL
1727 || ref->u.ar.as->lower[i] == NULL
1728 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1729 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1734 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1735 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1737 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1738 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1746 return (is_str_storage) ? substrlen + (elements-1)*strlen
1749 return elements*strlen;
1753 /* Given an expression, check whether it is an array section
1754 which has a vector subscript. If it has, one is returned,
1758 has_vector_subscript (gfc_expr *e)
1763 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1766 for (ref = e->ref; ref; ref = ref->next)
1767 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1768 for (i = 0; i < ref->u.ar.dimen; i++)
1769 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1776 /* Given formal and actual argument lists, see if they are compatible.
1777 If they are compatible, the actual argument list is sorted to
1778 correspond with the formal list, and elements for missing optional
1779 arguments are inserted. If WHERE pointer is nonnull, then we issue
1780 errors when things don't match instead of just returning the status
1784 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1785 int ranks_must_agree, int is_elemental, locus *where)
1787 gfc_actual_arglist **new_arg, *a, *actual, temp;
1788 gfc_formal_arglist *f;
1790 unsigned long actual_size, formal_size;
1794 if (actual == NULL && formal == NULL)
1798 for (f = formal; f; f = f->next)
1801 new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1803 for (i = 0; i < n; i++)
1810 for (a = actual; a; a = a->next, f = f->next)
1812 /* Look for keywords but ignore g77 extensions like %VAL. */
1813 if (a->name != NULL && a->name[0] != '%')
1816 for (f = formal; f; f = f->next, i++)
1820 if (strcmp (f->sym->name, a->name) == 0)
1827 gfc_error ("Keyword argument '%s' at %L is not in "
1828 "the procedure", a->name, &a->expr->where);
1832 if (new_arg[i] != NULL)
1835 gfc_error ("Keyword argument '%s' at %L is already associated "
1836 "with another actual argument", a->name,
1845 gfc_error ("More actual than formal arguments in procedure "
1846 "call at %L", where);
1851 if (f->sym == NULL && a->expr == NULL)
1857 gfc_error ("Missing alternate return spec in subroutine call "
1862 if (a->expr == NULL)
1865 gfc_error ("Unexpected alternate return spec in subroutine "
1866 "call at %L", where);
1870 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1871 is_elemental, where))
1874 /* Special case for character arguments. For allocatable, pointer
1875 and assumed-shape dummies, the string length needs to match
1877 if (a->expr->ts.type == BT_CHARACTER
1878 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
1879 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1880 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
1881 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
1882 && (f->sym->attr.pointer || f->sym->attr.allocatable
1883 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1884 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
1885 f->sym->ts.u.cl->length->value.integer) != 0))
1887 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1888 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1889 "argument and pointer or allocatable dummy argument "
1891 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1892 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1893 f->sym->name, &a->expr->where);
1895 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1896 "argument and assumed-shape dummy argument '%s' "
1898 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1899 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1900 f->sym->name, &a->expr->where);
1904 actual_size = get_expr_storage_size (a->expr);
1905 formal_size = get_sym_storage_size (f->sym);
1906 if (actual_size != 0
1907 && actual_size < formal_size
1908 && a->expr->ts.type != BT_PROCEDURE)
1910 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1911 gfc_warning ("Character length of actual argument shorter "
1912 "than of dummy argument '%s' (%lu/%lu) at %L",
1913 f->sym->name, actual_size, formal_size,
1916 gfc_warning ("Actual argument contains too few "
1917 "elements for dummy argument '%s' (%lu/%lu) at %L",
1918 f->sym->name, actual_size, formal_size,
1923 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1924 is provided for a procedure pointer formal argument. */
1925 if (f->sym->attr.proc_pointer
1926 && !((a->expr->expr_type == EXPR_VARIABLE
1927 && a->expr->symtree->n.sym->attr.proc_pointer)
1928 || (a->expr->expr_type == EXPR_FUNCTION
1929 && a->expr->symtree->n.sym->result->attr.proc_pointer)
1930 || gfc_is_proc_ptr_comp (a->expr, NULL)))
1933 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1934 f->sym->name, &a->expr->where);
1938 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1939 provided for a procedure formal argument. */
1940 if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
1941 && a->expr->expr_type == EXPR_VARIABLE
1942 && f->sym->attr.flavor == FL_PROCEDURE)
1945 gfc_error ("Expected a procedure for argument '%s' at %L",
1946 f->sym->name, &a->expr->where);
1950 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1951 && a->expr->ts.type == BT_PROCEDURE
1952 && !a->expr->symtree->n.sym->attr.pure)
1955 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1956 f->sym->name, &a->expr->where);
1960 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1961 && a->expr->expr_type == EXPR_VARIABLE
1962 && a->expr->symtree->n.sym->as
1963 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1964 && (a->expr->ref == NULL
1965 || (a->expr->ref->type == REF_ARRAY
1966 && a->expr->ref->u.ar.type == AR_FULL)))
1969 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1970 " array at %L", f->sym->name, where);
1974 if (a->expr->expr_type != EXPR_NULL
1975 && compare_pointer (f->sym, a->expr) == 0)
1978 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1979 f->sym->name, &a->expr->where);
1983 if (a->expr->expr_type != EXPR_NULL
1984 && compare_allocatable (f->sym, a->expr) == 0)
1987 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1988 f->sym->name, &a->expr->where);
1992 /* Check intent = OUT/INOUT for definable actual argument. */
1993 if ((a->expr->expr_type != EXPR_VARIABLE
1994 || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
1995 && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
1996 && (f->sym->attr.intent == INTENT_OUT
1997 || f->sym->attr.intent == INTENT_INOUT))
2000 gfc_error ("Actual argument at %L must be definable as "
2001 "the dummy argument '%s' is INTENT = OUT/INOUT",
2002 &a->expr->where, f->sym->name);
2006 if (!compare_parameter_protected(f->sym, a->expr))
2009 gfc_error ("Actual argument at %L is use-associated with "
2010 "PROTECTED attribute and dummy argument '%s' is "
2011 "INTENT = OUT/INOUT",
2012 &a->expr->where,f->sym->name);
2016 if ((f->sym->attr.intent == INTENT_OUT
2017 || f->sym->attr.intent == INTENT_INOUT
2018 || f->sym->attr.volatile_)
2019 && has_vector_subscript (a->expr))
2022 gfc_error ("Array-section actual argument with vector subscripts "
2023 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2024 "or VOLATILE attribute of the dummy argument '%s'",
2025 &a->expr->where, f->sym->name);
2029 /* C1232 (R1221) For an actual argument which is an array section or
2030 an assumed-shape array, the dummy argument shall be an assumed-
2031 shape array, if the dummy argument has the VOLATILE attribute. */
2033 if (f->sym->attr.volatile_
2034 && a->expr->symtree->n.sym->as
2035 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2036 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2039 gfc_error ("Assumed-shape actual argument at %L is "
2040 "incompatible with the non-assumed-shape "
2041 "dummy argument '%s' due to VOLATILE attribute",
2042 &a->expr->where,f->sym->name);
2046 if (f->sym->attr.volatile_
2047 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2048 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2051 gfc_error ("Array-section actual argument at %L is "
2052 "incompatible with the non-assumed-shape "
2053 "dummy argument '%s' due to VOLATILE attribute",
2054 &a->expr->where,f->sym->name);
2058 /* C1233 (R1221) For an actual argument which is a pointer array, the
2059 dummy argument shall be an assumed-shape or pointer array, if the
2060 dummy argument has the VOLATILE attribute. */
2062 if (f->sym->attr.volatile_
2063 && a->expr->symtree->n.sym->attr.pointer
2064 && a->expr->symtree->n.sym->as
2066 && (f->sym->as->type == AS_ASSUMED_SHAPE
2067 || f->sym->attr.pointer)))
2070 gfc_error ("Pointer-array actual argument at %L requires "
2071 "an assumed-shape or pointer-array dummy "
2072 "argument '%s' due to VOLATILE attribute",
2073 &a->expr->where,f->sym->name);
2084 /* Make sure missing actual arguments are optional. */
2086 for (f = formal; f; f = f->next, i++)
2088 if (new_arg[i] != NULL)
2093 gfc_error ("Missing alternate return spec in subroutine call "
2097 if (!f->sym->attr.optional)
2100 gfc_error ("Missing actual argument for argument '%s' at %L",
2101 f->sym->name, where);
2106 /* The argument lists are compatible. We now relink a new actual
2107 argument list with null arguments in the right places. The head
2108 of the list remains the head. */
2109 for (i = 0; i < n; i++)
2110 if (new_arg[i] == NULL)
2111 new_arg[i] = gfc_get_actual_arglist ();
2116 *new_arg[0] = *actual;
2120 new_arg[0] = new_arg[na];
2124 for (i = 0; i < n - 1; i++)
2125 new_arg[i]->next = new_arg[i + 1];
2127 new_arg[i]->next = NULL;
2129 if (*ap == NULL && n > 0)
2132 /* Note the types of omitted optional arguments. */
2133 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2134 if (a->expr == NULL && a->label == NULL)
2135 a->missing_arg_type = f->sym->ts.type;
2143 gfc_formal_arglist *f;
2144 gfc_actual_arglist *a;
2148 /* qsort comparison function for argument pairs, with the following
2150 - p->a->expr == NULL
2151 - p->a->expr->expr_type != EXPR_VARIABLE
2152 - growing p->a->expr->symbol. */
2155 pair_cmp (const void *p1, const void *p2)
2157 const gfc_actual_arglist *a1, *a2;
2159 /* *p1 and *p2 are elements of the to-be-sorted array. */
2160 a1 = ((const argpair *) p1)->a;
2161 a2 = ((const argpair *) p2)->a;
2170 if (a1->expr->expr_type != EXPR_VARIABLE)
2172 if (a2->expr->expr_type != EXPR_VARIABLE)
2176 if (a2->expr->expr_type != EXPR_VARIABLE)
2178 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2182 /* Given two expressions from some actual arguments, test whether they
2183 refer to the same expression. The analysis is conservative.
2184 Returning FAILURE will produce no warning. */
2187 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2189 const gfc_ref *r1, *r2;
2192 || e1->expr_type != EXPR_VARIABLE
2193 || e2->expr_type != EXPR_VARIABLE
2194 || e1->symtree->n.sym != e2->symtree->n.sym)
2197 /* TODO: improve comparison, see expr.c:show_ref(). */
2198 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2200 if (r1->type != r2->type)
2205 if (r1->u.ar.type != r2->u.ar.type)
2207 /* TODO: At the moment, consider only full arrays;
2208 we could do better. */
2209 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2214 if (r1->u.c.component != r2->u.c.component)
2222 gfc_internal_error ("compare_actual_expr(): Bad component code");
2231 /* Given formal and actual argument lists that correspond to one
2232 another, check that identical actual arguments aren't not
2233 associated with some incompatible INTENTs. */
2236 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2238 sym_intent f1_intent, f2_intent;
2239 gfc_formal_arglist *f1;
2240 gfc_actual_arglist *a1;
2243 gfc_try t = SUCCESS;
2246 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2248 if (f1 == NULL && a1 == NULL)
2250 if (f1 == NULL || a1 == NULL)
2251 gfc_internal_error ("check_some_aliasing(): List mismatch");
2256 p = (argpair *) alloca (n * sizeof (argpair));
2258 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2264 qsort (p, n, sizeof (argpair), pair_cmp);
2266 for (i = 0; i < n; i++)
2269 || p[i].a->expr->expr_type != EXPR_VARIABLE
2270 || p[i].a->expr->ts.type == BT_PROCEDURE)
2272 f1_intent = p[i].f->sym->attr.intent;
2273 for (j = i + 1; j < n; j++)
2275 /* Expected order after the sort. */
2276 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2277 gfc_internal_error ("check_some_aliasing(): corrupted data");
2279 /* Are the expression the same? */
2280 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2282 f2_intent = p[j].f->sym->attr.intent;
2283 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2284 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2286 gfc_warning ("Same actual argument associated with INTENT(%s) "
2287 "argument '%s' and INTENT(%s) argument '%s' at %L",
2288 gfc_intent_string (f1_intent), p[i].f->sym->name,
2289 gfc_intent_string (f2_intent), p[j].f->sym->name,
2290 &p[i].a->expr->where);
2300 /* Given a symbol of a formal argument list and an expression,
2301 return nonzero if their intents are compatible, zero otherwise. */
2304 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2306 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2309 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2312 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2319 /* Given formal and actual argument lists that correspond to one
2320 another, check that they are compatible in the sense that intents
2321 are not mismatched. */
2324 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2326 sym_intent f_intent;
2328 for (;; f = f->next, a = a->next)
2330 if (f == NULL && a == NULL)
2332 if (f == NULL || a == NULL)
2333 gfc_internal_error ("check_intents(): List mismatch");
2335 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2338 f_intent = f->sym->attr.intent;
2340 if (!compare_parameter_intent(f->sym, a->expr))
2342 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2343 "specifies INTENT(%s)", &a->expr->where,
2344 gfc_intent_string (f_intent));
2348 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2350 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2352 gfc_error ("Procedure argument at %L is local to a PURE "
2353 "procedure and is passed to an INTENT(%s) argument",
2354 &a->expr->where, gfc_intent_string (f_intent));
2358 if (f->sym->attr.pointer)
2360 gfc_error ("Procedure argument at %L is local to a PURE "
2361 "procedure and has the POINTER attribute",
2372 /* Check how a procedure is used against its interface. If all goes
2373 well, the actual argument list will also end up being properly
2377 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2380 /* Warn about calls with an implicit interface. Special case
2381 for calling a ISO_C_BINDING becase c_loc and c_funloc
2382 are pseudo-unknown. */
2383 if (gfc_option.warn_implicit_interface
2384 && sym->attr.if_source == IFSRC_UNKNOWN
2385 && ! sym->attr.is_iso_c)
2386 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2389 if (sym->attr.if_source == IFSRC_UNKNOWN)
2391 gfc_actual_arglist *a;
2392 for (a = *ap; a; a = a->next)
2394 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2395 if (a->name != NULL && a->name[0] != '%')
2397 gfc_error("Keyword argument requires explicit interface "
2398 "for procedure '%s' at %L", sym->name, &a->expr->where);
2406 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2409 check_intents (sym->formal, *ap);
2410 if (gfc_option.warn_aliasing)
2411 check_some_aliasing (sym->formal, *ap);
2415 /* Check how a procedure pointer component is used against its interface.
2416 If all goes well, the actual argument list will also end up being properly
2417 sorted. Completely analogous to gfc_procedure_use. */
2420 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2423 /* Warn about calls with an implicit interface. Special case
2424 for calling a ISO_C_BINDING becase c_loc and c_funloc
2425 are pseudo-unknown. */
2426 if (gfc_option.warn_implicit_interface
2427 && comp->attr.if_source == IFSRC_UNKNOWN
2428 && !comp->attr.is_iso_c)
2429 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2430 "interface at %L", comp->name, where);
2432 if (comp->attr.if_source == IFSRC_UNKNOWN)
2434 gfc_actual_arglist *a;
2435 for (a = *ap; a; a = a->next)
2437 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2438 if (a->name != NULL && a->name[0] != '%')
2440 gfc_error("Keyword argument requires explicit interface "
2441 "for procedure pointer component '%s' at %L",
2442 comp->name, &a->expr->where);
2450 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2453 check_intents (comp->formal, *ap);
2454 if (gfc_option.warn_aliasing)
2455 check_some_aliasing (comp->formal, *ap);
2459 /* Try if an actual argument list matches the formal list of a symbol,
2460 respecting the symbol's attributes like ELEMENTAL. This is used for
2461 GENERIC resolution. */
2464 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2468 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2470 r = !sym->attr.elemental;
2471 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2473 check_intents (sym->formal, *args);
2474 if (gfc_option.warn_aliasing)
2475 check_some_aliasing (sym->formal, *args);
2483 /* Given an interface pointer and an actual argument list, search for
2484 a formal argument list that matches the actual. If found, returns
2485 a pointer to the symbol of the correct interface. Returns NULL if
2489 gfc_search_interface (gfc_interface *intr, int sub_flag,
2490 gfc_actual_arglist **ap)
2492 gfc_symbol *elem_sym = NULL;
2493 for (; intr; intr = intr->next)
2495 if (sub_flag && intr->sym->attr.function)
2497 if (!sub_flag && intr->sym->attr.subroutine)
2500 if (gfc_arglist_matches_symbol (ap, intr->sym))
2502 /* Satisfy 12.4.4.1 such that an elemental match has lower
2503 weight than a non-elemental match. */
2504 if (intr->sym->attr.elemental)
2506 elem_sym = intr->sym;
2513 return elem_sym ? elem_sym : NULL;
2517 /* Do a brute force recursive search for a symbol. */
2519 static gfc_symtree *
2520 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2524 if (root->n.sym == sym)
2529 st = find_symtree0 (root->left, sym);
2530 if (root->right && ! st)
2531 st = find_symtree0 (root->right, sym);
2536 /* Find a symtree for a symbol. */
2539 gfc_find_sym_in_symtree (gfc_symbol *sym)
2544 /* First try to find it by name. */
2545 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2546 if (st && st->n.sym == sym)
2549 /* If it's been renamed, resort to a brute-force search. */
2550 /* TODO: avoid having to do this search. If the symbol doesn't exist
2551 in the symtree for the current namespace, it should probably be added. */
2552 for (ns = gfc_current_ns; ns; ns = ns->parent)
2554 st = find_symtree0 (ns->sym_root, sym);
2558 gfc_internal_error ("Unable to find symbol %s", sym->name);
2563 /* See if the arglist to an operator-call contains a derived-type argument
2564 with a matching type-bound operator. If so, return the matching specific
2565 procedure defined as operator-target as well as the base-object to use
2566 (which is the found derived-type argument with operator). */
2568 static gfc_typebound_proc*
2569 matching_typebound_op (gfc_expr** tb_base,
2570 gfc_actual_arglist* args,
2571 gfc_intrinsic_op op, const char* uop)
2573 gfc_actual_arglist* base;
2575 for (base = args; base; base = base->next)
2576 if (base->expr->ts.type == BT_DERIVED)
2578 gfc_typebound_proc* tb;
2579 gfc_symbol* derived;
2582 derived = base->expr->ts.u.derived;
2584 if (op == INTRINSIC_USER)
2586 gfc_symtree* tb_uop;
2589 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
2598 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
2601 /* This means we hit a PRIVATE operator which is use-associated and
2602 should thus not be seen. */
2603 if (result == FAILURE)
2606 /* Look through the super-type hierarchy for a matching specific
2608 for (; tb; tb = tb->overridden)
2612 gcc_assert (tb->is_generic);
2613 for (g = tb->u.generic; g; g = g->next)
2616 gfc_actual_arglist* argcopy;
2619 gcc_assert (g->specific);
2620 if (g->specific->error)
2623 target = g->specific->u.specific->n.sym;
2625 /* Check if this arglist matches the formal. */
2626 argcopy = gfc_copy_actual_arglist (args);
2627 matches = gfc_arglist_matches_symbol (&argcopy, target);
2628 gfc_free_actual_arglist (argcopy);
2630 /* Return if we found a match. */
2633 *tb_base = base->expr;
2644 /* For the 'actual arglist' of an operator call and a specific typebound
2645 procedure that has been found the target of a type-bound operator, build the
2646 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2647 type-bound procedures rather than resolving type-bound operators 'directly'
2648 so that we can reuse the existing logic. */
2651 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
2652 gfc_expr* base, gfc_typebound_proc* target)
2654 e->expr_type = EXPR_COMPCALL;
2655 e->value.compcall.tbp = target;
2656 e->value.compcall.name = "operator"; /* Should not matter. */
2657 e->value.compcall.actual = actual;
2658 e->value.compcall.base_object = base;
2659 e->value.compcall.ignore_pass = 1;
2660 e->value.compcall.assign = 0;
2664 /* This subroutine is called when an expression is being resolved.
2665 The expression node in question is either a user defined operator
2666 or an intrinsic operator with arguments that aren't compatible
2667 with the operator. This subroutine builds an actual argument list
2668 corresponding to the operands, then searches for a compatible
2669 interface. If one is found, the expression node is replaced with
2670 the appropriate function call.
2671 real_error is an additional output argument that specifies if FAILURE
2672 is because of some real error and not because no match was found. */
2675 gfc_extend_expr (gfc_expr *e, bool *real_error)
2677 gfc_actual_arglist *actual;
2685 actual = gfc_get_actual_arglist ();
2686 actual->expr = e->value.op.op1;
2688 *real_error = false;
2690 if (e->value.op.op2 != NULL)
2692 actual->next = gfc_get_actual_arglist ();
2693 actual->next->expr = e->value.op.op2;
2696 i = fold_unary_intrinsic (e->value.op.op);
2698 if (i == INTRINSIC_USER)
2700 for (ns = gfc_current_ns; ns; ns = ns->parent)
2702 uop = gfc_find_uop (e->value.op.uop->name, ns);
2706 sym = gfc_search_interface (uop->op, 0, &actual);
2713 for (ns = gfc_current_ns; ns; ns = ns->parent)
2715 /* Due to the distinction between '==' and '.eq.' and friends, one has
2716 to check if either is defined. */
2719 #define CHECK_OS_COMPARISON(comp) \
2720 case INTRINSIC_##comp: \
2721 case INTRINSIC_##comp##_OS: \
2722 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2724 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2726 CHECK_OS_COMPARISON(EQ)
2727 CHECK_OS_COMPARISON(NE)
2728 CHECK_OS_COMPARISON(GT)
2729 CHECK_OS_COMPARISON(GE)
2730 CHECK_OS_COMPARISON(LT)
2731 CHECK_OS_COMPARISON(LE)
2732 #undef CHECK_OS_COMPARISON
2735 sym = gfc_search_interface (ns->op[i], 0, &actual);
2743 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2744 found rather than just taking the first one and not checking further. */
2748 gfc_typebound_proc* tbo;
2751 /* See if we find a matching type-bound operator. */
2752 if (i == INTRINSIC_USER)
2753 tbo = matching_typebound_op (&tb_base, actual,
2754 i, e->value.op.uop->name);
2758 #define CHECK_OS_COMPARISON(comp) \
2759 case INTRINSIC_##comp: \
2760 case INTRINSIC_##comp##_OS: \
2761 tbo = matching_typebound_op (&tb_base, actual, \
2762 INTRINSIC_##comp, NULL); \
2764 tbo = matching_typebound_op (&tb_base, actual, \
2765 INTRINSIC_##comp##_OS, NULL); \
2767 CHECK_OS_COMPARISON(EQ)
2768 CHECK_OS_COMPARISON(NE)
2769 CHECK_OS_COMPARISON(GT)
2770 CHECK_OS_COMPARISON(GE)
2771 CHECK_OS_COMPARISON(LT)
2772 CHECK_OS_COMPARISON(LE)
2773 #undef CHECK_OS_COMPARISON
2776 tbo = matching_typebound_op (&tb_base, actual, i, NULL);
2780 /* If there is a matching typebound-operator, replace the expression with
2781 a call to it and succeed. */
2786 gcc_assert (tb_base);
2787 build_compcall_for_operator (e, actual, tb_base, tbo);
2789 result = gfc_resolve_expr (e);
2790 if (result == FAILURE)
2796 /* Don't use gfc_free_actual_arglist(). */
2797 if (actual->next != NULL)
2798 gfc_free (actual->next);
2804 /* Change the expression node to a function call. */
2805 e->expr_type = EXPR_FUNCTION;
2806 e->symtree = gfc_find_sym_in_symtree (sym);
2807 e->value.function.actual = actual;
2808 e->value.function.esym = NULL;
2809 e->value.function.isym = NULL;
2810 e->value.function.name = NULL;
2811 e->user_operator = 1;
2813 if (gfc_resolve_expr (e) == FAILURE)
2823 /* Tries to replace an assignment code node with a subroutine call to
2824 the subroutine associated with the assignment operator. Return
2825 SUCCESS if the node was replaced. On FAILURE, no error is
2829 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2831 gfc_actual_arglist *actual;
2832 gfc_expr *lhs, *rhs;
2838 /* Don't allow an intrinsic assignment to be replaced. */
2839 if (lhs->ts.type != BT_DERIVED
2840 && (rhs->rank == 0 || rhs->rank == lhs->rank)
2841 && (lhs->ts.type == rhs->ts.type
2842 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2845 actual = gfc_get_actual_arglist ();
2848 actual->next = gfc_get_actual_arglist ();
2849 actual->next->expr = rhs;
2853 for (; ns; ns = ns->parent)
2855 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
2860 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
2864 gfc_typebound_proc* tbo;
2867 /* See if we find a matching type-bound assignment. */
2868 tbo = matching_typebound_op (&tb_base, actual,
2869 INTRINSIC_ASSIGN, NULL);
2871 /* If there is one, replace the expression with a call to it and
2875 gcc_assert (tb_base);
2876 c->expr1 = gfc_get_expr ();
2877 build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
2878 c->expr1->value.compcall.assign = 1;
2880 c->op = EXEC_COMPCALL;
2882 /* c is resolved from the caller, so no need to do it here. */
2887 gfc_free (actual->next);
2892 /* Replace the assignment with the call. */
2893 c->op = EXEC_ASSIGN_CALL;
2894 c->symtree = gfc_find_sym_in_symtree (sym);
2897 c->ext.actual = actual;
2903 /* Make sure that the interface just parsed is not already present in
2904 the given interface list. Ambiguity isn't checked yet since module
2905 procedures can be present without interfaces. */
2908 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
2912 for (ip = base; ip; ip = ip->next)
2914 if (ip->sym == new_sym)
2916 gfc_error ("Entity '%s' at %C is already present in the interface",
2926 /* Add a symbol to the current interface. */
2929 gfc_add_interface (gfc_symbol *new_sym)
2931 gfc_interface **head, *intr;
2935 switch (current_interface.type)
2937 case INTERFACE_NAMELESS:
2938 case INTERFACE_ABSTRACT:
2941 case INTERFACE_INTRINSIC_OP:
2942 for (ns = current_interface.ns; ns; ns = ns->parent)
2943 switch (current_interface.op)
2946 case INTRINSIC_EQ_OS:
2947 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
2948 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
2953 case INTRINSIC_NE_OS:
2954 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
2955 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
2960 case INTRINSIC_GT_OS:
2961 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
2962 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
2967 case INTRINSIC_GE_OS:
2968 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
2969 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
2974 case INTRINSIC_LT_OS:
2975 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
2976 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
2981 case INTRINSIC_LE_OS:
2982 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
2983 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
2988 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
2992 head = ¤t_interface.ns->op[current_interface.op];
2995 case INTERFACE_GENERIC:
2996 for (ns = current_interface.ns; ns; ns = ns->parent)
2998 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3002 if (check_new_interface (sym->generic, new_sym) == FAILURE)
3006 head = ¤t_interface.sym->generic;
3009 case INTERFACE_USER_OP:
3010 if (check_new_interface (current_interface.uop->op, new_sym)
3014 head = ¤t_interface.uop->op;
3018 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3021 intr = gfc_get_interface ();
3022 intr->sym = new_sym;
3023 intr->where = gfc_current_locus;
3033 gfc_current_interface_head (void)
3035 switch (current_interface.type)
3037 case INTERFACE_INTRINSIC_OP:
3038 return current_interface.ns->op[current_interface.op];
3041 case INTERFACE_GENERIC:
3042 return current_interface.sym->generic;
3045 case INTERFACE_USER_OP:
3046 return current_interface.uop->op;
3056 gfc_set_current_interface_head (gfc_interface *i)
3058 switch (current_interface.type)
3060 case INTERFACE_INTRINSIC_OP:
3061 current_interface.ns->op[current_interface.op] = i;
3064 case INTERFACE_GENERIC:
3065 current_interface.sym->generic = i;
3068 case INTERFACE_USER_OP:
3069 current_interface.uop->op = i;
3078 /* Gets rid of a formal argument list. We do not free symbols.
3079 Symbols are freed when a namespace is freed. */
3082 gfc_free_formal_arglist (gfc_formal_arglist *p)
3084 gfc_formal_arglist *q;