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 - Types and kinds do not conform, and
658 - First argument is of derived type. */
659 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
660 && sym
->formal
->sym
->ts
.type
!= BT_CLASS
661 && (r1
== 0 || r1
== r2
)
662 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
663 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
664 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
666 gfc_error ("Assignment operator interface at %L must not redefine "
667 "an INTRINSIC type assignment", &sym
->declared_at
);
673 if (!sym
->attr
.function
)
675 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
681 /* Check intents on operator interfaces. */
682 if (op
== INTRINSIC_ASSIGN
)
684 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
686 gfc_error ("First argument of defined assignment at %L must be "
687 "INTENT(OUT) or INTENT(INOUT)", &sym
->declared_at
);
693 gfc_error ("Second argument of defined assignment at %L must be "
694 "INTENT(IN)", &sym
->declared_at
);
702 gfc_error ("First argument of operator interface at %L must be "
703 "INTENT(IN)", &sym
->declared_at
);
707 if (args
== 2 && i2
!= INTENT_IN
)
709 gfc_error ("Second argument of operator interface at %L must be "
710 "INTENT(IN)", &sym
->declared_at
);
715 /* From now on, all we have to do is check that the operator definition
716 doesn't conflict with an intrinsic operator. The rules for this
717 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
718 as well as 12.3.2.1.1 of Fortran 2003:
720 "If the operator is an intrinsic-operator (R310), the number of
721 function arguments shall be consistent with the intrinsic uses of
722 that operator, and the types, kind type parameters, or ranks of the
723 dummy arguments shall differ from those required for the intrinsic
724 operation (7.1.2)." */
726 #define IS_NUMERIC_TYPE(t) \
727 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
729 /* Unary ops are easy, do them first. */
730 if (op
== INTRINSIC_NOT
)
732 if (t1
== BT_LOGICAL
)
738 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
740 if (IS_NUMERIC_TYPE (t1
))
746 /* Character intrinsic operators have same character kind, thus
747 operator definitions with operands of different character kinds
749 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
752 /* Intrinsic operators always perform on arguments of same rank,
753 so different ranks is also always safe. (rank == 0) is an exception
754 to that, because all intrinsic operators are elemental. */
755 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
761 case INTRINSIC_EQ_OS
:
763 case INTRINSIC_NE_OS
:
764 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
769 case INTRINSIC_MINUS
:
770 case INTRINSIC_TIMES
:
771 case INTRINSIC_DIVIDE
:
772 case INTRINSIC_POWER
:
773 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
778 case INTRINSIC_GT_OS
:
780 case INTRINSIC_GE_OS
:
782 case INTRINSIC_LT_OS
:
784 case INTRINSIC_LE_OS
:
785 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
787 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
788 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
792 case INTRINSIC_CONCAT
:
793 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
801 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
811 #undef IS_NUMERIC_TYPE
814 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
820 /* Given a pair of formal argument lists, we see if the two lists can
821 be distinguished by counting the number of nonoptional arguments of
822 a given type/rank in f1 and seeing if there are less then that
823 number of those arguments in f2 (including optional arguments).
824 Since this test is asymmetric, it has to be called twice to make it
825 symmetric. Returns nonzero if the argument lists are incompatible
826 by this test. This subroutine implements rule 1 of section
827 14.1.2.3 in the Fortran 95 standard. */
830 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
832 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
833 gfc_formal_arglist
*f
;
846 for (f
= f1
; f
; f
= f
->next
)
849 /* Build an array of integers that gives the same integer to
850 arguments of the same type/rank. */
851 arg
= XCNEWVEC (arginfo
, n1
);
854 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
862 for (i
= 0; i
< n1
; i
++)
864 if (arg
[i
].flag
!= -1)
867 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
868 continue; /* Skip optional arguments. */
872 /* Find other nonoptional arguments of the same type/rank. */
873 for (j
= i
+ 1; j
< n1
; j
++)
874 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
875 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
881 /* Now loop over each distinct type found in f1. */
885 for (i
= 0; i
< n1
; i
++)
887 if (arg
[i
].flag
!= k
)
891 for (j
= i
+ 1; j
< n1
; j
++)
892 if (arg
[j
].flag
== k
)
895 /* Count the number of arguments in f2 with that type, including
896 those that are optional. */
899 for (f
= f2
; f
; f
= f
->next
)
900 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
918 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
919 Returns zero if no argument is found that satisfies rule 2, nonzero
922 This test is also not symmetric in f1 and f2 and must be called
923 twice. This test finds problems caused by sorting the actual
924 argument list with keywords. For example:
928 INTEGER :: A ; REAL :: B
932 INTEGER :: A ; REAL :: B
936 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
939 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
941 gfc_formal_arglist
*f2_save
, *g
;
948 if (f1
->sym
->attr
.optional
)
951 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
954 /* Now search for a disambiguating keyword argument starting at
955 the current non-match. */
956 for (g
= f1
; g
; g
= g
->next
)
958 if (g
->sym
->attr
.optional
)
961 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
962 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
976 /* 'Compare' two formal interfaces associated with a pair of symbols.
977 We return nonzero if there exists an actual argument list that
978 would be ambiguous between the two interfaces, zero otherwise.
979 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
980 required to match, which is not the case for ambiguity checks.*/
983 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
984 int generic_flag
, int intent_flag
,
985 char *errmsg
, int err_len
)
987 gfc_formal_arglist
*f1
, *f2
;
989 gcc_assert (name2
!= NULL
);
991 if (s1
->attr
.function
&& (s2
->attr
.subroutine
992 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
993 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
996 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1000 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1003 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1007 /* If the arguments are functions, check type and kind
1008 (only for dummy procedures and procedure pointer assignments). */
1009 if (!generic_flag
&& intent_flag
&& s1
->attr
.function
&& s2
->attr
.function
)
1011 if (s1
->ts
.type
== BT_UNKNOWN
)
1013 if ((s1
->ts
.type
!= s2
->ts
.type
) || (s1
->ts
.kind
!= s2
->ts
.kind
))
1016 snprintf (errmsg
, err_len
, "Type/kind mismatch in return value "
1022 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1023 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1029 if (f1
== NULL
&& f2
== NULL
)
1030 return 1; /* Special case: No arguments. */
1034 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1036 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
1040 /* Perform the abbreviated correspondence test for operators (the
1041 arguments cannot be optional and are always ordered correctly).
1042 This is also done when comparing interfaces for dummy procedures and in
1043 procedure pointer assignments. */
1047 /* Check existence. */
1048 if (f1
== NULL
&& f2
== NULL
)
1050 if (f1
== NULL
|| f2
== NULL
)
1053 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1054 "arguments", name2
);
1058 /* Check type and rank. */
1059 if (!compare_type_rank (f1
->sym
, f2
->sym
))
1062 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1068 if (intent_flag
&& (f1
->sym
->attr
.intent
!= f2
->sym
->attr
.intent
))
1070 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1075 /* Check OPTIONAL. */
1076 if (intent_flag
&& (f1
->sym
->attr
.optional
!= f2
->sym
->attr
.optional
))
1078 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1091 /* Given a pointer to an interface pointer, remove duplicate
1092 interfaces and make sure that all symbols are either functions or
1093 subroutines. Returns nonzero if something goes wrong. */
1096 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1098 gfc_interface
*psave
, *q
, *qlast
;
1101 /* Make sure all symbols in the interface have been defined as
1102 functions or subroutines. */
1103 for (; p
; p
= p
->next
)
1104 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1105 || !p
->sym
->attr
.if_source
)
1107 if (p
->sym
->attr
.external
)
1108 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1109 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1111 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1112 "subroutine", p
->sym
->name
, interface_name
,
1113 &p
->sym
->declared_at
);
1118 /* Remove duplicate interfaces in this interface list. */
1119 for (; p
; p
= p
->next
)
1123 for (q
= p
->next
; q
;)
1125 if (p
->sym
!= q
->sym
)
1132 /* Duplicate interface. */
1133 qlast
->next
= q
->next
;
1144 /* Check lists of interfaces to make sure that no two interfaces are
1145 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1148 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1149 int generic_flag
, const char *interface_name
,
1153 for (; p
; p
= p
->next
)
1154 for (q
= q0
; q
; q
= q
->next
)
1156 if (p
->sym
== q
->sym
)
1157 continue; /* Duplicates OK here. */
1159 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1162 if (gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
, generic_flag
,
1166 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1167 p
->sym
->name
, q
->sym
->name
, interface_name
,
1169 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1170 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1171 p
->sym
->name
, q
->sym
->name
, interface_name
,
1174 gfc_warning ("Although not referenced, '%s' has ambiguous "
1175 "interfaces at %L", interface_name
, &p
->where
);
1183 /* Check the generic and operator interfaces of symbols to make sure
1184 that none of the interfaces conflict. The check has to be done
1185 after all of the symbols are actually loaded. */
1188 check_sym_interfaces (gfc_symbol
*sym
)
1190 char interface_name
[100];
1193 if (sym
->ns
!= gfc_current_ns
)
1196 if (sym
->generic
!= NULL
)
1198 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1199 if (check_interface0 (sym
->generic
, interface_name
))
1202 for (p
= sym
->generic
; p
; p
= p
->next
)
1204 if (p
->sym
->attr
.mod_proc
1205 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1206 || p
->sym
->attr
.procedure
))
1208 gfc_error ("'%s' at %L is not a module procedure",
1209 p
->sym
->name
, &p
->where
);
1214 /* Originally, this test was applied to host interfaces too;
1215 this is incorrect since host associated symbols, from any
1216 source, cannot be ambiguous with local symbols. */
1217 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1218 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1224 check_uop_interfaces (gfc_user_op
*uop
)
1226 char interface_name
[100];
1230 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1231 if (check_interface0 (uop
->op
, interface_name
))
1234 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1236 uop2
= gfc_find_uop (uop
->name
, ns
);
1240 check_interface1 (uop
->op
, uop2
->op
, 0,
1241 interface_name
, true);
1246 /* For the namespace, check generic, user operator and intrinsic
1247 operator interfaces for consistency and to remove duplicate
1248 interfaces. We traverse the whole namespace, counting on the fact
1249 that most symbols will not have generic or operator interfaces. */
1252 gfc_check_interfaces (gfc_namespace
*ns
)
1254 gfc_namespace
*old_ns
, *ns2
;
1255 char interface_name
[100];
1258 old_ns
= gfc_current_ns
;
1259 gfc_current_ns
= ns
;
1261 gfc_traverse_ns (ns
, check_sym_interfaces
);
1263 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1265 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1267 if (i
== INTRINSIC_USER
)
1270 if (i
== INTRINSIC_ASSIGN
)
1271 strcpy (interface_name
, "intrinsic assignment operator");
1273 sprintf (interface_name
, "intrinsic '%s' operator",
1274 gfc_op2string ((gfc_intrinsic_op
) i
));
1276 if (check_interface0 (ns
->op
[i
], interface_name
))
1280 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1283 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1285 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1286 interface_name
, true))
1292 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ_OS
],
1293 0, interface_name
, true)) goto done
;
1296 case INTRINSIC_EQ_OS
:
1297 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ
],
1298 0, interface_name
, true)) goto done
;
1302 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE_OS
],
1303 0, interface_name
, true)) goto done
;
1306 case INTRINSIC_NE_OS
:
1307 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE
],
1308 0, interface_name
, true)) goto done
;
1312 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT_OS
],
1313 0, interface_name
, true)) goto done
;
1316 case INTRINSIC_GT_OS
:
1317 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT
],
1318 0, interface_name
, true)) goto done
;
1322 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE_OS
],
1323 0, interface_name
, true)) goto done
;
1326 case INTRINSIC_GE_OS
:
1327 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE
],
1328 0, interface_name
, true)) goto done
;
1332 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT_OS
],
1333 0, interface_name
, true)) goto done
;
1336 case INTRINSIC_LT_OS
:
1337 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT
],
1338 0, interface_name
, true)) goto done
;
1342 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE_OS
],
1343 0, interface_name
, true)) goto done
;
1346 case INTRINSIC_LE_OS
:
1347 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE
],
1348 0, interface_name
, true)) goto done
;
1358 gfc_current_ns
= old_ns
;
1363 symbol_rank (gfc_symbol
*sym
)
1365 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1369 /* Given a symbol of a formal argument list and an expression, if the
1370 formal argument is allocatable, check that the actual argument is
1371 allocatable. Returns nonzero if compatible, zero if not compatible. */
1374 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1376 symbol_attribute attr
;
1378 if (formal
->attr
.allocatable
)
1380 attr
= gfc_expr_attr (actual
);
1381 if (!attr
.allocatable
)
1389 /* Given a symbol of a formal argument list and an expression, if the
1390 formal argument is a pointer, see if the actual argument is a
1391 pointer. Returns nonzero if compatible, zero if not compatible. */
1394 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1396 symbol_attribute attr
;
1398 if (formal
->attr
.pointer
)
1400 attr
= gfc_expr_attr (actual
);
1402 /* Fortran 2008 allows non-pointer actual arguments. */
1403 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1414 /* Emit clear error messages for rank mismatch. */
1417 argument_rank_mismatch (const char *name
, locus
*where
,
1418 int rank1
, int rank2
)
1422 gfc_error ("Rank mismatch in argument '%s' at %L "
1423 "(scalar and rank-%d)", name
, where
, rank2
);
1425 else if (rank2
== 0)
1427 gfc_error ("Rank mismatch in argument '%s' at %L "
1428 "(rank-%d and scalar)", name
, where
, rank1
);
1432 gfc_error ("Rank mismatch in argument '%s' at %L "
1433 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1438 /* Given a symbol of a formal argument list and an expression, see if
1439 the two are compatible as arguments. Returns nonzero if
1440 compatible, zero if not compatible. */
1443 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1444 int ranks_must_agree
, int is_elemental
, locus
*where
)
1449 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1450 procs c_f_pointer or c_f_procpointer, and we need to accept most
1451 pointers the user could give us. This should allow that. */
1452 if (formal
->ts
.type
== BT_VOID
)
1455 if (formal
->ts
.type
== BT_DERIVED
1456 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1457 && actual
->ts
.type
== BT_DERIVED
1458 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1461 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1462 /* Make sure the vtab symbol is present when
1463 the module variables are generated. */
1464 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1466 if (actual
->ts
.type
== BT_PROCEDURE
)
1469 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1471 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1474 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1478 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1482 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1483 formal
->name
, &actual
->where
, err
);
1487 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1489 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1490 &act_sym
->declared_at
);
1491 if (act_sym
->ts
.type
== BT_UNKNOWN
1492 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1495 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1496 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1497 &act_sym
->declared_at
);
1503 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1504 && !gfc_is_simply_contiguous (actual
, true))
1507 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1508 "must be simply contigous", formal
->name
, &actual
->where
);
1512 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1513 && actual
->ts
.type
!= BT_HOLLERITH
1514 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1517 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1518 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1519 gfc_typename (&formal
->ts
));
1523 if (formal
->attr
.codimension
)
1525 gfc_ref
*last
= NULL
;
1527 if (actual
->expr_type
!= EXPR_VARIABLE
1528 || (actual
->ref
== NULL
1529 && !actual
->symtree
->n
.sym
->attr
.codimension
))
1532 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1533 formal
->name
, &actual
->where
);
1537 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1539 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
!= 0)
1542 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1543 "and not coindexed", formal
->name
, &ref
->u
.ar
.where
);
1546 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
->corank
1547 && ref
->u
.ar
.type
!= AR_FULL
&& ref
->u
.ar
.dimen
!= 0)
1550 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1551 "and thus shall not have an array designator",
1552 formal
->name
, &ref
->u
.ar
.where
);
1555 if (ref
->type
== REF_COMPONENT
)
1559 if (last
&& !last
->u
.c
.component
->attr
.codimension
)
1562 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1563 formal
->name
, &actual
->where
);
1567 /* F2008, 12.5.2.6. */
1568 if (formal
->attr
.allocatable
&&
1569 ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1571 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
)))
1574 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1575 formal
->name
, &actual
->where
, formal
->as
->corank
,
1576 last
? last
->u
.c
.component
->as
->corank
1577 : actual
->symtree
->n
.sym
->as
->corank
);
1581 /* F2008, 12.5.2.8. */
1582 if (formal
->attr
.dimension
1583 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1584 && !gfc_is_simply_contiguous (actual
, true))
1587 gfc_error ("Actual argument to '%s' at %L must be simply "
1588 "contiguous", formal
->name
, &actual
->where
);
1593 /* F2008, C1239/C1240. */
1594 if (actual
->expr_type
== EXPR_VARIABLE
1595 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1596 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1597 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1598 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1599 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1600 || formal
->attr
.contiguous
))
1603 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1604 "array without CONTIGUOUS attribute - as actual argument at"
1605 " %L is not simply contiguous and both are ASYNCHRONOUS "
1606 "or VOLATILE", formal
->name
, &actual
->where
);
1610 if (symbol_rank (formal
) == actual
->rank
)
1613 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1614 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1615 || formal
->as
->type
== AS_DEFERRED
)
1616 && actual
->expr_type
!= EXPR_NULL
;
1618 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1619 if (rank_check
|| ranks_must_agree
1620 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
1621 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1622 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
1623 && actual
->expr_type
!= EXPR_NULL
)
1624 || (actual
->rank
== 0 && formal
->attr
.dimension
1625 && gfc_is_coindexed (actual
)))
1628 argument_rank_mismatch (formal
->name
, &actual
->where
,
1629 symbol_rank (formal
), actual
->rank
);
1632 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1635 /* At this point, we are considering a scalar passed to an array. This
1636 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1637 - if the actual argument is (a substring of) an element of a
1638 non-assumed-shape/non-pointer array;
1639 - (F2003) if the actual argument is of type character. */
1641 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1642 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1643 && ref
->u
.ar
.dimen
> 0)
1646 /* Not an array element. */
1647 if (formal
->ts
.type
== BT_CHARACTER
1649 || (actual
->expr_type
== EXPR_VARIABLE
1650 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1651 || actual
->symtree
->n
.sym
->attr
.pointer
))))
1653 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1655 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1656 "array dummy argument '%s' at %L",
1657 formal
->name
, &actual
->where
);
1660 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1665 else if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
1668 argument_rank_mismatch (formal
->name
, &actual
->where
,
1669 symbol_rank (formal
), actual
->rank
);
1673 if (actual
->expr_type
== EXPR_VARIABLE
1674 && actual
->symtree
->n
.sym
->as
1675 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1676 || actual
->symtree
->n
.sym
->attr
.pointer
))
1679 gfc_error ("Element of assumed-shaped array passed to dummy "
1680 "argument '%s' at %L", formal
->name
, &actual
->where
);
1688 /* Returns the storage size of a symbol (formal argument) or
1689 zero if it cannot be determined. */
1691 static unsigned long
1692 get_sym_storage_size (gfc_symbol
*sym
)
1695 unsigned long strlen
, elements
;
1697 if (sym
->ts
.type
== BT_CHARACTER
)
1699 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1700 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1701 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
1708 if (symbol_rank (sym
) == 0)
1712 if (sym
->as
->type
!= AS_EXPLICIT
)
1714 for (i
= 0; i
< sym
->as
->rank
; i
++)
1716 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1717 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1720 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
1721 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1724 return strlen
*elements
;
1728 /* Returns the storage size of an expression (actual argument) or
1729 zero if it cannot be determined. For an array element, it returns
1730 the remaining size as the element sequence consists of all storage
1731 units of the actual argument up to the end of the array. */
1733 static unsigned long
1734 get_expr_storage_size (gfc_expr
*e
)
1737 long int strlen
, elements
;
1738 long int substrlen
= 0;
1739 bool is_str_storage
= false;
1745 if (e
->ts
.type
== BT_CHARACTER
)
1747 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1748 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1749 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
1750 else if (e
->expr_type
== EXPR_CONSTANT
1751 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
1752 strlen
= e
->value
.character
.length
;
1757 strlen
= 1; /* Length per element. */
1759 if (e
->rank
== 0 && !e
->ref
)
1767 for (i
= 0; i
< e
->rank
; i
++)
1768 elements
*= mpz_get_si (e
->shape
[i
]);
1769 return elements
*strlen
;
1772 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1774 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1775 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1779 /* The string length is the substring length.
1780 Set now to full string length. */
1781 if (ref
->u
.ss
.length
== NULL
1782 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1785 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1787 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1791 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1792 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1793 && ref
->u
.ar
.as
->upper
)
1794 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1796 long int start
, end
, stride
;
1799 if (ref
->u
.ar
.stride
[i
])
1801 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1802 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1807 if (ref
->u
.ar
.start
[i
])
1809 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1810 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1814 else if (ref
->u
.ar
.as
->lower
[i
]
1815 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1816 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1820 if (ref
->u
.ar
.end
[i
])
1822 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1823 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1827 else if (ref
->u
.ar
.as
->upper
[i
]
1828 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1829 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1833 elements
*= (end
- start
)/stride
+ 1L;
1835 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1836 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1837 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1839 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1840 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1841 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1842 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1843 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1848 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1849 && e
->expr_type
== EXPR_VARIABLE
)
1851 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1852 || e
->symtree
->n
.sym
->attr
.pointer
)
1858 /* Determine the number of remaining elements in the element
1859 sequence for array element designators. */
1860 is_str_storage
= true;
1861 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1863 if (ref
->u
.ar
.start
[i
] == NULL
1864 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1865 || ref
->u
.ar
.as
->upper
[i
] == NULL
1866 || ref
->u
.ar
.as
->lower
[i
] == NULL
1867 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1868 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1873 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1874 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1876 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1877 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1885 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1888 return elements
*strlen
;
1892 /* Given an expression, check whether it is an array section
1893 which has a vector subscript. If it has, one is returned,
1897 gfc_has_vector_subscript (gfc_expr
*e
)
1902 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1905 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1906 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1907 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1908 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1915 /* Given formal and actual argument lists, see if they are compatible.
1916 If they are compatible, the actual argument list is sorted to
1917 correspond with the formal list, and elements for missing optional
1918 arguments are inserted. If WHERE pointer is nonnull, then we issue
1919 errors when things don't match instead of just returning the status
1923 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1924 int ranks_must_agree
, int is_elemental
, locus
*where
)
1926 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
1927 gfc_formal_arglist
*f
;
1929 unsigned long actual_size
, formal_size
;
1933 if (actual
== NULL
&& formal
== NULL
)
1937 for (f
= formal
; f
; f
= f
->next
)
1940 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
1942 for (i
= 0; i
< n
; i
++)
1949 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1951 /* Look for keywords but ignore g77 extensions like %VAL. */
1952 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1955 for (f
= formal
; f
; f
= f
->next
, i
++)
1959 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1966 gfc_error ("Keyword argument '%s' at %L is not in "
1967 "the procedure", a
->name
, &a
->expr
->where
);
1971 if (new_arg
[i
] != NULL
)
1974 gfc_error ("Keyword argument '%s' at %L is already associated "
1975 "with another actual argument", a
->name
,
1984 gfc_error ("More actual than formal arguments in procedure "
1985 "call at %L", where
);
1990 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1996 gfc_error ("Missing alternate return spec in subroutine call "
2001 if (a
->expr
== NULL
)
2004 gfc_error ("Unexpected alternate return spec in subroutine "
2005 "call at %L", where
);
2009 if (a
->expr
->expr_type
== EXPR_NULL
&& !f
->sym
->attr
.pointer
2010 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2011 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2013 if (where
&& (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
))
2014 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2015 where
, f
->sym
->name
);
2017 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2018 "dummy '%s'", where
, f
->sym
->name
);
2023 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2024 is_elemental
, where
))
2027 /* Special case for character arguments. For allocatable, pointer
2028 and assumed-shape dummies, the string length needs to match
2030 if (a
->expr
->ts
.type
== BT_CHARACTER
2031 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2032 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2033 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2034 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2035 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2036 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2037 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2038 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2040 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2041 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2042 "argument and pointer or allocatable dummy argument "
2044 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2045 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2046 f
->sym
->name
, &a
->expr
->where
);
2048 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2049 "argument and assumed-shape dummy argument '%s' "
2051 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2052 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2053 f
->sym
->name
, &a
->expr
->where
);
2057 actual_size
= get_expr_storage_size (a
->expr
);
2058 formal_size
= get_sym_storage_size (f
->sym
);
2059 if (actual_size
!= 0
2060 && actual_size
< formal_size
2061 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
2063 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2064 gfc_warning ("Character length of actual argument shorter "
2065 "than of dummy argument '%s' (%lu/%lu) at %L",
2066 f
->sym
->name
, actual_size
, formal_size
,
2069 gfc_warning ("Actual argument contains too few "
2070 "elements for dummy argument '%s' (%lu/%lu) at %L",
2071 f
->sym
->name
, actual_size
, formal_size
,
2076 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2077 is provided for a procedure pointer formal argument. */
2078 if (f
->sym
->attr
.proc_pointer
2079 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2080 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2081 || (a
->expr
->expr_type
== EXPR_FUNCTION
2082 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2083 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
2086 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2087 f
->sym
->name
, &a
->expr
->where
);
2091 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2092 provided for a procedure formal argument. */
2093 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
2094 && a
->expr
->expr_type
== EXPR_VARIABLE
2095 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2098 gfc_error ("Expected a procedure for argument '%s' at %L",
2099 f
->sym
->name
, &a
->expr
->where
);
2103 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
2104 && a
->expr
->ts
.type
== BT_PROCEDURE
2105 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
2108 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2109 f
->sym
->name
, &a
->expr
->where
);
2113 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2114 && a
->expr
->expr_type
== EXPR_VARIABLE
2115 && a
->expr
->symtree
->n
.sym
->as
2116 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2117 && (a
->expr
->ref
== NULL
2118 || (a
->expr
->ref
->type
== REF_ARRAY
2119 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2122 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2123 " array at %L", f
->sym
->name
, where
);
2127 if (a
->expr
->expr_type
!= EXPR_NULL
2128 && compare_pointer (f
->sym
, a
->expr
) == 0)
2131 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2132 f
->sym
->name
, &a
->expr
->where
);
2136 if (a
->expr
->expr_type
!= EXPR_NULL
2137 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2138 && compare_pointer (f
->sym
, a
->expr
) == 2)
2141 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2142 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2147 /* Fortran 2008, C1242. */
2148 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2151 gfc_error ("Coindexed actual argument at %L to pointer "
2153 &a
->expr
->where
, f
->sym
->name
);
2157 /* Fortran 2008, 12.5.2.5 (no constraint). */
2158 if (a
->expr
->expr_type
== EXPR_VARIABLE
2159 && f
->sym
->attr
.intent
!= INTENT_IN
2160 && f
->sym
->attr
.allocatable
2161 && gfc_is_coindexed (a
->expr
))
2164 gfc_error ("Coindexed actual argument at %L to allocatable "
2165 "dummy '%s' requires INTENT(IN)",
2166 &a
->expr
->where
, f
->sym
->name
);
2170 /* Fortran 2008, C1237. */
2171 if (a
->expr
->expr_type
== EXPR_VARIABLE
2172 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2173 && gfc_is_coindexed (a
->expr
)
2174 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2175 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2178 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2179 "at %L requires that dummy %s' has neither "
2180 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2185 /* Fortran 2008, 12.5.2.4 (no constraint). */
2186 if (a
->expr
->expr_type
== EXPR_VARIABLE
2187 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2188 && gfc_is_coindexed (a
->expr
)
2189 && gfc_has_ultimate_allocatable (a
->expr
))
2192 gfc_error ("Coindexed actual argument at %L with allocatable "
2193 "ultimate component to dummy '%s' requires either VALUE "
2194 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2198 if (a
->expr
->expr_type
!= EXPR_NULL
2199 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2202 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2203 f
->sym
->name
, &a
->expr
->where
);
2207 /* Check intent = OUT/INOUT for definable actual argument. */
2208 if ((f
->sym
->attr
.intent
== INTENT_OUT
2209 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2211 const char* context
= (where
2212 ? _("actual argument to INTENT = OUT/INOUT")
2215 if (f
->sym
->attr
.pointer
2216 && gfc_check_vardef_context (a
->expr
, true, context
)
2219 if (gfc_check_vardef_context (a
->expr
, false, context
)
2224 if ((f
->sym
->attr
.intent
== INTENT_OUT
2225 || f
->sym
->attr
.intent
== INTENT_INOUT
2226 || f
->sym
->attr
.volatile_
2227 || f
->sym
->attr
.asynchronous
)
2228 && gfc_has_vector_subscript (a
->expr
))
2231 gfc_error ("Array-section actual argument with vector "
2232 "subscripts at %L is incompatible with INTENT(OUT), "
2233 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2234 "of the dummy argument '%s'",
2235 &a
->expr
->where
, f
->sym
->name
);
2239 /* C1232 (R1221) For an actual argument which is an array section or
2240 an assumed-shape array, the dummy argument shall be an assumed-
2241 shape array, if the dummy argument has the VOLATILE attribute. */
2243 if (f
->sym
->attr
.volatile_
2244 && a
->expr
->symtree
->n
.sym
->as
2245 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2246 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2249 gfc_error ("Assumed-shape actual argument at %L is "
2250 "incompatible with the non-assumed-shape "
2251 "dummy argument '%s' due to VOLATILE attribute",
2252 &a
->expr
->where
,f
->sym
->name
);
2256 if (f
->sym
->attr
.volatile_
2257 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2258 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2261 gfc_error ("Array-section actual argument at %L is "
2262 "incompatible with the non-assumed-shape "
2263 "dummy argument '%s' due to VOLATILE attribute",
2264 &a
->expr
->where
,f
->sym
->name
);
2268 /* C1233 (R1221) For an actual argument which is a pointer array, the
2269 dummy argument shall be an assumed-shape or pointer array, if the
2270 dummy argument has the VOLATILE attribute. */
2272 if (f
->sym
->attr
.volatile_
2273 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2274 && a
->expr
->symtree
->n
.sym
->as
2276 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2277 || f
->sym
->attr
.pointer
)))
2280 gfc_error ("Pointer-array actual argument at %L requires "
2281 "an assumed-shape or pointer-array dummy "
2282 "argument '%s' due to VOLATILE attribute",
2283 &a
->expr
->where
,f
->sym
->name
);
2294 /* Make sure missing actual arguments are optional. */
2296 for (f
= formal
; f
; f
= f
->next
, i
++)
2298 if (new_arg
[i
] != NULL
)
2303 gfc_error ("Missing alternate return spec in subroutine call "
2307 if (!f
->sym
->attr
.optional
)
2310 gfc_error ("Missing actual argument for argument '%s' at %L",
2311 f
->sym
->name
, where
);
2316 /* The argument lists are compatible. We now relink a new actual
2317 argument list with null arguments in the right places. The head
2318 of the list remains the head. */
2319 for (i
= 0; i
< n
; i
++)
2320 if (new_arg
[i
] == NULL
)
2321 new_arg
[i
] = gfc_get_actual_arglist ();
2326 *new_arg
[0] = *actual
;
2330 new_arg
[0] = new_arg
[na
];
2334 for (i
= 0; i
< n
- 1; i
++)
2335 new_arg
[i
]->next
= new_arg
[i
+ 1];
2337 new_arg
[i
]->next
= NULL
;
2339 if (*ap
== NULL
&& n
> 0)
2342 /* Note the types of omitted optional arguments. */
2343 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2344 if (a
->expr
== NULL
&& a
->label
== NULL
)
2345 a
->missing_arg_type
= f
->sym
->ts
.type
;
2353 gfc_formal_arglist
*f
;
2354 gfc_actual_arglist
*a
;
2358 /* qsort comparison function for argument pairs, with the following
2360 - p->a->expr == NULL
2361 - p->a->expr->expr_type != EXPR_VARIABLE
2362 - growing p->a->expr->symbol. */
2365 pair_cmp (const void *p1
, const void *p2
)
2367 const gfc_actual_arglist
*a1
, *a2
;
2369 /* *p1 and *p2 are elements of the to-be-sorted array. */
2370 a1
= ((const argpair
*) p1
)->a
;
2371 a2
= ((const argpair
*) p2
)->a
;
2380 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2382 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2386 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2388 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2392 /* Given two expressions from some actual arguments, test whether they
2393 refer to the same expression. The analysis is conservative.
2394 Returning FAILURE will produce no warning. */
2397 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2399 const gfc_ref
*r1
, *r2
;
2402 || e1
->expr_type
!= EXPR_VARIABLE
2403 || e2
->expr_type
!= EXPR_VARIABLE
2404 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2407 /* TODO: improve comparison, see expr.c:show_ref(). */
2408 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2410 if (r1
->type
!= r2
->type
)
2415 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2417 /* TODO: At the moment, consider only full arrays;
2418 we could do better. */
2419 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2424 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2432 gfc_internal_error ("compare_actual_expr(): Bad component code");
2441 /* Given formal and actual argument lists that correspond to one
2442 another, check that identical actual arguments aren't not
2443 associated with some incompatible INTENTs. */
2446 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2448 sym_intent f1_intent
, f2_intent
;
2449 gfc_formal_arglist
*f1
;
2450 gfc_actual_arglist
*a1
;
2453 gfc_try t
= SUCCESS
;
2456 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2458 if (f1
== NULL
&& a1
== NULL
)
2460 if (f1
== NULL
|| a1
== NULL
)
2461 gfc_internal_error ("check_some_aliasing(): List mismatch");
2466 p
= XALLOCAVEC (argpair
, n
);
2468 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2474 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2476 for (i
= 0; i
< n
; i
++)
2479 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2480 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2482 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2483 for (j
= i
+ 1; j
< n
; j
++)
2485 /* Expected order after the sort. */
2486 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2487 gfc_internal_error ("check_some_aliasing(): corrupted data");
2489 /* Are the expression the same? */
2490 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2492 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2493 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2494 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2496 gfc_warning ("Same actual argument associated with INTENT(%s) "
2497 "argument '%s' and INTENT(%s) argument '%s' at %L",
2498 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2499 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2500 &p
[i
].a
->expr
->where
);
2510 /* Given a symbol of a formal argument list and an expression,
2511 return nonzero if their intents are compatible, zero otherwise. */
2514 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2516 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2519 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2522 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2529 /* Given formal and actual argument lists that correspond to one
2530 another, check that they are compatible in the sense that intents
2531 are not mismatched. */
2534 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2536 sym_intent f_intent
;
2538 for (;; f
= f
->next
, a
= a
->next
)
2540 if (f
== NULL
&& a
== NULL
)
2542 if (f
== NULL
|| a
== NULL
)
2543 gfc_internal_error ("check_intents(): List mismatch");
2545 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2548 f_intent
= f
->sym
->attr
.intent
;
2550 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2552 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2553 "specifies INTENT(%s)", &a
->expr
->where
,
2554 gfc_intent_string (f_intent
));
2558 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2560 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2562 gfc_error ("Procedure argument at %L is local to a PURE "
2563 "procedure and is passed to an INTENT(%s) argument",
2564 &a
->expr
->where
, gfc_intent_string (f_intent
));
2568 if (f
->sym
->attr
.pointer
)
2570 gfc_error ("Procedure argument at %L is local to a PURE "
2571 "procedure and has the POINTER attribute",
2577 /* Fortran 2008, C1283. */
2578 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
2580 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2582 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2583 "is passed to an INTENT(%s) argument",
2584 &a
->expr
->where
, gfc_intent_string (f_intent
));
2588 if (f
->sym
->attr
.pointer
)
2590 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2591 "is passed to a POINTER dummy argument",
2597 /* F2008, Section 12.5.2.4. */
2598 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
2599 && gfc_is_coindexed (a
->expr
))
2601 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2602 "polymorphic dummy argument '%s'",
2603 &a
->expr
->where
, f
->sym
->name
);
2612 /* Check how a procedure is used against its interface. If all goes
2613 well, the actual argument list will also end up being properly
2617 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2620 /* Warn about calls with an implicit interface. Special case
2621 for calling a ISO_C_BINDING becase c_loc and c_funloc
2622 are pseudo-unknown. Additionally, warn about procedures not
2623 explicitly declared at all if requested. */
2624 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2626 if (gfc_option
.warn_implicit_interface
)
2627 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2629 else if (gfc_option
.warn_implicit_procedure
2630 && sym
->attr
.proc
== PROC_UNKNOWN
)
2631 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2635 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2637 gfc_actual_arglist
*a
;
2638 for (a
= *ap
; a
; a
= a
->next
)
2640 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2641 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2643 gfc_error("Keyword argument requires explicit interface "
2644 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2652 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2655 check_intents (sym
->formal
, *ap
);
2656 if (gfc_option
.warn_aliasing
)
2657 check_some_aliasing (sym
->formal
, *ap
);
2661 /* Check how a procedure pointer component is used against its interface.
2662 If all goes well, the actual argument list will also end up being properly
2663 sorted. Completely analogous to gfc_procedure_use. */
2666 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2669 /* Warn about calls with an implicit interface. Special case
2670 for calling a ISO_C_BINDING becase c_loc and c_funloc
2671 are pseudo-unknown. */
2672 if (gfc_option
.warn_implicit_interface
2673 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2674 && !comp
->attr
.is_iso_c
)
2675 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2676 "interface at %L", comp
->name
, where
);
2678 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2680 gfc_actual_arglist
*a
;
2681 for (a
= *ap
; a
; a
= a
->next
)
2683 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2684 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2686 gfc_error("Keyword argument requires explicit interface "
2687 "for procedure pointer component '%s' at %L",
2688 comp
->name
, &a
->expr
->where
);
2696 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2699 check_intents (comp
->formal
, *ap
);
2700 if (gfc_option
.warn_aliasing
)
2701 check_some_aliasing (comp
->formal
, *ap
);
2705 /* Try if an actual argument list matches the formal list of a symbol,
2706 respecting the symbol's attributes like ELEMENTAL. This is used for
2707 GENERIC resolution. */
2710 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2714 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2716 r
= !sym
->attr
.elemental
;
2717 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2719 check_intents (sym
->formal
, *args
);
2720 if (gfc_option
.warn_aliasing
)
2721 check_some_aliasing (sym
->formal
, *args
);
2729 /* Given an interface pointer and an actual argument list, search for
2730 a formal argument list that matches the actual. If found, returns
2731 a pointer to the symbol of the correct interface. Returns NULL if
2735 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2736 gfc_actual_arglist
**ap
)
2738 gfc_symbol
*elem_sym
= NULL
;
2739 for (; intr
; intr
= intr
->next
)
2741 if (sub_flag
&& intr
->sym
->attr
.function
)
2743 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2746 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
2748 /* Satisfy 12.4.4.1 such that an elemental match has lower
2749 weight than a non-elemental match. */
2750 if (intr
->sym
->attr
.elemental
)
2752 elem_sym
= intr
->sym
;
2759 return elem_sym
? elem_sym
: NULL
;
2763 /* Do a brute force recursive search for a symbol. */
2765 static gfc_symtree
*
2766 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2770 if (root
->n
.sym
== sym
)
2775 st
= find_symtree0 (root
->left
, sym
);
2776 if (root
->right
&& ! st
)
2777 st
= find_symtree0 (root
->right
, sym
);
2782 /* Find a symtree for a symbol. */
2785 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
2790 /* First try to find it by name. */
2791 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2792 if (st
&& st
->n
.sym
== sym
)
2795 /* If it's been renamed, resort to a brute-force search. */
2796 /* TODO: avoid having to do this search. If the symbol doesn't exist
2797 in the symtree for the current namespace, it should probably be added. */
2798 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2800 st
= find_symtree0 (ns
->sym_root
, sym
);
2804 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2809 /* See if the arglist to an operator-call contains a derived-type argument
2810 with a matching type-bound operator. If so, return the matching specific
2811 procedure defined as operator-target as well as the base-object to use
2812 (which is the found derived-type argument with operator). The generic
2813 name, if any, is transmitted to the final expression via 'gname'. */
2815 static gfc_typebound_proc
*
2816 matching_typebound_op (gfc_expr
** tb_base
,
2817 gfc_actual_arglist
* args
,
2818 gfc_intrinsic_op op
, const char* uop
,
2819 const char ** gname
)
2821 gfc_actual_arglist
* base
;
2823 for (base
= args
; base
; base
= base
->next
)
2824 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
2826 gfc_typebound_proc
* tb
;
2827 gfc_symbol
* derived
;
2830 if (base
->expr
->ts
.type
== BT_CLASS
)
2831 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
2833 derived
= base
->expr
->ts
.u
.derived
;
2835 if (op
== INTRINSIC_USER
)
2837 gfc_symtree
* tb_uop
;
2840 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
2849 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
2852 /* This means we hit a PRIVATE operator which is use-associated and
2853 should thus not be seen. */
2854 if (result
== FAILURE
)
2857 /* Look through the super-type hierarchy for a matching specific
2859 for (; tb
; tb
= tb
->overridden
)
2863 gcc_assert (tb
->is_generic
);
2864 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
2867 gfc_actual_arglist
* argcopy
;
2870 gcc_assert (g
->specific
);
2871 if (g
->specific
->error
)
2874 target
= g
->specific
->u
.specific
->n
.sym
;
2876 /* Check if this arglist matches the formal. */
2877 argcopy
= gfc_copy_actual_arglist (args
);
2878 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
2879 gfc_free_actual_arglist (argcopy
);
2881 /* Return if we found a match. */
2884 *tb_base
= base
->expr
;
2885 *gname
= g
->specific_st
->name
;
2896 /* For the 'actual arglist' of an operator call and a specific typebound
2897 procedure that has been found the target of a type-bound operator, build the
2898 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2899 type-bound procedures rather than resolving type-bound operators 'directly'
2900 so that we can reuse the existing logic. */
2903 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
2904 gfc_expr
* base
, gfc_typebound_proc
* target
,
2907 e
->expr_type
= EXPR_COMPCALL
;
2908 e
->value
.compcall
.tbp
= target
;
2909 e
->value
.compcall
.name
= gname
? gname
: "$op";
2910 e
->value
.compcall
.actual
= actual
;
2911 e
->value
.compcall
.base_object
= base
;
2912 e
->value
.compcall
.ignore_pass
= 1;
2913 e
->value
.compcall
.assign
= 0;
2917 /* This subroutine is called when an expression is being resolved.
2918 The expression node in question is either a user defined operator
2919 or an intrinsic operator with arguments that aren't compatible
2920 with the operator. This subroutine builds an actual argument list
2921 corresponding to the operands, then searches for a compatible
2922 interface. If one is found, the expression node is replaced with
2923 the appropriate function call.
2924 real_error is an additional output argument that specifies if FAILURE
2925 is because of some real error and not because no match was found. */
2928 gfc_extend_expr (gfc_expr
*e
, bool *real_error
)
2930 gfc_actual_arglist
*actual
;
2939 actual
= gfc_get_actual_arglist ();
2940 actual
->expr
= e
->value
.op
.op1
;
2942 *real_error
= false;
2945 if (e
->value
.op
.op2
!= NULL
)
2947 actual
->next
= gfc_get_actual_arglist ();
2948 actual
->next
->expr
= e
->value
.op
.op2
;
2951 i
= fold_unary_intrinsic (e
->value
.op
.op
);
2953 if (i
== INTRINSIC_USER
)
2955 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2957 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2961 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
2968 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2970 /* Due to the distinction between '==' and '.eq.' and friends, one has
2971 to check if either is defined. */
2974 #define CHECK_OS_COMPARISON(comp) \
2975 case INTRINSIC_##comp: \
2976 case INTRINSIC_##comp##_OS: \
2977 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2979 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2981 CHECK_OS_COMPARISON(EQ
)
2982 CHECK_OS_COMPARISON(NE
)
2983 CHECK_OS_COMPARISON(GT
)
2984 CHECK_OS_COMPARISON(GE
)
2985 CHECK_OS_COMPARISON(LT
)
2986 CHECK_OS_COMPARISON(LE
)
2987 #undef CHECK_OS_COMPARISON
2990 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
2998 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2999 found rather than just taking the first one and not checking further. */
3003 gfc_typebound_proc
* tbo
;
3006 /* See if we find a matching type-bound operator. */
3007 if (i
== INTRINSIC_USER
)
3008 tbo
= matching_typebound_op (&tb_base
, actual
,
3009 i
, e
->value
.op
.uop
->name
, &gname
);
3013 #define CHECK_OS_COMPARISON(comp) \
3014 case INTRINSIC_##comp: \
3015 case INTRINSIC_##comp##_OS: \
3016 tbo = matching_typebound_op (&tb_base, actual, \
3017 INTRINSIC_##comp, NULL, &gname); \
3019 tbo = matching_typebound_op (&tb_base, actual, \
3020 INTRINSIC_##comp##_OS, NULL, &gname); \
3022 CHECK_OS_COMPARISON(EQ
)
3023 CHECK_OS_COMPARISON(NE
)
3024 CHECK_OS_COMPARISON(GT
)
3025 CHECK_OS_COMPARISON(GE
)
3026 CHECK_OS_COMPARISON(LT
)
3027 CHECK_OS_COMPARISON(LE
)
3028 #undef CHECK_OS_COMPARISON
3031 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3035 /* If there is a matching typebound-operator, replace the expression with
3036 a call to it and succeed. */
3041 gcc_assert (tb_base
);
3042 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3044 result
= gfc_resolve_expr (e
);
3045 if (result
== FAILURE
)
3051 /* Don't use gfc_free_actual_arglist(). */
3052 if (actual
->next
!= NULL
)
3053 gfc_free (actual
->next
);
3059 /* Change the expression node to a function call. */
3060 e
->expr_type
= EXPR_FUNCTION
;
3061 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3062 e
->value
.function
.actual
= actual
;
3063 e
->value
.function
.esym
= NULL
;
3064 e
->value
.function
.isym
= NULL
;
3065 e
->value
.function
.name
= NULL
;
3066 e
->user_operator
= 1;
3068 if (gfc_resolve_expr (e
) == FAILURE
)
3078 /* Tries to replace an assignment code node with a subroutine call to
3079 the subroutine associated with the assignment operator. Return
3080 SUCCESS if the node was replaced. On FAILURE, no error is
3084 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3086 gfc_actual_arglist
*actual
;
3087 gfc_expr
*lhs
, *rhs
;
3096 /* Don't allow an intrinsic assignment to be replaced. */
3097 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3098 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3099 && (lhs
->ts
.type
== rhs
->ts
.type
3100 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3103 actual
= gfc_get_actual_arglist ();
3106 actual
->next
= gfc_get_actual_arglist ();
3107 actual
->next
->expr
= rhs
;
3111 for (; ns
; ns
= ns
->parent
)
3113 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3118 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3122 gfc_typebound_proc
* tbo
;
3125 /* See if we find a matching type-bound assignment. */
3126 tbo
= matching_typebound_op (&tb_base
, actual
,
3127 INTRINSIC_ASSIGN
, NULL
, &gname
);
3129 /* If there is one, replace the expression with a call to it and
3133 gcc_assert (tb_base
);
3134 c
->expr1
= gfc_get_expr ();
3135 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3136 c
->expr1
->value
.compcall
.assign
= 1;
3138 c
->op
= EXEC_COMPCALL
;
3140 /* c is resolved from the caller, so no need to do it here. */
3145 gfc_free (actual
->next
);
3150 /* Replace the assignment with the call. */
3151 c
->op
= EXEC_ASSIGN_CALL
;
3152 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3155 c
->ext
.actual
= actual
;
3161 /* Make sure that the interface just parsed is not already present in
3162 the given interface list. Ambiguity isn't checked yet since module
3163 procedures can be present without interfaces. */
3166 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
3170 for (ip
= base
; ip
; ip
= ip
->next
)
3172 if (ip
->sym
== new_sym
)
3174 gfc_error ("Entity '%s' at %C is already present in the interface",
3184 /* Add a symbol to the current interface. */
3187 gfc_add_interface (gfc_symbol
*new_sym
)
3189 gfc_interface
**head
, *intr
;
3193 switch (current_interface
.type
)
3195 case INTERFACE_NAMELESS
:
3196 case INTERFACE_ABSTRACT
:
3199 case INTERFACE_INTRINSIC_OP
:
3200 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3201 switch (current_interface
.op
)
3204 case INTRINSIC_EQ_OS
:
3205 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
3206 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
3211 case INTRINSIC_NE_OS
:
3212 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
3213 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
3218 case INTRINSIC_GT_OS
:
3219 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
3220 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
3225 case INTRINSIC_GE_OS
:
3226 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
3227 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
3232 case INTRINSIC_LT_OS
:
3233 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
3234 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
3239 case INTRINSIC_LE_OS
:
3240 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
3241 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
3246 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
3250 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3253 case INTERFACE_GENERIC
:
3254 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3256 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3260 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
3264 head
= ¤t_interface
.sym
->generic
;
3267 case INTERFACE_USER_OP
:
3268 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
3272 head
= ¤t_interface
.uop
->op
;
3276 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3279 intr
= gfc_get_interface ();
3280 intr
->sym
= new_sym
;
3281 intr
->where
= gfc_current_locus
;
3291 gfc_current_interface_head (void)
3293 switch (current_interface
.type
)
3295 case INTERFACE_INTRINSIC_OP
:
3296 return current_interface
.ns
->op
[current_interface
.op
];
3299 case INTERFACE_GENERIC
:
3300 return current_interface
.sym
->generic
;
3303 case INTERFACE_USER_OP
:
3304 return current_interface
.uop
->op
;
3314 gfc_set_current_interface_head (gfc_interface
*i
)
3316 switch (current_interface
.type
)
3318 case INTERFACE_INTRINSIC_OP
:
3319 current_interface
.ns
->op
[current_interface
.op
] = i
;
3322 case INTERFACE_GENERIC
:
3323 current_interface
.sym
->generic
= i
;
3326 case INTERFACE_USER_OP
:
3327 current_interface
.uop
->op
= i
;
3336 /* Gets rid of a formal argument list. We do not free symbols.
3337 Symbols are freed when a namespace is freed. */
3340 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3342 gfc_formal_arglist
*q
;