1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Deal with interfaces. An explicit interface is represented as a
25 singly linked list of formal argument structures attached to the
26 relevant symbols. For an implicit interface, the arguments don't
27 point to symbols. Explicit interfaces point to namespaces that
28 contain the symbols within that interface.
30 Implicit interfaces are linked together in a singly linked list
31 along the next_if member of symbol nodes. Since a particular
32 symbol can only have a single explicit interface, the symbol cannot
33 be part of multiple lists and a single next-member suffices.
35 This is not the case for general classes, though. An operator
36 definition is independent of just about all other uses and has it's
40 Nameless interfaces create symbols with explicit interfaces within
41 the current namespace. They are otherwise unlinked.
44 The generic name points to a linked list of symbols. Each symbol
45 has an explicit interface. Each explicit interface has its own
46 namespace containing the arguments. Module procedures are symbols in
47 which the interface is added later when the module procedure is parsed.
50 User-defined operators are stored in a their own set of symtrees
51 separate from regular symbols. The symtrees point to gfc_user_op
52 structures which in turn head up a list of relevant interfaces.
54 Extended intrinsics and assignment:
55 The head of these interface lists are stored in the containing namespace.
58 An implicit interface is represented as a singly linked list of
59 formal argument list structures that don't point to any symbol
60 nodes -- they just contain types.
63 When a subprogram is defined, the program unit's name points to an
64 interface as usual, but the link to the namespace is NULL and the
65 formal argument list points to symbols within the same namespace as
66 the program unit name. */
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface
;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface
*intr
)
87 for (; intr
; intr
= next
)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary_intrinsic (gfc_intrinsic_op op
)
103 case INTRINSIC_UPLUS
:
106 case INTRINSIC_UMINUS
:
107 op
= INTRINSIC_MINUS
;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'op' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type
*type
,
124 gfc_intrinsic_op
*op
)
126 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES
)
132 *type
= INTERFACE_INTRINSIC_OP
;
133 *op
= INTRINSIC_ASSIGN
;
137 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
139 *type
= INTERFACE_INTRINSIC_OP
;
140 *op
= fold_unary_intrinsic (i
);
144 *op
= INTRINSIC_NONE
;
145 if (gfc_match (" operator ( ") == MATCH_YES
)
147 m
= gfc_match_defined_op_name (buffer
, 1);
153 m
= gfc_match_char (')');
159 strcpy (name
, buffer
);
160 *type
= INTERFACE_USER_OP
;
164 if (gfc_match_name (buffer
) == MATCH_YES
)
166 strcpy (name
, buffer
);
167 *type
= INTERFACE_GENERIC
;
171 *type
= INTERFACE_NAMELESS
;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five F95 forms of an interface statement. The
181 matcher for the abstract interface follows. */
184 gfc_match_interface (void)
186 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
192 m
= gfc_match_space ();
194 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
202 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
207 current_interface
.type
= type
;
211 case INTERFACE_GENERIC
:
212 if (gfc_get_symbol (name
, NULL
, &sym
))
215 if (!sym
->attr
.generic
216 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
221 gfc_error ("Dummy procedure '%s' at %C cannot have a "
222 "generic interface", sym
->name
);
226 current_interface
.sym
= gfc_new_block
= sym
;
229 case INTERFACE_USER_OP
:
230 current_interface
.uop
= gfc_get_uop (name
);
233 case INTERFACE_INTRINSIC_OP
:
234 current_interface
.op
= op
;
237 case INTERFACE_NAMELESS
:
238 case INTERFACE_ABSTRACT
:
247 /* Match a F2003 abstract interface. */
250 gfc_match_abstract_interface (void)
254 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ABSTRACT INTERFACE at %C")
258 m
= gfc_match_eos ();
262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
266 current_interface
.type
= INTERFACE_ABSTRACT
;
272 /* Match the different sort of generic-specs that can be present after
273 the END INTERFACE itself. */
276 gfc_match_end_interface (void)
278 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
283 m
= gfc_match_space ();
285 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
288 /* If we're not looking at the end of the statement now, or if this
289 is not a nameless interface but we did not see a space, punt. */
290 if (gfc_match_eos () != MATCH_YES
291 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
300 switch (current_interface
.type
)
302 case INTERFACE_NAMELESS
:
303 case INTERFACE_ABSTRACT
:
304 if (type
!= INTERFACE_NAMELESS
)
306 gfc_error ("Expected a nameless interface at %C");
312 case INTERFACE_INTRINSIC_OP
:
313 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
316 if (current_interface
.op
== INTRINSIC_ASSIGN
)
319 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
324 s1
= gfc_op2string (current_interface
.op
);
325 s2
= gfc_op2string (op
);
327 /* The following if-statements are used to enforce C1202
329 if ((strcmp(s1
, "==") == 0 && strcmp(s2
, ".eq.") == 0)
330 || (strcmp(s1
, ".eq.") == 0 && strcmp(s2
, "==") == 0))
332 if ((strcmp(s1
, "/=") == 0 && strcmp(s2
, ".ne.") == 0)
333 || (strcmp(s1
, ".ne.") == 0 && strcmp(s2
, "/=") == 0))
335 if ((strcmp(s1
, "<=") == 0 && strcmp(s2
, ".le.") == 0)
336 || (strcmp(s1
, ".le.") == 0 && strcmp(s2
, "<=") == 0))
338 if ((strcmp(s1
, "<") == 0 && strcmp(s2
, ".lt.") == 0)
339 || (strcmp(s1
, ".lt.") == 0 && strcmp(s2
, "<") == 0))
341 if ((strcmp(s1
, ">=") == 0 && strcmp(s2
, ".ge.") == 0)
342 || (strcmp(s1
, ".ge.") == 0 && strcmp(s2
, ">=") == 0))
344 if ((strcmp(s1
, ">") == 0 && strcmp(s2
, ".gt.") == 0)
345 || (strcmp(s1
, ".gt.") == 0 && strcmp(s2
, ">") == 0))
349 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
350 "but got %s", s1
, s2
);
357 case INTERFACE_USER_OP
:
358 /* Comparing the symbol node names is OK because only use-associated
359 symbols can be renamed. */
360 if (type
!= current_interface
.type
361 || strcmp (current_interface
.uop
->name
, name
) != 0)
363 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
364 current_interface
.uop
->name
);
370 case INTERFACE_GENERIC
:
371 if (type
!= current_interface
.type
372 || strcmp (current_interface
.sym
->name
, name
) != 0)
374 gfc_error ("Expecting 'END INTERFACE %s' at %C",
375 current_interface
.sym
->name
);
386 /* Compare two derived types using the criteria in 4.4.2 of the standard,
387 recursing through gfc_compare_types for the components. */
390 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
392 gfc_component
*dt1
, *dt2
;
394 if (derived1
== derived2
)
397 /* Special case for comparing derived types across namespaces. If the
398 true names and module names are the same and the module name is
399 nonnull, then they are equal. */
400 if (derived1
!= NULL
&& derived2
!= NULL
401 && strcmp (derived1
->name
, derived2
->name
) == 0
402 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
403 && strcmp (derived1
->module
, derived2
->module
) == 0)
406 /* Compare type via the rules of the standard. Both types must have
407 the SEQUENCE attribute to be equal. */
409 if (strcmp (derived1
->name
, derived2
->name
))
412 if (derived1
->component_access
== ACCESS_PRIVATE
413 || derived2
->component_access
== ACCESS_PRIVATE
)
416 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
419 dt1
= derived1
->components
;
420 dt2
= derived2
->components
;
422 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
423 simple test can speed things up. Otherwise, lots of things have to
427 if (strcmp (dt1
->name
, dt2
->name
) != 0)
430 if (dt1
->attr
.access
!= dt2
->attr
.access
)
433 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
436 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
439 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
442 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
445 /* Make sure that link lists do not put this function into an
446 endless recursive loop! */
447 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
448 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
449 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
452 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
453 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
456 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
)
457 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.u
.derived
))
463 if (dt1
== NULL
&& dt2
== NULL
)
465 if (dt1
== NULL
|| dt2
== NULL
)
473 /* Compare two typespecs, recursively if necessary. */
476 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
478 /* See if one of the typespecs is a BT_VOID, which is what is being used
479 to allow the funcs like c_f_pointer to accept any pointer type.
480 TODO: Possibly should narrow this to just the one typespec coming in
481 that is for the formal arg, but oh well. */
482 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
485 if (ts1
->type
!= ts2
->type
486 && ((ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
487 || (ts2
->type
!= BT_DERIVED
&& ts2
->type
!= BT_CLASS
)))
489 if (ts1
->type
!= BT_DERIVED
&& ts1
->type
!= BT_CLASS
)
490 return (ts1
->kind
== ts2
->kind
);
492 /* Compare derived types. */
493 if (gfc_type_compatible (ts1
, ts2
))
496 return gfc_compare_derived_types (ts1
->u
.derived
,ts2
->u
.derived
);
500 /* Given two symbols that are formal arguments, compare their ranks
501 and types. Returns nonzero if they have the same rank and type,
505 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
509 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
510 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
513 return 0; /* Ranks differ. */
515 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
519 /* Given two symbols that are formal arguments, compare their types
520 and rank and their formal interfaces if they are both dummy
521 procedures. Returns nonzero if the same, zero if different. */
524 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
526 if (s1
== NULL
|| s2
== NULL
)
527 return s1
== s2
? 1 : 0;
532 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
533 return compare_type_rank (s1
, s2
);
535 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
538 /* At this point, both symbols are procedures. It can happen that
539 external procedures are compared, where one is identified by usage
540 to be a function or subroutine but the other is not. Check TKR
541 nonetheless for these cases. */
542 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
543 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
545 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
546 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
548 /* Now the type of procedure has been identified. */
549 if (s1
->attr
.function
!= s2
->attr
.function
550 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
553 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
556 /* Originally, gfortran recursed here to check the interfaces of passed
557 procedures. This is explicitly not required by the standard. */
562 /* Given a formal argument list and a keyword name, search the list
563 for that keyword. Returns the correct symbol node if found, NULL
567 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
569 for (; f
; f
= f
->next
)
570 if (strcmp (f
->sym
->name
, name
) == 0)
577 /******** Interface checking subroutines **********/
580 /* Given an operator interface and the operator, make sure that all
581 interfaces for that operator are legal. */
584 gfc_check_operator_interface (gfc_symbol
*sym
, gfc_intrinsic_op op
,
587 gfc_formal_arglist
*formal
;
590 int args
, r1
, r2
, k1
, k2
;
595 t1
= t2
= BT_UNKNOWN
;
596 i1
= i2
= INTENT_UNKNOWN
;
600 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
602 gfc_symbol
*fsym
= formal
->sym
;
605 gfc_error ("Alternate return cannot appear in operator "
606 "interface at %L", &sym
->declared_at
);
612 i1
= fsym
->attr
.intent
;
613 r1
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
619 i2
= fsym
->attr
.intent
;
620 r2
= (fsym
->as
!= NULL
) ? fsym
->as
->rank
: 0;
626 /* Only +, - and .not. can be unary operators.
627 .not. cannot be a binary operator. */
628 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
629 && op
!= INTRINSIC_MINUS
630 && op
!= INTRINSIC_NOT
)
631 || (args
== 2 && op
== INTRINSIC_NOT
))
633 gfc_error ("Operator interface at %L has the wrong number of arguments",
638 /* Check that intrinsics are mapped to functions, except
639 INTRINSIC_ASSIGN which should map to a subroutine. */
640 if (op
== INTRINSIC_ASSIGN
)
642 if (!sym
->attr
.subroutine
)
644 gfc_error ("Assignment operator interface at %L must be "
645 "a SUBROUTINE", &sym
->declared_at
);
650 gfc_error ("Assignment operator interface at %L must have "
651 "two arguments", &sym
->declared_at
);
655 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
656 - First argument an array with different rank than second,
657 - First argument is a scalar and second an array,
658 - Types and kinds do not conform, or
659 - First argument is of derived type. */
660 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
661 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
662 && (r2
== 0 || r1
== r2
)
663 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
664 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
665 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
667 gfc_error ("Assignment operator interface at %L must not redefine "
668 "an INTRINSIC type assignment", &sym
->declared_at
);
674 if (!sym
->attr
.function
)
676 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
682 /* Check intents on operator interfaces. */
683 if (op
== INTRINSIC_ASSIGN
)
685 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
687 gfc_error ("First argument of defined assignment at %L must be "
688 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
694 gfc_error ("Second argument of defined assignment at %L must be "
695 "INTENT(IN)", &sym
->declared_at
);
703 gfc_error ("First argument of operator interface at %L must be "
704 "INTENT(IN)", &sym
->declared_at
);
708 if (args
== 2 && i2
!= INTENT_IN
)
710 gfc_error ("Second argument of operator interface at %L must be "
711 "INTENT(IN)", &sym
->declared_at
);
716 /* From now on, all we have to do is check that the operator definition
717 doesn't conflict with an intrinsic operator. The rules for this
718 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
719 as well as 12.3.2.1.1 of Fortran 2003:
721 "If the operator is an intrinsic-operator (R310), the number of
722 function arguments shall be consistent with the intrinsic uses of
723 that operator, and the types, kind type parameters, or ranks of the
724 dummy arguments shall differ from those required for the intrinsic
725 operation (7.1.2)." */
727 #define IS_NUMERIC_TYPE(t) \
728 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
730 /* Unary ops are easy, do them first. */
731 if (op
== INTRINSIC_NOT
)
733 if (t1
== BT_LOGICAL
)
739 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
741 if (IS_NUMERIC_TYPE (t1
))
747 /* Character intrinsic operators have same character kind, thus
748 operator definitions with operands of different character kinds
750 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
753 /* Intrinsic operators always perform on arguments of same rank,
754 so different ranks is also always safe. (rank == 0) is an exception
755 to that, because all intrinsic operators are elemental. */
756 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
762 case INTRINSIC_EQ_OS
:
764 case INTRINSIC_NE_OS
:
765 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
770 case INTRINSIC_MINUS
:
771 case INTRINSIC_TIMES
:
772 case INTRINSIC_DIVIDE
:
773 case INTRINSIC_POWER
:
774 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
779 case INTRINSIC_GT_OS
:
781 case INTRINSIC_GE_OS
:
783 case INTRINSIC_LT_OS
:
785 case INTRINSIC_LE_OS
:
786 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
788 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
789 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
793 case INTRINSIC_CONCAT
:
794 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
802 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
812 #undef IS_NUMERIC_TYPE
815 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
821 /* Given a pair of formal argument lists, we see if the two lists can
822 be distinguished by counting the number of nonoptional arguments of
823 a given type/rank in f1 and seeing if there are less then that
824 number of those arguments in f2 (including optional arguments).
825 Since this test is asymmetric, it has to be called twice to make it
826 symmetric. Returns nonzero if the argument lists are incompatible
827 by this test. This subroutine implements rule 1 of section
828 14.1.2.3 in the Fortran 95 standard. */
831 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
833 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
834 gfc_formal_arglist
*f
;
847 for (f
= f1
; f
; f
= f
->next
)
850 /* Build an array of integers that gives the same integer to
851 arguments of the same type/rank. */
852 arg
= XCNEWVEC (arginfo
, n1
);
855 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
863 for (i
= 0; i
< n1
; i
++)
865 if (arg
[i
].flag
!= -1)
868 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
869 continue; /* Skip optional arguments. */
873 /* Find other nonoptional arguments of the same type/rank. */
874 for (j
= i
+ 1; j
< n1
; j
++)
875 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
876 && (compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
)
877 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
883 /* Now loop over each distinct type found in f1. */
887 for (i
= 0; i
< n1
; i
++)
889 if (arg
[i
].flag
!= k
)
893 for (j
= i
+ 1; j
< n1
; j
++)
894 if (arg
[j
].flag
== k
)
897 /* Count the number of arguments in f2 with that type, including
898 those that are optional. */
901 for (f
= f2
; f
; f
= f
->next
)
902 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
903 || compare_type_rank_if (f
->sym
, arg
[i
].sym
))
921 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
922 Returns zero if no argument is found that satisfies rule 2, nonzero
925 This test is also not symmetric in f1 and f2 and must be called
926 twice. This test finds problems caused by sorting the actual
927 argument list with keywords. For example:
931 INTEGER :: A ; REAL :: B
935 INTEGER :: A ; REAL :: B
939 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
942 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
944 gfc_formal_arglist
*f2_save
, *g
;
951 if (f1
->sym
->attr
.optional
)
954 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
955 || compare_type_rank (f2
->sym
, f1
->sym
)))
958 /* Now search for a disambiguating keyword argument starting at
959 the current non-match. */
960 for (g
= f1
; g
; g
= g
->next
)
962 if (g
->sym
->attr
.optional
)
965 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
966 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
980 /* 'Compare' two formal interfaces associated with a pair of symbols.
981 We return nonzero if there exists an actual argument list that
982 would be ambiguous between the two interfaces, zero otherwise.
983 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
984 required to match, which is not the case for ambiguity checks.*/
987 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
988 int generic_flag
, int intent_flag
,
989 char *errmsg
, int err_len
)
991 gfc_formal_arglist
*f1
, *f2
;
993 gcc_assert (name2
!= NULL
);
995 if (s1
->attr
.function
&& (s2
->attr
.subroutine
996 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
997 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
1000 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1004 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1007 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1011 /* If the arguments are functions, check type and kind
1012 (only for dummy procedures and procedure pointer assignments). */
1013 if (!generic_flag
&& intent_flag
&& s1
->attr
.function
&& s2
->attr
.function
)
1015 if (s1
->ts
.type
== BT_UNKNOWN
)
1017 if ((s1
->ts
.type
!= s2
->ts
.type
) || (s1
->ts
.kind
!= s2
->ts
.kind
))
1020 snprintf (errmsg
, err_len
, "Type/kind mismatch in return value "
1026 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1027 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1033 if (f1
== NULL
&& f2
== NULL
)
1034 return 1; /* Special case: No arguments. */
1038 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1040 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
1044 /* Perform the abbreviated correspondence test for operators (the
1045 arguments cannot be optional and are always ordered correctly).
1046 This is also done when comparing interfaces for dummy procedures and in
1047 procedure pointer assignments. */
1051 /* Check existence. */
1052 if (f1
== NULL
&& f2
== NULL
)
1054 if (f1
== NULL
|| f2
== NULL
)
1057 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1058 "arguments", name2
);
1062 /* Check type and rank. */
1063 if (!compare_type_rank (f2
->sym
, f1
->sym
))
1066 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1072 if (intent_flag
&& (f1
->sym
->attr
.intent
!= f2
->sym
->attr
.intent
))
1074 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1079 /* Check OPTIONAL. */
1080 if (intent_flag
&& (f1
->sym
->attr
.optional
!= f2
->sym
->attr
.optional
))
1082 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1095 /* Given a pointer to an interface pointer, remove duplicate
1096 interfaces and make sure that all symbols are either functions
1097 or subroutines, and all of the same kind. Returns nonzero if
1098 something goes wrong. */
1101 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1103 gfc_interface
*psave
, *q
, *qlast
;
1106 for (; p
; p
= p
->next
)
1108 /* Make sure all symbols in the interface have been defined as
1109 functions or subroutines. */
1110 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1111 || !p
->sym
->attr
.if_source
)
1113 if (p
->sym
->attr
.external
)
1114 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1115 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1117 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1118 "subroutine", p
->sym
->name
, interface_name
,
1119 &p
->sym
->declared_at
);
1123 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1124 if ((psave
->sym
->attr
.function
&& !p
->sym
->attr
.function
)
1125 || (psave
->sym
->attr
.subroutine
&& !p
->sym
->attr
.subroutine
))
1127 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1128 " or all FUNCTIONs", interface_name
, &p
->sym
->declared_at
);
1134 /* Remove duplicate interfaces in this interface list. */
1135 for (; p
; p
= p
->next
)
1139 for (q
= p
->next
; q
;)
1141 if (p
->sym
!= q
->sym
)
1148 /* Duplicate interface. */
1149 qlast
->next
= q
->next
;
1160 /* Check lists of interfaces to make sure that no two interfaces are
1161 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1164 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1165 int generic_flag
, const char *interface_name
,
1169 for (; p
; p
= p
->next
)
1170 for (q
= q0
; q
; q
= q
->next
)
1172 if (p
->sym
== q
->sym
)
1173 continue; /* Duplicates OK here. */
1175 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1178 if (gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
, generic_flag
,
1182 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1183 p
->sym
->name
, q
->sym
->name
, interface_name
,
1185 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1186 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1187 p
->sym
->name
, q
->sym
->name
, interface_name
,
1190 gfc_warning ("Although not referenced, '%s' has ambiguous "
1191 "interfaces at %L", interface_name
, &p
->where
);
1199 /* Check the generic and operator interfaces of symbols to make sure
1200 that none of the interfaces conflict. The check has to be done
1201 after all of the symbols are actually loaded. */
1204 check_sym_interfaces (gfc_symbol
*sym
)
1206 char interface_name
[100];
1209 if (sym
->ns
!= gfc_current_ns
)
1212 if (sym
->generic
!= NULL
)
1214 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1215 if (check_interface0 (sym
->generic
, interface_name
))
1218 for (p
= sym
->generic
; p
; p
= p
->next
)
1220 if (p
->sym
->attr
.mod_proc
1221 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1222 || p
->sym
->attr
.procedure
))
1224 gfc_error ("'%s' at %L is not a module procedure",
1225 p
->sym
->name
, &p
->where
);
1230 /* Originally, this test was applied to host interfaces too;
1231 this is incorrect since host associated symbols, from any
1232 source, cannot be ambiguous with local symbols. */
1233 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1234 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1240 check_uop_interfaces (gfc_user_op
*uop
)
1242 char interface_name
[100];
1246 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1247 if (check_interface0 (uop
->op
, interface_name
))
1250 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1252 uop2
= gfc_find_uop (uop
->name
, ns
);
1256 check_interface1 (uop
->op
, uop2
->op
, 0,
1257 interface_name
, true);
1262 /* For the namespace, check generic, user operator and intrinsic
1263 operator interfaces for consistency and to remove duplicate
1264 interfaces. We traverse the whole namespace, counting on the fact
1265 that most symbols will not have generic or operator interfaces. */
1268 gfc_check_interfaces (gfc_namespace
*ns
)
1270 gfc_namespace
*old_ns
, *ns2
;
1271 char interface_name
[100];
1274 old_ns
= gfc_current_ns
;
1275 gfc_current_ns
= ns
;
1277 gfc_traverse_ns (ns
, check_sym_interfaces
);
1279 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1281 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1283 if (i
== INTRINSIC_USER
)
1286 if (i
== INTRINSIC_ASSIGN
)
1287 strcpy (interface_name
, "intrinsic assignment operator");
1289 sprintf (interface_name
, "intrinsic '%s' operator",
1290 gfc_op2string ((gfc_intrinsic_op
) i
));
1292 if (check_interface0 (ns
->op
[i
], interface_name
))
1296 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1299 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1301 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1302 interface_name
, true))
1308 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ_OS
],
1309 0, interface_name
, true)) goto done
;
1312 case INTRINSIC_EQ_OS
:
1313 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ
],
1314 0, interface_name
, true)) goto done
;
1318 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE_OS
],
1319 0, interface_name
, true)) goto done
;
1322 case INTRINSIC_NE_OS
:
1323 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE
],
1324 0, interface_name
, true)) goto done
;
1328 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT_OS
],
1329 0, interface_name
, true)) goto done
;
1332 case INTRINSIC_GT_OS
:
1333 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT
],
1334 0, interface_name
, true)) goto done
;
1338 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE_OS
],
1339 0, interface_name
, true)) goto done
;
1342 case INTRINSIC_GE_OS
:
1343 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE
],
1344 0, interface_name
, true)) goto done
;
1348 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT_OS
],
1349 0, interface_name
, true)) goto done
;
1352 case INTRINSIC_LT_OS
:
1353 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT
],
1354 0, interface_name
, true)) goto done
;
1358 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE_OS
],
1359 0, interface_name
, true)) goto done
;
1362 case INTRINSIC_LE_OS
:
1363 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE
],
1364 0, interface_name
, true)) goto done
;
1374 gfc_current_ns
= old_ns
;
1379 symbol_rank (gfc_symbol
*sym
)
1381 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1385 /* Given a symbol of a formal argument list and an expression, if the
1386 formal argument is allocatable, check that the actual argument is
1387 allocatable. Returns nonzero if compatible, zero if not compatible. */
1390 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1392 symbol_attribute attr
;
1394 if (formal
->attr
.allocatable
1395 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1397 attr
= gfc_expr_attr (actual
);
1398 if (!attr
.allocatable
)
1406 /* Given a symbol of a formal argument list and an expression, if the
1407 formal argument is a pointer, see if the actual argument is a
1408 pointer. Returns nonzero if compatible, zero if not compatible. */
1411 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1413 symbol_attribute attr
;
1415 if (formal
->attr
.pointer
)
1417 attr
= gfc_expr_attr (actual
);
1419 /* Fortran 2008 allows non-pointer actual arguments. */
1420 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1431 /* Emit clear error messages for rank mismatch. */
1434 argument_rank_mismatch (const char *name
, locus
*where
,
1435 int rank1
, int rank2
)
1439 gfc_error ("Rank mismatch in argument '%s' at %L "
1440 "(scalar and rank-%d)", name
, where
, rank2
);
1442 else if (rank2
== 0)
1444 gfc_error ("Rank mismatch in argument '%s' at %L "
1445 "(rank-%d and scalar)", name
, where
, rank1
);
1449 gfc_error ("Rank mismatch in argument '%s' at %L "
1450 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1455 /* Given a symbol of a formal argument list and an expression, see if
1456 the two are compatible as arguments. Returns nonzero if
1457 compatible, zero if not compatible. */
1460 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1461 int ranks_must_agree
, int is_elemental
, locus
*where
)
1464 bool rank_check
, is_pointer
;
1466 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1467 procs c_f_pointer or c_f_procpointer, and we need to accept most
1468 pointers the user could give us. This should allow that. */
1469 if (formal
->ts
.type
== BT_VOID
)
1472 if (formal
->ts
.type
== BT_DERIVED
1473 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1474 && actual
->ts
.type
== BT_DERIVED
1475 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1478 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1479 /* Make sure the vtab symbol is present when
1480 the module variables are generated. */
1481 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1483 if (actual
->ts
.type
== BT_PROCEDURE
)
1486 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1488 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1491 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1495 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1499 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1500 formal
->name
, &actual
->where
, err
);
1504 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1506 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1507 &act_sym
->declared_at
);
1508 if (act_sym
->ts
.type
== BT_UNKNOWN
1509 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1512 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1513 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1514 &act_sym
->declared_at
);
1520 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1521 && !gfc_is_simply_contiguous (actual
, true))
1524 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1525 "must be simply contigous", formal
->name
, &actual
->where
);
1529 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1530 && actual
->ts
.type
!= BT_HOLLERITH
1531 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1534 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1535 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1536 gfc_typename (&formal
->ts
));
1540 /* F2003, 12.5.2.5. */
1541 if (formal
->ts
.type
== BT_CLASS
1542 && (CLASS_DATA (formal
)->attr
.class_pointer
1543 || CLASS_DATA (formal
)->attr
.allocatable
))
1545 if (actual
->ts
.type
!= BT_CLASS
)
1548 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1549 formal
->name
, &actual
->where
);
1552 if (CLASS_DATA (actual
)->ts
.u
.derived
1553 != CLASS_DATA (formal
)->ts
.u
.derived
)
1556 gfc_error ("Actual argument to '%s' at %L must have the same "
1557 "declared type", formal
->name
, &actual
->where
);
1562 if (formal
->attr
.codimension
)
1564 gfc_ref
*last
= NULL
;
1566 if (actual
->expr_type
!= EXPR_VARIABLE
1567 || (actual
->ref
== NULL
1568 && !actual
->symtree
->n
.sym
->attr
.codimension
))
1571 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1572 formal
->name
, &actual
->where
);
1576 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1578 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
!= 0)
1581 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1582 "and not coindexed", formal
->name
, &ref
->u
.ar
.where
);
1585 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
->corank
1586 && ref
->u
.ar
.type
!= AR_FULL
&& ref
->u
.ar
.dimen
!= 0)
1589 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1590 "and thus shall not have an array designator",
1591 formal
->name
, &ref
->u
.ar
.where
);
1594 if (ref
->type
== REF_COMPONENT
)
1598 if (last
&& !last
->u
.c
.component
->attr
.codimension
)
1601 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1602 formal
->name
, &actual
->where
);
1606 /* F2008, 12.5.2.6. */
1607 if (formal
->attr
.allocatable
&&
1608 ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1610 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
)))
1613 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1614 formal
->name
, &actual
->where
, formal
->as
->corank
,
1615 last
? last
->u
.c
.component
->as
->corank
1616 : actual
->symtree
->n
.sym
->as
->corank
);
1620 /* F2008, 12.5.2.8. */
1621 if (formal
->attr
.dimension
1622 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1623 && !gfc_is_simply_contiguous (actual
, true))
1626 gfc_error ("Actual argument to '%s' at %L must be simply "
1627 "contiguous", formal
->name
, &actual
->where
);
1632 /* F2008, C1239/C1240. */
1633 if (actual
->expr_type
== EXPR_VARIABLE
1634 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1635 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1636 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1637 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1638 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1639 || formal
->attr
.contiguous
))
1642 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1643 "array without CONTIGUOUS attribute - as actual argument at"
1644 " %L is not simply contiguous and both are ASYNCHRONOUS "
1645 "or VOLATILE", formal
->name
, &actual
->where
);
1649 if (symbol_rank (formal
) == actual
->rank
)
1652 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1653 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1654 || formal
->as
->type
== AS_DEFERRED
)
1655 && actual
->expr_type
!= EXPR_NULL
;
1657 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1658 if (rank_check
|| ranks_must_agree
1659 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
1660 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1661 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
1662 && actual
->expr_type
!= EXPR_NULL
)
1663 || (actual
->rank
== 0 && formal
->attr
.dimension
1664 && gfc_is_coindexed (actual
)))
1667 argument_rank_mismatch (formal
->name
, &actual
->where
,
1668 symbol_rank (formal
), actual
->rank
);
1671 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1674 /* At this point, we are considering a scalar passed to an array. This
1675 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1676 - if the actual argument is (a substring of) an element of a
1677 non-assumed-shape/non-pointer/non-polymorphic array; or
1678 - (F2003) if the actual argument is of type character of default/c_char
1681 is_pointer
= actual
->expr_type
== EXPR_VARIABLE
1682 ? actual
->symtree
->n
.sym
->attr
.pointer
: false;
1684 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1686 if (ref
->type
== REF_COMPONENT
)
1687 is_pointer
= ref
->u
.c
.component
->attr
.pointer
;
1688 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1689 && ref
->u
.ar
.dimen
> 0
1691 || (ref
->next
->type
== REF_SUBSTRING
&& !ref
->next
->next
)))
1695 if (actual
->ts
.type
== BT_CLASS
&& actual
->expr_type
!= EXPR_NULL
)
1698 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1699 "at %L", formal
->name
, &actual
->where
);
1703 if (actual
->expr_type
!= EXPR_NULL
&& ref
&& actual
->ts
.type
!= BT_CHARACTER
1704 && (is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
1707 gfc_error ("Element of assumed-shaped or pointer "
1708 "array passed to array dummy argument '%s' at %L",
1709 formal
->name
, &actual
->where
);
1713 if (actual
->ts
.type
== BT_CHARACTER
&& actual
->expr_type
!= EXPR_NULL
1714 && (!ref
|| is_pointer
|| ref
->u
.ar
.as
->type
== AS_ASSUMED_SHAPE
))
1716 if (formal
->ts
.kind
!= 1 && (gfc_option
.allow_std
& GFC_STD_GNU
) == 0)
1719 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1720 "CHARACTER actual argument with array dummy argument "
1721 "'%s' at %L", formal
->name
, &actual
->where
);
1725 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1727 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1728 "array dummy argument '%s' at %L",
1729 formal
->name
, &actual
->where
);
1732 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1738 if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
1741 argument_rank_mismatch (formal
->name
, &actual
->where
,
1742 symbol_rank (formal
), actual
->rank
);
1750 /* Returns the storage size of a symbol (formal argument) or
1751 zero if it cannot be determined. */
1753 static unsigned long
1754 get_sym_storage_size (gfc_symbol
*sym
)
1757 unsigned long strlen
, elements
;
1759 if (sym
->ts
.type
== BT_CHARACTER
)
1761 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1762 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1763 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
1770 if (symbol_rank (sym
) == 0)
1774 if (sym
->as
->type
!= AS_EXPLICIT
)
1776 for (i
= 0; i
< sym
->as
->rank
; i
++)
1778 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1779 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1782 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
1783 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1786 return strlen
*elements
;
1790 /* Returns the storage size of an expression (actual argument) or
1791 zero if it cannot be determined. For an array element, it returns
1792 the remaining size as the element sequence consists of all storage
1793 units of the actual argument up to the end of the array. */
1795 static unsigned long
1796 get_expr_storage_size (gfc_expr
*e
)
1799 long int strlen
, elements
;
1800 long int substrlen
= 0;
1801 bool is_str_storage
= false;
1807 if (e
->ts
.type
== BT_CHARACTER
)
1809 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1810 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1811 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
1812 else if (e
->expr_type
== EXPR_CONSTANT
1813 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
1814 strlen
= e
->value
.character
.length
;
1819 strlen
= 1; /* Length per element. */
1821 if (e
->rank
== 0 && !e
->ref
)
1829 for (i
= 0; i
< e
->rank
; i
++)
1830 elements
*= mpz_get_si (e
->shape
[i
]);
1831 return elements
*strlen
;
1834 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1836 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1837 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1841 /* The string length is the substring length.
1842 Set now to full string length. */
1843 if (ref
->u
.ss
.length
== NULL
1844 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1847 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1849 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1853 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1854 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1855 && ref
->u
.ar
.as
->upper
)
1856 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1858 long int start
, end
, stride
;
1861 if (ref
->u
.ar
.stride
[i
])
1863 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1864 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1869 if (ref
->u
.ar
.start
[i
])
1871 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1872 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1876 else if (ref
->u
.ar
.as
->lower
[i
]
1877 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1878 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1882 if (ref
->u
.ar
.end
[i
])
1884 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1885 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1889 else if (ref
->u
.ar
.as
->upper
[i
]
1890 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1891 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1895 elements
*= (end
- start
)/stride
+ 1L;
1897 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1898 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1899 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1901 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1902 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1903 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1904 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1905 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1910 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1911 && e
->expr_type
== EXPR_VARIABLE
)
1913 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1914 || e
->symtree
->n
.sym
->attr
.pointer
)
1920 /* Determine the number of remaining elements in the element
1921 sequence for array element designators. */
1922 is_str_storage
= true;
1923 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1925 if (ref
->u
.ar
.start
[i
] == NULL
1926 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1927 || ref
->u
.ar
.as
->upper
[i
] == NULL
1928 || ref
->u
.ar
.as
->lower
[i
] == NULL
1929 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1930 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1935 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1936 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1938 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1939 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1947 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1950 return elements
*strlen
;
1954 /* Given an expression, check whether it is an array section
1955 which has a vector subscript. If it has, one is returned,
1959 gfc_has_vector_subscript (gfc_expr
*e
)
1964 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1967 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1968 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1969 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1970 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1977 /* Given formal and actual argument lists, see if they are compatible.
1978 If they are compatible, the actual argument list is sorted to
1979 correspond with the formal list, and elements for missing optional
1980 arguments are inserted. If WHERE pointer is nonnull, then we issue
1981 errors when things don't match instead of just returning the status
1985 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1986 int ranks_must_agree
, int is_elemental
, locus
*where
)
1988 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
1989 gfc_formal_arglist
*f
;
1991 unsigned long actual_size
, formal_size
;
1995 if (actual
== NULL
&& formal
== NULL
)
1999 for (f
= formal
; f
; f
= f
->next
)
2002 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
2004 for (i
= 0; i
< n
; i
++)
2011 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
2013 /* Look for keywords but ignore g77 extensions like %VAL. */
2014 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2017 for (f
= formal
; f
; f
= f
->next
, i
++)
2021 if (strcmp (f
->sym
->name
, a
->name
) == 0)
2028 gfc_error ("Keyword argument '%s' at %L is not in "
2029 "the procedure", a
->name
, &a
->expr
->where
);
2033 if (new_arg
[i
] != NULL
)
2036 gfc_error ("Keyword argument '%s' at %L is already associated "
2037 "with another actual argument", a
->name
,
2046 gfc_error ("More actual than formal arguments in procedure "
2047 "call at %L", where
);
2052 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2058 gfc_error ("Missing alternate return spec in subroutine call "
2063 if (a
->expr
== NULL
)
2066 gfc_error ("Unexpected alternate return spec in subroutine "
2067 "call at %L", where
);
2071 if (a
->expr
->expr_type
== EXPR_NULL
&& !f
->sym
->attr
.pointer
2072 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2073 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2075 if (where
&& (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
))
2076 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2077 where
, f
->sym
->name
);
2079 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2080 "dummy '%s'", where
, f
->sym
->name
);
2085 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2086 is_elemental
, where
))
2089 /* Special case for character arguments. For allocatable, pointer
2090 and assumed-shape dummies, the string length needs to match
2092 if (a
->expr
->ts
.type
== BT_CHARACTER
2093 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2094 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2095 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2096 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2097 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2098 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2099 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2100 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2102 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2103 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2104 "argument and pointer or allocatable dummy argument "
2106 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2107 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2108 f
->sym
->name
, &a
->expr
->where
);
2110 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2111 "argument and assumed-shape dummy argument '%s' "
2113 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2114 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2115 f
->sym
->name
, &a
->expr
->where
);
2119 if ((f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
)
2120 && f
->sym
->ts
.deferred
!= a
->expr
->ts
.deferred
2121 && a
->expr
->ts
.type
== BT_CHARACTER
)
2124 gfc_error ("Actual argument argument at %L to allocatable or "
2125 "pointer dummy argument '%s' must have a deferred "
2126 "length type parameter if and only if the dummy has one",
2127 &a
->expr
->where
, f
->sym
->name
);
2131 actual_size
= get_expr_storage_size (a
->expr
);
2132 formal_size
= get_sym_storage_size (f
->sym
);
2133 if (actual_size
!= 0
2134 && actual_size
< formal_size
2135 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
2137 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2138 gfc_warning ("Character length of actual argument shorter "
2139 "than of dummy argument '%s' (%lu/%lu) at %L",
2140 f
->sym
->name
, actual_size
, formal_size
,
2143 gfc_warning ("Actual argument contains too few "
2144 "elements for dummy argument '%s' (%lu/%lu) at %L",
2145 f
->sym
->name
, actual_size
, formal_size
,
2150 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2151 is provided for a procedure pointer formal argument. */
2152 if (f
->sym
->attr
.proc_pointer
2153 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2154 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2155 || (a
->expr
->expr_type
== EXPR_FUNCTION
2156 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2157 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
2160 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2161 f
->sym
->name
, &a
->expr
->where
);
2165 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2166 provided for a procedure formal argument. */
2167 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
2168 && a
->expr
->expr_type
== EXPR_VARIABLE
2169 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2172 gfc_error ("Expected a procedure for argument '%s' at %L",
2173 f
->sym
->name
, &a
->expr
->where
);
2177 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
2178 && a
->expr
->ts
.type
== BT_PROCEDURE
2179 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
2182 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2183 f
->sym
->name
, &a
->expr
->where
);
2187 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2188 && a
->expr
->expr_type
== EXPR_VARIABLE
2189 && a
->expr
->symtree
->n
.sym
->as
2190 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2191 && (a
->expr
->ref
== NULL
2192 || (a
->expr
->ref
->type
== REF_ARRAY
2193 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2196 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2197 " array at %L", f
->sym
->name
, where
);
2201 if (a
->expr
->expr_type
!= EXPR_NULL
2202 && compare_pointer (f
->sym
, a
->expr
) == 0)
2205 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2206 f
->sym
->name
, &a
->expr
->where
);
2210 if (a
->expr
->expr_type
!= EXPR_NULL
2211 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2212 && compare_pointer (f
->sym
, a
->expr
) == 2)
2215 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2216 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2221 /* Fortran 2008, C1242. */
2222 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2225 gfc_error ("Coindexed actual argument at %L to pointer "
2227 &a
->expr
->where
, f
->sym
->name
);
2231 /* Fortran 2008, 12.5.2.5 (no constraint). */
2232 if (a
->expr
->expr_type
== EXPR_VARIABLE
2233 && f
->sym
->attr
.intent
!= INTENT_IN
2234 && f
->sym
->attr
.allocatable
2235 && gfc_is_coindexed (a
->expr
))
2238 gfc_error ("Coindexed actual argument at %L to allocatable "
2239 "dummy '%s' requires INTENT(IN)",
2240 &a
->expr
->where
, f
->sym
->name
);
2244 /* Fortran 2008, C1237. */
2245 if (a
->expr
->expr_type
== EXPR_VARIABLE
2246 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2247 && gfc_is_coindexed (a
->expr
)
2248 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2249 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2252 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2253 "at %L requires that dummy %s' has neither "
2254 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2259 /* Fortran 2008, 12.5.2.4 (no constraint). */
2260 if (a
->expr
->expr_type
== EXPR_VARIABLE
2261 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2262 && gfc_is_coindexed (a
->expr
)
2263 && gfc_has_ultimate_allocatable (a
->expr
))
2266 gfc_error ("Coindexed actual argument at %L with allocatable "
2267 "ultimate component to dummy '%s' requires either VALUE "
2268 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2272 if (a
->expr
->expr_type
!= EXPR_NULL
2273 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2276 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2277 f
->sym
->name
, &a
->expr
->where
);
2281 /* Check intent = OUT/INOUT for definable actual argument. */
2282 if ((f
->sym
->attr
.intent
== INTENT_OUT
2283 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2285 const char* context
= (where
2286 ? _("actual argument to INTENT = OUT/INOUT")
2289 if (f
->sym
->attr
.pointer
2290 && gfc_check_vardef_context (a
->expr
, true, context
)
2293 if (gfc_check_vardef_context (a
->expr
, false, context
)
2298 if ((f
->sym
->attr
.intent
== INTENT_OUT
2299 || f
->sym
->attr
.intent
== INTENT_INOUT
2300 || f
->sym
->attr
.volatile_
2301 || f
->sym
->attr
.asynchronous
)
2302 && gfc_has_vector_subscript (a
->expr
))
2305 gfc_error ("Array-section actual argument with vector "
2306 "subscripts at %L is incompatible with INTENT(OUT), "
2307 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2308 "of the dummy argument '%s'",
2309 &a
->expr
->where
, f
->sym
->name
);
2313 /* C1232 (R1221) For an actual argument which is an array section or
2314 an assumed-shape array, the dummy argument shall be an assumed-
2315 shape array, if the dummy argument has the VOLATILE attribute. */
2317 if (f
->sym
->attr
.volatile_
2318 && a
->expr
->symtree
->n
.sym
->as
2319 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2320 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2323 gfc_error ("Assumed-shape actual argument at %L is "
2324 "incompatible with the non-assumed-shape "
2325 "dummy argument '%s' due to VOLATILE attribute",
2326 &a
->expr
->where
,f
->sym
->name
);
2330 if (f
->sym
->attr
.volatile_
2331 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2332 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2335 gfc_error ("Array-section actual argument at %L is "
2336 "incompatible with the non-assumed-shape "
2337 "dummy argument '%s' due to VOLATILE attribute",
2338 &a
->expr
->where
,f
->sym
->name
);
2342 /* C1233 (R1221) For an actual argument which is a pointer array, the
2343 dummy argument shall be an assumed-shape or pointer array, if the
2344 dummy argument has the VOLATILE attribute. */
2346 if (f
->sym
->attr
.volatile_
2347 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2348 && a
->expr
->symtree
->n
.sym
->as
2350 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2351 || f
->sym
->attr
.pointer
)))
2354 gfc_error ("Pointer-array actual argument at %L requires "
2355 "an assumed-shape or pointer-array dummy "
2356 "argument '%s' due to VOLATILE attribute",
2357 &a
->expr
->where
,f
->sym
->name
);
2368 /* Make sure missing actual arguments are optional. */
2370 for (f
= formal
; f
; f
= f
->next
, i
++)
2372 if (new_arg
[i
] != NULL
)
2377 gfc_error ("Missing alternate return spec in subroutine call "
2381 if (!f
->sym
->attr
.optional
)
2384 gfc_error ("Missing actual argument for argument '%s' at %L",
2385 f
->sym
->name
, where
);
2390 /* The argument lists are compatible. We now relink a new actual
2391 argument list with null arguments in the right places. The head
2392 of the list remains the head. */
2393 for (i
= 0; i
< n
; i
++)
2394 if (new_arg
[i
] == NULL
)
2395 new_arg
[i
] = gfc_get_actual_arglist ();
2400 *new_arg
[0] = *actual
;
2404 new_arg
[0] = new_arg
[na
];
2408 for (i
= 0; i
< n
- 1; i
++)
2409 new_arg
[i
]->next
= new_arg
[i
+ 1];
2411 new_arg
[i
]->next
= NULL
;
2413 if (*ap
== NULL
&& n
> 0)
2416 /* Note the types of omitted optional arguments. */
2417 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2418 if (a
->expr
== NULL
&& a
->label
== NULL
)
2419 a
->missing_arg_type
= f
->sym
->ts
.type
;
2427 gfc_formal_arglist
*f
;
2428 gfc_actual_arglist
*a
;
2432 /* qsort comparison function for argument pairs, with the following
2434 - p->a->expr == NULL
2435 - p->a->expr->expr_type != EXPR_VARIABLE
2436 - growing p->a->expr->symbol. */
2439 pair_cmp (const void *p1
, const void *p2
)
2441 const gfc_actual_arglist
*a1
, *a2
;
2443 /* *p1 and *p2 are elements of the to-be-sorted array. */
2444 a1
= ((const argpair
*) p1
)->a
;
2445 a2
= ((const argpair
*) p2
)->a
;
2454 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2456 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2460 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2462 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2466 /* Given two expressions from some actual arguments, test whether they
2467 refer to the same expression. The analysis is conservative.
2468 Returning FAILURE will produce no warning. */
2471 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2473 const gfc_ref
*r1
, *r2
;
2476 || e1
->expr_type
!= EXPR_VARIABLE
2477 || e2
->expr_type
!= EXPR_VARIABLE
2478 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2481 /* TODO: improve comparison, see expr.c:show_ref(). */
2482 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2484 if (r1
->type
!= r2
->type
)
2489 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2491 /* TODO: At the moment, consider only full arrays;
2492 we could do better. */
2493 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2498 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2506 gfc_internal_error ("compare_actual_expr(): Bad component code");
2515 /* Given formal and actual argument lists that correspond to one
2516 another, check that identical actual arguments aren't not
2517 associated with some incompatible INTENTs. */
2520 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2522 sym_intent f1_intent
, f2_intent
;
2523 gfc_formal_arglist
*f1
;
2524 gfc_actual_arglist
*a1
;
2527 gfc_try t
= SUCCESS
;
2530 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2532 if (f1
== NULL
&& a1
== NULL
)
2534 if (f1
== NULL
|| a1
== NULL
)
2535 gfc_internal_error ("check_some_aliasing(): List mismatch");
2540 p
= XALLOCAVEC (argpair
, n
);
2542 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2548 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2550 for (i
= 0; i
< n
; i
++)
2553 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2554 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2556 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2557 for (j
= i
+ 1; j
< n
; j
++)
2559 /* Expected order after the sort. */
2560 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2561 gfc_internal_error ("check_some_aliasing(): corrupted data");
2563 /* Are the expression the same? */
2564 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2566 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2567 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2568 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2570 gfc_warning ("Same actual argument associated with INTENT(%s) "
2571 "argument '%s' and INTENT(%s) argument '%s' at %L",
2572 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2573 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2574 &p
[i
].a
->expr
->where
);
2584 /* Given a symbol of a formal argument list and an expression,
2585 return nonzero if their intents are compatible, zero otherwise. */
2588 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2590 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2593 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2596 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2603 /* Given formal and actual argument lists that correspond to one
2604 another, check that they are compatible in the sense that intents
2605 are not mismatched. */
2608 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2610 sym_intent f_intent
;
2612 for (;; f
= f
->next
, a
= a
->next
)
2614 if (f
== NULL
&& a
== NULL
)
2616 if (f
== NULL
|| a
== NULL
)
2617 gfc_internal_error ("check_intents(): List mismatch");
2619 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2622 f_intent
= f
->sym
->attr
.intent
;
2624 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2626 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2627 "specifies INTENT(%s)", &a
->expr
->where
,
2628 gfc_intent_string (f_intent
));
2632 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2634 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2636 gfc_error ("Procedure argument at %L is local to a PURE "
2637 "procedure and is passed to an INTENT(%s) argument",
2638 &a
->expr
->where
, gfc_intent_string (f_intent
));
2642 if (f
->sym
->attr
.pointer
)
2644 gfc_error ("Procedure argument at %L is local to a PURE "
2645 "procedure and has the POINTER attribute",
2651 /* Fortran 2008, C1283. */
2652 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
2654 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2656 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2657 "is passed to an INTENT(%s) argument",
2658 &a
->expr
->where
, gfc_intent_string (f_intent
));
2662 if (f
->sym
->attr
.pointer
)
2664 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2665 "is passed to a POINTER dummy argument",
2671 /* F2008, Section 12.5.2.4. */
2672 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
2673 && gfc_is_coindexed (a
->expr
))
2675 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2676 "polymorphic dummy argument '%s'",
2677 &a
->expr
->where
, f
->sym
->name
);
2686 /* Check how a procedure is used against its interface. If all goes
2687 well, the actual argument list will also end up being properly
2691 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2694 /* Warn about calls with an implicit interface. Special case
2695 for calling a ISO_C_BINDING becase c_loc and c_funloc
2696 are pseudo-unknown. Additionally, warn about procedures not
2697 explicitly declared at all if requested. */
2698 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2700 if (gfc_option
.warn_implicit_interface
)
2701 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2703 else if (gfc_option
.warn_implicit_procedure
2704 && sym
->attr
.proc
== PROC_UNKNOWN
)
2705 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2709 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2711 gfc_actual_arglist
*a
;
2713 if (sym
->attr
.pointer
)
2715 gfc_error("The pointer object '%s' at %L must have an explicit "
2716 "function interface or be declared as array",
2721 if (sym
->attr
.allocatable
&& !sym
->attr
.external
)
2723 gfc_error("The allocatable object '%s' at %L must have an explicit "
2724 "function interface or be declared as array",
2729 if (sym
->attr
.allocatable
)
2731 gfc_error("Allocatable function '%s' at %L must have an explicit "
2732 "function interface", sym
->name
, where
);
2736 for (a
= *ap
; a
; a
= a
->next
)
2738 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2739 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2741 gfc_error("Keyword argument requires explicit interface "
2742 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2750 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2753 check_intents (sym
->formal
, *ap
);
2754 if (gfc_option
.warn_aliasing
)
2755 check_some_aliasing (sym
->formal
, *ap
);
2759 /* Check how a procedure pointer component is used against its interface.
2760 If all goes well, the actual argument list will also end up being properly
2761 sorted. Completely analogous to gfc_procedure_use. */
2764 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2767 /* Warn about calls with an implicit interface. Special case
2768 for calling a ISO_C_BINDING becase c_loc and c_funloc
2769 are pseudo-unknown. */
2770 if (gfc_option
.warn_implicit_interface
2771 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2772 && !comp
->attr
.is_iso_c
)
2773 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2774 "interface at %L", comp
->name
, where
);
2776 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2778 gfc_actual_arglist
*a
;
2779 for (a
= *ap
; a
; a
= a
->next
)
2781 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2782 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2784 gfc_error("Keyword argument requires explicit interface "
2785 "for procedure pointer component '%s' at %L",
2786 comp
->name
, &a
->expr
->where
);
2794 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2797 check_intents (comp
->formal
, *ap
);
2798 if (gfc_option
.warn_aliasing
)
2799 check_some_aliasing (comp
->formal
, *ap
);
2803 /* Try if an actual argument list matches the formal list of a symbol,
2804 respecting the symbol's attributes like ELEMENTAL. This is used for
2805 GENERIC resolution. */
2808 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2812 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2814 r
= !sym
->attr
.elemental
;
2815 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2817 check_intents (sym
->formal
, *args
);
2818 if (gfc_option
.warn_aliasing
)
2819 check_some_aliasing (sym
->formal
, *args
);
2827 /* Given an interface pointer and an actual argument list, search for
2828 a formal argument list that matches the actual. If found, returns
2829 a pointer to the symbol of the correct interface. Returns NULL if
2833 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2834 gfc_actual_arglist
**ap
)
2836 gfc_symbol
*elem_sym
= NULL
;
2837 for (; intr
; intr
= intr
->next
)
2839 if (sub_flag
&& intr
->sym
->attr
.function
)
2841 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2844 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
2846 /* Satisfy 12.4.4.1 such that an elemental match has lower
2847 weight than a non-elemental match. */
2848 if (intr
->sym
->attr
.elemental
)
2850 elem_sym
= intr
->sym
;
2857 return elem_sym
? elem_sym
: NULL
;
2861 /* Do a brute force recursive search for a symbol. */
2863 static gfc_symtree
*
2864 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2868 if (root
->n
.sym
== sym
)
2873 st
= find_symtree0 (root
->left
, sym
);
2874 if (root
->right
&& ! st
)
2875 st
= find_symtree0 (root
->right
, sym
);
2880 /* Find a symtree for a symbol. */
2883 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
2888 /* First try to find it by name. */
2889 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2890 if (st
&& st
->n
.sym
== sym
)
2893 /* If it's been renamed, resort to a brute-force search. */
2894 /* TODO: avoid having to do this search. If the symbol doesn't exist
2895 in the symtree for the current namespace, it should probably be added. */
2896 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2898 st
= find_symtree0 (ns
->sym_root
, sym
);
2902 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2907 /* See if the arglist to an operator-call contains a derived-type argument
2908 with a matching type-bound operator. If so, return the matching specific
2909 procedure defined as operator-target as well as the base-object to use
2910 (which is the found derived-type argument with operator). The generic
2911 name, if any, is transmitted to the final expression via 'gname'. */
2913 static gfc_typebound_proc
*
2914 matching_typebound_op (gfc_expr
** tb_base
,
2915 gfc_actual_arglist
* args
,
2916 gfc_intrinsic_op op
, const char* uop
,
2917 const char ** gname
)
2919 gfc_actual_arglist
* base
;
2921 for (base
= args
; base
; base
= base
->next
)
2922 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
2924 gfc_typebound_proc
* tb
;
2925 gfc_symbol
* derived
;
2928 if (base
->expr
->ts
.type
== BT_CLASS
)
2929 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
2931 derived
= base
->expr
->ts
.u
.derived
;
2933 if (op
== INTRINSIC_USER
)
2935 gfc_symtree
* tb_uop
;
2938 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
2947 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
2950 /* This means we hit a PRIVATE operator which is use-associated and
2951 should thus not be seen. */
2952 if (result
== FAILURE
)
2955 /* Look through the super-type hierarchy for a matching specific
2957 for (; tb
; tb
= tb
->overridden
)
2961 gcc_assert (tb
->is_generic
);
2962 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
2965 gfc_actual_arglist
* argcopy
;
2968 gcc_assert (g
->specific
);
2969 if (g
->specific
->error
)
2972 target
= g
->specific
->u
.specific
->n
.sym
;
2974 /* Check if this arglist matches the formal. */
2975 argcopy
= gfc_copy_actual_arglist (args
);
2976 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
2977 gfc_free_actual_arglist (argcopy
);
2979 /* Return if we found a match. */
2982 *tb_base
= base
->expr
;
2983 *gname
= g
->specific_st
->name
;
2994 /* For the 'actual arglist' of an operator call and a specific typebound
2995 procedure that has been found the target of a type-bound operator, build the
2996 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2997 type-bound procedures rather than resolving type-bound operators 'directly'
2998 so that we can reuse the existing logic. */
3001 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
3002 gfc_expr
* base
, gfc_typebound_proc
* target
,
3005 e
->expr_type
= EXPR_COMPCALL
;
3006 e
->value
.compcall
.tbp
= target
;
3007 e
->value
.compcall
.name
= gname
? gname
: "$op";
3008 e
->value
.compcall
.actual
= actual
;
3009 e
->value
.compcall
.base_object
= base
;
3010 e
->value
.compcall
.ignore_pass
= 1;
3011 e
->value
.compcall
.assign
= 0;
3015 /* This subroutine is called when an expression is being resolved.
3016 The expression node in question is either a user defined operator
3017 or an intrinsic operator with arguments that aren't compatible
3018 with the operator. This subroutine builds an actual argument list
3019 corresponding to the operands, then searches for a compatible
3020 interface. If one is found, the expression node is replaced with
3021 the appropriate function call.
3022 real_error is an additional output argument that specifies if FAILURE
3023 is because of some real error and not because no match was found. */
3026 gfc_extend_expr (gfc_expr
*e
, bool *real_error
)
3028 gfc_actual_arglist
*actual
;
3037 actual
= gfc_get_actual_arglist ();
3038 actual
->expr
= e
->value
.op
.op1
;
3040 *real_error
= false;
3043 if (e
->value
.op
.op2
!= NULL
)
3045 actual
->next
= gfc_get_actual_arglist ();
3046 actual
->next
->expr
= e
->value
.op
.op2
;
3049 i
= fold_unary_intrinsic (e
->value
.op
.op
);
3051 if (i
== INTRINSIC_USER
)
3053 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3055 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
3059 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
3066 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3068 /* Due to the distinction between '==' and '.eq.' and friends, one has
3069 to check if either is defined. */
3072 #define CHECK_OS_COMPARISON(comp) \
3073 case INTRINSIC_##comp: \
3074 case INTRINSIC_##comp##_OS: \
3075 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3077 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3079 CHECK_OS_COMPARISON(EQ
)
3080 CHECK_OS_COMPARISON(NE
)
3081 CHECK_OS_COMPARISON(GT
)
3082 CHECK_OS_COMPARISON(GE
)
3083 CHECK_OS_COMPARISON(LT
)
3084 CHECK_OS_COMPARISON(LE
)
3085 #undef CHECK_OS_COMPARISON
3088 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3096 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3097 found rather than just taking the first one and not checking further. */
3101 gfc_typebound_proc
* tbo
;
3104 /* See if we find a matching type-bound operator. */
3105 if (i
== INTRINSIC_USER
)
3106 tbo
= matching_typebound_op (&tb_base
, actual
,
3107 i
, e
->value
.op
.uop
->name
, &gname
);
3111 #define CHECK_OS_COMPARISON(comp) \
3112 case INTRINSIC_##comp: \
3113 case INTRINSIC_##comp##_OS: \
3114 tbo = matching_typebound_op (&tb_base, actual, \
3115 INTRINSIC_##comp, NULL, &gname); \
3117 tbo = matching_typebound_op (&tb_base, actual, \
3118 INTRINSIC_##comp##_OS, NULL, &gname); \
3120 CHECK_OS_COMPARISON(EQ
)
3121 CHECK_OS_COMPARISON(NE
)
3122 CHECK_OS_COMPARISON(GT
)
3123 CHECK_OS_COMPARISON(GE
)
3124 CHECK_OS_COMPARISON(LT
)
3125 CHECK_OS_COMPARISON(LE
)
3126 #undef CHECK_OS_COMPARISON
3129 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3133 /* If there is a matching typebound-operator, replace the expression with
3134 a call to it and succeed. */
3139 gcc_assert (tb_base
);
3140 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3142 result
= gfc_resolve_expr (e
);
3143 if (result
== FAILURE
)
3149 /* Don't use gfc_free_actual_arglist(). */
3150 if (actual
->next
!= NULL
)
3151 gfc_free (actual
->next
);
3157 /* Change the expression node to a function call. */
3158 e
->expr_type
= EXPR_FUNCTION
;
3159 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3160 e
->value
.function
.actual
= actual
;
3161 e
->value
.function
.esym
= NULL
;
3162 e
->value
.function
.isym
= NULL
;
3163 e
->value
.function
.name
= NULL
;
3164 e
->user_operator
= 1;
3166 if (gfc_resolve_expr (e
) == FAILURE
)
3176 /* Tries to replace an assignment code node with a subroutine call to
3177 the subroutine associated with the assignment operator. Return
3178 SUCCESS if the node was replaced. On FAILURE, no error is
3182 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3184 gfc_actual_arglist
*actual
;
3185 gfc_expr
*lhs
, *rhs
;
3194 /* Don't allow an intrinsic assignment to be replaced. */
3195 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3196 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3197 && (lhs
->ts
.type
== rhs
->ts
.type
3198 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3201 actual
= gfc_get_actual_arglist ();
3204 actual
->next
= gfc_get_actual_arglist ();
3205 actual
->next
->expr
= rhs
;
3209 for (; ns
; ns
= ns
->parent
)
3211 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3216 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3220 gfc_typebound_proc
* tbo
;
3223 /* See if we find a matching type-bound assignment. */
3224 tbo
= matching_typebound_op (&tb_base
, actual
,
3225 INTRINSIC_ASSIGN
, NULL
, &gname
);
3227 /* If there is one, replace the expression with a call to it and
3231 gcc_assert (tb_base
);
3232 c
->expr1
= gfc_get_expr ();
3233 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3234 c
->expr1
->value
.compcall
.assign
= 1;
3236 c
->op
= EXEC_COMPCALL
;
3238 /* c is resolved from the caller, so no need to do it here. */
3243 gfc_free (actual
->next
);
3248 /* Replace the assignment with the call. */
3249 c
->op
= EXEC_ASSIGN_CALL
;
3250 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3253 c
->ext
.actual
= actual
;
3259 /* Make sure that the interface just parsed is not already present in
3260 the given interface list. Ambiguity isn't checked yet since module
3261 procedures can be present without interfaces. */
3264 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
3268 for (ip
= base
; ip
; ip
= ip
->next
)
3270 if (ip
->sym
== new_sym
)
3272 gfc_error ("Entity '%s' at %C is already present in the interface",
3282 /* Add a symbol to the current interface. */
3285 gfc_add_interface (gfc_symbol
*new_sym
)
3287 gfc_interface
**head
, *intr
;
3291 switch (current_interface
.type
)
3293 case INTERFACE_NAMELESS
:
3294 case INTERFACE_ABSTRACT
:
3297 case INTERFACE_INTRINSIC_OP
:
3298 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3299 switch (current_interface
.op
)
3302 case INTRINSIC_EQ_OS
:
3303 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
3304 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
3309 case INTRINSIC_NE_OS
:
3310 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
3311 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
3316 case INTRINSIC_GT_OS
:
3317 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
3318 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
3323 case INTRINSIC_GE_OS
:
3324 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
3325 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
3330 case INTRINSIC_LT_OS
:
3331 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
3332 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
3337 case INTRINSIC_LE_OS
:
3338 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
3339 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
3344 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
3348 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3351 case INTERFACE_GENERIC
:
3352 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3354 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3358 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
3362 head
= ¤t_interface
.sym
->generic
;
3365 case INTERFACE_USER_OP
:
3366 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
3370 head
= ¤t_interface
.uop
->op
;
3374 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3377 intr
= gfc_get_interface ();
3378 intr
->sym
= new_sym
;
3379 intr
->where
= gfc_current_locus
;
3389 gfc_current_interface_head (void)
3391 switch (current_interface
.type
)
3393 case INTERFACE_INTRINSIC_OP
:
3394 return current_interface
.ns
->op
[current_interface
.op
];
3397 case INTERFACE_GENERIC
:
3398 return current_interface
.sym
->generic
;
3401 case INTERFACE_USER_OP
:
3402 return current_interface
.uop
->op
;
3412 gfc_set_current_interface_head (gfc_interface
*i
)
3414 switch (current_interface
.type
)
3416 case INTERFACE_INTRINSIC_OP
:
3417 current_interface
.ns
->op
[current_interface
.op
] = i
;
3420 case INTERFACE_GENERIC
:
3421 current_interface
.sym
->generic
= i
;
3424 case INTERFACE_USER_OP
:
3425 current_interface
.uop
->op
= i
;
3434 /* Gets rid of a formal argument list. We do not free symbols.
3435 Symbols are freed when a namespace is freed. */
3438 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3440 gfc_formal_arglist
*q
;