1 /* Deal with interfaces.
2 Copyright (C) 2000-2021 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 (strcmp (mode
, "formatted") == 0)
126 return INTRINSIC_FORMATTED
;
127 if (strcmp (mode
, "unformatted") == 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 %qs", 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 if (cmp1
->ts
.type
== BT_CHARACTER
&& cmp2
->ts
.type
== BT_CHARACTER
)
500 gfc_charlen
*l1
= cmp1
->ts
.u
.cl
;
501 gfc_charlen
*l2
= cmp2
->ts
.u
.cl
;
502 if (l1
&& l2
&& l1
->length
&& l2
->length
503 && l1
->length
->expr_type
== EXPR_CONSTANT
504 && l2
->length
->expr_type
== EXPR_CONSTANT
505 && gfc_dep_compare_expr (l1
->length
, l2
->length
) != 0)
509 /* Make sure that link lists do not put this function into an
510 endless recursive loop! */
511 if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
512 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
)
513 && !gfc_compare_types (&cmp1
->ts
, &cmp2
->ts
))
516 else if ( (cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
517 && !(cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
520 else if (!(cmp1
->ts
.type
== BT_DERIVED
&& derived1
== cmp1
->ts
.u
.derived
)
521 && (cmp2
->ts
.type
== BT_DERIVED
&& derived2
== cmp2
->ts
.u
.derived
))
528 /* Compare two union types by comparing the components of their maps.
529 Because unions and maps are anonymous their types get special internal
530 names; therefore the usual derived type comparison will fail on them.
532 Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
533 gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
534 definitions' than 'equivalent structure'. */
537 compare_union_types (gfc_symbol
*un1
, gfc_symbol
*un2
)
539 gfc_component
*map1
, *map2
, *cmp1
, *cmp2
;
540 gfc_symbol
*map1_t
, *map2_t
;
542 if (un1
->attr
.flavor
!= FL_UNION
|| un2
->attr
.flavor
!= FL_UNION
)
545 if (un1
->attr
.zero_comp
!= un2
->attr
.zero_comp
)
548 if (un1
->attr
.zero_comp
)
551 map1
= un1
->components
;
552 map2
= un2
->components
;
554 /* In terms of 'equality' here we are worried about types which are
555 declared the same in two places, not types that represent equivalent
556 structures. (This is common because of FORTRAN's weird scoping rules.)
557 Though two unions with their maps in different orders could be equivalent,
558 we will say they are not equal for the purposes of this test; therefore
559 we compare the maps sequentially. */
562 map1_t
= map1
->ts
.u
.derived
;
563 map2_t
= map2
->ts
.u
.derived
;
565 cmp1
= map1_t
->components
;
566 cmp2
= map2_t
->components
;
568 /* Protect against null components. */
569 if (map1_t
->attr
.zero_comp
!= map2_t
->attr
.zero_comp
)
572 if (map1_t
->attr
.zero_comp
)
577 /* No two fields will ever point to the same map type unless they are
578 the same component, because one map field is created with its type
579 declaration. Therefore don't worry about recursion here. */
580 /* TODO: worry about recursion into parent types of the unions? */
581 if (!compare_components (cmp1
, cmp2
, map1_t
, map2_t
))
587 if (cmp1
== NULL
&& cmp2
== NULL
)
589 if (cmp1
== NULL
|| cmp2
== NULL
)
596 if (map1
== NULL
&& map2
== NULL
)
598 if (map1
== NULL
|| map2
== NULL
)
607 /* Compare two derived types using the criteria in 4.4.2 of the standard,
608 recursing through gfc_compare_types for the components. */
611 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
613 gfc_component
*cmp1
, *cmp2
;
615 if (derived1
== derived2
)
618 if (!derived1
|| !derived2
)
619 gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
621 /* Compare UNION types specially. */
622 if (derived1
->attr
.flavor
== FL_UNION
|| derived2
->attr
.flavor
== FL_UNION
)
623 return compare_union_types (derived1
, derived2
);
625 /* Special case for comparing derived types across namespaces. If the
626 true names and module names are the same and the module name is
627 nonnull, then they are equal. */
628 if (strcmp (derived1
->name
, derived2
->name
) == 0
629 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
630 && strcmp (derived1
->module
, derived2
->module
) == 0)
633 /* Compare type via the rules of the standard. Both types must have
634 the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
635 because they can be anonymous; therefore two structures with different
636 names may be equal. */
638 /* Compare names, but not for anonymous types such as UNION or MAP. */
639 if (!is_anonymous_dt (derived1
) && !is_anonymous_dt (derived2
)
640 && strcmp (derived1
->name
, derived2
->name
) != 0)
643 if (derived1
->component_access
== ACCESS_PRIVATE
644 || derived2
->component_access
== ACCESS_PRIVATE
)
647 if (!(derived1
->attr
.sequence
&& derived2
->attr
.sequence
)
648 && !(derived1
->attr
.is_bind_c
&& derived2
->attr
.is_bind_c
)
649 && !(derived1
->attr
.pdt_type
&& derived2
->attr
.pdt_type
))
652 /* Protect against null components. */
653 if (derived1
->attr
.zero_comp
!= derived2
->attr
.zero_comp
)
656 if (derived1
->attr
.zero_comp
)
659 cmp1
= derived1
->components
;
660 cmp2
= derived2
->components
;
662 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
663 simple test can speed things up. Otherwise, lots of things have to
667 if (!compare_components (cmp1
, cmp2
, derived1
, derived2
))
673 if (cmp1
== NULL
&& cmp2
== NULL
)
675 if (cmp1
== NULL
|| cmp2
== NULL
)
683 /* Compare two typespecs, recursively if necessary. */
686 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
688 /* See if one of the typespecs is a BT_VOID, which is what is being used
689 to allow the funcs like c_f_pointer to accept any pointer type.
690 TODO: Possibly should narrow this to just the one typespec coming in
691 that is for the formal arg, but oh well. */
692 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
695 /* Special case for our C interop types. FIXME: There should be a
696 better way of doing this. When ISO C binding is cleared up,
697 this can probably be removed. See PR 57048. */
699 if (((ts1
->type
== BT_INTEGER
&& ts2
->type
== BT_DERIVED
)
700 || (ts1
->type
== BT_DERIVED
&& ts2
->type
== BT_INTEGER
))
701 && ts1
->u
.derived
&& ts2
->u
.derived
702 && ts1
->u
.derived
== ts2
->u
.derived
)
705 /* The _data component is not always present, therefore check for its
706 presence before assuming, that its derived->attr is available.
707 When the _data component is not present, then nevertheless the
708 unlimited_polymorphic flag may be set in the derived type's attr. */
709 if (ts1
->type
== BT_CLASS
&& ts1
->u
.derived
->components
710 && ((ts1
->u
.derived
->attr
.is_class
711 && ts1
->u
.derived
->components
->ts
.u
.derived
->attr
712 .unlimited_polymorphic
)
713 || ts1
->u
.derived
->attr
.unlimited_polymorphic
))
717 if (ts2
->type
== BT_CLASS
&& ts1
->type
== BT_DERIVED
718 && ts2
->u
.derived
->components
719 && ((ts2
->u
.derived
->attr
.is_class
720 && ts2
->u
.derived
->components
->ts
.u
.derived
->attr
721 .unlimited_polymorphic
)
722 || ts2
->u
.derived
->attr
.unlimited_polymorphic
)
723 && (ts1
->u
.derived
->attr
.sequence
|| ts1
->u
.derived
->attr
.is_bind_c
))
726 if (ts1
->type
!= ts2
->type
727 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
728 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
731 if (ts1
->type
== BT_UNION
)
732 return compare_union_types (ts1
->u
.derived
, ts2
->u
.derived
);
734 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
735 return (ts1
->kind
== ts2
->kind
);
737 /* Compare derived types. */
738 return gfc_type_compatible (ts1
, ts2
);
743 compare_type (gfc_symbol
*s1
, gfc_symbol
*s2
)
745 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
748 return gfc_compare_types (&s1
->ts
, &s2
->ts
) || s2
->ts
.type
== BT_ASSUMED
;
753 compare_type_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
)
755 /* TYPE and CLASS of the same declared type are type compatible,
756 but have different characteristics. */
757 if ((s1
->ts
.type
== BT_CLASS
&& s2
->ts
.type
== BT_DERIVED
)
758 || (s1
->ts
.type
== BT_DERIVED
&& s2
->ts
.type
== BT_CLASS
))
761 return compare_type (s1
, s2
);
766 compare_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
768 gfc_array_spec
*as1
, *as2
;
771 if (s2
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
774 as1
= (s1
->ts
.type
== BT_CLASS
775 && !s1
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
776 ? CLASS_DATA (s1
)->as
: s1
->as
;
777 as2
= (s2
->ts
.type
== BT_CLASS
778 && !s2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
779 ? CLASS_DATA (s2
)->as
: s2
->as
;
781 r1
= as1
? as1
->rank
: 0;
782 r2
= as2
? as2
->rank
: 0;
784 if (r1
!= r2
&& (!as2
|| as2
->type
!= AS_ASSUMED_RANK
))
785 return false; /* Ranks differ. */
791 /* Given two symbols that are formal arguments, compare their ranks
792 and types. Returns true if they have the same rank and type,
796 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
798 return compare_type (s1
, s2
) && compare_rank (s1
, s2
);
802 /* Given two symbols that are formal arguments, compare their types
803 and rank and their formal interfaces if they are both dummy
804 procedures. Returns true if the same, false if different. */
807 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
809 if (s1
== NULL
|| s2
== NULL
)
815 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
816 return compare_type_rank (s1
, s2
);
818 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
821 /* At this point, both symbols are procedures. It can happen that
822 external procedures are compared, where one is identified by usage
823 to be a function or subroutine but the other is not. Check TKR
824 nonetheless for these cases. */
825 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
826 return s1
->attr
.external
? compare_type_rank (s1
, s2
) : false;
828 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
829 return s2
->attr
.external
? compare_type_rank (s1
, s2
) : false;
831 /* Now the type of procedure has been identified. */
832 if (s1
->attr
.function
!= s2
->attr
.function
833 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
836 if (s1
->attr
.function
&& !compare_type_rank (s1
, s2
))
839 /* Originally, gfortran recursed here to check the interfaces of passed
840 procedures. This is explicitly not required by the standard. */
845 /* Given a formal argument list and a keyword name, search the list
846 for that keyword. Returns the correct symbol node if found, NULL
850 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
852 for (; f
; f
= f
->next
)
853 if (strcmp (f
->sym
->name
, name
) == 0)
860 /******** Interface checking subroutines **********/
863 /* Given an operator interface and the operator, make sure that all
864 interfaces for that operator are legal. */
867 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
870 gfc_formal_arglist
*formal
;
873 int args
, r1
, r2
, k1
, k2
;
878 t1
= t2
= BT_UNKNOWN
;
879 i1
= i2
= INTENT_UNKNOWN
;
883 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
885 gfc_symbol
*fsym
= formal
->sym
;
888 gfc_error ("Alternate return cannot appear in operator "
889 "interface at %L", &sym
->declared_at
);
895 i1
= fsym
->attr
.intent
;
896 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
902 i2
= fsym
->attr
.intent
;
903 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
909 /* Only +, - and .not. can be unary operators.
910 .not. cannot be a binary operator. */
911 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
912 && op
!= INTRINSIC_MINUS
913 && op
!= INTRINSIC_NOT
)
914 || (args
== 2 && op
== INTRINSIC_NOT
))
916 if (op
== INTRINSIC_ASSIGN
)
917 gfc_error ("Assignment operator interface at %L must have "
918 "two arguments", &sym
->declared_at
);
920 gfc_error ("Operator interface at %L has the wrong number of arguments",
925 /* Check that intrinsics are mapped to functions, except
926 INTRINSIC_ASSIGN which should map to a subroutine. */
927 if (op
== INTRINSIC_ASSIGN
)
929 gfc_formal_arglist
*dummy_args
;
931 if (!sym
->attr
.subroutine
)
933 gfc_error ("Assignment operator interface at %L must be "
934 "a SUBROUTINE", &sym
->declared_at
);
938 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
939 - First argument an array with different rank than second,
940 - First argument is a scalar and second an array,
941 - Types and kinds do not conform, or
942 - First argument is of derived type. */
943 dummy_args
= gfc_sym_get_dummy_args (sym
);
944 if (dummy_args
->sym
->ts
.type
!= BT_DERIVED
945 && dummy_args
->sym
->ts
.type
!= BT_CLASS
946 && (r2
== 0 || r1
== r2
)
947 && (dummy_args
->sym
->ts
.type
== dummy_args
->next
->sym
->ts
.type
948 || (gfc_numeric_ts (&dummy_args
->sym
->ts
)
949 && gfc_numeric_ts (&dummy_args
->next
->sym
->ts
))))
951 gfc_error ("Assignment operator interface at %L must not redefine "
952 "an INTRINSIC type assignment", &sym
->declared_at
);
958 if (!sym
->attr
.function
)
960 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
966 /* Check intents on operator interfaces. */
967 if (op
== INTRINSIC_ASSIGN
)
969 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
971 gfc_error ("First argument of defined assignment at %L must be "
972 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
978 gfc_error ("Second argument of defined assignment at %L must be "
979 "INTENT(IN)", &sym
->declared_at
);
987 gfc_error ("First argument of operator interface at %L must be "
988 "INTENT(IN)", &sym
->declared_at
);
992 if (args
== 2 && i2
!= INTENT_IN
)
994 gfc_error ("Second argument of operator interface at %L must be "
995 "INTENT(IN)", &sym
->declared_at
);
1000 /* From now on, all we have to do is check that the operator definition
1001 doesn't conflict with an intrinsic operator. The rules for this
1002 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
1003 as well as 12.3.2.1.1 of Fortran 2003:
1005 "If the operator is an intrinsic-operator (R310), the number of
1006 function arguments shall be consistent with the intrinsic uses of
1007 that operator, and the types, kind type parameters, or ranks of the
1008 dummy arguments shall differ from those required for the intrinsic
1009 operation (7.1.2)." */
1011 #define IS_NUMERIC_TYPE(t) \
1012 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
1014 /* Unary ops are easy, do them first. */
1015 if (op
== INTRINSIC_NOT
)
1017 if (t1
== BT_LOGICAL
)
1023 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
1025 if (IS_NUMERIC_TYPE (t1
))
1031 /* Character intrinsic operators have same character kind, thus
1032 operator definitions with operands of different character kinds
1034 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
1037 /* Intrinsic operators always perform on arguments of same rank,
1038 so different ranks is also always safe. (rank == 0) is an exception
1039 to that, because all intrinsic operators are elemental. */
1040 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
1046 case INTRINSIC_EQ_OS
:
1048 case INTRINSIC_NE_OS
:
1049 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1053 case INTRINSIC_PLUS
:
1054 case INTRINSIC_MINUS
:
1055 case INTRINSIC_TIMES
:
1056 case INTRINSIC_DIVIDE
:
1057 case INTRINSIC_POWER
:
1058 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
1063 case INTRINSIC_GT_OS
:
1065 case INTRINSIC_GE_OS
:
1067 case INTRINSIC_LT_OS
:
1069 case INTRINSIC_LE_OS
:
1070 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1072 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
1073 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
1077 case INTRINSIC_CONCAT
:
1078 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
1085 case INTRINSIC_NEQV
:
1086 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
1096 #undef IS_NUMERIC_TYPE
1099 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
1105 /* Given a pair of formal argument lists, we see if the two lists can
1106 be distinguished by counting the number of nonoptional arguments of
1107 a given type/rank in f1 and seeing if there are less then that
1108 number of those arguments in f2 (including optional arguments).
1109 Since this test is asymmetric, it has to be called twice to make it
1110 symmetric. Returns nonzero if the argument lists are incompatible
1111 by this test. This subroutine implements rule 1 of section F03:16.2.3.
1112 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1115 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1116 const char *p1
, const char *p2
)
1118 int ac1
, ac2
, i
, j
, k
, n1
;
1119 gfc_formal_arglist
*f
;
1132 for (f
= f1
; f
; f
= f
->next
)
1135 /* Build an array of integers that gives the same integer to
1136 arguments of the same type/rank. */
1137 arg
= XCNEWVEC (arginfo
, n1
);
1140 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
1143 arg
[i
].sym
= f
->sym
;
1148 for (i
= 0; i
< n1
; i
++)
1150 if (arg
[i
].flag
!= -1)
1153 if (arg
[i
].sym
&& (arg
[i
].sym
->attr
.optional
1154 || (p1
&& strcmp (arg
[i
].sym
->name
, p1
) == 0)))
1155 continue; /* Skip OPTIONAL and PASS arguments. */
1159 /* Find other non-optional, non-pass arguments of the same type/rank. */
1160 for (j
= i
+ 1; j
< n1
; j
++)
1161 if ((arg
[j
].sym
== NULL
1162 || !(arg
[j
].sym
->attr
.optional
1163 || (p1
&& strcmp (arg
[j
].sym
->name
, p1
) == 0)))
1164 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
1165 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
1171 /* Now loop over each distinct type found in f1. */
1175 for (i
= 0; i
< n1
; i
++)
1177 if (arg
[i
].flag
!= k
)
1181 for (j
= i
+ 1; j
< n1
; j
++)
1182 if (arg
[j
].flag
== k
)
1185 /* Count the number of non-pass arguments in f2 with that type,
1186 including those that are optional. */
1189 for (f
= f2
; f
; f
= f
->next
)
1190 if ((!p2
|| strcmp (f
->sym
->name
, p2
) != 0)
1191 && (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
1192 || compare_type_rank_if (f
->sym
, arg
[i
].sym
)))
1210 /* Returns true if two dummy arguments are distinguishable due to their POINTER
1211 and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
1212 The function is asymmetric wrt to the arguments s1 and s2 and should always
1213 be called twice (with flipped arguments in the second call). */
1216 compare_ptr_alloc(gfc_symbol
*s1
, gfc_symbol
*s2
)
1218 /* Is s1 allocatable? */
1219 const bool a1
= s1
->ts
.type
== BT_CLASS
?
1220 CLASS_DATA(s1
)->attr
.allocatable
: s1
->attr
.allocatable
;
1221 /* Is s2 a pointer? */
1222 const bool p2
= s2
->ts
.type
== BT_CLASS
?
1223 CLASS_DATA(s2
)->attr
.class_pointer
: s2
->attr
.pointer
;
1224 return a1
&& p2
&& (s2
->attr
.intent
!= INTENT_IN
);
1228 /* Perform the correspondence test in rule (3) of F08:C1215.
1229 Returns zero if no argument is found that satisfies this rule,
1230 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1233 This test is also not symmetric in f1 and f2 and must be called
1234 twice. This test finds problems caused by sorting the actual
1235 argument list with keywords. For example:
1239 INTEGER :: A ; REAL :: B
1243 INTEGER :: A ; REAL :: B
1247 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
1250 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
,
1251 const char *p1
, const char *p2
)
1253 gfc_formal_arglist
*f2_save
, *g
;
1260 if (!f1
->sym
|| f1
->sym
->attr
.optional
)
1263 if (p1
&& strcmp (f1
->sym
->name
, p1
) == 0)
1265 if (f2
&& p2
&& strcmp (f2
->sym
->name
, p2
) == 0)
1268 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
1269 || compare_type_rank (f2
->sym
, f1
->sym
))
1270 && !((gfc_option
.allow_std
& GFC_STD_F2008
)
1271 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1272 || compare_ptr_alloc(f2
->sym
, f1
->sym
))))
1275 /* Now search for a disambiguating keyword argument starting at
1276 the current non-match. */
1277 for (g
= f1
; g
; g
= g
->next
)
1279 if (g
->sym
->attr
.optional
|| (p1
&& strcmp (g
->sym
->name
, p1
) == 0))
1282 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
1283 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
)
1284 || ((gfc_option
.allow_std
& GFC_STD_F2008
)
1285 && (compare_ptr_alloc(sym
, g
->sym
)
1286 || compare_ptr_alloc(g
->sym
, sym
))))
1302 symbol_rank (gfc_symbol
*sym
)
1304 gfc_array_spec
*as
= NULL
;
1306 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1307 as
= CLASS_DATA (sym
)->as
;
1311 return as
? as
->rank
: 0;
1315 /* Check if the characteristics of two dummy arguments match,
1319 gfc_check_dummy_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1320 bool type_must_agree
, char *errmsg
,
1323 if (s1
== NULL
|| s2
== NULL
)
1324 return s1
== s2
? true : false;
1326 /* Check type and rank. */
1327 if (type_must_agree
)
1329 if (!compare_type_characteristics (s1
, s2
)
1330 || !compare_type_characteristics (s2
, s1
))
1332 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' (%s/%s)",
1333 s1
->name
, gfc_dummy_typename (&s1
->ts
),
1334 gfc_dummy_typename (&s2
->ts
));
1337 if (!compare_rank (s1
, s2
))
1339 snprintf (errmsg
, err_len
, "Rank mismatch in argument '%s' (%i/%i)",
1340 s1
->name
, symbol_rank (s1
), symbol_rank (s2
));
1346 if (s1
->attr
.intent
!= s2
->attr
.intent
&& !s1
->attr
.artificial
1347 && !s2
->attr
.artificial
)
1349 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1354 /* Check OPTIONAL attribute. */
1355 if (s1
->attr
.optional
!= s2
->attr
.optional
)
1357 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1362 /* Check ALLOCATABLE attribute. */
1363 if (s1
->attr
.allocatable
!= s2
->attr
.allocatable
)
1365 snprintf (errmsg
, err_len
, "ALLOCATABLE mismatch in argument '%s'",
1370 /* Check POINTER attribute. */
1371 if (s1
->attr
.pointer
!= s2
->attr
.pointer
)
1373 snprintf (errmsg
, err_len
, "POINTER mismatch in argument '%s'",
1378 /* Check TARGET attribute. */
1379 if (s1
->attr
.target
!= s2
->attr
.target
)
1381 snprintf (errmsg
, err_len
, "TARGET mismatch in argument '%s'",
1386 /* Check ASYNCHRONOUS attribute. */
1387 if (s1
->attr
.asynchronous
!= s2
->attr
.asynchronous
)
1389 snprintf (errmsg
, err_len
, "ASYNCHRONOUS mismatch in argument '%s'",
1394 /* Check CONTIGUOUS attribute. */
1395 if (s1
->attr
.contiguous
!= s2
->attr
.contiguous
)
1397 snprintf (errmsg
, err_len
, "CONTIGUOUS mismatch in argument '%s'",
1402 /* Check VALUE attribute. */
1403 if (s1
->attr
.value
!= s2
->attr
.value
)
1405 snprintf (errmsg
, err_len
, "VALUE mismatch in argument '%s'",
1410 /* Check VOLATILE attribute. */
1411 if (s1
->attr
.volatile_
!= s2
->attr
.volatile_
)
1413 snprintf (errmsg
, err_len
, "VOLATILE mismatch in argument '%s'",
1418 /* Check interface of dummy procedures. */
1419 if (s1
->attr
.flavor
== FL_PROCEDURE
)
1422 if (!gfc_compare_interfaces (s1
, s2
, s2
->name
, 0, 1, err
, sizeof(err
),
1425 snprintf (errmsg
, err_len
, "Interface mismatch in dummy procedure "
1426 "'%s': %s", s1
->name
, err
);
1431 /* Check string length. */
1432 if (s1
->ts
.type
== BT_CHARACTER
1433 && s1
->ts
.u
.cl
&& s1
->ts
.u
.cl
->length
1434 && s2
->ts
.u
.cl
&& s2
->ts
.u
.cl
->length
)
1436 int compval
= gfc_dep_compare_expr (s1
->ts
.u
.cl
->length
,
1437 s2
->ts
.u
.cl
->length
);
1443 snprintf (errmsg
, err_len
, "Character length mismatch "
1444 "in argument '%s'", s1
->name
);
1448 /* FIXME: Implement a warning for this case.
1449 gfc_warning (0, "Possible character length mismatch in argument %qs",
1457 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1458 "%i of gfc_dep_compare_expr", compval
);
1463 /* Check array shape. */
1464 if (s1
->as
&& s2
->as
)
1467 gfc_expr
*shape1
, *shape2
;
1469 /* Sometimes the ambiguity between deferred shape and assumed shape
1470 does not get resolved in module procedures, where the only explicit
1471 declaration of the dummy is in the interface. */
1472 if (s1
->ns
->proc_name
&& s1
->ns
->proc_name
->attr
.module_procedure
1473 && s1
->as
->type
== AS_ASSUMED_SHAPE
1474 && s2
->as
->type
== AS_DEFERRED
)
1476 s2
->as
->type
= AS_ASSUMED_SHAPE
;
1477 for (i
= 0; i
< s2
->as
->rank
; i
++)
1478 if (s1
->as
->lower
[i
] != NULL
)
1479 s2
->as
->lower
[i
] = gfc_copy_expr (s1
->as
->lower
[i
]);
1482 if (s1
->as
->type
!= s2
->as
->type
)
1484 snprintf (errmsg
, err_len
, "Shape mismatch in argument '%s'",
1489 if (s1
->as
->corank
!= s2
->as
->corank
)
1491 snprintf (errmsg
, err_len
, "Corank mismatch in argument '%s' (%i/%i)",
1492 s1
->name
, s1
->as
->corank
, s2
->as
->corank
);
1496 if (s1
->as
->type
== AS_EXPLICIT
)
1497 for (i
= 0; i
< s1
->as
->rank
+ MAX (0, s1
->as
->corank
-1); i
++)
1499 shape1
= gfc_subtract (gfc_copy_expr (s1
->as
->upper
[i
]),
1500 gfc_copy_expr (s1
->as
->lower
[i
]));
1501 shape2
= gfc_subtract (gfc_copy_expr (s2
->as
->upper
[i
]),
1502 gfc_copy_expr (s2
->as
->lower
[i
]));
1503 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1504 gfc_free_expr (shape1
);
1505 gfc_free_expr (shape2
);
1511 if (i
< s1
->as
->rank
)
1512 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of"
1513 " argument '%s'", i
+ 1, s1
->name
);
1515 snprintf (errmsg
, err_len
, "Shape mismatch in codimension %i "
1516 "of argument '%s'", i
- s1
->as
->rank
+ 1, s1
->name
);
1520 /* FIXME: Implement a warning for this case.
1521 gfc_warning (0, "Possible shape mismatch in argument %qs",
1529 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1530 "result %i of gfc_dep_compare_expr",
1541 /* Check if the characteristics of two function results match,
1545 gfc_check_result_characteristics (gfc_symbol
*s1
, gfc_symbol
*s2
,
1546 char *errmsg
, int err_len
)
1548 gfc_symbol
*r1
, *r2
;
1550 if (s1
->ts
.interface
&& s1
->ts
.interface
->result
)
1551 r1
= s1
->ts
.interface
->result
;
1553 r1
= s1
->result
? s1
->result
: s1
;
1555 if (s2
->ts
.interface
&& s2
->ts
.interface
->result
)
1556 r2
= s2
->ts
.interface
->result
;
1558 r2
= s2
->result
? s2
->result
: s2
;
1560 if (r1
->ts
.type
== BT_UNKNOWN
)
1563 /* Check type and rank. */
1564 if (!compare_type_characteristics (r1
, r2
))
1566 snprintf (errmsg
, err_len
, "Type mismatch in function result (%s/%s)",
1567 gfc_typename (&r1
->ts
), gfc_typename (&r2
->ts
));
1570 if (!compare_rank (r1
, r2
))
1572 snprintf (errmsg
, err_len
, "Rank mismatch in function result (%i/%i)",
1573 symbol_rank (r1
), symbol_rank (r2
));
1577 /* Check ALLOCATABLE attribute. */
1578 if (r1
->attr
.allocatable
!= r2
->attr
.allocatable
)
1580 snprintf (errmsg
, err_len
, "ALLOCATABLE attribute mismatch in "
1585 /* Check POINTER attribute. */
1586 if (r1
->attr
.pointer
!= r2
->attr
.pointer
)
1588 snprintf (errmsg
, err_len
, "POINTER attribute mismatch in "
1593 /* Check CONTIGUOUS attribute. */
1594 if (r1
->attr
.contiguous
!= r2
->attr
.contiguous
)
1596 snprintf (errmsg
, err_len
, "CONTIGUOUS attribute mismatch in "
1601 /* Check PROCEDURE POINTER attribute. */
1602 if (r1
!= s1
&& r1
->attr
.proc_pointer
!= r2
->attr
.proc_pointer
)
1604 snprintf (errmsg
, err_len
, "PROCEDURE POINTER mismatch in "
1609 /* Check string length. */
1610 if (r1
->ts
.type
== BT_CHARACTER
&& r1
->ts
.u
.cl
&& r2
->ts
.u
.cl
)
1612 if (r1
->ts
.deferred
!= r2
->ts
.deferred
)
1614 snprintf (errmsg
, err_len
, "Character length mismatch "
1615 "in function result");
1619 if (r1
->ts
.u
.cl
->length
&& r2
->ts
.u
.cl
->length
)
1621 int compval
= gfc_dep_compare_expr (r1
->ts
.u
.cl
->length
,
1622 r2
->ts
.u
.cl
->length
);
1628 snprintf (errmsg
, err_len
, "Character length mismatch "
1629 "in function result");
1633 /* FIXME: Implement a warning for this case.
1634 snprintf (errmsg, err_len, "Possible character length mismatch "
1635 "in function result");*/
1642 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1643 "result %i of gfc_dep_compare_expr", compval
);
1649 /* Check array shape. */
1650 if (!r1
->attr
.allocatable
&& !r1
->attr
.pointer
&& r1
->as
&& r2
->as
)
1653 gfc_expr
*shape1
, *shape2
;
1655 if (r1
->as
->type
!= r2
->as
->type
)
1657 snprintf (errmsg
, err_len
, "Shape mismatch in function result");
1661 if (r1
->as
->type
== AS_EXPLICIT
)
1662 for (i
= 0; i
< r1
->as
->rank
+ r1
->as
->corank
; i
++)
1664 shape1
= gfc_subtract (gfc_copy_expr (r1
->as
->upper
[i
]),
1665 gfc_copy_expr (r1
->as
->lower
[i
]));
1666 shape2
= gfc_subtract (gfc_copy_expr (r2
->as
->upper
[i
]),
1667 gfc_copy_expr (r2
->as
->lower
[i
]));
1668 compval
= gfc_dep_compare_expr (shape1
, shape2
);
1669 gfc_free_expr (shape1
);
1670 gfc_free_expr (shape2
);
1676 snprintf (errmsg
, err_len
, "Shape mismatch in dimension %i of "
1677 "function result", i
+ 1);
1681 /* FIXME: Implement a warning for this case.
1682 gfc_warning (0, "Possible shape mismatch in return value");*/
1689 gfc_internal_error ("check_result_characteristics (2): "
1690 "Unexpected result %i of "
1691 "gfc_dep_compare_expr", compval
);
1701 /* 'Compare' two formal interfaces associated with a pair of symbols.
1702 We return true if there exists an actual argument list that
1703 would be ambiguous between the two interfaces, zero otherwise.
1704 'strict_flag' specifies whether all the characteristics are
1705 required to match, which is not the case for ambiguity checks.
1706 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1709 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
1710 int generic_flag
, int strict_flag
,
1711 char *errmsg
, int err_len
,
1712 const char *p1
, const char *p2
,
1713 bool *bad_result_characteristics
)
1715 gfc_formal_arglist
*f1
, *f2
;
1717 gcc_assert (name2
!= NULL
);
1719 if (bad_result_characteristics
)
1720 *bad_result_characteristics
= false;
1722 if (s1
->attr
.function
&& (s2
->attr
.subroutine
1723 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
1724 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1727 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1731 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1734 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1738 /* Do strict checks on all characteristics
1739 (for dummy procedures and procedure pointer assignments). */
1740 if (!generic_flag
&& strict_flag
)
1742 if (s1
->attr
.function
&& s2
->attr
.function
)
1744 /* If both are functions, check result characteristics. */
1745 if (!gfc_check_result_characteristics (s1
, s2
, errmsg
, err_len
)
1746 || !gfc_check_result_characteristics (s2
, s1
, errmsg
, err_len
))
1748 if (bad_result_characteristics
)
1749 *bad_result_characteristics
= true;
1754 if (s1
->attr
.pure
&& !s2
->attr
.pure
)
1756 snprintf (errmsg
, err_len
, "Mismatch in PURE attribute");
1759 if (s1
->attr
.elemental
&& !s2
->attr
.elemental
)
1761 snprintf (errmsg
, err_len
, "Mismatch in ELEMENTAL attribute");
1766 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1767 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1770 f1
= gfc_sym_get_dummy_args (s1
);
1771 f2
= gfc_sym_get_dummy_args (s2
);
1773 /* Special case: No arguments. */
1774 if (f1
== NULL
&& f2
== NULL
)
1779 if (count_types_test (f1
, f2
, p1
, p2
)
1780 || count_types_test (f2
, f1
, p2
, p1
))
1783 /* Special case: alternate returns. If both f1->sym and f2->sym are
1784 NULL, then the leading formal arguments are alternate returns.
1785 The previous conditional should catch argument lists with
1786 different number of argument. */
1787 if (f1
&& f1
->sym
== NULL
&& f2
&& f2
->sym
== NULL
)
1790 if (generic_correspondence (f1
, f2
, p1
, p2
)
1791 || generic_correspondence (f2
, f1
, p2
, p1
))
1795 /* Perform the abbreviated correspondence test for operators (the
1796 arguments cannot be optional and are always ordered correctly).
1797 This is also done when comparing interfaces for dummy procedures and in
1798 procedure pointer assignments. */
1800 for (; f1
|| f2
; f1
= f1
->next
, f2
= f2
->next
)
1802 /* Check existence. */
1803 if (f1
== NULL
|| f2
== NULL
)
1806 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1807 "arguments", name2
);
1813 /* Check all characteristics. */
1814 if (!gfc_check_dummy_characteristics (f1
->sym
, f2
->sym
, true,
1820 /* Operators: Only check type and rank of arguments. */
1821 if (!compare_type (f2
->sym
, f1
->sym
))
1824 snprintf (errmsg
, err_len
, "Type mismatch in argument '%s' "
1825 "(%s/%s)", f1
->sym
->name
,
1826 gfc_typename (&f1
->sym
->ts
),
1827 gfc_typename (&f2
->sym
->ts
));
1830 if (!compare_rank (f2
->sym
, f1
->sym
))
1833 snprintf (errmsg
, err_len
, "Rank mismatch in argument "
1834 "'%s' (%i/%i)", f1
->sym
->name
,
1835 symbol_rank (f1
->sym
), symbol_rank (f2
->sym
));
1838 if ((gfc_option
.allow_std
& GFC_STD_F2008
)
1839 && (compare_ptr_alloc(f1
->sym
, f2
->sym
)
1840 || compare_ptr_alloc(f2
->sym
, f1
->sym
)))
1843 snprintf (errmsg
, err_len
, "Mismatching POINTER/ALLOCATABLE "
1844 "attribute in argument '%s' ", f1
->sym
->name
);
1854 /* Given a pointer to an interface pointer, remove duplicate
1855 interfaces and make sure that all symbols are either functions
1856 or subroutines, and all of the same kind. Returns true if
1857 something goes wrong. */
1860 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1862 gfc_interface
*psave
, *q
, *qlast
;
1865 for (; p
; p
= p
->next
)
1867 /* Make sure all symbols in the interface have been defined as
1868 functions or subroutines. */
1869 if (((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1870 || !p
->sym
->attr
.if_source
)
1871 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1874 = gfc_lookup_function_fuzzy (p
->sym
->name
, p
->sym
->ns
->sym_root
);
1876 if (p
->sym
->attr
.external
)
1878 gfc_error ("Procedure %qs in %s at %L has no explicit interface"
1879 "; did you mean %qs?",
1880 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
,
1883 gfc_error ("Procedure %qs in %s at %L has no explicit interface",
1884 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1887 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1888 "subroutine; did you mean %qs?", p
->sym
->name
,
1889 interface_name
, &p
->sym
->declared_at
, guessed
);
1891 gfc_error ("Procedure %qs in %s at %L is neither function nor "
1892 "subroutine", p
->sym
->name
, interface_name
,
1893 &p
->sym
->declared_at
);
1897 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1898 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
1899 && !gfc_fl_struct (p
->sym
->attr
.flavor
))
1900 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1902 if (!gfc_fl_struct (p
->sym
->attr
.flavor
))
1903 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1904 " or all FUNCTIONs", interface_name
,
1905 &p
->sym
->declared_at
);
1906 else if (p
->sym
->attr
.flavor
== FL_DERIVED
)
1907 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1908 "generic name is also the name of a derived type",
1909 interface_name
, &p
->sym
->declared_at
);
1913 /* F2003, C1207. F2008, C1207. */
1914 if (p
->sym
->attr
.proc
== PROC_INTERNAL
1915 && !gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
1916 "%qs in %s at %L", p
->sym
->name
,
1917 interface_name
, &p
->sym
->declared_at
))
1922 /* Remove duplicate interfaces in this interface list. */
1923 for (; p
; p
= p
->next
)
1927 for (q
= p
->next
; q
;)
1929 if (p
->sym
!= q
->sym
)
1936 /* Duplicate interface. */
1937 qlast
->next
= q
->next
;
1948 /* Check lists of interfaces to make sure that no two interfaces are
1949 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1952 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1953 int generic_flag
, const char *interface_name
,
1957 for (; p
; p
= p
->next
)
1958 for (q
= q0
; q
; q
= q
->next
)
1960 if (p
->sym
== q
->sym
)
1961 continue; /* Duplicates OK here. */
1963 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1966 if (!gfc_fl_struct (p
->sym
->attr
.flavor
)
1967 && !gfc_fl_struct (q
->sym
->attr
.flavor
)
1968 && gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
,
1969 generic_flag
, 0, NULL
, 0, NULL
, NULL
))
1972 gfc_error ("Ambiguous interfaces in %s for %qs at %L "
1973 "and %qs at %L", interface_name
,
1974 q
->sym
->name
, &q
->sym
->declared_at
,
1975 p
->sym
->name
, &p
->sym
->declared_at
);
1976 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1977 gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
1978 "and %qs at %L", interface_name
,
1979 q
->sym
->name
, &q
->sym
->declared_at
,
1980 p
->sym
->name
, &p
->sym
->declared_at
);
1982 gfc_warning (0, "Although not referenced, %qs has ambiguous "
1983 "interfaces at %L", interface_name
, &p
->where
);
1991 /* Check the generic and operator interfaces of symbols to make sure
1992 that none of the interfaces conflict. The check has to be done
1993 after all of the symbols are actually loaded. */
1996 check_sym_interfaces (gfc_symbol
*sym
)
1998 /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */
1999 char interface_name
[2*GFC_MAX_SYMBOL_LEN
+2 + sizeof("generic interface ''")];
2002 if (sym
->ns
!= gfc_current_ns
)
2005 if (sym
->generic
!= NULL
)
2007 size_t len
= strlen (sym
->name
) + sizeof("generic interface ''");
2008 gcc_assert (len
< sizeof (interface_name
));
2009 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
2010 if (check_interface0 (sym
->generic
, interface_name
))
2013 for (p
= sym
->generic
; p
; p
= p
->next
)
2015 if (p
->sym
->attr
.mod_proc
2016 && !p
->sym
->attr
.module_procedure
2017 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
2018 || p
->sym
->attr
.procedure
))
2020 gfc_error ("%qs at %L is not a module procedure",
2021 p
->sym
->name
, &p
->where
);
2026 /* Originally, this test was applied to host interfaces too;
2027 this is incorrect since host associated symbols, from any
2028 source, cannot be ambiguous with local symbols. */
2029 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
2030 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
2036 check_uop_interfaces (gfc_user_op
*uop
)
2038 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("operator interface ''")];
2042 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
2043 if (check_interface0 (uop
->op
, interface_name
))
2046 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2048 uop2
= gfc_find_uop (uop
->name
, ns
);
2052 check_interface1 (uop
->op
, uop2
->op
, 0,
2053 interface_name
, true);
2057 /* Given an intrinsic op, return an equivalent op if one exists,
2058 or INTRINSIC_NONE otherwise. */
2061 gfc_equivalent_op (gfc_intrinsic_op op
)
2066 return INTRINSIC_EQ_OS
;
2068 case INTRINSIC_EQ_OS
:
2069 return INTRINSIC_EQ
;
2072 return INTRINSIC_NE_OS
;
2074 case INTRINSIC_NE_OS
:
2075 return INTRINSIC_NE
;
2078 return INTRINSIC_GT_OS
;
2080 case INTRINSIC_GT_OS
:
2081 return INTRINSIC_GT
;
2084 return INTRINSIC_GE_OS
;
2086 case INTRINSIC_GE_OS
:
2087 return INTRINSIC_GE
;
2090 return INTRINSIC_LT_OS
;
2092 case INTRINSIC_LT_OS
:
2093 return INTRINSIC_LT
;
2096 return INTRINSIC_LE_OS
;
2098 case INTRINSIC_LE_OS
:
2099 return INTRINSIC_LE
;
2102 return INTRINSIC_NONE
;
2106 /* For the namespace, check generic, user operator and intrinsic
2107 operator interfaces for consistency and to remove duplicate
2108 interfaces. We traverse the whole namespace, counting on the fact
2109 that most symbols will not have generic or operator interfaces. */
2112 gfc_check_interfaces (gfc_namespace
*ns
)
2114 gfc_namespace
*old_ns
, *ns2
;
2115 char interface_name
[GFC_MAX_SYMBOL_LEN
+ sizeof("intrinsic '' operator")];
2118 old_ns
= gfc_current_ns
;
2119 gfc_current_ns
= ns
;
2121 gfc_traverse_ns (ns
, check_sym_interfaces
);
2123 gfc_traverse_user_op (ns
, check_uop_interfaces
);
2125 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
2127 if (i
== INTRINSIC_USER
)
2130 if (i
== INTRINSIC_ASSIGN
)
2131 strcpy (interface_name
, "intrinsic assignment operator");
2133 sprintf (interface_name
, "intrinsic '%s' operator",
2134 gfc_op2string ((gfc_intrinsic_op
) i
));
2136 if (check_interface0 (ns
->op
[i
], interface_name
))
2140 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
2143 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
2145 gfc_intrinsic_op other_op
;
2147 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
2148 interface_name
, true))
2151 /* i should be gfc_intrinsic_op, but has to be int with this cast
2152 here for stupid C++ compatibility rules. */
2153 other_op
= gfc_equivalent_op ((gfc_intrinsic_op
) i
);
2154 if (other_op
!= INTRINSIC_NONE
2155 && check_interface1 (ns
->op
[i
], ns2
->op
[other_op
],
2156 0, interface_name
, true))
2162 gfc_current_ns
= old_ns
;
2166 /* Given a symbol of a formal argument list and an expression, if the
2167 formal argument is allocatable, check that the actual argument is
2168 allocatable. Returns true if compatible, zero if not compatible. */
2171 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
2173 if (formal
->attr
.allocatable
2174 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
2176 symbol_attribute attr
= gfc_expr_attr (actual
);
2177 if (actual
->ts
.type
== BT_CLASS
&& !attr
.class_ok
)
2179 else if (!attr
.allocatable
)
2187 /* Given a symbol of a formal argument list and an expression, if the
2188 formal argument is a pointer, see if the actual argument is a
2189 pointer. Returns nonzero if compatible, zero if not compatible. */
2192 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
2194 symbol_attribute attr
;
2196 if (formal
->attr
.pointer
2197 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)
2198 && CLASS_DATA (formal
)->attr
.class_pointer
))
2200 attr
= gfc_expr_attr (actual
);
2202 /* Fortran 2008 allows non-pointer actual arguments. */
2203 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
2214 /* Emit clear error messages for rank mismatch. */
2217 argument_rank_mismatch (const char *name
, locus
*where
,
2218 int rank1
, int rank2
, locus
*where_formal
)
2221 /* TS 29113, C407b. */
2222 if (where_formal
== NULL
)
2225 gfc_error ("The assumed-rank array at %L requires that the dummy "
2226 "argument %qs has assumed-rank", where
, name
);
2227 else if (rank1
== 0)
2228 gfc_error_opt (0, "Rank mismatch in argument %qs "
2229 "at %L (scalar and rank-%d)", name
, where
, rank2
);
2230 else if (rank2
== 0)
2231 gfc_error_opt (0, "Rank mismatch in argument %qs "
2232 "at %L (rank-%d and scalar)", name
, where
, rank1
);
2234 gfc_error_opt (0, "Rank mismatch in argument %qs "
2235 "at %L (rank-%d and rank-%d)", name
, where
, rank1
,
2240 gcc_assert (rank2
!= -1);
2242 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2243 "and actual argument at %L (scalar and rank-%d)",
2244 where
, where_formal
, rank2
);
2245 else if (rank2
== 0)
2246 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2247 "and actual argument at %L (rank-%d and scalar)",
2248 where
, where_formal
, rank1
);
2250 gfc_error_opt (0, "Rank mismatch between actual argument at %L "
2251 "and actual argument at %L (rank-%d and rank-%d)", where
,
2252 where_formal
, rank1
, rank2
);
2257 /* Under certain conditions, a scalar actual argument can be passed
2258 to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
2259 This function returns true for these conditions so that an error
2260 or warning for this can be suppressed later. Always return false
2261 for expressions with rank > 0. */
2264 maybe_dummy_array_arg (gfc_expr
*e
)
2268 bool array_pointer
= false;
2269 bool assumed_shape
= false;
2270 bool scalar_ref
= true;
2275 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
== 1)
2278 /* If this comes from a constructor, it has been an array element
2281 if (e
->expr_type
== EXPR_CONSTANT
)
2282 return e
->from_constructor
;
2284 if (e
->expr_type
!= EXPR_VARIABLE
)
2287 s
= e
->symtree
->n
.sym
;
2289 if (s
->attr
.dimension
)
2292 array_pointer
= s
->attr
.pointer
;
2295 if (s
->as
&& s
->as
->type
== AS_ASSUMED_SHAPE
)
2296 assumed_shape
= true;
2298 for (ref
=e
->ref
; ref
; ref
=ref
->next
)
2300 if (ref
->type
== REF_COMPONENT
)
2302 symbol_attribute
*attr
;
2303 attr
= &ref
->u
.c
.component
->attr
;
2304 if (attr
->dimension
)
2306 array_pointer
= attr
->pointer
;
2307 assumed_shape
= false;
2315 return !(scalar_ref
|| array_pointer
|| assumed_shape
);
2318 /* Given a symbol of a formal argument list and an expression, see if
2319 the two are compatible as arguments. Returns true if
2320 compatible, false if not compatible. */
2323 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
2324 int ranks_must_agree
, int is_elemental
, locus
*where
)
2327 bool rank_check
, is_pointer
;
2330 bool codimension
= false;
2332 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
2333 procs c_f_pointer or c_f_procpointer, and we need to accept most
2334 pointers the user could give us. This should allow that. */
2335 if (formal
->ts
.type
== BT_VOID
)
2338 if (formal
->ts
.type
== BT_DERIVED
2339 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
2340 && actual
->ts
.type
== BT_DERIVED
2341 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
2344 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
2345 /* Make sure the vtab symbol is present when
2346 the module variables are generated. */
2347 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
2349 if (actual
->ts
.type
== BT_PROCEDURE
)
2351 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
2353 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
2356 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
2360 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
2361 sizeof(err
), NULL
, NULL
))
2364 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2365 " %s", formal
->name
, &actual
->where
, err
);
2369 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
2371 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
2372 &act_sym
->declared_at
);
2373 if (act_sym
->ts
.type
== BT_UNKNOWN
2374 && !gfc_set_default_type (act_sym
, 1, act_sym
->ns
))
2377 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
2378 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
2379 &act_sym
->declared_at
);
2384 ppc
= gfc_get_proc_ptr_comp (actual
);
2385 if (ppc
&& ppc
->ts
.interface
)
2387 if (!gfc_compare_interfaces (formal
, ppc
->ts
.interface
, ppc
->name
, 0, 1,
2388 err
, sizeof(err
), NULL
, NULL
))
2391 gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
2392 " %s", formal
->name
, &actual
->where
, err
);
2398 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
2399 && !gfc_is_simply_contiguous (actual
, true, false))
2402 gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
2403 "must be simply contiguous", formal
->name
, &actual
->where
);
2407 symbol_attribute actual_attr
= gfc_expr_attr (actual
);
2408 if (actual
->ts
.type
== BT_CLASS
&& !actual_attr
.class_ok
)
2411 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
2412 && actual
->ts
.type
!= BT_HOLLERITH
2413 && formal
->ts
.type
!= BT_ASSUMED
2414 && !(formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2415 && !gfc_compare_types (&formal
->ts
, &actual
->ts
)
2416 && !(formal
->ts
.type
== BT_DERIVED
&& actual
->ts
.type
== BT_CLASS
2417 && gfc_compare_derived_types (formal
->ts
.u
.derived
,
2418 CLASS_DATA (actual
)->ts
.u
.derived
)))
2422 if (formal
->attr
.artificial
)
2424 if (!flag_allow_argument_mismatch
|| !formal
->error
)
2425 gfc_error_opt (0, "Type mismatch between actual argument at %L "
2426 "and actual argument at %L (%s/%s).",
2428 &formal
->declared_at
,
2429 gfc_typename (actual
),
2430 gfc_dummy_typename (&formal
->ts
));
2435 gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
2436 "to %s", formal
->name
, where
, gfc_typename (actual
),
2437 gfc_dummy_typename (&formal
->ts
));
2442 if (actual
->ts
.type
== BT_ASSUMED
&& formal
->ts
.type
!= BT_ASSUMED
)
2445 gfc_error ("Assumed-type actual argument at %L requires that dummy "
2446 "argument %qs is of assumed type", &actual
->where
,
2451 /* F2008, 12.5.2.5; IR F08/0073. */
2452 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
2453 && actual
->expr_type
!= EXPR_NULL
2454 && ((CLASS_DATA (formal
)->attr
.class_pointer
2455 && formal
->attr
.intent
!= INTENT_IN
)
2456 || CLASS_DATA (formal
)->attr
.allocatable
))
2458 if (actual
->ts
.type
!= BT_CLASS
)
2461 gfc_error ("Actual argument to %qs at %L must be polymorphic",
2462 formal
->name
, &actual
->where
);
2466 if ((!UNLIMITED_POLY (formal
) || !UNLIMITED_POLY(actual
))
2467 && !gfc_compare_derived_types (CLASS_DATA (actual
)->ts
.u
.derived
,
2468 CLASS_DATA (formal
)->ts
.u
.derived
))
2471 gfc_error ("Actual argument to %qs at %L must have the same "
2472 "declared type", formal
->name
, &actual
->where
);
2477 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
2478 is necessary also for F03, so retain error for both.
2479 NOTE: Other type/kind errors pre-empt this error. Since they are F03
2480 compatible, no attempt has been made to channel to this one. */
2481 if (UNLIMITED_POLY (formal
) && !UNLIMITED_POLY (actual
)
2482 && (CLASS_DATA (formal
)->attr
.allocatable
2483 ||CLASS_DATA (formal
)->attr
.class_pointer
))
2486 gfc_error ("Actual argument to %qs at %L must be unlimited "
2487 "polymorphic since the formal argument is a "
2488 "pointer or allocatable unlimited polymorphic "
2489 "entity [F2008: 12.5.2.5]", formal
->name
,
2494 if (formal
->ts
.type
== BT_CLASS
&& formal
->attr
.class_ok
)
2495 codimension
= CLASS_DATA (formal
)->attr
.codimension
;
2497 codimension
= formal
->attr
.codimension
;
2499 if (codimension
&& !gfc_is_coarray (actual
))
2502 gfc_error ("Actual argument to %qs at %L must be a coarray",
2503 formal
->name
, &actual
->where
);
2507 if (codimension
&& formal
->attr
.allocatable
)
2509 gfc_ref
*last
= NULL
;
2511 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2512 if (ref
->type
== REF_COMPONENT
)
2515 /* F2008, 12.5.2.6. */
2516 if ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
2518 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
))
2521 gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
2522 formal
->name
, &actual
->where
, formal
->as
->corank
,
2523 last
? last
->u
.c
.component
->as
->corank
2524 : actual
->symtree
->n
.sym
->as
->corank
);
2531 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2532 /* F2018, 12.5.2.8. */
2533 if (formal
->attr
.dimension
2534 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
2535 && actual_attr
.dimension
2536 && !gfc_is_simply_contiguous (actual
, true, true))
2539 gfc_error ("Actual argument to %qs at %L must be simply "
2540 "contiguous or an element of such an array",
2541 formal
->name
, &actual
->where
);
2545 /* F2008, C1303 and C1304. */
2546 if (formal
->attr
.intent
!= INTENT_INOUT
2547 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2548 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2549 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2550 || formal
->attr
.lock_comp
))
2554 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2555 "which is LOCK_TYPE or has a LOCK_TYPE component",
2556 formal
->name
, &actual
->where
);
2560 /* TS18508, C702/C703. */
2561 if (formal
->attr
.intent
!= INTENT_INOUT
2562 && (((formal
->ts
.type
== BT_DERIVED
|| formal
->ts
.type
== BT_CLASS
)
2563 && formal
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2564 && formal
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2565 || formal
->attr
.event_comp
))
2569 gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
2570 "which is EVENT_TYPE or has a EVENT_TYPE component",
2571 formal
->name
, &actual
->where
);
2576 /* F2008, C1239/C1240. */
2577 if (actual
->expr_type
== EXPR_VARIABLE
2578 && (actual
->symtree
->n
.sym
->attr
.asynchronous
2579 || actual
->symtree
->n
.sym
->attr
.volatile_
)
2580 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
2581 && actual
->rank
&& formal
->as
2582 && !gfc_is_simply_contiguous (actual
, true, false)
2583 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
2584 && formal
->as
->type
!= AS_ASSUMED_RANK
&& !formal
->attr
.pointer
)
2585 || formal
->attr
.contiguous
))
2588 gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
2589 "assumed-rank array without CONTIGUOUS attribute - as actual"
2590 " argument at %L is not simply contiguous and both are "
2591 "ASYNCHRONOUS or VOLATILE", formal
->name
, &actual
->where
);
2595 if (formal
->attr
.allocatable
&& !codimension
2596 && actual_attr
.codimension
)
2598 if (formal
->attr
.intent
== INTENT_OUT
)
2601 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2602 "INTENT(OUT) dummy argument %qs", &actual
->where
,
2606 else if (warn_surprising
&& where
&& formal
->attr
.intent
!= INTENT_IN
)
2607 gfc_warning (OPT_Wsurprising
,
2608 "Passing coarray at %L to allocatable, noncoarray dummy "
2609 "argument %qs, which is invalid if the allocation status"
2610 " is modified", &actual
->where
, formal
->name
);
2613 /* If the rank is the same or the formal argument has assumed-rank. */
2614 if (symbol_rank (formal
) == actual
->rank
|| symbol_rank (formal
) == -1)
2617 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
2618 && (formal
->as
->type
== AS_ASSUMED_SHAPE
2619 || formal
->as
->type
== AS_DEFERRED
)
2620 && actual
->expr_type
!= EXPR_NULL
;
2622 /* Skip rank checks for NO_ARG_CHECK. */
2623 if (formal
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2626 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2627 if (rank_check
|| ranks_must_agree
2628 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
2629 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
2630 || (actual
->rank
== 0
2631 && ((formal
->ts
.type
== BT_CLASS
2632 && CLASS_DATA (formal
)->as
->type
== AS_ASSUMED_SHAPE
)
2633 || (formal
->ts
.type
!= BT_CLASS
2634 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
2635 && actual
->expr_type
!= EXPR_NULL
)
2636 || (actual
->rank
== 0 && formal
->attr
.dimension
2637 && gfc_is_coindexed (actual
)))
2640 && (!formal
->attr
.artificial
|| (!formal
->maybe_array
2641 && !maybe_dummy_array_arg (actual
))))
2643 locus
*where_formal
;
2644 if (formal
->attr
.artificial
)
2645 where_formal
= &formal
->declared_at
;
2647 where_formal
= NULL
;
2649 argument_rank_mismatch (formal
->name
, &actual
->where
,
2650 symbol_rank (formal
), actual
->rank
,
2655 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
2658 /* At this point, we are considering a scalar passed to an array. This
2659 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2660 - if the actual argument is (a substring of) an element of a
2661 non-assumed-shape/non-pointer/non-polymorphic array; or
2662 - (F2003) if the actual argument is of type character of default/c_char
2665 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
2666 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
2668 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
2670 if (ref
->type
== REF_COMPONENT
)
2671 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
2672 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2673 && ref
->u
.ar
.dimen
> 0
2675 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
2679 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
2682 gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
2683 "at %L", formal
->name
, &actual
->where
);
2687 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
2688 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2692 if (formal
->attr
.artificial
)
2693 gfc_error ("Element of assumed-shape or pointer array "
2694 "as actual argument at %L cannot correspond to "
2695 "actual argument at %L",
2696 &actual
->where
, &formal
->declared_at
);
2698 gfc_error ("Element of assumed-shape or pointer "
2699 "array passed to array dummy argument %qs at %L",
2700 formal
->name
, &actual
->where
);
2705 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
2706 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
2708 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
2711 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2712 "CHARACTER actual argument with array dummy argument "
2713 "%qs at %L", formal
->name
, &actual
->where
);
2717 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
2719 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2720 "array dummy argument %qs at %L",
2721 formal
->name
, &actual
->where
);
2725 return ((gfc_option
.allow_std
& GFC_STD_F2003
) != 0);
2728 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
2731 && (!formal
->attr
.artificial
|| (!formal
->maybe_array
2732 && !maybe_dummy_array_arg (actual
))))
2734 locus
*where_formal
;
2735 if (formal
->attr
.artificial
)
2736 where_formal
= &formal
->declared_at
;
2738 where_formal
= NULL
;
2740 argument_rank_mismatch (formal
->name
, &actual
->where
,
2741 symbol_rank (formal
), actual
->rank
,
2751 /* Returns the storage size of a symbol (formal argument) or
2752 zero if it cannot be determined. */
2754 static unsigned long
2755 get_sym_storage_size (gfc_symbol
*sym
)
2758 unsigned long strlen
, elements
;
2760 if (sym
->ts
.type
== BT_CHARACTER
)
2762 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
2763 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2764 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
2771 if (symbol_rank (sym
) == 0)
2775 if (sym
->as
->type
!= AS_EXPLICIT
)
2777 for (i
= 0; i
< sym
->as
->rank
; i
++)
2779 if (sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2780 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2783 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
2784 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
2787 return strlen
*elements
;
2791 /* Returns the storage size of an expression (actual argument) or
2792 zero if it cannot be determined. For an array element, it returns
2793 the remaining size as the element sequence consists of all storage
2794 units of the actual argument up to the end of the array. */
2796 static unsigned long
2797 get_expr_storage_size (gfc_expr
*e
)
2800 long int strlen
, elements
;
2801 long int substrlen
= 0;
2802 bool is_str_storage
= false;
2808 if (e
->ts
.type
== BT_CHARACTER
)
2810 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
2811 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2812 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
2813 else if (e
->expr_type
== EXPR_CONSTANT
2814 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
2815 strlen
= e
->value
.character
.length
;
2820 strlen
= 1; /* Length per element. */
2822 if (e
->rank
== 0 && !e
->ref
)
2830 for (i
= 0; i
< e
->rank
; i
++)
2831 elements
*= mpz_get_si (e
->shape
[i
]);
2832 return elements
*strlen
;
2835 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2837 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
2838 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
2842 /* The string length is the substring length.
2843 Set now to full string length. */
2844 if (!ref
->u
.ss
.length
|| !ref
->u
.ss
.length
->length
2845 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
2848 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
2850 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2854 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2855 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2857 long int start
, end
, stride
;
2860 if (ref
->u
.ar
.stride
[i
])
2862 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
2863 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
2868 if (ref
->u
.ar
.start
[i
])
2870 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
2871 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
2875 else if (ref
->u
.ar
.as
->lower
[i
]
2876 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
2877 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
2881 if (ref
->u
.ar
.end
[i
])
2883 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
2884 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
2888 else if (ref
->u
.ar
.as
->upper
[i
]
2889 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
2890 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
2894 elements
*= (end
- start
)/stride
+ 1L;
2896 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
)
2897 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
2899 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
2900 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2901 && ref
->u
.ar
.as
->lower
[i
]->ts
.type
== BT_INTEGER
2902 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2903 && ref
->u
.ar
.as
->upper
[i
]->ts
.type
== BT_INTEGER
)
2904 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2905 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2910 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
2911 && e
->expr_type
== EXPR_VARIABLE
)
2913 if (ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
2914 || e
->symtree
->n
.sym
->attr
.pointer
)
2920 /* Determine the number of remaining elements in the element
2921 sequence for array element designators. */
2922 is_str_storage
= true;
2923 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
2925 if (ref
->u
.ar
.start
[i
] == NULL
2926 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
2927 || ref
->u
.ar
.as
->upper
[i
] == NULL
2928 || ref
->u
.ar
.as
->lower
[i
] == NULL
2929 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2930 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2935 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
2936 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
2938 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
2939 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
2942 else if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.function
2943 && ref
->u
.c
.component
->attr
.proc_pointer
2944 && ref
->u
.c
.component
->attr
.dimension
)
2946 /* Array-valued procedure-pointer components. */
2947 gfc_array_spec
*as
= ref
->u
.c
.component
->as
;
2948 for (i
= 0; i
< as
->rank
; i
++)
2950 if (!as
->upper
[i
] || !as
->lower
[i
]
2951 || as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
2952 || as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
2956 * (mpz_get_si (as
->upper
[i
]->value
.integer
)
2957 - mpz_get_si (as
->lower
[i
]->value
.integer
) + 1L);
2963 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
2966 return elements
*strlen
;
2970 /* Given an expression, check whether it is an array section
2971 which has a vector subscript. */
2974 gfc_has_vector_subscript (gfc_expr
*e
)
2979 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
2982 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2983 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2984 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2985 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2993 is_procptr_result (gfc_expr
*expr
)
2995 gfc_component
*c
= gfc_get_proc_ptr_comp (expr
);
2997 return (c
->ts
.interface
&& (c
->ts
.interface
->attr
.proc_pointer
== 1));
2999 return ((expr
->symtree
->n
.sym
->result
!= expr
->symtree
->n
.sym
)
3000 && (expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
== 1));
3004 /* Recursively append candidate argument ARG to CANDIDATES. Store the
3005 number of total candidates in CANDIDATES_LEN. */
3008 lookup_arg_fuzzy_find_candidates (gfc_formal_arglist
*arg
,
3010 size_t &candidates_len
)
3012 for (gfc_formal_arglist
*p
= arg
; p
&& p
->sym
; p
= p
->next
)
3013 vec_push (candidates
, candidates_len
, p
->sym
->name
);
3017 /* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
3020 lookup_arg_fuzzy (const char *arg
, gfc_formal_arglist
*arguments
)
3022 char **candidates
= NULL
;
3023 size_t candidates_len
= 0;
3024 lookup_arg_fuzzy_find_candidates (arguments
, candidates
, candidates_len
);
3025 return gfc_closest_fuzzy_match (arg
, candidates
);
3029 /* Given formal and actual argument lists, see if they are compatible.
3030 If they are compatible, the actual argument list is sorted to
3031 correspond with the formal list, and elements for missing optional
3032 arguments are inserted. If WHERE pointer is nonnull, then we issue
3033 errors when things don't match instead of just returning the status
3037 gfc_compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
3038 int ranks_must_agree
, int is_elemental
,
3039 bool in_statement_function
, locus
*where
)
3041 gfc_actual_arglist
**new_arg
, *a
, *actual
;
3042 gfc_formal_arglist
*f
;
3044 unsigned long actual_size
, formal_size
;
3045 bool full_array
= false;
3046 gfc_array_ref
*actual_arr_ref
;
3050 if (actual
== NULL
&& formal
== NULL
)
3054 for (f
= formal
; f
; f
= f
->next
)
3057 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
3059 for (i
= 0; i
< n
; i
++)
3066 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
3068 if (a
->name
!= NULL
&& in_statement_function
)
3070 gfc_error ("Keyword argument %qs at %L is invalid in "
3071 "a statement function", a
->name
, &a
->expr
->where
);
3075 /* Look for keywords but ignore g77 extensions like %VAL. */
3076 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3079 for (f
= formal
; f
; f
= f
->next
, i
++)
3083 if (strcmp (f
->sym
->name
, a
->name
) == 0)
3091 const char *guessed
= lookup_arg_fuzzy (a
->name
, formal
);
3093 gfc_error ("Keyword argument %qs at %L is not in "
3094 "the procedure; did you mean %qs?",
3095 a
->name
, &a
->expr
->where
, guessed
);
3097 gfc_error ("Keyword argument %qs at %L is not in "
3098 "the procedure", a
->name
, &a
->expr
->where
);
3103 if (new_arg
[i
] != NULL
)
3106 gfc_error ("Keyword argument %qs at %L is already associated "
3107 "with another actual argument", a
->name
,
3116 gfc_error ("More actual than formal arguments in procedure "
3117 "call at %L", where
);
3122 if (f
->sym
== NULL
&& a
->expr
== NULL
)
3127 /* These errors have to be issued, otherwise an ICE can occur.
3130 gfc_error_now ("Missing alternate return specifier in subroutine "
3131 "call at %L", where
);
3135 if (a
->expr
== NULL
)
3137 if (f
->sym
->attr
.optional
)
3142 gfc_error_now ("Unexpected alternate return specifier in "
3143 "subroutine call at %L", where
);
3148 /* Make sure that intrinsic vtables exist for calls to unlimited
3149 polymorphic formal arguments. */
3150 if (UNLIMITED_POLY (f
->sym
)
3151 && a
->expr
->ts
.type
!= BT_DERIVED
3152 && a
->expr
->ts
.type
!= BT_CLASS
3153 && a
->expr
->ts
.type
!= BT_ASSUMED
)
3154 gfc_find_vtab (&a
->expr
->ts
);
3156 if (a
->expr
->expr_type
== EXPR_NULL
3157 && ((f
->sym
->ts
.type
!= BT_CLASS
&& !f
->sym
->attr
.pointer
3158 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
3159 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
3160 || (f
->sym
->ts
.type
== BT_CLASS
3161 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3162 && (CLASS_DATA (f
->sym
)->attr
.allocatable
3163 || !f
->sym
->attr
.optional
3164 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))))
3167 && (!f
->sym
->attr
.optional
3168 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.allocatable
)
3169 || (f
->sym
->ts
.type
== BT_CLASS
3170 && CLASS_DATA (f
->sym
)->attr
.allocatable
)))
3171 gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
3172 where
, f
->sym
->name
);
3174 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
3175 "dummy %qs", where
, f
->sym
->name
);
3180 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
3181 is_elemental
, where
))
3184 /* TS 29113, 6.3p2. */
3185 if (f
->sym
->ts
.type
== BT_ASSUMED
3186 && (a
->expr
->ts
.type
== BT_DERIVED
3187 || (a
->expr
->ts
.type
== BT_CLASS
&& CLASS_DATA (a
->expr
))))
3189 gfc_namespace
*f2k_derived
;
3191 f2k_derived
= a
->expr
->ts
.type
== BT_DERIVED
3192 ? a
->expr
->ts
.u
.derived
->f2k_derived
3193 : CLASS_DATA (a
->expr
)->ts
.u
.derived
->f2k_derived
;
3196 && (f2k_derived
->finalizers
|| f2k_derived
->tb_sym_root
))
3198 gfc_error ("Actual argument at %L to assumed-type dummy is of "
3199 "derived type with type-bound or FINAL procedures",
3205 /* Special case for character arguments. For allocatable, pointer
3206 and assumed-shape dummies, the string length needs to match
3208 if (a
->expr
->ts
.type
== BT_CHARACTER
3209 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
3210 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3211 && f
->sym
->ts
.type
== BT_CHARACTER
&& f
->sym
->ts
.u
.cl
3212 && f
->sym
->ts
.u
.cl
->length
3213 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3214 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
3215 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3216 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
3217 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
3219 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
3220 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
3221 "argument and pointer or allocatable dummy argument "
3223 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3224 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3225 f
->sym
->name
, &a
->expr
->where
);
3227 gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
3228 "argument and assumed-shape dummy argument %qs "
3230 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
3231 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
3232 f
->sym
->name
, &a
->expr
->where
);
3236 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
3237 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
3238 && a
->expr
->ts
.type
== BT_CHARACTER
)
3241 gfc_error ("Actual argument at %L to allocatable or "
3242 "pointer dummy argument %qs must have a deferred "
3243 "length type parameter if and only if the dummy has one",
3244 &a
->expr
->where
, f
->sym
->name
);
3248 if (f
->sym
->ts
.type
== BT_CLASS
)
3249 goto skip_size_check
;
3251 actual_size
= get_expr_storage_size (a
->expr
);
3252 formal_size
= get_sym_storage_size (f
->sym
);
3253 if (actual_size
!= 0 && actual_size
< formal_size
3254 && a
->expr
->ts
.type
!= BT_PROCEDURE
3255 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
)
3257 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
3259 gfc_warning (0, "Character length of actual argument shorter "
3260 "than of dummy argument %qs (%lu/%lu) at %L",
3261 f
->sym
->name
, actual_size
, formal_size
,
3263 goto skip_size_check
;
3267 /* Emit a warning for -std=legacy and an error otherwise. */
3268 if (gfc_option
.warn_std
== 0)
3269 gfc_warning (0, "Actual argument contains too few "
3270 "elements for dummy argument %qs (%lu/%lu) "
3271 "at %L", f
->sym
->name
, actual_size
,
3272 formal_size
, &a
->expr
->where
);
3274 gfc_error_now ("Actual argument contains too few "
3275 "elements for dummy argument %qs (%lu/%lu) "
3276 "at %L", f
->sym
->name
, actual_size
,
3277 formal_size
, &a
->expr
->where
);
3284 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
3285 argument is provided for a procedure pointer formal argument. */
3286 if (f
->sym
->attr
.proc_pointer
3287 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3288 && (a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3289 || gfc_is_proc_ptr_comp (a
->expr
)))
3290 || (a
->expr
->expr_type
== EXPR_FUNCTION
3291 && is_procptr_result (a
->expr
))))
3294 gfc_error ("Expected a procedure pointer for argument %qs at %L",
3295 f
->sym
->name
, &a
->expr
->where
);
3299 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
3300 provided for a procedure formal argument. */
3301 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
3302 && !((a
->expr
->expr_type
== EXPR_VARIABLE
3303 && (a
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3304 || a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3305 || gfc_is_proc_ptr_comp (a
->expr
)))
3306 || (a
->expr
->expr_type
== EXPR_FUNCTION
3307 && is_procptr_result (a
->expr
))))
3310 gfc_error ("Expected a procedure for argument %qs at %L",
3311 f
->sym
->name
, &a
->expr
->where
);
3316 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3317 || f
->sym
->as
->type
== AS_DEFERRED
3318 || (f
->sym
->as
->type
== AS_ASSUMED_RANK
&& f
->sym
->attr
.pointer
))
3319 && a
->expr
->expr_type
== EXPR_VARIABLE
3320 && a
->expr
->symtree
->n
.sym
->as
3321 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
3322 && (a
->expr
->ref
== NULL
3323 || (a
->expr
->ref
->type
== REF_ARRAY
3324 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
3327 gfc_error ("Actual argument for %qs cannot be an assumed-size"
3328 " array at %L", f
->sym
->name
, where
);
3332 if (a
->expr
->expr_type
!= EXPR_NULL
3333 && compare_pointer (f
->sym
, a
->expr
) == 0)
3336 gfc_error ("Actual argument for %qs must be a pointer at %L",
3337 f
->sym
->name
, &a
->expr
->where
);
3341 if (a
->expr
->expr_type
!= EXPR_NULL
3342 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
3343 && compare_pointer (f
->sym
, a
->expr
) == 2)
3346 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
3347 "pointer dummy %qs", &a
->expr
->where
,f
->sym
->name
);
3352 /* Fortran 2008, C1242. */
3353 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
3356 gfc_error ("Coindexed actual argument at %L to pointer "
3358 &a
->expr
->where
, f
->sym
->name
);
3362 /* Fortran 2008, 12.5.2.5 (no constraint). */
3363 if (a
->expr
->expr_type
== EXPR_VARIABLE
3364 && f
->sym
->attr
.intent
!= INTENT_IN
3365 && f
->sym
->attr
.allocatable
3366 && gfc_is_coindexed (a
->expr
))
3369 gfc_error ("Coindexed actual argument at %L to allocatable "
3370 "dummy %qs requires INTENT(IN)",
3371 &a
->expr
->where
, f
->sym
->name
);
3375 /* Fortran 2008, C1237. */
3376 if (a
->expr
->expr_type
== EXPR_VARIABLE
3377 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
3378 && gfc_is_coindexed (a
->expr
)
3379 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
3380 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
3383 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
3384 "%L requires that dummy %qs has neither "
3385 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
3390 /* Fortran 2008, 12.5.2.4 (no constraint). */
3391 if (a
->expr
->expr_type
== EXPR_VARIABLE
3392 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
3393 && gfc_is_coindexed (a
->expr
)
3394 && gfc_has_ultimate_allocatable (a
->expr
))
3397 gfc_error ("Coindexed actual argument at %L with allocatable "
3398 "ultimate component to dummy %qs requires either VALUE "
3399 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
3403 if (f
->sym
->ts
.type
== BT_CLASS
3404 && CLASS_DATA (f
->sym
)->attr
.allocatable
3405 && gfc_is_class_array_ref (a
->expr
, &full_array
)
3409 gfc_error ("Actual CLASS array argument for %qs must be a full "
3410 "array at %L", f
->sym
->name
, &a
->expr
->where
);
3415 if (a
->expr
->expr_type
!= EXPR_NULL
3416 && !compare_allocatable (f
->sym
, a
->expr
))
3419 gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
3420 f
->sym
->name
, &a
->expr
->where
);
3424 /* Check intent = OUT/INOUT for definable actual argument. */
3425 if (!in_statement_function
3426 && (f
->sym
->attr
.intent
== INTENT_OUT
3427 || f
->sym
->attr
.intent
== INTENT_INOUT
))
3429 const char* context
= (where
3430 ? _("actual argument to INTENT = OUT/INOUT")
3433 if (((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3434 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3435 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3436 && !gfc_check_vardef_context (a
->expr
, true, false, false, context
))
3438 if (!gfc_check_vardef_context (a
->expr
, false, false, false, context
))
3442 if ((f
->sym
->attr
.intent
== INTENT_OUT
3443 || f
->sym
->attr
.intent
== INTENT_INOUT
3444 || f
->sym
->attr
.volatile_
3445 || f
->sym
->attr
.asynchronous
)
3446 && gfc_has_vector_subscript (a
->expr
))
3449 gfc_error ("Array-section actual argument with vector "
3450 "subscripts at %L is incompatible with INTENT(OUT), "
3451 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
3452 "of the dummy argument %qs",
3453 &a
->expr
->where
, f
->sym
->name
);
3457 /* C1232 (R1221) For an actual argument which is an array section or
3458 an assumed-shape array, the dummy argument shall be an assumed-
3459 shape array, if the dummy argument has the VOLATILE attribute. */
3461 if (f
->sym
->attr
.volatile_
3462 && a
->expr
->expr_type
== EXPR_VARIABLE
3463 && a
->expr
->symtree
->n
.sym
->as
3464 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
3465 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3468 gfc_error ("Assumed-shape actual argument at %L is "
3469 "incompatible with the non-assumed-shape "
3470 "dummy argument %qs due to VOLATILE attribute",
3471 &a
->expr
->where
,f
->sym
->name
);
3475 /* Find the last array_ref. */
3476 actual_arr_ref
= NULL
;
3478 actual_arr_ref
= gfc_find_array_ref (a
->expr
, true);
3480 if (f
->sym
->attr
.volatile_
3481 && actual_arr_ref
&& actual_arr_ref
->type
== AR_SECTION
3482 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
3485 gfc_error ("Array-section actual argument at %L is "
3486 "incompatible with the non-assumed-shape "
3487 "dummy argument %qs due to VOLATILE attribute",
3488 &a
->expr
->where
, f
->sym
->name
);
3492 /* C1233 (R1221) For an actual argument which is a pointer array, the
3493 dummy argument shall be an assumed-shape or pointer array, if the
3494 dummy argument has the VOLATILE attribute. */
3496 if (f
->sym
->attr
.volatile_
3497 && a
->expr
->expr_type
== EXPR_VARIABLE
3498 && a
->expr
->symtree
->n
.sym
->attr
.pointer
3499 && a
->expr
->symtree
->n
.sym
->as
3501 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
3502 || f
->sym
->attr
.pointer
)))
3505 gfc_error ("Pointer-array actual argument at %L requires "
3506 "an assumed-shape or pointer-array dummy "
3507 "argument %qs due to VOLATILE attribute",
3508 &a
->expr
->where
,f
->sym
->name
);
3519 /* Make sure missing actual arguments are optional. */
3521 for (f
= formal
; f
; f
= f
->next
, i
++)
3523 if (new_arg
[i
] != NULL
)
3528 gfc_error ("Missing alternate return spec in subroutine call "
3532 if (!f
->sym
->attr
.optional
3533 || (in_statement_function
&& f
->sym
->attr
.optional
))
3536 gfc_error ("Missing actual argument for argument %qs at %L",
3537 f
->sym
->name
, where
);
3542 /* We should have handled the cases where the formal arglist is null
3546 /* The argument lists are compatible. We now relink a new actual
3547 argument list with null arguments in the right places. The head
3548 of the list remains the head. */
3549 for (i
= 0; i
< n
; i
++)
3550 if (new_arg
[i
] == NULL
)
3551 new_arg
[i
] = gfc_get_actual_arglist ();
3555 std::swap (*new_arg
[0], *actual
);
3556 std::swap (new_arg
[0], new_arg
[na
]);
3559 for (i
= 0; i
< n
- 1; i
++)
3560 new_arg
[i
]->next
= new_arg
[i
+ 1];
3562 new_arg
[i
]->next
= NULL
;
3564 if (*ap
== NULL
&& n
> 0)
3567 /* Note the types of omitted optional arguments. */
3568 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
3569 if (a
->expr
== NULL
&& a
->label
== NULL
)
3570 a
->missing_arg_type
= f
->sym
->ts
.type
;
3578 gfc_formal_arglist
*f
;
3579 gfc_actual_arglist
*a
;
3583 /* qsort comparison function for argument pairs, with the following
3585 - p->a->expr == NULL
3586 - p->a->expr->expr_type != EXPR_VARIABLE
3587 - by gfc_symbol pointer value (larger first). */
3590 pair_cmp (const void *p1
, const void *p2
)
3592 const gfc_actual_arglist
*a1
, *a2
;
3594 /* *p1 and *p2 are elements of the to-be-sorted array. */
3595 a1
= ((const argpair
*) p1
)->a
;
3596 a2
= ((const argpair
*) p2
)->a
;
3605 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
3607 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3611 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
3613 if (a1
->expr
->symtree
->n
.sym
> a2
->expr
->symtree
->n
.sym
)
3615 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
3619 /* Given two expressions from some actual arguments, test whether they
3620 refer to the same expression. The analysis is conservative.
3621 Returning false will produce no warning. */
3624 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
3626 const gfc_ref
*r1
, *r2
;
3629 || e1
->expr_type
!= EXPR_VARIABLE
3630 || e2
->expr_type
!= EXPR_VARIABLE
3631 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
3634 /* TODO: improve comparison, see expr.c:show_ref(). */
3635 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
3637 if (r1
->type
!= r2
->type
)
3642 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
3644 /* TODO: At the moment, consider only full arrays;
3645 we could do better. */
3646 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
3651 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
3659 if (e1
->symtree
->n
.sym
->ts
.type
== BT_COMPLEX
3660 && e1
->ts
.type
== BT_REAL
&& e2
->ts
.type
== BT_REAL
3661 && r1
->u
.i
!= r2
->u
.i
)
3666 gfc_internal_error ("compare_actual_expr(): Bad component code");
3675 /* Given formal and actual argument lists that correspond to one
3676 another, check that identical actual arguments aren't not
3677 associated with some incompatible INTENTs. */
3680 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3682 sym_intent f1_intent
, f2_intent
;
3683 gfc_formal_arglist
*f1
;
3684 gfc_actual_arglist
*a1
;
3690 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
3692 if (f1
== NULL
&& a1
== NULL
)
3694 if (f1
== NULL
|| a1
== NULL
)
3695 gfc_internal_error ("check_some_aliasing(): List mismatch");
3700 p
= XALLOCAVEC (argpair
, n
);
3702 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
3708 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
3710 for (i
= 0; i
< n
; i
++)
3713 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
3714 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
3716 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
3717 for (j
= i
+ 1; j
< n
; j
++)
3719 /* Expected order after the sort. */
3720 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
3721 gfc_internal_error ("check_some_aliasing(): corrupted data");
3723 /* Are the expression the same? */
3724 if (!compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
))
3726 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
3727 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
3728 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
)
3729 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_OUT
))
3731 gfc_warning (0, "Same actual argument associated with INTENT(%s) "
3732 "argument %qs and INTENT(%s) argument %qs at %L",
3733 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
3734 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
3735 &p
[i
].a
->expr
->where
);
3745 /* Given formal and actual argument lists that correspond to one
3746 another, check that they are compatible in the sense that intents
3747 are not mismatched. */
3750 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
3752 sym_intent f_intent
;
3754 for (;; f
= f
->next
, a
= a
->next
)
3758 if (f
== NULL
&& a
== NULL
)
3760 if (f
== NULL
|| a
== NULL
)
3761 gfc_internal_error ("check_intents(): List mismatch");
3763 if (a
->expr
&& a
->expr
->expr_type
== EXPR_FUNCTION
3764 && a
->expr
->value
.function
.isym
3765 && a
->expr
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3766 expr
= a
->expr
->value
.function
.actual
->expr
;
3770 if (expr
== NULL
|| expr
->expr_type
!= EXPR_VARIABLE
)
3773 f_intent
= f
->sym
->attr
.intent
;
3775 if (gfc_pure (NULL
) && gfc_impure_variable (expr
->symtree
->n
.sym
))
3777 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3778 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3779 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3781 gfc_error ("Procedure argument at %L is local to a PURE "
3782 "procedure and has the POINTER attribute",
3788 /* Fortran 2008, C1283. */
3789 if (gfc_pure (NULL
) && gfc_is_coindexed (expr
))
3791 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
3793 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3794 "is passed to an INTENT(%s) argument",
3795 &expr
->where
, gfc_intent_string (f_intent
));
3799 if ((f
->sym
->ts
.type
== BT_CLASS
&& f
->sym
->attr
.class_ok
3800 && CLASS_DATA (f
->sym
)->attr
.class_pointer
)
3801 || (f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.pointer
))
3803 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3804 "is passed to a POINTER dummy argument",
3810 /* F2008, Section 12.5.2.4. */
3811 if (expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
3812 && gfc_is_coindexed (expr
))
3814 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3815 "polymorphic dummy argument %qs",
3816 &expr
->where
, f
->sym
->name
);
3825 /* Check how a procedure is used against its interface. If all goes
3826 well, the actual argument list will also end up being properly
3830 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
3832 gfc_actual_arglist
*a
;
3833 gfc_formal_arglist
*dummy_args
;
3834 bool implicit
= false;
3836 /* Warn about calls with an implicit interface. Special case
3837 for calling a ISO_C_BINDING because c_loc and c_funloc
3838 are pseudo-unknown. Additionally, warn about procedures not
3839 explicitly declared at all if requested. */
3840 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& !sym
->attr
.is_iso_c
)
3842 bool has_implicit_none_export
= false;
3844 if (sym
->attr
.proc
== PROC_UNKNOWN
)
3845 for (gfc_namespace
*ns
= sym
->ns
; ns
; ns
= ns
->parent
)
3846 if (ns
->has_implicit_none_export
)
3848 has_implicit_none_export
= true;
3851 if (has_implicit_none_export
)
3854 = gfc_lookup_function_fuzzy (sym
->name
, sym
->ns
->sym_root
);
3856 gfc_error ("Procedure %qs called at %L is not explicitly declared"
3857 "; did you mean %qs?",
3858 sym
->name
, where
, guessed
);
3860 gfc_error ("Procedure %qs called at %L is not explicitly declared",
3864 if (warn_implicit_interface
)
3865 gfc_warning (OPT_Wimplicit_interface
,
3866 "Procedure %qs called with an implicit interface at %L",
3868 else if (warn_implicit_procedure
&& sym
->attr
.proc
== PROC_UNKNOWN
)
3869 gfc_warning (OPT_Wimplicit_procedure
,
3870 "Procedure %qs called at %L is not explicitly declared",
3872 gfc_find_proc_namespace (sym
->ns
)->implicit_interface_calls
= 1;
3875 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3877 if (sym
->attr
.pointer
)
3879 gfc_error ("The pointer object %qs at %L must have an explicit "
3880 "function interface or be declared as array",
3885 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
3887 gfc_error ("The allocatable object %qs at %L must have an explicit "
3888 "function interface or be declared as array",
3893 if (sym
->attr
.allocatable
)
3895 gfc_error ("Allocatable function %qs at %L must have an explicit "
3896 "function interface", sym
->name
, where
);
3900 for (a
= *ap
; a
; a
= a
->next
)
3902 if (a
->expr
&& a
->expr
->error
)
3905 /* F2018, 15.4.2.2 Explicit interface is required for a
3906 polymorphic dummy argument, so there is no way to
3907 legally have a class appear in an argument with an
3908 implicit interface. */
3910 if (implicit
&& a
->expr
&& a
->expr
->ts
.type
== BT_CLASS
)
3912 gfc_error ("Explicit interface required for polymorphic "
3913 "argument at %L",&a
->expr
->where
);
3918 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3919 if (a
->name
!= NULL
&& a
->name
[0] != '%')
3921 gfc_error ("Keyword argument requires explicit interface "
3922 "for procedure %qs at %L", sym
->name
, &a
->expr
->where
);
3926 /* TS 29113, 6.2. */
3927 if (a
->expr
&& a
->expr
->ts
.type
== BT_ASSUMED
3928 && sym
->intmod_sym_id
!= ISOCBINDING_LOC
)
3930 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3931 "interface", a
->expr
->symtree
->n
.sym
->name
,
3937 /* F2008, C1303 and C1304. */
3939 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3940 && a
->expr
->ts
.u
.derived
3941 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3942 && a
->expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3943 || gfc_expr_attr (a
->expr
).lock_comp
))
3945 gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3946 "component at %L requires an explicit interface for "
3947 "procedure %qs", &a
->expr
->where
, sym
->name
);
3953 && (a
->expr
->ts
.type
== BT_DERIVED
|| a
->expr
->ts
.type
== BT_CLASS
)
3954 && a
->expr
->ts
.u
.derived
3955 && ((a
->expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3956 && a
->expr
->ts
.u
.derived
->intmod_sym_id
3957 == ISOFORTRAN_EVENT_TYPE
)
3958 || gfc_expr_attr (a
->expr
).event_comp
))
3960 gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
3961 "component at %L requires an explicit interface for "
3962 "procedure %qs", &a
->expr
->where
, sym
->name
);
3967 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
3968 && a
->expr
->ts
.type
== BT_UNKNOWN
)
3970 gfc_error ("MOLD argument to NULL required at %L",
3976 /* TS 29113, C407b. */
3977 if (a
->expr
&& a
->expr
->expr_type
== EXPR_VARIABLE
3978 && symbol_rank (a
->expr
->symtree
->n
.sym
) == -1)
3980 gfc_error ("Assumed-rank argument requires an explicit interface "
3981 "at %L", &a
->expr
->where
);
3990 dummy_args
= gfc_sym_get_dummy_args (sym
);
3992 /* For a statement function, check that types and type parameters of actual
3993 arguments and dummy arguments match. */
3994 if (!gfc_compare_actual_formal (ap
, dummy_args
, 0, sym
->attr
.elemental
,
3995 sym
->attr
.proc
== PROC_ST_FUNCTION
, where
))
3998 if (!check_intents (dummy_args
, *ap
))
4002 check_some_aliasing (dummy_args
, *ap
);
4008 /* Check how a procedure pointer component is used against its interface.
4009 If all goes well, the actual argument list will also end up being properly
4010 sorted. Completely analogous to gfc_procedure_use. */
4013 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
4015 /* Warn about calls with an implicit interface. Special case
4016 for calling a ISO_C_BINDING because c_loc and c_funloc
4017 are pseudo-unknown. */
4018 if (warn_implicit_interface
4019 && comp
->attr
.if_source
== IFSRC_UNKNOWN
4020 && !comp
->attr
.is_iso_c
)
4021 gfc_warning (OPT_Wimplicit_interface
,
4022 "Procedure pointer component %qs called with an implicit "
4023 "interface at %L", comp
->name
, where
);
4025 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
4027 gfc_actual_arglist
*a
;
4028 for (a
= *ap
; a
; a
= a
->next
)
4030 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
4031 if (a
->name
!= NULL
&& a
->name
[0] != '%')
4033 gfc_error ("Keyword argument requires explicit interface "
4034 "for procedure pointer component %qs at %L",
4035 comp
->name
, &a
->expr
->where
);
4043 if (!gfc_compare_actual_formal (ap
, comp
->ts
.interface
->formal
, 0,
4044 comp
->attr
.elemental
, false, where
))
4047 check_intents (comp
->ts
.interface
->formal
, *ap
);
4049 check_some_aliasing (comp
->ts
.interface
->formal
, *ap
);
4053 /* Try if an actual argument list matches the formal list of a symbol,
4054 respecting the symbol's attributes like ELEMENTAL. This is used for
4055 GENERIC resolution. */
4058 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
4060 gfc_formal_arglist
*dummy_args
;
4063 if (sym
->attr
.flavor
!= FL_PROCEDURE
)
4066 dummy_args
= gfc_sym_get_dummy_args (sym
);
4068 r
= !sym
->attr
.elemental
;
4069 if (gfc_compare_actual_formal (args
, dummy_args
, r
, !r
, false, NULL
))
4071 check_intents (dummy_args
, *args
);
4073 check_some_aliasing (dummy_args
, *args
);
4081 /* Given an interface pointer and an actual argument list, search for
4082 a formal argument list that matches the actual. If found, returns
4083 a pointer to the symbol of the correct interface. Returns NULL if
4087 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
4088 gfc_actual_arglist
**ap
)
4090 gfc_symbol
*elem_sym
= NULL
;
4091 gfc_symbol
*null_sym
= NULL
;
4092 locus null_expr_loc
;
4093 gfc_actual_arglist
*a
;
4094 bool has_null_arg
= false;
4096 for (a
= *ap
; a
; a
= a
->next
)
4097 if (a
->expr
&& a
->expr
->expr_type
== EXPR_NULL
4098 && a
->expr
->ts
.type
== BT_UNKNOWN
)
4100 has_null_arg
= true;
4101 null_expr_loc
= a
->expr
->where
;
4105 for (; intr
; intr
= intr
->next
)
4107 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
4109 if (sub_flag
&& intr
->sym
->attr
.function
)
4111 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
4114 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
4116 if (has_null_arg
&& null_sym
)
4118 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
4119 "between specific functions %s and %s",
4120 &null_expr_loc
, null_sym
->name
, intr
->sym
->name
);
4123 else if (has_null_arg
)
4125 null_sym
= intr
->sym
;
4129 /* Satisfy 12.4.4.1 such that an elemental match has lower
4130 weight than a non-elemental match. */
4131 if (intr
->sym
->attr
.elemental
)
4133 elem_sym
= intr
->sym
;
4143 return elem_sym
? elem_sym
: NULL
;
4147 /* Do a brute force recursive search for a symbol. */
4149 static gfc_symtree
*
4150 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
4154 if (root
->n
.sym
== sym
)
4159 st
= find_symtree0 (root
->left
, sym
);
4160 if (root
->right
&& ! st
)
4161 st
= find_symtree0 (root
->right
, sym
);
4166 /* Find a symtree for a symbol. */
4169 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
4174 /* First try to find it by name. */
4175 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
4176 if (st
&& st
->n
.sym
== sym
)
4179 /* If it's been renamed, resort to a brute-force search. */
4180 /* TODO: avoid having to do this search. If the symbol doesn't exist
4181 in the symtree for the current namespace, it should probably be added. */
4182 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4184 st
= find_symtree0 (ns
->sym_root
, sym
);
4188 gfc_internal_error ("Unable to find symbol %qs", sym
->name
);
4193 /* See if the arglist to an operator-call contains a derived-type argument
4194 with a matching type-bound operator. If so, return the matching specific
4195 procedure defined as operator-target as well as the base-object to use
4196 (which is the found derived-type argument with operator). The generic
4197 name, if any, is transmitted to the final expression via 'gname'. */
4199 static gfc_typebound_proc
*
4200 matching_typebound_op (gfc_expr
** tb_base
,
4201 gfc_actual_arglist
* args
,
4202 gfc_intrinsic_op op
, const char* uop
,
4203 const char ** gname
)
4205 gfc_actual_arglist
* base
;
4207 for (base
= args
; base
; base
= base
->next
)
4208 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
4210 gfc_typebound_proc
* tb
;
4211 gfc_symbol
* derived
;
4214 while (base
->expr
->expr_type
== EXPR_OP
4215 && base
->expr
->value
.op
.op
== INTRINSIC_PARENTHESES
)
4216 base
->expr
= base
->expr
->value
.op
.op1
;
4218 if (base
->expr
->ts
.type
== BT_CLASS
)
4220 if (!base
->expr
->ts
.u
.derived
|| CLASS_DATA (base
->expr
) == NULL
4221 || !gfc_expr_attr (base
->expr
).class_ok
)
4223 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
4226 derived
= base
->expr
->ts
.u
.derived
;
4228 if (op
== INTRINSIC_USER
)
4230 gfc_symtree
* tb_uop
;
4233 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
4242 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
4245 /* This means we hit a PRIVATE operator which is use-associated and
4246 should thus not be seen. */
4250 /* Look through the super-type hierarchy for a matching specific
4252 for (; tb
; tb
= tb
->overridden
)
4256 gcc_assert (tb
->is_generic
);
4257 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
4260 gfc_actual_arglist
* argcopy
;
4263 gcc_assert (g
->specific
);
4264 if (g
->specific
->error
)
4267 target
= g
->specific
->u
.specific
->n
.sym
;
4269 /* Check if this arglist matches the formal. */
4270 argcopy
= gfc_copy_actual_arglist (args
);
4271 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
4272 gfc_free_actual_arglist (argcopy
);
4274 /* Return if we found a match. */
4277 *tb_base
= base
->expr
;
4278 *gname
= g
->specific_st
->name
;
4289 /* For the 'actual arglist' of an operator call and a specific typebound
4290 procedure that has been found the target of a type-bound operator, build the
4291 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
4292 type-bound procedures rather than resolving type-bound operators 'directly'
4293 so that we can reuse the existing logic. */
4296 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
4297 gfc_expr
* base
, gfc_typebound_proc
* target
,
4300 e
->expr_type
= EXPR_COMPCALL
;
4301 e
->value
.compcall
.tbp
= target
;
4302 e
->value
.compcall
.name
= gname
? gname
: "$op";
4303 e
->value
.compcall
.actual
= actual
;
4304 e
->value
.compcall
.base_object
= base
;
4305 e
->value
.compcall
.ignore_pass
= 1;
4306 e
->value
.compcall
.assign
= 0;
4307 if (e
->ts
.type
== BT_UNKNOWN
4308 && target
->function
)
4310 if (target
->is_generic
)
4311 e
->ts
= target
->u
.generic
->specific
->u
.specific
->n
.sym
->ts
;
4313 e
->ts
= target
->u
.specific
->n
.sym
->ts
;
4318 /* This subroutine is called when an expression is being resolved.
4319 The expression node in question is either a user defined operator
4320 or an intrinsic operator with arguments that aren't compatible
4321 with the operator. This subroutine builds an actual argument list
4322 corresponding to the operands, then searches for a compatible
4323 interface. If one is found, the expression node is replaced with
4324 the appropriate function call. We use the 'match' enum to specify
4325 whether a replacement has been made or not, or if an error occurred. */
4328 gfc_extend_expr (gfc_expr
*e
)
4330 gfc_actual_arglist
*actual
;
4336 gfc_typebound_proc
* tbo
;
4341 actual
= gfc_get_actual_arglist ();
4342 actual
->expr
= e
->value
.op
.op1
;
4346 if (e
->value
.op
.op2
!= NULL
)
4348 actual
->next
= gfc_get_actual_arglist ();
4349 actual
->next
->expr
= e
->value
.op
.op2
;
4352 i
= fold_unary_intrinsic (e
->value
.op
.op
);
4354 /* See if we find a matching type-bound operator. */
4355 if (i
== INTRINSIC_USER
)
4356 tbo
= matching_typebound_op (&tb_base
, actual
,
4357 i
, e
->value
.op
.uop
->name
, &gname
);
4361 #define CHECK_OS_COMPARISON(comp) \
4362 case INTRINSIC_##comp: \
4363 case INTRINSIC_##comp##_OS: \
4364 tbo = matching_typebound_op (&tb_base, actual, \
4365 INTRINSIC_##comp, NULL, &gname); \
4367 tbo = matching_typebound_op (&tb_base, actual, \
4368 INTRINSIC_##comp##_OS, NULL, &gname); \
4370 CHECK_OS_COMPARISON(EQ
)
4371 CHECK_OS_COMPARISON(NE
)
4372 CHECK_OS_COMPARISON(GT
)
4373 CHECK_OS_COMPARISON(GE
)
4374 CHECK_OS_COMPARISON(LT
)
4375 CHECK_OS_COMPARISON(LE
)
4376 #undef CHECK_OS_COMPARISON
4379 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
4383 /* If there is a matching typebound-operator, replace the expression with
4384 a call to it and succeed. */
4387 gcc_assert (tb_base
);
4388 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
4390 if (!gfc_resolve_expr (e
))
4396 if (i
== INTRINSIC_USER
)
4398 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4400 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
4404 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
4411 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4413 /* Due to the distinction between '==' and '.eq.' and friends, one has
4414 to check if either is defined. */
4417 #define CHECK_OS_COMPARISON(comp) \
4418 case INTRINSIC_##comp: \
4419 case INTRINSIC_##comp##_OS: \
4420 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
4422 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
4424 CHECK_OS_COMPARISON(EQ
)
4425 CHECK_OS_COMPARISON(NE
)
4426 CHECK_OS_COMPARISON(GT
)
4427 CHECK_OS_COMPARISON(GE
)
4428 CHECK_OS_COMPARISON(LT
)
4429 CHECK_OS_COMPARISON(LE
)
4430 #undef CHECK_OS_COMPARISON
4433 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
4441 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
4442 found rather than just taking the first one and not checking further. */
4446 /* Don't use gfc_free_actual_arglist(). */
4447 free (actual
->next
);
4452 /* Change the expression node to a function call. */
4453 e
->expr_type
= EXPR_FUNCTION
;
4454 e
->symtree
= gfc_find_sym_in_symtree (sym
);
4455 e
->value
.function
.actual
= actual
;
4456 e
->value
.function
.esym
= NULL
;
4457 e
->value
.function
.isym
= NULL
;
4458 e
->value
.function
.name
= NULL
;
4459 e
->user_operator
= 1;
4461 if (!gfc_resolve_expr (e
))
4468 /* Tries to replace an assignment code node with a subroutine call to the
4469 subroutine associated with the assignment operator. Return true if the node
4470 was replaced. On false, no error is generated. */
4473 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
4475 gfc_actual_arglist
*actual
;
4476 gfc_expr
*lhs
, *rhs
, *tb_base
;
4477 gfc_symbol
*sym
= NULL
;
4478 const char *gname
= NULL
;
4479 gfc_typebound_proc
* tbo
;
4484 /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */
4485 if (c
->op
== EXEC_ASSIGN
4486 && c
->expr1
->expr_type
== EXPR_VARIABLE
4487 && c
->expr2
->expr_type
== EXPR_CONSTANT
&& c
->expr2
->ts
.type
== BT_BOZ
)
4490 /* Don't allow an intrinsic assignment to be replaced. */
4491 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
4492 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
4493 && (lhs
->ts
.type
== rhs
->ts
.type
4494 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
4497 actual
= gfc_get_actual_arglist ();
4500 actual
->next
= gfc_get_actual_arglist ();
4501 actual
->next
->expr
= rhs
;
4503 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
4505 /* See if we find a matching type-bound assignment. */
4506 tbo
= matching_typebound_op (&tb_base
, actual
, INTRINSIC_ASSIGN
,
4511 /* Success: Replace the expression with a type-bound call. */
4512 gcc_assert (tb_base
);
4513 c
->expr1
= gfc_get_expr ();
4514 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
4515 c
->expr1
->value
.compcall
.assign
= 1;
4516 c
->expr1
->where
= c
->loc
;
4518 c
->op
= EXEC_COMPCALL
;
4522 /* See if we find an 'ordinary' (non-typebound) assignment procedure. */
4523 for (; ns
; ns
= ns
->parent
)
4525 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
4532 /* Success: Replace the assignment with the call. */
4533 c
->op
= EXEC_ASSIGN_CALL
;
4534 c
->symtree
= gfc_find_sym_in_symtree (sym
);
4537 c
->ext
.actual
= actual
;
4541 /* Failure: No assignment procedure found. */
4542 free (actual
->next
);
4548 /* Make sure that the interface just parsed is not already present in
4549 the given interface list. Ambiguity isn't checked yet since module
4550 procedures can be present without interfaces. */
4553 gfc_check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
, locus loc
)
4557 for (ip
= base
; ip
; ip
= ip
->next
)
4559 if (ip
->sym
== new_sym
)
4561 gfc_error ("Entity %qs at %L is already present in the interface",
4562 new_sym
->name
, &loc
);
4571 /* Add a symbol to the current interface. */
4574 gfc_add_interface (gfc_symbol
*new_sym
)
4576 gfc_interface
**head
, *intr
;
4580 switch (current_interface
.type
)
4582 case INTERFACE_NAMELESS
:
4583 case INTERFACE_ABSTRACT
:
4586 case INTERFACE_INTRINSIC_OP
:
4587 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4588 switch (current_interface
.op
)
4591 case INTRINSIC_EQ_OS
:
4592 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
,
4594 || !gfc_check_new_interface (ns
->op
[INTRINSIC_EQ_OS
],
4595 new_sym
, gfc_current_locus
))
4600 case INTRINSIC_NE_OS
:
4601 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
,
4603 || !gfc_check_new_interface (ns
->op
[INTRINSIC_NE_OS
],
4604 new_sym
, gfc_current_locus
))
4609 case INTRINSIC_GT_OS
:
4610 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GT
],
4611 new_sym
, gfc_current_locus
)
4612 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GT_OS
],
4613 new_sym
, gfc_current_locus
))
4618 case INTRINSIC_GE_OS
:
4619 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_GE
],
4620 new_sym
, gfc_current_locus
)
4621 || !gfc_check_new_interface (ns
->op
[INTRINSIC_GE_OS
],
4622 new_sym
, gfc_current_locus
))
4627 case INTRINSIC_LT_OS
:
4628 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LT
],
4629 new_sym
, gfc_current_locus
)
4630 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LT_OS
],
4631 new_sym
, gfc_current_locus
))
4636 case INTRINSIC_LE_OS
:
4637 if (!gfc_check_new_interface (ns
->op
[INTRINSIC_LE
],
4638 new_sym
, gfc_current_locus
)
4639 || !gfc_check_new_interface (ns
->op
[INTRINSIC_LE_OS
],
4640 new_sym
, gfc_current_locus
))
4645 if (!gfc_check_new_interface (ns
->op
[current_interface
.op
],
4646 new_sym
, gfc_current_locus
))
4650 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
4653 case INTERFACE_GENERIC
:
4654 case INTERFACE_DTIO
:
4655 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
4657 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
4661 if (!gfc_check_new_interface (sym
->generic
,
4662 new_sym
, gfc_current_locus
))
4666 head
= ¤t_interface
.sym
->generic
;
4669 case INTERFACE_USER_OP
:
4670 if (!gfc_check_new_interface (current_interface
.uop
->op
,
4671 new_sym
, gfc_current_locus
))
4674 head
= ¤t_interface
.uop
->op
;
4678 gfc_internal_error ("gfc_add_interface(): Bad interface type");
4681 intr
= gfc_get_interface ();
4682 intr
->sym
= new_sym
;
4683 intr
->where
= gfc_current_locus
;
4693 gfc_current_interface_head (void)
4695 switch (current_interface
.type
)
4697 case INTERFACE_INTRINSIC_OP
:
4698 return current_interface
.ns
->op
[current_interface
.op
];
4700 case INTERFACE_GENERIC
:
4701 case INTERFACE_DTIO
:
4702 return current_interface
.sym
->generic
;
4704 case INTERFACE_USER_OP
:
4705 return current_interface
.uop
->op
;
4714 gfc_set_current_interface_head (gfc_interface
*i
)
4716 switch (current_interface
.type
)
4718 case INTERFACE_INTRINSIC_OP
:
4719 current_interface
.ns
->op
[current_interface
.op
] = i
;
4722 case INTERFACE_GENERIC
:
4723 case INTERFACE_DTIO
:
4724 current_interface
.sym
->generic
= i
;
4727 case INTERFACE_USER_OP
:
4728 current_interface
.uop
->op
= i
;
4737 /* Gets rid of a formal argument list. We do not free symbols.
4738 Symbols are freed when a namespace is freed. */
4741 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
4743 gfc_formal_arglist
*q
;
4753 /* Check that it is ok for the type-bound procedure 'proc' to override the
4754 procedure 'old', cf. F08:4.5.7.3. */
4757 gfc_check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
4760 gfc_symbol
*proc_target
, *old_target
;
4761 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
4762 gfc_formal_arglist
*proc_formal
, *old_formal
;
4766 /* This procedure should only be called for non-GENERIC proc. */
4767 gcc_assert (!proc
->n
.tb
->is_generic
);
4769 /* If the overwritten procedure is GENERIC, this is an error. */
4770 if (old
->n
.tb
->is_generic
)
4772 gfc_error ("Cannot overwrite GENERIC %qs at %L",
4773 old
->name
, &proc
->n
.tb
->where
);
4777 where
= proc
->n
.tb
->where
;
4778 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
4779 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
4781 /* Check that overridden binding is not NON_OVERRIDABLE. */
4782 if (old
->n
.tb
->non_overridable
)
4784 gfc_error ("%qs at %L overrides a procedure binding declared"
4785 " NON_OVERRIDABLE", proc
->name
, &where
);
4789 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4790 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
4792 gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
4793 " non-DEFERRED binding", proc
->name
, &where
);
4797 /* If the overridden binding is PURE, the overriding must be, too. */
4798 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
4800 gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
4801 proc
->name
, &where
);
4805 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4806 is not, the overriding must not be either. */
4807 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
4809 gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
4810 " ELEMENTAL", proc
->name
, &where
);
4813 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
4815 gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
4816 " be ELEMENTAL, either", proc
->name
, &where
);
4820 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4822 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
4824 gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
4825 " SUBROUTINE", proc
->name
, &where
);
4829 /* If the overridden binding is a FUNCTION, the overriding must also be a
4830 FUNCTION and have the same characteristics. */
4831 if (old_target
->attr
.function
)
4833 if (!proc_target
->attr
.function
)
4835 gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
4836 " FUNCTION", proc
->name
, &where
);
4840 if (!gfc_check_result_characteristics (proc_target
, old_target
,
4843 gfc_error ("Result mismatch for the overriding procedure "
4844 "%qs at %L: %s", proc
->name
, &where
, err
);
4849 /* If the overridden binding is PUBLIC, the overriding one must not be
4851 if (old
->n
.tb
->access
== ACCESS_PUBLIC
4852 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
4854 gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
4855 " PRIVATE", proc
->name
, &where
);
4859 /* Compare the formal argument lists of both procedures. This is also abused
4860 to find the position of the passed-object dummy arguments of both
4861 bindings as at least the overridden one might not yet be resolved and we
4862 need those positions in the check below. */
4863 proc_pass_arg
= old_pass_arg
= 0;
4864 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
4866 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
4869 proc_formal
= gfc_sym_get_dummy_args (proc_target
);
4870 old_formal
= gfc_sym_get_dummy_args (old_target
);
4871 for ( ; proc_formal
&& old_formal
;
4872 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
4874 if (proc
->n
.tb
->pass_arg
4875 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
4876 proc_pass_arg
= argpos
;
4877 if (old
->n
.tb
->pass_arg
4878 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
4879 old_pass_arg
= argpos
;
4881 /* Check that the names correspond. */
4882 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
4884 gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
4885 " to match the corresponding argument of the overridden"
4886 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
4887 old_formal
->sym
->name
);
4891 check_type
= proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
;
4892 if (!gfc_check_dummy_characteristics (proc_formal
->sym
, old_formal
->sym
,
4893 check_type
, err
, sizeof(err
)))
4895 gfc_error_opt (0, "Argument mismatch for the overriding procedure "
4896 "%qs at %L: %s", proc
->name
, &where
, err
);
4902 if (proc_formal
|| old_formal
)
4904 gfc_error ("%qs at %L must have the same number of formal arguments as"
4905 " the overridden procedure", proc
->name
, &where
);
4909 /* If the overridden binding is NOPASS, the overriding one must also be
4911 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
4913 gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
4914 " NOPASS", proc
->name
, &where
);
4918 /* If the overridden binding is PASS(x), the overriding one must also be
4919 PASS and the passed-object dummy arguments must correspond. */
4920 if (!old
->n
.tb
->nopass
)
4922 if (proc
->n
.tb
->nopass
)
4924 gfc_error ("%qs at %L overrides a binding with PASS and must also be"
4925 " PASS", proc
->name
, &where
);
4929 if (proc_pass_arg
!= old_pass_arg
)
4931 gfc_error ("Passed-object dummy argument of %qs at %L must be at"
4932 " the same position as the passed-object dummy argument of"
4933 " the overridden procedure", proc
->name
, &where
);
4942 /* The following three functions check that the formal arguments
4943 of user defined derived type IO procedures are compliant with
4944 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4947 check_dtio_arg_TKR_intent (gfc_symbol
*fsym
, bool typebound
, bt type
,
4948 int kind
, int rank
, sym_intent intent
)
4950 if (fsym
->ts
.type
!= type
)
4952 gfc_error ("DTIO dummy argument at %L must be of type %s",
4953 &fsym
->declared_at
, gfc_basic_typename (type
));
4957 if (fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
4958 && fsym
->ts
.kind
!= kind
)
4959 gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
4960 &fsym
->declared_at
, kind
);
4964 && (((type
== BT_CLASS
) && CLASS_DATA (fsym
)->attr
.dimension
)
4965 || ((type
!= BT_CLASS
) && fsym
->attr
.dimension
)))
4966 gfc_error ("DTIO dummy argument at %L must be a scalar",
4967 &fsym
->declared_at
);
4969 && (fsym
->as
== NULL
|| fsym
->as
->type
!= AS_ASSUMED_SHAPE
))
4970 gfc_error ("DTIO dummy argument at %L must be an "
4971 "ASSUMED SHAPE ARRAY", &fsym
->declared_at
);
4973 if (type
== BT_CHARACTER
&& fsym
->ts
.u
.cl
->length
!= NULL
)
4974 gfc_error ("DTIO character argument at %L must have assumed length",
4975 &fsym
->declared_at
);
4977 if (fsym
->attr
.intent
!= intent
)
4978 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4979 &fsym
->declared_at
, gfc_code2string (intents
, (int)intent
));
4985 check_dtio_interface1 (gfc_symbol
*derived
, gfc_symtree
*tb_io_st
,
4986 bool typebound
, bool formatted
, int code
)
4988 gfc_symbol
*dtio_sub
, *generic_proc
, *fsym
;
4989 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
4990 gfc_interface
*intr
;
4991 gfc_formal_arglist
*formal
;
4994 bool read
= ((dtio_codes
)code
== DTIO_RF
)
4995 || ((dtio_codes
)code
== DTIO_RUF
);
5003 /* Typebound DTIO binding. */
5004 tb_io_proc
= tb_io_st
->n
.tb
;
5005 if (tb_io_proc
== NULL
)
5008 gcc_assert (tb_io_proc
->is_generic
);
5010 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5011 if (specific_proc
== NULL
|| specific_proc
->is_generic
)
5014 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5018 generic_proc
= tb_io_st
->n
.sym
;
5019 if (generic_proc
== NULL
|| generic_proc
->generic
== NULL
)
5022 for (intr
= tb_io_st
->n
.sym
->generic
; intr
; intr
= intr
->next
)
5024 if (intr
->sym
&& intr
->sym
->formal
&& intr
->sym
->formal
->sym
5025 && ((intr
->sym
->formal
->sym
->ts
.type
== BT_CLASS
5026 && CLASS_DATA (intr
->sym
->formal
->sym
)->ts
.u
.derived
5028 || (intr
->sym
->formal
->sym
->ts
.type
== BT_DERIVED
5029 && intr
->sym
->formal
->sym
->ts
.u
.derived
== derived
)))
5031 dtio_sub
= intr
->sym
;
5034 else if (intr
->sym
&& intr
->sym
->formal
&& !intr
->sym
->formal
->sym
)
5036 gfc_error ("Alternate return at %L is not permitted in a DTIO "
5037 "procedure", &intr
->sym
->declared_at
);
5042 if (dtio_sub
== NULL
)
5046 gcc_assert (dtio_sub
);
5047 if (!dtio_sub
->attr
.subroutine
)
5048 gfc_error ("DTIO procedure %qs at %L must be a subroutine",
5049 dtio_sub
->name
, &dtio_sub
->declared_at
);
5051 if (!dtio_sub
->resolve_symbol_called
)
5052 gfc_resolve_formal_arglist (dtio_sub
);
5055 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
)
5058 if (arg_num
< (formatted
? 6 : 4))
5060 gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L",
5061 dtio_sub
->name
, &dtio_sub
->declared_at
);
5065 if (arg_num
> (formatted
? 6 : 4))
5067 gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L",
5068 dtio_sub
->name
, &dtio_sub
->declared_at
);
5072 /* Now go through the formal arglist. */
5074 for (formal
= dtio_sub
->formal
; formal
; formal
= formal
->next
, arg_num
++)
5076 if (!formatted
&& arg_num
== 3)
5082 gfc_error ("Alternate return at %L is not permitted in a DTIO "
5083 "procedure", &dtio_sub
->declared_at
);
5090 type
= derived
->attr
.sequence
|| derived
->attr
.is_bind_c
?
5091 BT_DERIVED
: BT_CLASS
;
5093 intent
= read
? INTENT_INOUT
: INTENT_IN
;
5094 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5100 kind
= gfc_default_integer_kind
;
5102 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5105 case(3): /* IOTYPE */
5106 type
= BT_CHARACTER
;
5107 kind
= gfc_default_character_kind
;
5109 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5112 case(4): /* VLIST */
5114 kind
= gfc_default_integer_kind
;
5116 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5119 case(5): /* IOSTAT */
5121 kind
= gfc_default_integer_kind
;
5122 intent
= INTENT_OUT
;
5123 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5126 case(6): /* IOMSG */
5127 type
= BT_CHARACTER
;
5128 kind
= gfc_default_character_kind
;
5129 intent
= INTENT_INOUT
;
5130 check_dtio_arg_TKR_intent (fsym
, typebound
, type
, kind
,
5137 derived
->attr
.has_dtio_procs
= 1;
5142 gfc_check_dtio_interfaces (gfc_symbol
*derived
)
5144 gfc_symtree
*tb_io_st
;
5149 if (derived
->attr
.is_class
== 1 || derived
->attr
.vtype
== 1)
5152 /* Check typebound DTIO bindings. */
5153 for (code
= 0; code
< 4; code
++)
5155 formatted
= ((dtio_codes
)code
== DTIO_RF
)
5156 || ((dtio_codes
)code
== DTIO_WF
);
5158 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5159 gfc_code2string (dtio_procs
, code
),
5160 true, &derived
->declared_at
);
5161 if (tb_io_st
!= NULL
)
5162 check_dtio_interface1 (derived
, tb_io_st
, true, formatted
, code
);
5165 /* Check generic DTIO interfaces. */
5166 for (code
= 0; code
< 4; code
++)
5168 formatted
= ((dtio_codes
)code
== DTIO_RF
)
5169 || ((dtio_codes
)code
== DTIO_WF
);
5171 tb_io_st
= gfc_find_symtree (derived
->ns
->sym_root
,
5172 gfc_code2string (dtio_procs
, code
));
5173 if (tb_io_st
!= NULL
)
5174 check_dtio_interface1 (derived
, tb_io_st
, false, formatted
, code
);
5180 gfc_find_typebound_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
5182 gfc_symtree
*tb_io_st
= NULL
;
5185 if (!derived
|| !derived
->resolve_symbol_called
5186 || derived
->attr
.flavor
!= FL_DERIVED
)
5189 /* Try to find a typebound DTIO binding. */
5190 if (formatted
== true)
5193 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5194 gfc_code2string (dtio_procs
,
5197 &derived
->declared_at
);
5199 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5200 gfc_code2string (dtio_procs
,
5203 &derived
->declared_at
);
5208 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5209 gfc_code2string (dtio_procs
,
5212 &derived
->declared_at
);
5214 tb_io_st
= gfc_find_typebound_proc (derived
, &t
,
5215 gfc_code2string (dtio_procs
,
5218 &derived
->declared_at
);
5225 gfc_find_specific_dtio_proc (gfc_symbol
*derived
, bool write
, bool formatted
)
5227 gfc_symtree
*tb_io_st
= NULL
;
5228 gfc_symbol
*dtio_sub
= NULL
;
5229 gfc_symbol
*extended
;
5230 gfc_typebound_proc
*tb_io_proc
, *specific_proc
;
5232 tb_io_st
= gfc_find_typebound_dtio_proc (derived
, write
, formatted
);
5234 if (tb_io_st
!= NULL
)
5236 const char *genname
;
5239 tb_io_proc
= tb_io_st
->n
.tb
;
5240 gcc_assert (tb_io_proc
!= NULL
);
5241 gcc_assert (tb_io_proc
->is_generic
);
5242 gcc_assert (tb_io_proc
->u
.generic
->next
== NULL
);
5244 specific_proc
= tb_io_proc
->u
.generic
->specific
;
5245 gcc_assert (!specific_proc
->is_generic
);
5247 /* Go back and make sure that we have the right specific procedure.
5248 Here we most likely have a procedure from the parent type, which
5249 can be overridden in extensions. */
5250 genname
= tb_io_proc
->u
.generic
->specific_st
->name
;
5251 st
= gfc_find_typebound_proc (derived
, NULL
, genname
,
5252 true, &tb_io_proc
->where
);
5254 dtio_sub
= st
->n
.tb
->u
.specific
->n
.sym
;
5256 dtio_sub
= specific_proc
->u
.specific
->n
.sym
;
5261 /* If there is not a typebound binding, look for a generic
5263 for (extended
= derived
; extended
;
5264 extended
= gfc_get_derived_super_type (extended
))
5266 if (extended
== NULL
|| extended
->ns
== NULL
5267 || extended
->attr
.flavor
== FL_UNKNOWN
)
5270 if (formatted
== true)
5273 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5274 gfc_code2string (dtio_procs
,
5277 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5278 gfc_code2string (dtio_procs
,
5284 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5285 gfc_code2string (dtio_procs
,
5288 tb_io_st
= gfc_find_symtree (extended
->ns
->sym_root
,
5289 gfc_code2string (dtio_procs
,
5293 if (tb_io_st
!= NULL
5295 && tb_io_st
->n
.sym
->generic
)
5297 for (gfc_interface
*intr
= tb_io_st
->n
.sym
->generic
;
5298 intr
&& intr
->sym
; intr
= intr
->next
)
5300 if (intr
->sym
->formal
)
5302 gfc_symbol
*fsym
= intr
->sym
->formal
->sym
;
5303 if ((fsym
->ts
.type
== BT_CLASS
5304 && CLASS_DATA (fsym
)->ts
.u
.derived
== extended
)
5305 || (fsym
->ts
.type
== BT_DERIVED
5306 && fsym
->ts
.u
.derived
== extended
))
5308 dtio_sub
= intr
->sym
;
5318 && dtio_sub
->formal
->sym
->ts
.type
== BT_CLASS
5319 && derived
!= CLASS_DATA (dtio_sub
->formal
->sym
)->ts
.u
.derived
)
5320 gfc_find_derived_vtab (derived
);
5325 /* Helper function - if we do not find an interface for a procedure,
5326 construct it from the actual arglist. Luckily, this can only
5327 happen for call by reference, so the information we actually need
5328 to provide (and which would be impossible to guess from the call
5329 itself) is not actually needed. */
5332 gfc_get_formal_from_actual_arglist (gfc_symbol
*sym
,
5333 gfc_actual_arglist
*actual_args
)
5335 gfc_actual_arglist
*a
;
5336 gfc_formal_arglist
**f
;
5338 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5342 for (a
= actual_args
; a
!= NULL
; a
= a
->next
)
5344 (*f
) = gfc_get_formal_arglist ();
5347 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "_formal_%d", var_num
++);
5348 gfc_get_symbol (name
, gfc_current_ns
, &s
);
5349 if (a
->expr
->ts
.type
== BT_PROCEDURE
)
5351 s
->attr
.flavor
= FL_PROCEDURE
;
5355 s
->ts
= a
->expr
->ts
;
5357 if (s
->ts
.type
== BT_CHARACTER
)
5358 s
->ts
.u
.cl
= gfc_get_charlen ();
5362 s
->ts
.is_c_interop
= 0;
5363 s
->attr
.flavor
= FL_VARIABLE
;
5364 if (a
->expr
->rank
> 0)
5366 s
->attr
.dimension
= 1;
5367 s
->as
= gfc_get_array_spec ();
5369 s
->as
->lower
[0] = gfc_get_int_expr (gfc_index_integer_kind
,
5370 &a
->expr
->where
, 1);
5371 s
->as
->upper
[0] = NULL
;
5372 s
->as
->type
= AS_ASSUMED_SIZE
;
5375 s
->maybe_array
= maybe_dummy_array_arg (a
->expr
);
5378 s
->attr
.artificial
= 1;
5379 s
->declared_at
= a
->expr
->where
;
5380 s
->attr
.intent
= INTENT_UNKNOWN
;
5383 else /* If a->expr is NULL, this is an alternate rerturn. */