1 /* Deal with interfaces.
2 Copyright (C) 2000-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Deal with interfaces. An explicit interface is represented as a
23 singly linked list of formal argument structures attached to the
24 relevant symbols. For an implicit interface, the arguments don't
25 point to symbols. Explicit interfaces point to namespaces that
26 contain the symbols within that interface.
28 Implicit interfaces are linked together in a singly linked list
29 along the next_if member of symbol nodes. Since a particular
30 symbol can only have a single explicit interface, the symbol cannot
31 be part of multiple lists and a single next-member suffices.
33 This is not the case for general classes, though. An operator
34 definition is independent of just about all other uses and has it's
38 Nameless interfaces create symbols with explicit interfaces within
39 the current namespace. They are otherwise unlinked.
42 The generic name points to a linked list of symbols. Each symbol
43 has an explicit interface. Each explicit interface has its own
44 namespace containing the arguments. Module procedures are symbols in
45 which the interface is added later when the module procedure is parsed.
48 User-defined operators are stored in a their own set of symtrees
49 separate from regular symbols. The symtrees point to gfc_user_op
50 structures which in turn head up a list of relevant interfaces.
52 Extended intrinsics and assignment:
53 The head of these interface lists are stored in the containing namespace.
56 An implicit interface is represented as a singly linked list of
57 formal argument list structures that don't point to any symbol
58 nodes -- they just contain types.
61 When a subprogram is defined, the program unit's name points to an
62 interface as usual, but the link to the namespace is NULL and the
63 formal argument list points to symbols within the same namespace as
64 the program unit name. */
68 #include "coretypes.h"
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface *intr)
88 for (; intr; intr = next)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op)
104 case INTRINSIC_UPLUS:
107 case INTRINSIC_UMINUS:
108 op = INTRINSIC_MINUS;
118 /* Return the operator depending on the DTIO moded string. Note that
119 these are not operators in the normal sense and so have been placed
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
122 static gfc_intrinsic_op
125 if (strncmp (mode, "formatted", 9) == 0)
126 return INTRINSIC_FORMATTED;
127 if (strncmp (mode, "unformatted", 9) == 0)
128 return INTRINSIC_UNFORMATTED;
129 return INTRINSIC_NONE;
133 /* Match a generic specification. Depending on which type of
134 interface is found, the 'name' or 'op' pointers may be set.
135 This subroutine doesn't return MATCH_NO. */
138 gfc_match_generic_spec (interface_type *type,
140 gfc_intrinsic_op *op)
142 char buffer[GFC_MAX_SYMBOL_LEN + 1];
146 if (gfc_match (" assignment ( = )") == MATCH_YES)
148 *type = INTERFACE_INTRINSIC_OP;
149 *op = INTRINSIC_ASSIGN;
153 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
155 *type = INTERFACE_INTRINSIC_OP;
156 *op = fold_unary_intrinsic (i);
160 *op = INTRINSIC_NONE;
161 if (gfc_match (" operator ( ") == MATCH_YES)
163 m = gfc_match_defined_op_name (buffer, 1);
169 m = gfc_match_char (')');
175 strcpy (name, buffer);
176 *type = INTERFACE_USER_OP;
180 if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
182 *op = dtio_op (buffer);
183 if (*op == INTRINSIC_FORMATTED)
185 strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
186 *type = INTERFACE_DTIO;
188 if (*op == INTRINSIC_UNFORMATTED)
190 strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
191 *type = INTERFACE_DTIO;
193 if (*op != INTRINSIC_NONE)
197 if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
199 *op = dtio_op (buffer);
200 if (*op == INTRINSIC_FORMATTED)
202 strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
203 *type = INTERFACE_DTIO;
205 if (*op == INTRINSIC_UNFORMATTED)
207 strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
208 *type = INTERFACE_DTIO;
210 if (*op != INTRINSIC_NONE)
214 if (gfc_match_name (buffer) == MATCH_YES)
216 strcpy (name, buffer);
217 *type = INTERFACE_GENERIC;
221 *type = INTERFACE_NAMELESS;
225 gfc_error ("Syntax error in generic specification at %C");
230 /* Match one of the five F95 forms of an interface statement. The
231 matcher for the abstract interface follows. */
234 gfc_match_interface (void)
236 char name[GFC_MAX_SYMBOL_LEN + 1];
242 m = gfc_match_space ();
244 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
247 /* If we're not looking at the end of the statement now, or if this
248 is not a nameless interface but we did not see a space, punt. */
249 if (gfc_match_eos () != MATCH_YES
250 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
252 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
257 current_interface.type = type;
262 case INTERFACE_GENERIC:
263 if (gfc_get_symbol (name, NULL, &sym))
266 if (!sym->attr.generic
267 && !gfc_add_generic (&sym->attr, sym->name, NULL))
272 gfc_error ("Dummy procedure %qs at %C cannot have a "
273 "generic interface", sym->name);
277 current_interface.sym = gfc_new_block = sym;
280 case INTERFACE_USER_OP:
281 current_interface.uop = gfc_get_uop (name);
284 case INTERFACE_INTRINSIC_OP:
285 current_interface.op = op;
288 case INTERFACE_NAMELESS:
289 case INTERFACE_ABSTRACT:
298 /* Match a F2003 abstract interface. */
301 gfc_match_abstract_interface (void)
305 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
308 m = gfc_match_eos ();
312 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
316 current_interface.type = INTERFACE_ABSTRACT;
322 /* Match the different sort of generic-specs that can be present after
323 the END INTERFACE itself. */
326 gfc_match_end_interface (void)
328 char name[GFC_MAX_SYMBOL_LEN + 1];
333 m = gfc_match_space ();
335 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
338 /* If we're not looking at the end of the statement now, or if this
339 is not a nameless interface but we did not see a space, punt. */
340 if (gfc_match_eos () != MATCH_YES
341 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
343 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
350 switch (current_interface.type)
352 case INTERFACE_NAMELESS:
353 case INTERFACE_ABSTRACT:
354 if (type != INTERFACE_NAMELESS)
356 gfc_error ("Expected a nameless interface at %C");
362 case INTERFACE_INTRINSIC_OP:
363 if (type != current_interface.type || op != current_interface.op)
366 if (current_interface.op == INTRINSIC_ASSIGN)
369 gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
374 s1 = gfc_op2string (current_interface.op);
375 s2 = gfc_op2string (op);
377 /* The following if-statements are used to enforce C1202
379 if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0)
380 || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0))
382 if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0)
383 || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0))
385 if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0)
386 || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0))
388 if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0)
389 || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0))
391 if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0)
392 || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0))
394 if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0)
395 || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0))
399 if (strcmp(s2, "none") == 0)
400 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
403 gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
404 "but got %s", s1, s2);
411 case INTERFACE_USER_OP:
412 /* Comparing the symbol node names is OK because only use-associated
413 symbols can be renamed. */
414 if (type != current_interface.type
415 || strcmp (current_interface.uop->name, name) != 0)
417 gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
418 current_interface.uop->name);
425 case INTERFACE_GENERIC:
426 if (type != current_interface.type
427 || strcmp (current_interface.sym->name, name) != 0)
429 gfc_error ("Expecting %<END INTERFACE %s%> at %C",
430 current_interface.sym->name);
441 /* Return whether the component was defined anonymously. */
444 is_anonymous_component (gfc_component *cmp)
446 /* Only UNION and MAP components are anonymous. In the case of a MAP,
447 the derived type symbol is FL_STRUCT and the component name looks like mM*.
448 This is the only case in which the second character of a component name is
450 return cmp->ts.type == BT_UNION
451 || (cmp->ts.type == BT_DERIVED
452 && cmp->ts.u.derived->attr.flavor == FL_STRUCT
453 && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1]));
457 /* Return whether the derived type was defined anonymously. */
460 is_anonymous_dt (gfc_symbol *derived)
462 /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
463 types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
464 and the type name looks like XX*. This is the only case in which the
465 second character of a type name is uppercase. */
466 return derived->attr.flavor == FL_UNION
467 || (derived->attr.flavor == FL_STRUCT
468 && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1]));
472 /* Compare components according to 4.4.2 of the Fortran standard. */
475 compare_components (gfc_component *cmp1, gfc_component *cmp2,
476 gfc_symbol *derived1, gfc_symbol *derived2)
478 /* Compare names, but not for anonymous components such as UNION or MAP. */
479 if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
480 && strcmp (cmp1->name, cmp2->name) != 0)
483 if (cmp1->attr.access != cmp2->attr.access)
486 if (cmp1->attr.pointer != cmp2->attr.pointer)
489 if (cmp1->attr.dimension != cmp2->attr.dimension)
492 if (cmp1->attr.allocatable != cmp2->attr.allocatable)
495 if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
498 /* Make sure that link lists do not put this function into an
499 endless recursive loop! */
500 if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
501 && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)
502 && gfc_compare_types (&cmp1->ts, &cmp2->ts) == 0)
505 else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
506 && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
509 else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
510 && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
517 /* Compare two union types by comparing the components of their maps.
518 Because unions and maps are anonymous their types get special internal
519 names; therefore the usual derived type comparison will fail on them.
521 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
522 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
523 definitions' than 'equivalent structure'. */
526 gfc_compare_union_types (gfc_symbol *un1, gfc_symbol *un2)
528 gfc_component *map1, *map2, *cmp1, *cmp2;
529 gfc_symbol *map1_t, *map2_t;
531 if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION)
534 map1 = un1->components;
535 map2 = un2->components;
537 /* In terms of 'equality' here we are worried about types which are
538 declared the same in two places, not types that represent equivalent
539 structures. (This is common because of FORTRAN's weird scoping rules.)
540 Though two unions with their maps in different orders could be equivalent,
541 we will say they are not equal for the purposes of this test; therefore
542 we compare the maps sequentially. */
545 map1_t = map1->ts.u.derived;
546 map2_t = map2->ts.u.derived;
548 cmp1 = map1_t->components;
549 cmp2 = map2_t->components;
551 /* Protect against null components. */
552 if (map1_t->attr.zero_comp != map2_t->attr.zero_comp)
555 if (map1_t->attr.zero_comp)
560 /* No two fields will ever point to the same map type unless they are
561 the same component, because one map field is created with its type
562 declaration. Therefore don't worry about recursion here. */
563 /* TODO: worry about recursion into parent types of the unions? */
564 if (compare_components (cmp1, cmp2, map1_t, map2_t) == 0)
570 if (cmp1 == NULL && cmp2 == NULL)
572 if (cmp1 == NULL || cmp2 == NULL)
579 if (map1 == NULL && map2 == NULL)
581 if (map1 == NULL || map2 == NULL)
590 /* Compare two derived types using the criteria in 4.4.2 of the standard,
591 recursing through gfc_compare_types for the components. */
594 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
596 gfc_component *cmp1, *cmp2;
598 if (derived1 == derived2)
601 gcc_assert (derived1 && derived2);
603 /* Compare UNION types specially. */
604 if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION)
605 return gfc_compare_union_types (derived1, derived2);
607 /* Special case for comparing derived types across namespaces. If the
608 true names and module names are the same and the module name is
609 nonnull, then they are equal. */
610 if (strcmp (derived1->name, derived2->name) == 0
611 && derived1->module != NULL && derived2->module != NULL
612 && strcmp (derived1->module, derived2->module) == 0)
615 /* Compare type via the rules of the standard. Both types must have
616 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
617 because they can be anonymous; therefore two structures with different
618 names may be equal. */
620 /* Compare names, but not for anonymous types such as UNION or MAP. */
621 if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
622 && strcmp (derived1->name, derived2->name) != 0)
625 if (derived1->component_access == ACCESS_PRIVATE
626 || derived2->component_access == ACCESS_PRIVATE)
629 if (!(derived1->attr.sequence && derived2->attr.sequence)
630 && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
633 /* Protect against null components. */
634 if (derived1->attr.zero_comp != derived2->attr.zero_comp)
637 if (derived1->attr.zero_comp)
640 cmp1 = derived1->components;
641 cmp2 = derived2->components;
643 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
644 simple test can speed things up. Otherwise, lots of things have to
648 if (!compare_components (cmp1, cmp2, derived1, derived2))
654 if (cmp1 == NULL && cmp2 == NULL)
656 if (cmp1 == NULL || cmp2 == NULL)
664 /* Compare two typespecs, recursively if necessary. */
667 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
669 /* See if one of the typespecs is a BT_VOID, which is what is being used
670 to allow the funcs like c_f_pointer to accept any pointer type.
671 TODO: Possibly should narrow this to just the one typespec coming in
672 that is for the formal arg, but oh well. */
673 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
676 /* The _data component is not always present, therefore check for its
677 presence before assuming, that its derived->attr is available.
678 When the _data component is not present, then nevertheless the
679 unlimited_polymorphic flag may be set in the derived type's attr. */
680 if (ts1->type == BT_CLASS && ts1->u.derived->components
681 && ((ts1->u.derived->attr.is_class
682 && ts1->u.derived->components->ts.u.derived->attr
683 .unlimited_polymorphic)
684 || ts1->u.derived->attr.unlimited_polymorphic))
688 if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
689 && ts2->u.derived->components
690 && ((ts2->u.derived->attr.is_class
691 && ts2->u.derived->components->ts.u.derived->attr
692 .unlimited_polymorphic)
693 || ts2->u.derived->attr.unlimited_polymorphic)
694 && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
697 if (ts1->type == BT_UNION && ts2->type == BT_UNION)
698 return gfc_compare_union_types (ts1->u.derived, ts2->u.derived);
700 if (ts1->type != ts2->type
701 && ((!gfc_bt_struct (ts1->type) && ts1->type != BT_CLASS)
702 || (!gfc_bt_struct (ts2->type) && ts2->type != BT_CLASS)))
704 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
705 return (ts1->kind == ts2->kind);
707 /* Compare derived types. */
708 return gfc_type_compatible (ts1, ts2);
713 compare_type (gfc_symbol *s1, gfc_symbol *s2)
715 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
718 /* TYPE and CLASS of the same declared type are type compatible,
719 but have different characteristics. */
720 if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
721 || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
724 return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
729 compare_rank (gfc_symbol *s1, gfc_symbol *s2)
731 gfc_array_spec *as1, *as2;
734 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
737 as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
738 as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
740 r1 = as1 ? as1->rank : 0;
741 r2 = as2 ? as2->rank : 0;
743 if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
744 return 0; /* Ranks differ. */
750 /* Given two symbols that are formal arguments, compare their ranks
751 and types. Returns nonzero if they have the same rank and type,
755 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
757 return compare_type (s1, s2) && compare_rank (s1, s2);
761 /* Given two symbols that are formal arguments, compare their types
762 and rank and their formal interfaces if they are both dummy
763 procedures. Returns nonzero if the same, zero if different. */
766 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
768 if (s1 == NULL || s2 == NULL)
769 return s1 == s2 ? 1 : 0;
774 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
775 return compare_type_rank (s1, s2);
777 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
780 /* At this point, both symbols are procedures. It can happen that
781 external procedures are compared, where one is identified by usage
782 to be a function or subroutine but the other is not. Check TKR
783 nonetheless for these cases. */
784 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
785 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
787 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
788 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
790 /* Now the type of procedure has been identified. */
791 if (s1->attr.function != s2->attr.function
792 || s1->attr.subroutine != s2->attr.subroutine)
795 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
798 /* Originally, gfortran recursed here to check the interfaces of passed
799 procedures. This is explicitly not required by the standard. */
804 /* Given a formal argument list and a keyword name, search the list
805 for that keyword. Returns the correct symbol node if found, NULL
809 find_keyword_arg (const char *name, gfc_formal_arglist *f)
811 for (; f; f = f->next)
812 if (strcmp (f->sym->name, name) == 0)
819 /******** Interface checking subroutines **********/
822 /* Given an operator interface and the operator, make sure that all
823 interfaces for that operator are legal. */
826 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
829 gfc_formal_arglist *formal;
832 int args, r1, r2, k1, k2;
837 t1 = t2 = BT_UNKNOWN;
838 i1 = i2 = INTENT_UNKNOWN;
842 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
844 gfc_symbol *fsym = formal->sym;
847 gfc_error ("Alternate return cannot appear in operator "
848 "interface at %L", &sym->declared_at);
854 i1 = fsym->attr.intent;
855 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
861 i2 = fsym->attr.intent;
862 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
868 /* Only +, - and .not. can be unary operators.
869 .not. cannot be a binary operator. */
870 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
871 && op != INTRINSIC_MINUS
872 && op != INTRINSIC_NOT)
873 || (args == 2 && op == INTRINSIC_NOT))
875 if (op == INTRINSIC_ASSIGN)
876 gfc_error ("Assignment operator interface at %L must have "
877 "two arguments", &sym->declared_at);
879 gfc_error ("Operator interface at %L has the wrong number of arguments",
884 /* Check that intrinsics are mapped to functions, except
885 INTRINSIC_ASSIGN which should map to a subroutine. */
886 if (op == INTRINSIC_ASSIGN)
888 gfc_formal_arglist *dummy_args;
890 if (!sym->attr.subroutine)
892 gfc_error ("Assignment operator interface at %L must be "
893 "a SUBROUTINE", &sym->declared_at);
897 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
898 - First argument an array with different rank than second,
899 - First argument is a scalar and second an array,
900 - Types and kinds do not conform, or
901 - First argument is of derived type. */
902 dummy_args = gfc_sym_get_dummy_args (sym);
903 if (dummy_args->sym->ts.type != BT_DERIVED
904 && dummy_args->sym->ts.type != BT_CLASS
905 && (r2 == 0 || r1 == r2)
906 && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type
907 || (gfc_numeric_ts (&dummy_args->sym->ts)
908 && gfc_numeric_ts (&dummy_args->next->sym->ts))))
910 gfc_error ("Assignment operator interface at %L must not redefine "
911 "an INTRINSIC type assignment", &sym->declared_at);
917 if (!sym->attr.function)
919 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
925 /* Check intents on operator interfaces. */
926 if (op == INTRINSIC_ASSIGN)
928 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
930 gfc_error ("First argument of defined assignment at %L must be "
931 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
937 gfc_error ("Second argument of defined assignment at %L must be "
938 "INTENT(IN)", &sym->declared_at);
946 gfc_error ("First argument of operator interface at %L must be "
947 "INTENT(IN)", &sym->declared_at);
951 if (args == 2 && i2 != INTENT_IN)
953 gfc_error ("Second argument of operator interface at %L must be "
954 "INTENT(IN)", &sym->declared_at);
959 /* From now on, all we have to do is check that the operator definition
960 doesn't conflict with an intrinsic operator. The rules for this
961 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
962 as well as 12.3.2.1.1 of Fortran 2003:
964 "If the operator is an intrinsic-operator (R310), the number of
965 function arguments shall be consistent with the intrinsic uses of
966 that operator, and the types, kind type parameters, or ranks of the
967 dummy arguments shall differ from those required for the intrinsic
968 operation (7.1.2)." */
970 #define IS_NUMERIC_TYPE(t) \
971 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
973 /* Unary ops are easy, do them first. */
974 if (op == INTRINSIC_NOT)
976 if (t1 == BT_LOGICAL)
982 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
984 if (IS_NUMERIC_TYPE (t1))
990 /* Character intrinsic operators have same character kind, thus
991 operator definitions with operands of different character kinds
993 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
996 /* Intrinsic operators always perform on arguments of same rank,
997 so different ranks is also always safe. (rank == 0) is an exception
998 to that, because all intrinsic operators are elemental. */
999 if (r1 != r2 && r1 != 0 && r2 != 0)
1005 case INTRINSIC_EQ_OS:
1007 case INTRINSIC_NE_OS:
1008 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
1012 case INTRINSIC_PLUS:
1013 case INTRINSIC_MINUS:
1014 case INTRINSIC_TIMES:
1015 case INTRINSIC_DIVIDE:
1016 case INTRINSIC_POWER:
1017 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
1022 case INTRINSIC_GT_OS:
1024 case INTRINSIC_GE_OS:
1026 case INTRINSIC_LT_OS:
1028 case INTRINSIC_LE_OS:
1029 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
1031 if ((t1 == BT_INTEGER || t1 == BT_REAL)
1032 && (t2 == BT_INTEGER || t2 == BT_REAL))
1036 case INTRINSIC_CONCAT:
1037 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
1044 case INTRINSIC_NEQV:
1045 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
1055 #undef IS_NUMERIC_TYPE
1058 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1064 /* Given a pair of formal argument lists, we see if the two lists can
1065 be distinguished by counting the number of nonoptional arguments of
1066 a given type/rank in f1 and seeing if there are less then that
1067 number of those arguments in f2 (including optional arguments).
1068 Since this test is asymmetric, it has to be called twice to make it
1069 symmetric. Returns nonzero if the argument lists are incompatible
1070 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1071 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1074 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
1075 const char *p1, const char *p2)
1077 int rc, ac1, ac2, i, j, k, n1;
1078 gfc_formal_arglist *f;
1091 for (f = f1; f; f = f->next)
1094 /* Build an array of integers that gives the same integer to
1095 arguments of the same type/rank. */
1096 arg = XCNEWVEC (arginfo, n1);
1099 for (i = 0; i < n1; i++, f = f->next)
1102 arg[i].sym = f->sym;
1107 for (i = 0; i < n1; i++)
1109 if (arg[i].flag != -1)
1112 if (arg[i].sym && (arg[i].sym->attr.optional
1113 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
1114 continue; /* Skip OPTIONAL and PASS arguments. */
1118 /* Find other non-optional, non-pass arguments of the same type/rank. */
1119 for (j = i + 1; j < n1; j++)
1120 if ((arg[j].sym == NULL
1121 || !(arg[j].sym->attr.optional
1122 || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
1123 && (compare_type_rank_if (arg[i].sym, arg[j].sym)
1124 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
1130 /* Now loop over each distinct type found in f1. */
1134 for (i = 0; i < n1; i++)
1136 if (arg[i].flag != k)
1140 for (j = i + 1; j < n1; j++)
1141 if (arg[j].flag == k)
1144 /* Count the number of non-pass arguments in f2 with that type,
1145 including those that are optional. */
1148 for (f = f2; f; f = f->next)
1149 if ((!p2 || strcmp (f->sym->name, p2) != 0)
1150 && (compare_type_rank_if (arg[i].sym, f->sym)
1151 || compare_type_rank_if (f->sym, arg[i].sym)))
1169 /* Perform the correspondence test in rule (3) of F08:C1215.
1170 Returns zero if no argument is found that satisfies this rule,
1171 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1174 This test is also not symmetric in f1 and f2 and must be called
1175 twice. This test finds problems caused by sorting the actual
1176 argument list with keywords. For example:
1180 INTEGER :: A ; REAL :: B
1184 INTEGER :: A ; REAL :: B
1188 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1191 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
1192 const char *p1, const char *p2)
1194 gfc_formal_arglist *f2_save, *g;
1201 if (f1->sym->attr.optional)
1204 if (p1 && strcmp (f1->sym->name, p1) == 0)
1206 if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
1209 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
1210 || compare_type_rank (f2->sym, f1->sym))
1211 && !((gfc_option.allow_std & GFC_STD_F2008)
1212 && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
1213 || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
1216 /* Now search for a disambiguating keyword argument starting at
1217 the current non-match. */
1218 for (g = f1; g; g = g->next)
1220 if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
1223 sym = find_keyword_arg (g->sym->name, f2_save);
1224 if (sym == NULL || !compare_type_rank (g->sym, sym)
1225 || ((gfc_option.allow_std & GFC_STD_F2008)
1226 && ((sym->attr.allocatable && g->sym->attr.pointer)
1227 || (sym->attr.pointer && g->sym->attr.allocatable))))
1243 symbol_rank (gfc_symbol *sym)
1246 as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as;
1247 return as ? as->rank : 0;
1251 /* Check if the characteristics of two dummy arguments match,
1255 gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1256 bool type_must_agree, char *errmsg,
1259 if (s1 == NULL || s2 == NULL)
1260 return s1 == s2 ? true : false;
1262 /* Check type and rank. */
1263 if (type_must_agree)
1265 if (!compare_type (s1, s2) || !compare_type (s2, s1))
1267 snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
1268 s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
1271 if (!compare_rank (s1, s2))
1273 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
1274 s1->name, symbol_rank (s1), symbol_rank (s2));
1280 if (s1->attr.intent != s2->attr.intent)
1282 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1287 /* Check OPTIONAL attribute. */
1288 if (s1->attr.optional != s2->attr.optional)
1290 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1295 /* Check ALLOCATABLE attribute. */
1296 if (s1->attr.allocatable != s2->attr.allocatable)
1298 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1303 /* Check POINTER attribute. */
1304 if (s1->attr.pointer != s2->attr.pointer)
1306 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1311 /* Check TARGET attribute. */
1312 if (s1->attr.target != s2->attr.target)
1314 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1319 /* Check ASYNCHRONOUS attribute. */
1320 if (s1->attr.asynchronous != s2->attr.asynchronous)
1322 snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
1327 /* Check CONTIGUOUS attribute. */
1328 if (s1->attr.contiguous != s2->attr.contiguous)
1330 snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
1335 /* Check VALUE attribute. */
1336 if (s1->attr.value != s2->attr.value)
1338 snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
1343 /* Check VOLATILE attribute. */
1344 if (s1->attr.volatile_ != s2->attr.volatile_)
1346 snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
1351 /* Check interface of dummy procedures. */
1352 if (s1->attr.flavor == FL_PROCEDURE)
1355 if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
1358 snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
1359 "'%s': %s", s1->name, err);
1364 /* Check string length. */
1365 if (s1->ts.type == BT_CHARACTER
1366 && s1->ts.u.cl && s1->ts.u.cl->length
1367 && s2->ts.u.cl && s2->ts.u.cl->length)
1369 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1370 s2->ts.u.cl->length);
1376 snprintf (errmsg, err_len, "Character length mismatch "
1377 "in argument '%s'", s1->name);
1381 /* FIXME: Implement a warning for this case.
1382 gfc_warning (0, "Possible character length mismatch in argument %qs",
1390 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1391 "%i of gfc_dep_compare_expr", compval);
1396 /* Check array shape. */
1397 if (s1->as && s2->as)
1400 gfc_expr *shape1, *shape2;
1402 if (s1->as->type != s2->as->type)
1404 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1409 if (s1->as->corank != s2->as->corank)
1411 snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
1412 s1->name, s1->as->corank, s2->as->corank);
1416 if (s1->as->type == AS_EXPLICIT)
1417 for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++)
1419 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1420 gfc_copy_expr (s1->as->lower[i]));
1421 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1422 gfc_copy_expr (s2->as->lower[i]));
1423 compval = gfc_dep_compare_expr (shape1, shape2);
1424 gfc_free_expr (shape1);
1425 gfc_free_expr (shape2);
1431 if (i < s1->as->rank)
1432 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
1433 " argument '%s'", i + 1, s1->name);
1435 snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
1436 "of argument '%s'", i - s1->as->rank + 1, s1->name);
1440 /* FIXME: Implement a warning for this case.
1441 gfc_warning (0, "Possible shape mismatch in argument %qs",
1449 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1450 "result %i of gfc_dep_compare_expr",
1461 /* Check if the characteristics of two function results match,
1465 gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1466 char *errmsg, int err_len)
1468 gfc_symbol *r1, *r2;
1470 if (s1->ts.interface && s1->ts.interface->result)
1471 r1 = s1->ts.interface->result;
1473 r1 = s1->result ? s1->result : s1;
1475 if (s2->ts.interface && s2->ts.interface->result)
1476 r2 = s2->ts.interface->result;
1478 r2 = s2->result ? s2->result : s2;
1480 if (r1->ts.type == BT_UNKNOWN)
1483 /* Check type and rank. */
1484 if (!compare_type (r1, r2))
1486 snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
1487 gfc_typename (&r1->ts), gfc_typename (&r2->ts));
1490 if (!compare_rank (r1, r2))
1492 snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
1493 symbol_rank (r1), symbol_rank (r2));
1497 /* Check ALLOCATABLE attribute. */
1498 if (r1->attr.allocatable != r2->attr.allocatable)
1500 snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1505 /* Check POINTER attribute. */
1506 if (r1->attr.pointer != r2->attr.pointer)
1508 snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1513 /* Check CONTIGUOUS attribute. */
1514 if (r1->attr.contiguous != r2->attr.contiguous)
1516 snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1521 /* Check PROCEDURE POINTER attribute. */
1522 if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1524 snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1529 /* Check string length. */
1530 if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1532 if (r1->ts.deferred != r2->ts.deferred)
1534 snprintf (errmsg, err_len, "Character length mismatch "
1535 "in function result");
1539 if (r1->ts.u.cl->length && r2->ts.u.cl->length)
1541 int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1542 r2->ts.u.cl->length);
1548 snprintf (errmsg, err_len, "Character length mismatch "
1549 "in function result");
1553 /* FIXME: Implement a warning for this case.
1554 snprintf (errmsg, err_len, "Possible character length mismatch "
1555 "in function result");*/
1562 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1563 "result %i of gfc_dep_compare_expr", compval);
1569 /* Check array shape. */
1570 if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1573 gfc_expr *shape1, *shape2;
1575 if (r1->as->type != r2->as->type)
1577 snprintf (errmsg, err_len, "Shape mismatch in function result");
1581 if (r1->as->type == AS_EXPLICIT)
1582 for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1584 shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1585 gfc_copy_expr (r1->as->lower[i]));
1586 shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1587 gfc_copy_expr (r2->as->lower[i]));
1588 compval = gfc_dep_compare_expr (shape1, shape2);
1589 gfc_free_expr (shape1);
1590 gfc_free_expr (shape2);
1596 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1597 "function result", i + 1);
1601 /* FIXME: Implement a warning for this case.
1602 gfc_warning (0, "Possible shape mismatch in return value");*/
1609 gfc_internal_error ("check_result_characteristics (2): "
1610 "Unexpected result %i of "
1611 "gfc_dep_compare_expr", compval);
1621 /* 'Compare' two formal interfaces associated with a pair of symbols.
1622 We return nonzero if there exists an actual argument list that
1623 would be ambiguous between the two interfaces, zero otherwise.
1624 'strict_flag' specifies whether all the characteristics are
1625 required to match, which is not the case for ambiguity checks.
1626 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1629 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1630 int generic_flag, int strict_flag,
1631 char *errmsg, int err_len,
1632 const char *p1, const char *p2)
1634 gfc_formal_arglist *f1, *f2;
1636 gcc_assert (name2 != NULL);
1638 if (s1->attr.function && (s2->attr.subroutine
1639 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1640 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1643 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1647 if (s1->attr.subroutine && s2->attr.function)
1650 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1654 /* Do strict checks on all characteristics
1655 (for dummy procedures and procedure pointer assignments). */
1656 if (!generic_flag && strict_flag)
1658 if (s1->attr.function && s2->attr.function)
1660 /* If both are functions, check result characteristics. */
1661 if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
1662 || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
1666 if (s1->attr.pure && !s2->attr.pure)
1668 snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1671 if (s1->attr.elemental && !s2->attr.elemental)
1673 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1678 if (s1->attr.if_source == IFSRC_UNKNOWN
1679 || s2->attr.if_source == IFSRC_UNKNOWN)
1682 f1 = gfc_sym_get_dummy_args (s1);
1683 f2 = gfc_sym_get_dummy_args (s2);
1685 if (f1 == NULL && f2 == NULL)
1686 return 1; /* Special case: No arguments. */
1690 if (count_types_test (f1, f2, p1, p2)
1691 || count_types_test (f2, f1, p2, p1))
1693 if (generic_correspondence (f1, f2, p1, p2)
1694 || generic_correspondence (f2, f1, p2, p1))
1698 /* Perform the abbreviated correspondence test for operators (the
1699 arguments cannot be optional and are always ordered correctly).
1700 This is also done when comparing interfaces for dummy procedures and in
1701 procedure pointer assignments. */
1705 /* Check existence. */
1706 if (f1 == NULL && f2 == NULL)
1708 if (f1 == NULL || f2 == NULL)
1711 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1712 "arguments", name2);
1716 if (UNLIMITED_POLY (f1->sym))
1721 /* Check all characteristics. */
1722 if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
1728 /* Only check type and rank. */
1729 if (!compare_type (f2->sym, f1->sym))
1732 snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
1733 "(%s/%s)", f1->sym->name,
1734 gfc_typename (&f1->sym->ts),
1735 gfc_typename (&f2->sym->ts));
1738 if (!compare_rank (f2->sym, f1->sym))
1741 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
1742 "(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
1743 symbol_rank (f2->sym));
1756 /* Given a pointer to an interface pointer, remove duplicate
1757 interfaces and make sure that all symbols are either functions
1758 or subroutines, and all of the same kind. Returns nonzero if
1759 something goes wrong. */
1762 check_interface0 (gfc_interface *p, const char *interface_name)
1764 gfc_interface *psave, *q, *qlast;
1767 for (; p; p = p->next)
1769 /* Make sure all symbols in the interface have been defined as
1770 functions or subroutines. */
1771 if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1772 || !p->sym->attr.if_source)
1773 && !gfc_fl_struct (p->sym->attr.flavor))
1775 if (p->sym->attr.external)
1776 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1777 p->sym->name, interface_name, &p->sym->declared_at);
1779 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1780 "subroutine", p->sym->name, interface_name,
1781 &p->sym->declared_at);
1785 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1786 if ((psave->sym->attr.function && !p->sym->attr.function
1787 && !gfc_fl_struct (p->sym->attr.flavor))
1788 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1790 if (!gfc_fl_struct (p->sym->attr.flavor))
1791 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1792 " or all FUNCTIONs", interface_name,
1793 &p->sym->declared_at);
1794 else if (p->sym->attr.flavor == FL_DERIVED)
1795 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1796 "generic name is also the name of a derived type",
1797 interface_name, &p->sym->declared_at);
1801 /* F2003, C1207. F2008, C1207. */
1802 if (p->sym->attr.proc == PROC_INTERNAL
1803 && !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1804 "%qs in %s at %L", p->sym->name,
1805 interface_name, &p->sym->declared_at))
1810 /* Remove duplicate interfaces in this interface list. */
1811 for (; p; p = p->next)
1815 for (q = p->next; q;)
1817 if (p->sym != q->sym)
1824 /* Duplicate interface. */
1825 qlast->next = q->next;
1836 /* Check lists of interfaces to make sure that no two interfaces are
1837 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1840 check_interface1 (gfc_interface *p, gfc_interface *q0,
1841 int generic_flag, const char *interface_name,
1845 for (; p; p = p->next)
1846 for (q = q0; q; q = q->next)
1848 if (p->sym == q->sym)
1849 continue; /* Duplicates OK here. */
1851 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1854 if (!gfc_fl_struct (p->sym->attr.flavor)
1855 && !gfc_fl_struct (q->sym->attr.flavor)
1856 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1857 generic_flag, 0, NULL, 0, NULL, NULL))
1860 gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
1861 p->sym->name, q->sym->name, interface_name,
1863 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1864 gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L",
1865 p->sym->name, q->sym->name, interface_name,
1868 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1869 "interfaces at %L", interface_name, &p->where);
1877 /* Check the generic and operator interfaces of symbols to make sure
1878 that none of the interfaces conflict. The check has to be done
1879 after all of the symbols are actually loaded. */
1882 check_sym_interfaces (gfc_symbol *sym)
1884 char interface_name[100];
1887 if (sym->ns != gfc_current_ns)
1890 if (sym->generic != NULL)
1892 sprintf (interface_name, "generic interface '%s'", sym->name);
1893 if (check_interface0 (sym->generic, interface_name))
1896 for (p = sym->generic; p; p = p->next)
1898 if (p->sym->attr.mod_proc
1899 && !p->sym->attr.module_procedure
1900 && (p->sym->attr.if_source != IFSRC_DECL
1901 || p->sym->attr.procedure))
1903 gfc_error ("%qs at %L is not a module procedure",
1904 p->sym->name, &p->where);
1909 /* Originally, this test was applied to host interfaces too;
1910 this is incorrect since host associated symbols, from any
1911 source, cannot be ambiguous with local symbols. */
1912 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1913 sym->attr.referenced || !sym->attr.use_assoc);
1919 check_uop_interfaces (gfc_user_op *uop)
1921 char interface_name[100];
1925 sprintf (interface_name, "operator interface '%s'", uop->name);
1926 if (check_interface0 (uop->op, interface_name))
1929 for (ns = gfc_current_ns; ns; ns = ns->parent)
1931 uop2 = gfc_find_uop (uop->name, ns);
1935 check_interface1 (uop->op, uop2->op, 0,
1936 interface_name, true);
1940 /* Given an intrinsic op, return an equivalent op if one exists,
1941 or INTRINSIC_NONE otherwise. */
1944 gfc_equivalent_op (gfc_intrinsic_op op)
1949 return INTRINSIC_EQ_OS;
1951 case INTRINSIC_EQ_OS:
1952 return INTRINSIC_EQ;
1955 return INTRINSIC_NE_OS;
1957 case INTRINSIC_NE_OS:
1958 return INTRINSIC_NE;
1961 return INTRINSIC_GT_OS;
1963 case INTRINSIC_GT_OS:
1964 return INTRINSIC_GT;
1967 return INTRINSIC_GE_OS;
1969 case INTRINSIC_GE_OS:
1970 return INTRINSIC_GE;
1973 return INTRINSIC_LT_OS;
1975 case INTRINSIC_LT_OS:
1976 return INTRINSIC_LT;
1979 return INTRINSIC_LE_OS;
1981 case INTRINSIC_LE_OS:
1982 return INTRINSIC_LE;
1985 return INTRINSIC_NONE;
1989 /* For the namespace, check generic, user operator and intrinsic
1990 operator interfaces for consistency and to remove duplicate
1991 interfaces. We traverse the whole namespace, counting on the fact
1992 that most symbols will not have generic or operator interfaces. */
1995 gfc_check_interfaces (gfc_namespace *ns)
1997 gfc_namespace *old_ns, *ns2;
1998 char interface_name[100];
2001 old_ns = gfc_current_ns;
2002 gfc_current_ns = ns;
2004 gfc_traverse_ns (ns, check_sym_interfaces);
2006 gfc_traverse_user_op (ns, check_uop_interfaces);
2008 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2010 if (i == INTRINSIC_USER)
2013 if (i == INTRINSIC_ASSIGN)
2014 strcpy (interface_name, "intrinsic assignment operator");
2016 sprintf (interface_name, "intrinsic '%s' operator",
2017 gfc_op2string ((gfc_intrinsic_op) i));
2019 if (check_interface0 (ns->op[i], interface_name))
2023 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
2026 for (ns2 = ns; ns2; ns2 = ns2->parent)
2028 gfc_intrinsic_op other_op;
2030 if (check_interface1 (ns->op[i], ns2->op[i], 0,
2031 interface_name, true))
2034 /* i should be gfc_intrinsic_op, but has to be int with this cast
2035 here for stupid C++ compatibility rules. */
2036 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
2037 if (other_op != INTRINSIC_NONE
2038 && check_interface1 (ns->op[i], ns2->op[other_op],
2039 0, interface_name, true))
2045 gfc_current_ns = old_ns;
2049 /* Given a symbol of a formal argument list and an expression, if the
2050 formal argument is allocatable, check that the actual argument is
2051 allocatable. Returns nonzero if compatible, zero if not compatible. */
2054 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
2056 symbol_attribute attr;
2058 if (formal->attr.allocatable
2059 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
2061 attr = gfc_expr_attr (actual);
2062 if (!attr.allocatable)
2070 /* Given a symbol of a formal argument list and an expression, if the
2071 formal argument is a pointer, see if the actual argument is a
2072 pointer. Returns nonzero if compatible, zero if not compatible. */
2075 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
2077 symbol_attribute attr;
2079 if (formal->attr.pointer
2080 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
2081 && CLASS_DATA (formal)->attr.class_pointer))
2083 attr = gfc_expr_attr (actual);
2085 /* Fortran 2008 allows non-pointer actual arguments. */
2086 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
2097 /* Emit clear error messages for rank mismatch. */
2100 argument_rank_mismatch (const char *name, locus *where,
2101 int rank1, int rank2)
2104 /* TS 29113, C407b. */
2107 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
2108 " %qs has assumed-rank", where, name);
2110 else if (rank1 == 0)
2112 gfc_error ("Rank mismatch in argument %qs at %L "
2113 "(scalar and rank-%d)", name, where, rank2);
2115 else if (rank2 == 0)
2117 gfc_error ("Rank mismatch in argument %qs at %L "
2118 "(rank-%d and scalar)", name, where, rank1);
2122 gfc_error ("Rank mismatch in argument %qs at %L "
2123 "(rank-%d and rank-%d)", name, where, rank1, rank2);
2128 /* Given a symbol of a formal argument list and an expression, see if
2129 the two are compatible as arguments. Returns nonzero if
2130 compatible, zero if not compatible. */
2133 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
2134 int ranks_must_agree, int is_elemental, locus *where)
2137 bool rank_check, is_pointer;
2141 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2142 procs c_f_pointer or c_f_procpointer, and we need to accept most
2143 pointers the user could give us. This should allow that. */
2144 if (formal->ts.type == BT_VOID)
2147 if (formal->ts.type == BT_DERIVED
2148 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
2149 && actual->ts.type == BT_DERIVED
2150 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
2153 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
2154 /* Make sure the vtab symbol is present when
2155 the module variables are generated. */
2156 gfc_find_derived_vtab (actual->ts.u.derived);
2158 if (actual->ts.type == BT_PROCEDURE)
2160 gfc_symbol *act_sym = actual->symtree->n.sym;
2162 if (formal->attr.flavor != FL_PROCEDURE)
2165 gfc_error ("Invalid procedure argument at %L", &actual->where);
2169 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
2170 sizeof(err), NULL, NULL))
2173 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2174 formal->name, &actual->where, err);
2178 if (formal->attr.function && !act_sym->attr.function)
2180 gfc_add_function (&act_sym->attr, act_sym->name,
2181 &act_sym->declared_at);
2182 if (act_sym->ts.type == BT_UNKNOWN
2183 && !gfc_set_default_type (act_sym, 1, act_sym->ns))
2186 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
2187 gfc_add_subroutine (&act_sym->attr, act_sym->name,
2188 &act_sym->declared_at);
2193 ppc = gfc_get_proc_ptr_comp (actual);
2194 if (ppc && ppc->ts.interface)
2196 if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
2197 err, sizeof(err), NULL, NULL))
2200 gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
2201 formal->name, &actual->where, err);
2207 if (formal->attr.pointer && formal->attr.contiguous
2208 && !gfc_is_simply_contiguous (actual, true, false))
2211 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2212 "must be simply contiguous", formal->name, &actual->where);
2216 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
2217 && actual->ts.type != BT_HOLLERITH
2218 && formal->ts.type != BT_ASSUMED
2219 && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2220 && !gfc_compare_types (&formal->ts, &actual->ts)
2221 && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
2222 && gfc_compare_derived_types (formal->ts.u.derived,
2223 CLASS_DATA (actual)->ts.u.derived)))
2226 gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
2227 formal->name, where, gfc_typename (&actual->ts),
2228 gfc_typename (&formal->ts));
2232 if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
2235 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2236 "argument %qs is of assumed type", &actual->where,
2241 /* F2008, 12.5.2.5; IR F08/0073. */
2242 if (formal->ts.type == BT_CLASS && formal->attr.class_ok
2243 && actual->expr_type != EXPR_NULL
2244 && ((CLASS_DATA (formal)->attr.class_pointer
2245 && formal->attr.intent != INTENT_IN)
2246 || CLASS_DATA (formal)->attr.allocatable))
2248 if (actual->ts.type != BT_CLASS)
2251 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2252 formal->name, &actual->where);
2256 if (!gfc_expr_attr (actual).class_ok)
2259 if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
2260 && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
2261 CLASS_DATA (formal)->ts.u.derived))
2264 gfc_error ("Actual argument to %qs at %L must have the same "
2265 "declared type", formal->name, &actual->where);
2270 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2271 is necessary also for F03, so retain error for both.
2272 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2273 compatible, no attempt has been made to channel to this one. */
2274 if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
2275 && (CLASS_DATA (formal)->attr.allocatable
2276 ||CLASS_DATA (formal)->attr.class_pointer))
2279 gfc_error ("Actual argument to %qs at %L must be unlimited "
2280 "polymorphic since the formal argument is a "
2281 "pointer or allocatable unlimited polymorphic "
2282 "entity [F2008: 12.5.2.5]", formal->name,
2287 if (formal->attr.codimension && !gfc_is_coarray (actual))
2290 gfc_error ("Actual argument to %qs at %L must be a coarray",
2291 formal->name, &actual->where);
2295 if (formal->attr.codimension && formal->attr.allocatable)
2297 gfc_ref *last = NULL;
2299 for (ref = actual->ref; ref; ref = ref->next)
2300 if (ref->type == REF_COMPONENT)
2303 /* F2008, 12.5.2.6. */
2304 if ((last && last->u.c.component->as->corank != formal->as->corank)
2306 && actual->symtree->n.sym->as->corank != formal->as->corank))
2309 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2310 formal->name, &actual->where, formal->as->corank,
2311 last ? last->u.c.component->as->corank
2312 : actual->symtree->n.sym->as->corank);
2317 if (formal->attr.codimension)
2319 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2320 /* F2015, 12.5.2.8. */
2321 if (formal->attr.dimension
2322 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
2323 && gfc_expr_attr (actual).dimension
2324 && !gfc_is_simply_contiguous (actual, true, true))
2327 gfc_error ("Actual argument to %qs at %L must be simply "
2328 "contiguous or an element of such an array",
2329 formal->name, &actual->where);
2333 /* F2008, C1303 and C1304. */
2334 if (formal->attr.intent != INTENT_INOUT
2335 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2336 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2337 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2338 || formal->attr.lock_comp))
2342 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2343 "which is LOCK_TYPE or has a LOCK_TYPE component",
2344 formal->name, &actual->where);
2348 /* TS18508, C702/C703. */
2349 if (formal->attr.intent != INTENT_INOUT
2350 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2351 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2352 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
2353 || formal->attr.event_comp))
2357 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2358 "which is EVENT_TYPE or has a EVENT_TYPE component",
2359 formal->name, &actual->where);
2364 /* F2008, C1239/C1240. */
2365 if (actual->expr_type == EXPR_VARIABLE
2366 && (actual->symtree->n.sym->attr.asynchronous
2367 || actual->symtree->n.sym->attr.volatile_)
2368 && (formal->attr.asynchronous || formal->attr.volatile_)
2369 && actual->rank && formal->as
2370 && !gfc_is_simply_contiguous (actual, true, false)
2371 && ((formal->as->type != AS_ASSUMED_SHAPE
2372 && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
2373 || formal->attr.contiguous))
2376 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2377 "assumed-rank array without CONTIGUOUS attribute - as actual"
2378 " argument at %L is not simply contiguous and both are "
2379 "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
2383 if (formal->attr.allocatable && !formal->attr.codimension
2384 && gfc_expr_attr (actual).codimension)
2386 if (formal->attr.intent == INTENT_OUT)
2389 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2390 "INTENT(OUT) dummy argument %qs", &actual->where,
2394 else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
2395 gfc_warning (OPT_Wsurprising,
2396 "Passing coarray at %L to allocatable, noncoarray dummy "
2397 "argument %qs, which is invalid if the allocation status"
2398 " is modified", &actual->where, formal->name);
2401 /* If the rank is the same or the formal argument has assumed-rank. */
2402 if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
2405 rank_check = where != NULL && !is_elemental && formal->as
2406 && (formal->as->type == AS_ASSUMED_SHAPE
2407 || formal->as->type == AS_DEFERRED)
2408 && actual->expr_type != EXPR_NULL;
2410 /* Skip rank checks for NO_ARG_CHECK. */
2411 if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2414 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2415 if (rank_check || ranks_must_agree
2416 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2417 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
2418 || (actual->rank == 0
2419 && ((formal->ts.type == BT_CLASS
2420 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2421 || (formal->ts.type != BT_CLASS
2422 && formal->as->type == AS_ASSUMED_SHAPE))
2423 && actual->expr_type != EXPR_NULL)
2424 || (actual->rank == 0 && formal->attr.dimension
2425 && gfc_is_coindexed (actual)))
2428 argument_rank_mismatch (formal->name, &actual->where,
2429 symbol_rank (formal), actual->rank);
2432 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
2435 /* At this point, we are considering a scalar passed to an array. This
2436 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2437 - if the actual argument is (a substring of) an element of a
2438 non-assumed-shape/non-pointer/non-polymorphic array; or
2439 - (F2003) if the actual argument is of type character of default/c_char
2442 is_pointer = actual->expr_type == EXPR_VARIABLE
2443 ? actual->symtree->n.sym->attr.pointer : false;
2445 for (ref = actual->ref; ref; ref = ref->next)
2447 if (ref->type == REF_COMPONENT)
2448 is_pointer = ref->u.c.component->attr.pointer;
2449 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2450 && ref->u.ar.dimen > 0
2452 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2456 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2459 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2460 "at %L", formal->name, &actual->where);
2464 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2465 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2468 gfc_error ("Element of assumed-shaped or pointer "
2469 "array passed to array dummy argument %qs at %L",
2470 formal->name, &actual->where);
2474 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2475 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2477 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2480 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2481 "CHARACTER actual argument with array dummy argument "
2482 "%qs at %L", formal->name, &actual->where);
2486 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2488 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2489 "array dummy argument %qs at %L",
2490 formal->name, &actual->where);
2493 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
2499 if (ref == NULL && actual->expr_type != EXPR_NULL)
2502 argument_rank_mismatch (formal->name, &actual->where,
2503 symbol_rank (formal), actual->rank);
2511 /* Returns the storage size of a symbol (formal argument) or
2512 zero if it cannot be determined. */
2514 static unsigned long
2515 get_sym_storage_size (gfc_symbol *sym)
2518 unsigned long strlen, elements;
2520 if (sym->ts.type == BT_CHARACTER)
2522 if (sym->ts.u.cl && sym->ts.u.cl->length
2523 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2524 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
2531 if (symbol_rank (sym) == 0)
2535 if (sym->as->type != AS_EXPLICIT)
2537 for (i = 0; i < sym->as->rank; i++)
2539 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
2540 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2543 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2544 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2547 return strlen*elements;
2551 /* Returns the storage size of an expression (actual argument) or
2552 zero if it cannot be determined. For an array element, it returns
2553 the remaining size as the element sequence consists of all storage
2554 units of the actual argument up to the end of the array. */
2556 static unsigned long
2557 get_expr_storage_size (gfc_expr *e)
2560 long int strlen, elements;
2561 long int substrlen = 0;
2562 bool is_str_storage = false;
2568 if (e->ts.type == BT_CHARACTER)
2570 if (e->ts.u.cl && e->ts.u.cl->length
2571 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2572 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2573 else if (e->expr_type == EXPR_CONSTANT
2574 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2575 strlen = e->value.character.length;
2580 strlen = 1; /* Length per element. */
2582 if (e->rank == 0 && !e->ref)
2590 for (i = 0; i < e->rank; i++)
2591 elements *= mpz_get_si (e->shape[i]);
2592 return elements*strlen;
2595 for (ref = e->ref; ref; ref = ref->next)
2597 if (ref->type == REF_SUBSTRING && ref->u.ss.start
2598 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2602 /* The string length is the substring length.
2603 Set now to full string length. */
2604 if (!ref->u.ss.length || !ref->u.ss.length->length
2605 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2608 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2610 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2614 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2615 for (i = 0; i < ref->u.ar.dimen; i++)
2617 long int start, end, stride;
2620 if (ref->u.ar.stride[i])
2622 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2623 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2628 if (ref->u.ar.start[i])
2630 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2631 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2635 else if (ref->u.ar.as->lower[i]
2636 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2637 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2641 if (ref->u.ar.end[i])
2643 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2644 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2648 else if (ref->u.ar.as->upper[i]
2649 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2650 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2654 elements *= (end - start)/stride + 1L;
2656 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
2657 for (i = 0; i < ref->u.ar.as->rank; i++)
2659 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2660 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2661 && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER
2662 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
2663 && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
2664 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2665 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2670 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2671 && e->expr_type == EXPR_VARIABLE)
2673 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2674 || e->symtree->n.sym->attr.pointer)
2680 /* Determine the number of remaining elements in the element
2681 sequence for array element designators. */
2682 is_str_storage = true;
2683 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2685 if (ref->u.ar.start[i] == NULL
2686 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2687 || ref->u.ar.as->upper[i] == NULL
2688 || ref->u.ar.as->lower[i] == NULL
2689 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2690 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2695 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2696 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2698 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2699 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2702 else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
2703 && ref->u.c.component->attr.proc_pointer
2704 && ref->u.c.component->attr.dimension)
2706 /* Array-valued procedure-pointer components. */
2707 gfc_array_spec *as = ref->u.c.component->as;
2708 for (i = 0; i < as->rank; i++)
2710 if (!as->upper[i] || !as->lower[i]
2711 || as->upper[i]->expr_type != EXPR_CONSTANT
2712 || as->lower[i]->expr_type != EXPR_CONSTANT)
2716 * (mpz_get_si (as->upper[i]->value.integer)
2717 - mpz_get_si (as->lower[i]->value.integer) + 1L);
2723 return (is_str_storage) ? substrlen + (elements-1)*strlen
2726 return elements*strlen;
2730 /* Given an expression, check whether it is an array section
2731 which has a vector subscript. If it has, one is returned,
2735 gfc_has_vector_subscript (gfc_expr *e)
2740 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2743 for (ref = e->ref; ref; ref = ref->next)
2744 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2745 for (i = 0; i < ref->u.ar.dimen; i++)
2746 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2754 is_procptr_result (gfc_expr *expr)
2756 gfc_component *c = gfc_get_proc_ptr_comp (expr);
2758 return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1));
2760 return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
2761 && (expr->symtree->n.sym->result->attr.proc_pointer == 1));
2765 /* Given formal and actual argument lists, see if they are compatible.
2766 If they are compatible, the actual argument list is sorted to
2767 correspond with the formal list, and elements for missing optional
2768 arguments are inserted. If WHERE pointer is nonnull, then we issue
2769 errors when things don't match instead of just returning the status
2773 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2774 int ranks_must_agree, int is_elemental, locus *where)
2776 gfc_actual_arglist **new_arg, *a, *actual;
2777 gfc_formal_arglist *f;
2779 unsigned long actual_size, formal_size;
2780 bool full_array = false;
2784 if (actual == NULL && formal == NULL)
2788 for (f = formal; f; f = f->next)
2791 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2793 for (i = 0; i < n; i++)
2800 for (a = actual; a; a = a->next, f = f->next)
2802 /* Look for keywords but ignore g77 extensions like %VAL. */
2803 if (a->name != NULL && a->name[0] != '%')
2806 for (f = formal; f; f = f->next, i++)
2810 if (strcmp (f->sym->name, a->name) == 0)
2817 gfc_error ("Keyword argument %qs at %L is not in "
2818 "the procedure", a->name, &a->expr->where);
2822 if (new_arg[i] != NULL)
2825 gfc_error ("Keyword argument %qs at %L is already associated "
2826 "with another actual argument", a->name,
2835 gfc_error ("More actual than formal arguments in procedure "
2836 "call at %L", where);
2841 if (f->sym == NULL && a->expr == NULL)
2847 gfc_error ("Missing alternate return spec in subroutine call "
2852 if (a->expr == NULL)
2855 gfc_error ("Unexpected alternate return spec in subroutine "
2856 "call at %L", where);
2860 /* Make sure that intrinsic vtables exist for calls to unlimited
2861 polymorphic formal arguments. */
2862 if (UNLIMITED_POLY (f->sym)
2863 && a->expr->ts.type != BT_DERIVED
2864 && a->expr->ts.type != BT_CLASS)
2865 gfc_find_vtab (&a->expr->ts);
2867 if (a->expr->expr_type == EXPR_NULL
2868 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
2869 && (f->sym->attr.allocatable || !f->sym->attr.optional
2870 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2871 || (f->sym->ts.type == BT_CLASS
2872 && !CLASS_DATA (f->sym)->attr.class_pointer
2873 && (CLASS_DATA (f->sym)->attr.allocatable
2874 || !f->sym->attr.optional
2875 || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
2878 && (!f->sym->attr.optional
2879 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
2880 || (f->sym->ts.type == BT_CLASS
2881 && CLASS_DATA (f->sym)->attr.allocatable)))
2882 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
2883 where, f->sym->name);
2885 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2886 "dummy %qs", where, f->sym->name);
2891 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2892 is_elemental, where))
2895 /* TS 29113, 6.3p2. */
2896 if (f->sym->ts.type == BT_ASSUMED
2897 && (a->expr->ts.type == BT_DERIVED
2898 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
2900 gfc_namespace *f2k_derived;
2902 f2k_derived = a->expr->ts.type == BT_DERIVED
2903 ? a->expr->ts.u.derived->f2k_derived
2904 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
2907 && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
2909 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2910 "derived type with type-bound or FINAL procedures",
2916 /* Special case for character arguments. For allocatable, pointer
2917 and assumed-shape dummies, the string length needs to match
2919 if (a->expr->ts.type == BT_CHARACTER
2920 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2921 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2922 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2923 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2924 && (f->sym->attr.pointer || f->sym->attr.allocatable
2925 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2926 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2927 f->sym->ts.u.cl->length->value.integer) != 0))
2929 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2931 "Character length mismatch (%ld/%ld) between actual "
2932 "argument and pointer or allocatable dummy argument "
2934 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2935 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2936 f->sym->name, &a->expr->where);
2939 "Character length mismatch (%ld/%ld) between actual "
2940 "argument and assumed-shape dummy argument %qs "
2942 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2943 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2944 f->sym->name, &a->expr->where);
2948 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2949 && f->sym->ts.deferred != a->expr->ts.deferred
2950 && a->expr->ts.type == BT_CHARACTER)
2953 gfc_error ("Actual argument at %L to allocatable or "
2954 "pointer dummy argument %qs must have a deferred "
2955 "length type parameter if and only if the dummy has one",
2956 &a->expr->where, f->sym->name);
2960 if (f->sym->ts.type == BT_CLASS)
2961 goto skip_size_check;
2963 actual_size = get_expr_storage_size (a->expr);
2964 formal_size = get_sym_storage_size (f->sym);
2965 if (actual_size != 0 && actual_size < formal_size
2966 && a->expr->ts.type != BT_PROCEDURE
2967 && f->sym->attr.flavor != FL_PROCEDURE)
2969 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2970 gfc_warning (0, "Character length of actual argument shorter "
2971 "than of dummy argument %qs (%lu/%lu) at %L",
2972 f->sym->name, actual_size, formal_size,
2975 gfc_warning (0, "Actual argument contains too few "
2976 "elements for dummy argument %qs (%lu/%lu) at %L",
2977 f->sym->name, actual_size, formal_size,
2984 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2985 argument is provided for a procedure pointer formal argument. */
2986 if (f->sym->attr.proc_pointer
2987 && !((a->expr->expr_type == EXPR_VARIABLE
2988 && (a->expr->symtree->n.sym->attr.proc_pointer
2989 || gfc_is_proc_ptr_comp (a->expr)))
2990 || (a->expr->expr_type == EXPR_FUNCTION
2991 && is_procptr_result (a->expr))))
2994 gfc_error ("Expected a procedure pointer for argument %qs at %L",
2995 f->sym->name, &a->expr->where);
2999 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3000 provided for a procedure formal argument. */
3001 if (f->sym->attr.flavor == FL_PROCEDURE
3002 && !((a->expr->expr_type == EXPR_VARIABLE
3003 && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
3004 || a->expr->symtree->n.sym->attr.proc_pointer
3005 || gfc_is_proc_ptr_comp (a->expr)))
3006 || (a->expr->expr_type == EXPR_FUNCTION
3007 && is_procptr_result (a->expr))))
3010 gfc_error ("Expected a procedure for argument %qs at %L",
3011 f->sym->name, &a->expr->where);
3015 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
3016 && a->expr->expr_type == EXPR_VARIABLE
3017 && a->expr->symtree->n.sym->as
3018 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
3019 && (a->expr->ref == NULL
3020 || (a->expr->ref->type == REF_ARRAY
3021 && a->expr->ref->u.ar.type == AR_FULL)))
3024 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3025 " array at %L", f->sym->name, where);
3029 if (a->expr->expr_type != EXPR_NULL
3030 && compare_pointer (f->sym, a->expr) == 0)
3033 gfc_error ("Actual argument for %qs must be a pointer at %L",
3034 f->sym->name, &a->expr->where);
3038 if (a->expr->expr_type != EXPR_NULL
3039 && (gfc_option.allow_std & GFC_STD_F2008) == 0
3040 && compare_pointer (f->sym, a->expr) == 2)
3043 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3044 "pointer dummy %qs", &a->expr->where,f->sym->name);
3049 /* Fortran 2008, C1242. */
3050 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
3053 gfc_error ("Coindexed actual argument at %L to pointer "
3055 &a->expr->where, f->sym->name);
3059 /* Fortran 2008, 12.5.2.5 (no constraint). */
3060 if (a->expr->expr_type == EXPR_VARIABLE
3061 && f->sym->attr.intent != INTENT_IN
3062 && f->sym->attr.allocatable
3063 && gfc_is_coindexed (a->expr))
3066 gfc_error ("Coindexed actual argument at %L to allocatable "
3067 "dummy %qs requires INTENT(IN)",
3068 &a->expr->where, f->sym->name);
3072 /* Fortran 2008, C1237. */
3073 if (a->expr->expr_type == EXPR_VARIABLE
3074 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
3075 && gfc_is_coindexed (a->expr)
3076 && (a->expr->symtree->n.sym->attr.volatile_
3077 || a->expr->symtree->n.sym->attr.asynchronous))
3080 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3081 "%L requires that dummy %qs has neither "
3082 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
3087 /* Fortran 2008, 12.5.2.4 (no constraint). */
3088 if (a->expr->expr_type == EXPR_VARIABLE
3089 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
3090 && gfc_is_coindexed (a->expr)
3091 && gfc_has_ultimate_allocatable (a->expr))
3094 gfc_error ("Coindexed actual argument at %L with allocatable "
3095 "ultimate component to dummy %qs requires either VALUE "
3096 "or INTENT(IN)", &a->expr->where, f->sym->name);
3100 if (f->sym->ts.type == BT_CLASS
3101 && CLASS_DATA (f->sym)->attr.allocatable
3102 && gfc_is_class_array_ref (a->expr, &full_array)
3106 gfc_error ("Actual CLASS array argument for %qs must be a full "
3107 "array at %L", f->sym->name, &a->expr->where);
3112 if (a->expr->expr_type != EXPR_NULL
3113 && compare_allocatable (f->sym, a->expr) == 0)
3116 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3117 f->sym->name, &a->expr->where);
3121 /* Check intent = OUT/INOUT for definable actual argument. */
3122 if ((f->sym->attr.intent == INTENT_OUT
3123 || f->sym->attr.intent == INTENT_INOUT))
3125 const char* context = (where
3126 ? _("actual argument to INTENT = OUT/INOUT")
3129 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3130 && CLASS_DATA (f->sym)->attr.class_pointer)
3131 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3132 && !gfc_check_vardef_context (a->expr, true, false, false, context))
3134 if (!gfc_check_vardef_context (a->expr, false, false, false, context))
3138 if ((f->sym->attr.intent == INTENT_OUT
3139 || f->sym->attr.intent == INTENT_INOUT
3140 || f->sym->attr.volatile_
3141 || f->sym->attr.asynchronous)
3142 && gfc_has_vector_subscript (a->expr))
3145 gfc_error ("Array-section actual argument with vector "
3146 "subscripts at %L is incompatible with INTENT(OUT), "
3147 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3148 "of the dummy argument %qs",
3149 &a->expr->where, f->sym->name);
3153 /* C1232 (R1221) For an actual argument which is an array section or
3154 an assumed-shape array, the dummy argument shall be an assumed-
3155 shape array, if the dummy argument has the VOLATILE attribute. */
3157 if (f->sym->attr.volatile_
3158 && a->expr->symtree->n.sym->as
3159 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
3160 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3163 gfc_error ("Assumed-shape actual argument at %L is "
3164 "incompatible with the non-assumed-shape "
3165 "dummy argument %qs due to VOLATILE attribute",
3166 &a->expr->where,f->sym->name);
3170 if (f->sym->attr.volatile_
3171 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
3172 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
3175 gfc_error ("Array-section actual argument at %L is "
3176 "incompatible with the non-assumed-shape "
3177 "dummy argument %qs due to VOLATILE attribute",
3178 &a->expr->where,f->sym->name);
3182 /* C1233 (R1221) For an actual argument which is a pointer array, the
3183 dummy argument shall be an assumed-shape or pointer array, if the
3184 dummy argument has the VOLATILE attribute. */
3186 if (f->sym->attr.volatile_
3187 && a->expr->symtree->n.sym->attr.pointer
3188 && a->expr->symtree->n.sym->as
3190 && (f->sym->as->type == AS_ASSUMED_SHAPE
3191 || f->sym->attr.pointer)))
3194 gfc_error ("Pointer-array actual argument at %L requires "
3195 "an assumed-shape or pointer-array dummy "
3196 "argument %qs due to VOLATILE attribute",
3197 &a->expr->where,f->sym->name);
3208 /* Make sure missing actual arguments are optional. */
3210 for (f = formal; f; f = f->next, i++)
3212 if (new_arg[i] != NULL)
3217 gfc_error ("Missing alternate return spec in subroutine call "
3221 if (!f->sym->attr.optional)
3224 gfc_error ("Missing actual argument for argument %qs at %L",
3225 f->sym->name, where);
3230 /* The argument lists are compatible. We now relink a new actual
3231 argument list with null arguments in the right places. The head
3232 of the list remains the head. */
3233 for (i = 0; i < n; i++)
3234 if (new_arg[i] == NULL)
3235 new_arg[i] = gfc_get_actual_arglist ();
3239 std::swap (*new_arg[0], *actual);
3240 std::swap (new_arg[0], new_arg[na]);
3243 for (i = 0; i < n - 1; i++)
3244 new_arg[i]->next = new_arg[i + 1];
3246 new_arg[i]->next = NULL;
3248 if (*ap == NULL && n > 0)
3251 /* Note the types of omitted optional arguments. */
3252 for (a = *ap, f = formal; a; a = a->next, f = f->next)
3253 if (a->expr == NULL && a->label == NULL)
3254 a->missing_arg_type = f->sym->ts.type;
3262 gfc_formal_arglist *f;
3263 gfc_actual_arglist *a;
3267 /* qsort comparison function for argument pairs, with the following
3269 - p->a->expr == NULL
3270 - p->a->expr->expr_type != EXPR_VARIABLE
3271 - growing p->a->expr->symbol. */
3274 pair_cmp (const void *p1, const void *p2)
3276 const gfc_actual_arglist *a1, *a2;
3278 /* *p1 and *p2 are elements of the to-be-sorted array. */
3279 a1 = ((const argpair *) p1)->a;
3280 a2 = ((const argpair *) p2)->a;
3289 if (a1->expr->expr_type != EXPR_VARIABLE)
3291 if (a2->expr->expr_type != EXPR_VARIABLE)
3295 if (a2->expr->expr_type != EXPR_VARIABLE)
3297 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
3301 /* Given two expressions from some actual arguments, test whether they
3302 refer to the same expression. The analysis is conservative.
3303 Returning false will produce no warning. */
3306 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
3308 const gfc_ref *r1, *r2;
3311 || e1->expr_type != EXPR_VARIABLE
3312 || e2->expr_type != EXPR_VARIABLE
3313 || e1->symtree->n.sym != e2->symtree->n.sym)
3316 /* TODO: improve comparison, see expr.c:show_ref(). */
3317 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
3319 if (r1->type != r2->type)
3324 if (r1->u.ar.type != r2->u.ar.type)
3326 /* TODO: At the moment, consider only full arrays;
3327 we could do better. */
3328 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
3333 if (r1->u.c.component != r2->u.c.component)
3341 gfc_internal_error ("compare_actual_expr(): Bad component code");
3350 /* Given formal and actual argument lists that correspond to one
3351 another, check that identical actual arguments aren't not
3352 associated with some incompatible INTENTs. */
3355 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
3357 sym_intent f1_intent, f2_intent;
3358 gfc_formal_arglist *f1;
3359 gfc_actual_arglist *a1;
3365 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
3367 if (f1 == NULL && a1 == NULL)
3369 if (f1 == NULL || a1 == NULL)
3370 gfc_internal_error ("check_some_aliasing(): List mismatch");
3375 p = XALLOCAVEC (argpair, n);
3377 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
3383 qsort (p, n, sizeof (argpair), pair_cmp);
3385 for (i = 0; i < n; i++)
3388 || p[i].a->expr->expr_type != EXPR_VARIABLE
3389 || p[i].a->expr->ts.type == BT_PROCEDURE)
3391 f1_intent = p[i].f->sym->attr.intent;
3392 for (j = i + 1; j < n; j++)
3394 /* Expected order after the sort. */
3395 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
3396 gfc_internal_error ("check_some_aliasing(): corrupted data");
3398 /* Are the expression the same? */
3399 if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
3401 f2_intent = p[j].f->sym->attr.intent;
3402 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
3403 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
3404 || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
3406 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3407 "argument %qs and INTENT(%s) argument %qs at %L",
3408 gfc_intent_string (f1_intent), p[i].f->sym->name,
3409 gfc_intent_string (f2_intent), p[j].f->sym->name,
3410 &p[i].a->expr->where);
3420 /* Given formal and actual argument lists that correspond to one
3421 another, check that they are compatible in the sense that intents
3422 are not mismatched. */
3425 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
3427 sym_intent f_intent;
3429 for (;; f = f->next, a = a->next)
3433 if (f == NULL && a == NULL)
3435 if (f == NULL || a == NULL)
3436 gfc_internal_error ("check_intents(): List mismatch");
3438 if (a->expr && a->expr->expr_type == EXPR_FUNCTION
3439 && a->expr->value.function.isym
3440 && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
3441 expr = a->expr->value.function.actual->expr;
3445 if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
3448 f_intent = f->sym->attr.intent;
3450 if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
3452 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3453 && CLASS_DATA (f->sym)->attr.class_pointer)
3454 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3456 gfc_error ("Procedure argument at %L is local to a PURE "
3457 "procedure and has the POINTER attribute",
3463 /* Fortran 2008, C1283. */
3464 if (gfc_pure (NULL) && gfc_is_coindexed (expr))
3466 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
3468 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3469 "is passed to an INTENT(%s) argument",
3470 &expr->where, gfc_intent_string (f_intent));
3474 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3475 && CLASS_DATA (f->sym)->attr.class_pointer)
3476 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3478 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3479 "is passed to a POINTER dummy argument",
3485 /* F2008, Section 12.5.2.4. */
3486 if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
3487 && gfc_is_coindexed (expr))
3489 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3490 "polymorphic dummy argument %qs",
3491 &expr->where, f->sym->name);
3500 /* Check how a procedure is used against its interface. If all goes
3501 well, the actual argument list will also end up being properly
3505 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
3507 gfc_formal_arglist *dummy_args;
3509 /* Warn about calls with an implicit interface. Special case
3510 for calling a ISO_C_BINDING because c_loc and c_funloc
3511 are pseudo-unknown. Additionally, warn about procedures not
3512 explicitly declared at all if requested. */
3513 if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
3515 if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
3517 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3521 if (warn_implicit_interface)
3522 gfc_warning (OPT_Wimplicit_interface,
3523 "Procedure %qs called with an implicit interface at %L",
3525 else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
3526 gfc_warning (OPT_Wimplicit_procedure,
3527 "Procedure %qs called at %L is not explicitly declared",
3531 if (sym->attr.if_source == IFSRC_UNKNOWN)
3533 gfc_actual_arglist *a;
3535 if (sym->attr.pointer)
3537 gfc_error ("The pointer object %qs at %L must have an explicit "
3538 "function interface or be declared as array",
3543 if (sym->attr.allocatable && !sym->attr.external)
3545 gfc_error ("The allocatable object %qs at %L must have an explicit "
3546 "function interface or be declared as array",
3551 if (sym->attr.allocatable)
3553 gfc_error ("Allocatable function %qs at %L must have an explicit "
3554 "function interface", sym->name, where);
3558 for (a = *ap; a; a = a->next)
3560 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3561 if (a->name != NULL && a->name[0] != '%')
3563 gfc_error ("Keyword argument requires explicit interface "
3564 "for procedure %qs at %L", sym->name, &a->expr->where);
3568 /* TS 29113, 6.2. */
3569 if (a->expr && a->expr->ts.type == BT_ASSUMED
3570 && sym->intmod_sym_id != ISOCBINDING_LOC)
3572 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3573 "interface", a->expr->symtree->n.sym->name,
3578 /* F2008, C1303 and C1304. */
3580 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3581 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3582 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3583 || gfc_expr_attr (a->expr).lock_comp))
3585 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3586 "component at %L requires an explicit interface for "
3587 "procedure %qs", &a->expr->where, sym->name);
3592 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3593 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3594 && a->expr->ts.u.derived->intmod_sym_id
3595 == ISOFORTRAN_EVENT_TYPE)
3596 || gfc_expr_attr (a->expr).event_comp))
3598 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3599 "component at %L requires an explicit interface for "
3600 "procedure %qs", &a->expr->where, sym->name);
3604 if (a->expr && a->expr->expr_type == EXPR_NULL
3605 && a->expr->ts.type == BT_UNKNOWN)
3607 gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
3611 /* TS 29113, C407b. */
3612 if (a->expr && a->expr->expr_type == EXPR_VARIABLE
3613 && symbol_rank (a->expr->symtree->n.sym) == -1)
3615 gfc_error ("Assumed-rank argument requires an explicit interface "
3616 "at %L", &a->expr->where);
3624 dummy_args = gfc_sym_get_dummy_args (sym);
3626 if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where))
3629 if (!check_intents (dummy_args, *ap))
3633 check_some_aliasing (dummy_args, *ap);
3639 /* Check how a procedure pointer component is used against its interface.
3640 If all goes well, the actual argument list will also end up being properly
3641 sorted. Completely analogous to gfc_procedure_use. */
3644 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
3646 /* Warn about calls with an implicit interface. Special case
3647 for calling a ISO_C_BINDING because c_loc and c_funloc
3648 are pseudo-unknown. */
3649 if (warn_implicit_interface
3650 && comp->attr.if_source == IFSRC_UNKNOWN
3651 && !comp->attr.is_iso_c)
3652 gfc_warning (OPT_Wimplicit_interface,
3653 "Procedure pointer component %qs called with an implicit "
3654 "interface at %L", comp->name, where);
3656 if (comp->attr.if_source == IFSRC_UNKNOWN)
3658 gfc_actual_arglist *a;
3659 for (a = *ap; a; a = a->next)
3661 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3662 if (a->name != NULL && a->name[0] != '%')
3664 gfc_error ("Keyword argument requires explicit interface "
3665 "for procedure pointer component %qs at %L",
3666 comp->name, &a->expr->where);
3674 if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
3675 comp->attr.elemental, where))
3678 check_intents (comp->ts.interface->formal, *ap);
3680 check_some_aliasing (comp->ts.interface->formal, *ap);
3684 /* Try if an actual argument list matches the formal list of a symbol,
3685 respecting the symbol's attributes like ELEMENTAL. This is used for
3686 GENERIC resolution. */
3689 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
3691 gfc_formal_arglist *dummy_args;
3694 if (sym->attr.flavor != FL_PROCEDURE)
3697 dummy_args = gfc_sym_get_dummy_args (sym);
3699 r = !sym->attr.elemental;
3700 if (compare_actual_formal (args, dummy_args, r, !r, NULL))
3702 check_intents (dummy_args, *args);
3704 check_some_aliasing (dummy_args, *args);
3712 /* Given an interface pointer and an actual argument list, search for
3713 a formal argument list that matches the actual. If found, returns
3714 a pointer to the symbol of the correct interface. Returns NULL if
3718 gfc_search_interface (gfc_interface *intr, int sub_flag,
3719 gfc_actual_arglist **ap)
3721 gfc_symbol *elem_sym = NULL;
3722 gfc_symbol *null_sym = NULL;
3723 locus null_expr_loc;
3724 gfc_actual_arglist *a;
3725 bool has_null_arg = false;
3727 for (a = *ap; a; a = a->next)
3728 if (a->expr && a->expr->expr_type == EXPR_NULL
3729 && a->expr->ts.type == BT_UNKNOWN)
3731 has_null_arg = true;
3732 null_expr_loc = a->expr->where;
3736 for (; intr; intr = intr->next)
3738 if (gfc_fl_struct (intr->sym->attr.flavor))
3740 if (sub_flag && intr->sym->attr.function)
3742 if (!sub_flag && intr->sym->attr.subroutine)
3745 if (gfc_arglist_matches_symbol (ap, intr->sym))
3747 if (has_null_arg && null_sym)
3749 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3750 "between specific functions %s and %s",
3751 &null_expr_loc, null_sym->name, intr->sym->name);
3754 else if (has_null_arg)
3756 null_sym = intr->sym;
3760 /* Satisfy 12.4.4.1 such that an elemental match has lower
3761 weight than a non-elemental match. */
3762 if (intr->sym->attr.elemental)
3764 elem_sym = intr->sym;
3774 return elem_sym ? elem_sym : NULL;
3778 /* Do a brute force recursive search for a symbol. */
3780 static gfc_symtree *
3781 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3785 if (root->n.sym == sym)
3790 st = find_symtree0 (root->left, sym);
3791 if (root->right && ! st)
3792 st = find_symtree0 (root->right, sym);
3797 /* Find a symtree for a symbol. */
3800 gfc_find_sym_in_symtree (gfc_symbol *sym)
3805 /* First try to find it by name. */
3806 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3807 if (st && st->n.sym == sym)
3810 /* If it's been renamed, resort to a brute-force search. */
3811 /* TODO: avoid having to do this search. If the symbol doesn't exist
3812 in the symtree for the current namespace, it should probably be added. */
3813 for (ns = gfc_current_ns; ns; ns = ns->parent)
3815 st = find_symtree0 (ns->sym_root, sym);
3819 gfc_internal_error ("Unable to find symbol %qs", sym->name);
3824 /* See if the arglist to an operator-call contains a derived-type argument
3825 with a matching type-bound operator. If so, return the matching specific
3826 procedure defined as operator-target as well as the base-object to use
3827 (which is the found derived-type argument with operator). The generic
3828 name, if any, is transmitted to the final expression via 'gname'. */
3830 static gfc_typebound_proc*
3831 matching_typebound_op (gfc_expr** tb_base,
3832 gfc_actual_arglist* args,
3833 gfc_intrinsic_op op, const char* uop,
3834 const char ** gname)
3836 gfc_actual_arglist* base;
3838 for (base = args; base; base = base->next)
3839 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3841 gfc_typebound_proc* tb;
3842 gfc_symbol* derived;
3845 while (base->expr->expr_type == EXPR_OP
3846 && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3847 base->expr = base->expr->value.op.op1;
3849 if (base->expr->ts.type == BT_CLASS)
3851 if (CLASS_DATA (base->expr) == NULL
3852 || !gfc_expr_attr (base->expr).class_ok)
3854 derived = CLASS_DATA (base->expr)->ts.u.derived;
3857 derived = base->expr->ts.u.derived;
3859 if (op == INTRINSIC_USER)
3861 gfc_symtree* tb_uop;
3864 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3873 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3876 /* This means we hit a PRIVATE operator which is use-associated and
3877 should thus not be seen. */
3881 /* Look through the super-type hierarchy for a matching specific
3883 for (; tb; tb = tb->overridden)
3887 gcc_assert (tb->is_generic);
3888 for (g = tb->u.generic; g; g = g->next)
3891 gfc_actual_arglist* argcopy;
3894 gcc_assert (g->specific);
3895 if (g->specific->error)
3898 target = g->specific->u.specific->n.sym;
3900 /* Check if this arglist matches the formal. */
3901 argcopy = gfc_copy_actual_arglist (args);
3902 matches = gfc_arglist_matches_symbol (&argcopy, target);
3903 gfc_free_actual_arglist (argcopy);
3905 /* Return if we found a match. */
3908 *tb_base = base->expr;
3909 *gname = g->specific_st->name;
3920 /* For the 'actual arglist' of an operator call and a specific typebound
3921 procedure that has been found the target of a type-bound operator, build the
3922 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3923 type-bound procedures rather than resolving type-bound operators 'directly'
3924 so that we can reuse the existing logic. */
3927 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3928 gfc_expr* base, gfc_typebound_proc* target,
3931 e->expr_type = EXPR_COMPCALL;
3932 e->value.compcall.tbp = target;
3933 e->value.compcall.name = gname ? gname : "$op";
3934 e->value.compcall.actual = actual;
3935 e->value.compcall.base_object = base;
3936 e->value.compcall.ignore_pass = 1;
3937 e->value.compcall.assign = 0;
3938 if (e->ts.type == BT_UNKNOWN
3939 && target->function)
3941 if (target->is_generic)
3942 e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3944 e->ts = target->u.specific->n.sym->ts;
3949 /* This subroutine is called when an expression is being resolved.
3950 The expression node in question is either a user defined operator
3951 or an intrinsic operator with arguments that aren't compatible
3952 with the operator. This subroutine builds an actual argument list
3953 corresponding to the operands, then searches for a compatible
3954 interface. If one is found, the expression node is replaced with
3955 the appropriate function call. We use the 'match' enum to specify
3956 whether a replacement has been made or not, or if an error occurred. */
3959 gfc_extend_expr (gfc_expr *e)
3961 gfc_actual_arglist *actual;
3967 gfc_typebound_proc* tbo;
3972 actual = gfc_get_actual_arglist ();
3973 actual->expr = e->value.op.op1;
3977 if (e->value.op.op2 != NULL)
3979 actual->next = gfc_get_actual_arglist ();
3980 actual->next->expr = e->value.op.op2;
3983 i = fold_unary_intrinsic (e->value.op.op);
3985 /* See if we find a matching type-bound operator. */
3986 if (i == INTRINSIC_USER)
3987 tbo = matching_typebound_op (&tb_base, actual,
3988 i, e->value.op.uop->name, &gname);
3992 #define CHECK_OS_COMPARISON(comp) \
3993 case INTRINSIC_##comp: \
3994 case INTRINSIC_##comp##_OS: \
3995 tbo = matching_typebound_op (&tb_base, actual, \
3996 INTRINSIC_##comp, NULL, &gname); \
3998 tbo = matching_typebound_op (&tb_base, actual, \
3999 INTRINSIC_##comp##_OS, NULL, &gname); \
4001 CHECK_OS_COMPARISON(EQ)
4002 CHECK_OS_COMPARISON(NE)
4003 CHECK_OS_COMPARISON(GT)
4004 CHECK_OS_COMPARISON(GE)
4005 CHECK_OS_COMPARISON(LT)
4006 CHECK_OS_COMPARISON(LE)
4007 #undef CHECK_OS_COMPARISON
4010 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
4014 /* If there is a matching typebound-operator, replace the expression with
4015 a call to it and succeed. */
4018 gcc_assert (tb_base);
4019 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
4021 if (!gfc_resolve_expr (e))
4027 if (i == INTRINSIC_USER)
4029 for (ns = gfc_current_ns; ns; ns = ns->parent)
4031 uop = gfc_find_uop (e->value.op.uop->name, ns);
4035 sym = gfc_search_interface (uop->op, 0, &actual);
4042 for (ns = gfc_current_ns; ns; ns = ns->parent)
4044 /* Due to the distinction between '==' and '.eq.' and friends, one has
4045 to check if either is defined. */
4048 #define CHECK_OS_COMPARISON(comp) \
4049 case INTRINSIC_##comp: \
4050 case INTRINSIC_##comp##_OS: \
4051 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4053 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4055 CHECK_OS_COMPARISON(EQ)
4056 CHECK_OS_COMPARISON(NE)
4057 CHECK_OS_COMPARISON(GT)
4058 CHECK_OS_COMPARISON(GE)
4059 CHECK_OS_COMPARISON(LT)
4060 CHECK_OS_COMPARISON(LE)
4061 #undef CHECK_OS_COMPARISON
4064 sym = gfc_search_interface (ns->op[i], 0, &actual);
4072 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4073 found rather than just taking the first one and not checking further. */
4077 /* Don't use gfc_free_actual_arglist(). */
4078 free (actual->next);
4083 /* Change the expression node to a function call. */
4084 e->expr_type = EXPR_FUNCTION;
4085 e->symtree = gfc_find_sym_in_symtree (sym);
4086 e->value.function.actual = actual;
4087 e->value.function.esym = NULL;
4088 e->value.function.isym = NULL;
4089 e->value.function.name = NULL;
4090 e->user_operator = 1;
4092 if (!gfc_resolve_expr (e))
4099 /* Tries to replace an assignment code node with a subroutine call to the
4100 subroutine associated with the assignment operator. Return true if the node
4101 was replaced. On false, no error is generated. */
4104 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
4106 gfc_actual_arglist *actual;
4107 gfc_expr *lhs, *rhs, *tb_base;
4108 gfc_symbol *sym = NULL;
4109 const char *gname = NULL;
4110 gfc_typebound_proc* tbo;
4115 /* Don't allow an intrinsic assignment to be replaced. */
4116 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
4117 && (rhs->rank == 0 || rhs->rank == lhs->rank)
4118 && (lhs->ts.type == rhs->ts.type
4119 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
4122 actual = gfc_get_actual_arglist ();
4125 actual->next = gfc_get_actual_arglist ();
4126 actual->next->expr = rhs;
4128 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4130 /* See if we find a matching type-bound assignment. */
4131 tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN,
4136 /* Success: Replace the expression with a type-bound call. */
4137 gcc_assert (tb_base);
4138 c->expr1 = gfc_get_expr ();
4139 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
4140 c->expr1->value.compcall.assign = 1;
4141 c->expr1->where = c->loc;
4143 c->op = EXEC_COMPCALL;
4147 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4148 for (; ns; ns = ns->parent)
4150 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
4157 /* Success: Replace the assignment with the call. */
4158 c->op = EXEC_ASSIGN_CALL;
4159 c->symtree = gfc_find_sym_in_symtree (sym);
4162 c->ext.actual = actual;
4166 /* Failure: No assignment procedure found. */
4167 free (actual->next);
4173 /* Make sure that the interface just parsed is not already present in
4174 the given interface list. Ambiguity isn't checked yet since module
4175 procedures can be present without interfaces. */
4178 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
4182 for (ip = base; ip; ip = ip->next)
4184 if (ip->sym == new_sym)
4186 gfc_error ("Entity %qs at %L is already present in the interface",
4187 new_sym->name, &loc);
4196 /* Add a symbol to the current interface. */
4199 gfc_add_interface (gfc_symbol *new_sym)
4201 gfc_interface **head, *intr;
4205 switch (current_interface.type)
4207 case INTERFACE_NAMELESS:
4208 case INTERFACE_ABSTRACT:
4211 case INTERFACE_INTRINSIC_OP:
4212 for (ns = current_interface.ns; ns; ns = ns->parent)
4213 switch (current_interface.op)
4216 case INTRINSIC_EQ_OS:
4217 if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
4219 || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
4220 new_sym, gfc_current_locus))
4225 case INTRINSIC_NE_OS:
4226 if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
4228 || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
4229 new_sym, gfc_current_locus))
4234 case INTRINSIC_GT_OS:
4235 if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
4236 new_sym, gfc_current_locus)
4237 || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
4238 new_sym, gfc_current_locus))
4243 case INTRINSIC_GE_OS:
4244 if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
4245 new_sym, gfc_current_locus)
4246 || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
4247 new_sym, gfc_current_locus))
4252 case INTRINSIC_LT_OS:
4253 if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
4254 new_sym, gfc_current_locus)
4255 || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
4256 new_sym, gfc_current_locus))
4261 case INTRINSIC_LE_OS:
4262 if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
4263 new_sym, gfc_current_locus)
4264 || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
4265 new_sym, gfc_current_locus))
4270 if (!gfc_check_new_interface (ns->op[current_interface.op],
4271 new_sym, gfc_current_locus))
4275 head = ¤t_interface.ns->op[current_interface.op];
4278 case INTERFACE_GENERIC:
4279 case INTERFACE_DTIO:
4280 for (ns = current_interface.ns; ns; ns = ns->parent)
4282 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
4286 if (!gfc_check_new_interface (sym->generic,
4287 new_sym, gfc_current_locus))
4291 head = ¤t_interface.sym->generic;
4294 case INTERFACE_USER_OP:
4295 if (!gfc_check_new_interface (current_interface.uop->op,
4296 new_sym, gfc_current_locus))
4299 head = ¤t_interface.uop->op;
4303 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4306 intr = gfc_get_interface ();
4307 intr->sym = new_sym;
4308 intr->where = gfc_current_locus;
4318 gfc_current_interface_head (void)
4320 switch (current_interface.type)
4322 case INTERFACE_INTRINSIC_OP:
4323 return current_interface.ns->op[current_interface.op];
4325 case INTERFACE_GENERIC:
4326 case INTERFACE_DTIO:
4327 return current_interface.sym->generic;
4329 case INTERFACE_USER_OP:
4330 return current_interface.uop->op;
4339 gfc_set_current_interface_head (gfc_interface *i)
4341 switch (current_interface.type)
4343 case INTERFACE_INTRINSIC_OP:
4344 current_interface.ns->op[current_interface.op] = i;
4347 case INTERFACE_GENERIC:
4348 case INTERFACE_DTIO:
4349 current_interface.sym->generic = i;
4352 case INTERFACE_USER_OP:
4353 current_interface.uop->op = i;
4362 /* Gets rid of a formal argument list. We do not free symbols.
4363 Symbols are freed when a namespace is freed. */
4366 gfc_free_formal_arglist (gfc_formal_arglist *p)
4368 gfc_formal_arglist *q;
4378 /* Check that it is ok for the type-bound procedure 'proc' to override the
4379 procedure 'old', cf. F08:4.5.7.3. */
4382 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
4385 gfc_symbol *proc_target, *old_target;
4386 unsigned proc_pass_arg, old_pass_arg, argpos;
4387 gfc_formal_arglist *proc_formal, *old_formal;
4391 /* This procedure should only be called for non-GENERIC proc. */
4392 gcc_assert (!proc->n.tb->is_generic);
4394 /* If the overwritten procedure is GENERIC, this is an error. */
4395 if (old->n.tb->is_generic)
4397 gfc_error ("Can't overwrite GENERIC %qs at %L",
4398 old->name, &proc->n.tb->where);
4402 where = proc->n.tb->where;
4403 proc_target = proc->n.tb->u.specific->n.sym;
4404 old_target = old->n.tb->u.specific->n.sym;
4406 /* Check that overridden binding is not NON_OVERRIDABLE. */
4407 if (old->n.tb->non_overridable)
4409 gfc_error ("%qs at %L overrides a procedure binding declared"
4410 " NON_OVERRIDABLE", proc->name, &where);
4414 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4415 if (!old->n.tb->deferred && proc->n.tb->deferred)
4417 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4418 " non-DEFERRED binding", proc->name, &where);
4422 /* If the overridden binding is PURE, the overriding must be, too. */
4423 if (old_target->attr.pure && !proc_target->attr.pure)
4425 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4426 proc->name, &where);
4430 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4431 is not, the overriding must not be either. */
4432 if (old_target->attr.elemental && !proc_target->attr.elemental)
4434 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4435 " ELEMENTAL", proc->name, &where);
4438 if (!old_target->attr.elemental && proc_target->attr.elemental)
4440 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4441 " be ELEMENTAL, either", proc->name, &where);
4445 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4447 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
4449 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4450 " SUBROUTINE", proc->name, &where);
4454 /* If the overridden binding is a FUNCTION, the overriding must also be a
4455 FUNCTION and have the same characteristics. */
4456 if (old_target->attr.function)
4458 if (!proc_target->attr.function)
4460 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4461 " FUNCTION", proc->name, &where);
4465 if (!gfc_check_result_characteristics (proc_target, old_target,
4468 gfc_error ("Result mismatch for the overriding procedure "
4469 "%qs at %L: %s", proc->name, &where, err);
4474 /* If the overridden binding is PUBLIC, the overriding one must not be
4476 if (old->n.tb->access == ACCESS_PUBLIC
4477 && proc->n.tb->access == ACCESS_PRIVATE)
4479 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4480 " PRIVATE", proc->name, &where);
4484 /* Compare the formal argument lists of both procedures. This is also abused
4485 to find the position of the passed-object dummy arguments of both
4486 bindings as at least the overridden one might not yet be resolved and we
4487 need those positions in the check below. */
4488 proc_pass_arg = old_pass_arg = 0;
4489 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
4491 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
4494 proc_formal = gfc_sym_get_dummy_args (proc_target);
4495 old_formal = gfc_sym_get_dummy_args (old_target);
4496 for ( ; proc_formal && old_formal;
4497 proc_formal = proc_formal->next, old_formal = old_formal->next)
4499 if (proc->n.tb->pass_arg
4500 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
4501 proc_pass_arg = argpos;
4502 if (old->n.tb->pass_arg
4503 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
4504 old_pass_arg = argpos;
4506 /* Check that the names correspond. */
4507 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
4509 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4510 " to match the corresponding argument of the overridden"
4511 " procedure", proc_formal->sym->name, proc->name, &where,
4512 old_formal->sym->name);
4516 check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
4517 if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
4518 check_type, err, sizeof(err)))
4520 gfc_error ("Argument mismatch for the overriding procedure "
4521 "%qs at %L: %s", proc->name, &where, err);
4527 if (proc_formal || old_formal)
4529 gfc_error ("%qs at %L must have the same number of formal arguments as"
4530 " the overridden procedure", proc->name, &where);
4534 /* If the overridden binding is NOPASS, the overriding one must also be
4536 if (old->n.tb->nopass && !proc->n.tb->nopass)
4538 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4539 " NOPASS", proc->name, &where);
4543 /* If the overridden binding is PASS(x), the overriding one must also be
4544 PASS and the passed-object dummy arguments must correspond. */
4545 if (!old->n.tb->nopass)
4547 if (proc->n.tb->nopass)
4549 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4550 " PASS", proc->name, &where);
4554 if (proc_pass_arg != old_pass_arg)
4556 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4557 " the same position as the passed-object dummy argument of"
4558 " the overridden procedure", proc->name, &where);
4567 /* The following three functions check that the formal arguments
4568 of user defined derived type IO procedures are compliant with
4569 the requirements of the standard. */
4572 check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
4573 int kind, int rank, sym_intent intent)
4575 if (fsym->ts.type != type)
4577 gfc_error ("DTIO dummy argument at %L must be of type %s",
4578 &fsym->declared_at, gfc_basic_typename (type));
4582 if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
4583 && fsym->ts.kind != kind)
4584 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4585 &fsym->declared_at, kind);
4589 && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
4590 || ((type != BT_CLASS) && fsym->attr.dimension)))
4591 gfc_error ("DTIO dummy argument at %L be a scalar",
4592 &fsym->declared_at);
4594 && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
4595 gfc_error ("DTIO dummy argument at %L must be an "
4596 "ASSUMED SHAPE ARRAY", &fsym->declared_at);
4598 if (fsym->attr.intent != intent)
4599 gfc_error ("DTIO dummy argument at %L must have intent %s",
4600 &fsym->declared_at, gfc_code2string (intents, (int)intent));
4606 check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
4607 bool typebound, bool formatted, int code)
4609 gfc_symbol *dtio_sub, *generic_proc, *fsym;
4610 gfc_typebound_proc *tb_io_proc, *specific_proc;
4611 gfc_interface *intr;
4612 gfc_formal_arglist *formal;
4615 bool read = ((dtio_codes)code == DTIO_RF)
4616 || ((dtio_codes)code == DTIO_RUF);
4624 /* Typebound DTIO binding. */
4625 tb_io_proc = tb_io_st->n.tb;
4626 if (tb_io_proc == NULL)
4629 gcc_assert (tb_io_proc->is_generic);
4630 gcc_assert (tb_io_proc->u.generic->next == NULL);
4632 specific_proc = tb_io_proc->u.generic->specific;
4633 if (specific_proc == NULL || specific_proc->is_generic)
4636 dtio_sub = specific_proc->u.specific->n.sym;
4640 generic_proc = tb_io_st->n.sym;
4641 if (generic_proc == NULL || generic_proc->generic == NULL)
4644 for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
4646 if (intr->sym && intr->sym->formal && intr->sym->formal->sym
4647 && ((intr->sym->formal->sym->ts.type == BT_CLASS
4648 && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
4650 || (intr->sym->formal->sym->ts.type == BT_DERIVED
4651 && intr->sym->formal->sym->ts.u.derived == derived)))
4653 dtio_sub = intr->sym;
4656 else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
4658 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4659 "procedure", &intr->sym->declared_at);
4664 if (dtio_sub == NULL)
4668 gcc_assert (dtio_sub);
4669 if (!dtio_sub->attr.subroutine)
4670 gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
4671 dtio_sub->name, &dtio_sub->declared_at);
4674 for (formal = dtio_sub->formal; formal; formal = formal->next)
4677 if (arg_num < (formatted ? 6 : 4))
4679 gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
4680 dtio_sub->name, &dtio_sub->declared_at);
4684 if (arg_num > (formatted ? 6 : 4))
4686 gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
4687 dtio_sub->name, &dtio_sub->declared_at);
4692 /* Now go through the formal arglist. */
4694 for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
4696 if (!formatted && arg_num == 3)
4702 gfc_error ("Alternate return at %L is not permitted in a DTIO "
4703 "procedure", &dtio_sub->declared_at);
4710 type = derived->attr.sequence || derived->attr.is_bind_c ?
4711 BT_DERIVED : BT_CLASS;
4713 intent = read ? INTENT_INOUT : INTENT_IN;
4714 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
4720 kind = gfc_default_integer_kind;
4722 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
4725 case(3): /* IOTYPE */
4726 type = BT_CHARACTER;
4727 kind = gfc_default_character_kind;
4729 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
4732 case(4): /* VLIST */
4734 kind = gfc_default_integer_kind;
4736 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
4739 case(5): /* IOSTAT */
4741 kind = gfc_default_integer_kind;
4742 intent = INTENT_OUT;
4743 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
4746 case(6): /* IOMSG */
4747 type = BT_CHARACTER;
4748 kind = gfc_default_character_kind;
4749 intent = INTENT_INOUT;
4750 check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
4757 derived->attr.has_dtio_procs = 1;
4762 gfc_check_dtio_interfaces (gfc_symbol *derived)
4764 gfc_symtree *tb_io_st;
4769 if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
4772 /* Check typebound DTIO bindings. */
4773 for (code = 0; code < 4; code++)
4775 formatted = ((dtio_codes)code == DTIO_RF)
4776 || ((dtio_codes)code == DTIO_WF);
4778 tb_io_st = gfc_find_typebound_proc (derived, &t,
4779 gfc_code2string (dtio_procs, code),
4780 true, &derived->declared_at);
4781 if (tb_io_st != NULL)
4782 check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
4785 /* Check generic DTIO interfaces. */
4786 for (code = 0; code < 4; code++)
4788 formatted = ((dtio_codes)code == DTIO_RF)
4789 || ((dtio_codes)code == DTIO_WF);
4791 tb_io_st = gfc_find_symtree (derived->ns->sym_root,
4792 gfc_code2string (dtio_procs, code));
4793 if (tb_io_st != NULL)
4794 check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
4800 gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
4802 gfc_symtree *tb_io_st = NULL;
4803 gfc_symbol *dtio_sub = NULL;
4804 gfc_symbol *extended;
4805 gfc_typebound_proc *tb_io_proc, *specific_proc;
4808 if (!derived || derived->attr.flavor != FL_DERIVED)
4811 /* Try to find a typebound DTIO binding. */
4812 if (formatted == true)
4815 tb_io_st = gfc_find_typebound_proc (derived, &t,
4816 gfc_code2string (dtio_procs,
4819 &derived->declared_at);
4821 tb_io_st = gfc_find_typebound_proc (derived, &t,
4822 gfc_code2string (dtio_procs,
4825 &derived->declared_at);
4830 tb_io_st = gfc_find_typebound_proc (derived, &t,
4831 gfc_code2string (dtio_procs,
4834 &derived->declared_at);
4836 tb_io_st = gfc_find_typebound_proc (derived, &t,
4837 gfc_code2string (dtio_procs,
4840 &derived->declared_at);
4843 if (tb_io_st != NULL)
4845 const char *genname;
4848 tb_io_proc = tb_io_st->n.tb;
4849 gcc_assert (tb_io_proc != NULL);
4850 gcc_assert (tb_io_proc->is_generic);
4851 gcc_assert (tb_io_proc->u.generic->next == NULL);
4853 specific_proc = tb_io_proc->u.generic->specific;
4854 gcc_assert (!specific_proc->is_generic);
4856 /* Go back and make sure that we have the right specific procedure.
4857 Here we most likely have a procedure from the parent type, which
4858 can be overridden in extensions. */
4859 genname = tb_io_proc->u.generic->specific_st->name;
4860 st = gfc_find_typebound_proc (derived, NULL, genname,
4861 true, &tb_io_proc->where);
4863 dtio_sub = st->n.tb->u.specific->n.sym;
4865 dtio_sub = specific_proc->u.specific->n.sym;
4868 if (tb_io_st != NULL)
4871 /* If there is not a typebound binding, look for a generic
4873 for (extended = derived; extended;
4874 extended = gfc_get_derived_super_type (extended))
4876 if (extended == NULL || extended->ns == NULL)
4879 if (formatted == true)
4882 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
4883 gfc_code2string (dtio_procs,
4886 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
4887 gfc_code2string (dtio_procs,
4893 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
4894 gfc_code2string (dtio_procs,
4897 tb_io_st = gfc_find_symtree (extended->ns->sym_root,
4898 gfc_code2string (dtio_procs,
4902 if (tb_io_st != NULL
4904 && tb_io_st->n.sym->generic)
4906 gfc_interface *intr;
4907 for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
4909 gfc_symbol *fsym = intr->sym->formal->sym;
4910 if (intr->sym && intr->sym->formal
4911 && ((fsym->ts.type == BT_CLASS
4912 && CLASS_DATA (fsym)->ts.u.derived == extended)
4913 || (fsym->ts.type == BT_DERIVED
4914 && fsym->ts.u.derived == extended)))
4916 dtio_sub = intr->sym;
4924 if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
4925 gfc_find_derived_vtab (derived);