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
)
876 || compare_type_rank_if (arg
[j
].sym
, arg
[i
].sym
)))
882 /* Now loop over each distinct type found in f1. */
886 for (i
= 0; i
< n1
; i
++)
888 if (arg
[i
].flag
!= k
)
892 for (j
= i
+ 1; j
< n1
; j
++)
893 if (arg
[j
].flag
== k
)
896 /* Count the number of arguments in f2 with that type, including
897 those that are optional. */
900 for (f
= f2
; f
; f
= f
->next
)
901 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
)
902 || compare_type_rank_if (f
->sym
, arg
[i
].sym
))
920 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
921 Returns zero if no argument is found that satisfies rule 2, nonzero
924 This test is also not symmetric in f1 and f2 and must be called
925 twice. This test finds problems caused by sorting the actual
926 argument list with keywords. For example:
930 INTEGER :: A ; REAL :: B
934 INTEGER :: A ; REAL :: B
938 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
941 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
943 gfc_formal_arglist
*f2_save
, *g
;
950 if (f1
->sym
->attr
.optional
)
953 if (f2
!= NULL
&& (compare_type_rank (f1
->sym
, f2
->sym
)
954 || compare_type_rank (f2
->sym
, f1
->sym
)))
957 /* Now search for a disambiguating keyword argument starting at
958 the current non-match. */
959 for (g
= f1
; g
; g
= g
->next
)
961 if (g
->sym
->attr
.optional
)
964 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
965 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
979 /* 'Compare' two formal interfaces associated with a pair of symbols.
980 We return nonzero if there exists an actual argument list that
981 would be ambiguous between the two interfaces, zero otherwise.
982 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
983 required to match, which is not the case for ambiguity checks.*/
986 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, const char *name2
,
987 int generic_flag
, int intent_flag
,
988 char *errmsg
, int err_len
)
990 gfc_formal_arglist
*f1
, *f2
;
992 gcc_assert (name2
!= NULL
);
994 if (s1
->attr
.function
&& (s2
->attr
.subroutine
995 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
996 && gfc_get_default_type (name2
, s2
->ns
)->type
== BT_UNKNOWN
)))
999 snprintf (errmsg
, err_len
, "'%s' is not a function", name2
);
1003 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
1006 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", name2
);
1010 /* If the arguments are functions, check type and kind
1011 (only for dummy procedures and procedure pointer assignments). */
1012 if (!generic_flag
&& intent_flag
&& s1
->attr
.function
&& s2
->attr
.function
)
1014 if (s1
->ts
.type
== BT_UNKNOWN
)
1016 if ((s1
->ts
.type
!= s2
->ts
.type
) || (s1
->ts
.kind
!= s2
->ts
.kind
))
1019 snprintf (errmsg
, err_len
, "Type/kind mismatch in return value "
1025 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
1026 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
1032 if (f1
== NULL
&& f2
== NULL
)
1033 return 1; /* Special case: No arguments. */
1037 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1039 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
1043 /* Perform the abbreviated correspondence test for operators (the
1044 arguments cannot be optional and are always ordered correctly).
1045 This is also done when comparing interfaces for dummy procedures and in
1046 procedure pointer assignments. */
1050 /* Check existence. */
1051 if (f1
== NULL
&& f2
== NULL
)
1053 if (f1
== NULL
|| f2
== NULL
)
1056 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1057 "arguments", name2
);
1061 /* Check type and rank. */
1062 if (!compare_type_rank (f2
->sym
, f1
->sym
))
1065 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1071 if (intent_flag
&& (f1
->sym
->attr
.intent
!= f2
->sym
->attr
.intent
))
1073 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1078 /* Check OPTIONAL. */
1079 if (intent_flag
&& (f1
->sym
->attr
.optional
!= f2
->sym
->attr
.optional
))
1081 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1094 /* Given a pointer to an interface pointer, remove duplicate
1095 interfaces and make sure that all symbols are either functions or
1096 subroutines. Returns nonzero if something goes wrong. */
1099 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1101 gfc_interface
*psave
, *q
, *qlast
;
1104 /* Make sure all symbols in the interface have been defined as
1105 functions or subroutines. */
1106 for (; p
; p
= p
->next
)
1107 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1108 || !p
->sym
->attr
.if_source
)
1110 if (p
->sym
->attr
.external
)
1111 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1112 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1114 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1115 "subroutine", p
->sym
->name
, interface_name
,
1116 &p
->sym
->declared_at
);
1121 /* Remove duplicate interfaces in this interface list. */
1122 for (; p
; p
= p
->next
)
1126 for (q
= p
->next
; q
;)
1128 if (p
->sym
!= q
->sym
)
1135 /* Duplicate interface. */
1136 qlast
->next
= q
->next
;
1147 /* Check lists of interfaces to make sure that no two interfaces are
1148 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1151 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1152 int generic_flag
, const char *interface_name
,
1156 for (; p
; p
= p
->next
)
1157 for (q
= q0
; q
; q
= q
->next
)
1159 if (p
->sym
== q
->sym
)
1160 continue; /* Duplicates OK here. */
1162 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1165 if (gfc_compare_interfaces (p
->sym
, q
->sym
, q
->sym
->name
, generic_flag
,
1169 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1170 p
->sym
->name
, q
->sym
->name
, interface_name
,
1172 else if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1173 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1174 p
->sym
->name
, q
->sym
->name
, interface_name
,
1177 gfc_warning ("Although not referenced, '%s' has ambiguous "
1178 "interfaces at %L", interface_name
, &p
->where
);
1186 /* Check the generic and operator interfaces of symbols to make sure
1187 that none of the interfaces conflict. The check has to be done
1188 after all of the symbols are actually loaded. */
1191 check_sym_interfaces (gfc_symbol
*sym
)
1193 char interface_name
[100];
1196 if (sym
->ns
!= gfc_current_ns
)
1199 if (sym
->generic
!= NULL
)
1201 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1202 if (check_interface0 (sym
->generic
, interface_name
))
1205 for (p
= sym
->generic
; p
; p
= p
->next
)
1207 if (p
->sym
->attr
.mod_proc
1208 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1209 || p
->sym
->attr
.procedure
))
1211 gfc_error ("'%s' at %L is not a module procedure",
1212 p
->sym
->name
, &p
->where
);
1217 /* Originally, this test was applied to host interfaces too;
1218 this is incorrect since host associated symbols, from any
1219 source, cannot be ambiguous with local symbols. */
1220 check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
,
1221 sym
->attr
.referenced
|| !sym
->attr
.use_assoc
);
1227 check_uop_interfaces (gfc_user_op
*uop
)
1229 char interface_name
[100];
1233 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1234 if (check_interface0 (uop
->op
, interface_name
))
1237 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1239 uop2
= gfc_find_uop (uop
->name
, ns
);
1243 check_interface1 (uop
->op
, uop2
->op
, 0,
1244 interface_name
, true);
1249 /* For the namespace, check generic, user operator and intrinsic
1250 operator interfaces for consistency and to remove duplicate
1251 interfaces. We traverse the whole namespace, counting on the fact
1252 that most symbols will not have generic or operator interfaces. */
1255 gfc_check_interfaces (gfc_namespace
*ns
)
1257 gfc_namespace
*old_ns
, *ns2
;
1258 char interface_name
[100];
1261 old_ns
= gfc_current_ns
;
1262 gfc_current_ns
= ns
;
1264 gfc_traverse_ns (ns
, check_sym_interfaces
);
1266 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1268 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1270 if (i
== INTRINSIC_USER
)
1273 if (i
== INTRINSIC_ASSIGN
)
1274 strcpy (interface_name
, "intrinsic assignment operator");
1276 sprintf (interface_name
, "intrinsic '%s' operator",
1277 gfc_op2string ((gfc_intrinsic_op
) i
));
1279 if (check_interface0 (ns
->op
[i
], interface_name
))
1283 gfc_check_operator_interface (ns
->op
[i
]->sym
, (gfc_intrinsic_op
) i
,
1286 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1288 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1289 interface_name
, true))
1295 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ_OS
],
1296 0, interface_name
, true)) goto done
;
1299 case INTRINSIC_EQ_OS
:
1300 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ
],
1301 0, interface_name
, true)) goto done
;
1305 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE_OS
],
1306 0, interface_name
, true)) goto done
;
1309 case INTRINSIC_NE_OS
:
1310 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE
],
1311 0, interface_name
, true)) goto done
;
1315 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT_OS
],
1316 0, interface_name
, true)) goto done
;
1319 case INTRINSIC_GT_OS
:
1320 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT
],
1321 0, interface_name
, true)) goto done
;
1325 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE_OS
],
1326 0, interface_name
, true)) goto done
;
1329 case INTRINSIC_GE_OS
:
1330 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE
],
1331 0, interface_name
, true)) goto done
;
1335 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT_OS
],
1336 0, interface_name
, true)) goto done
;
1339 case INTRINSIC_LT_OS
:
1340 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT
],
1341 0, interface_name
, true)) goto done
;
1345 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE_OS
],
1346 0, interface_name
, true)) goto done
;
1349 case INTRINSIC_LE_OS
:
1350 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE
],
1351 0, interface_name
, true)) goto done
;
1361 gfc_current_ns
= old_ns
;
1366 symbol_rank (gfc_symbol
*sym
)
1368 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1372 /* Given a symbol of a formal argument list and an expression, if the
1373 formal argument is allocatable, check that the actual argument is
1374 allocatable. Returns nonzero if compatible, zero if not compatible. */
1377 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1379 symbol_attribute attr
;
1381 if (formal
->attr
.allocatable
1382 || (formal
->ts
.type
== BT_CLASS
&& CLASS_DATA (formal
)->attr
.allocatable
))
1384 attr
= gfc_expr_attr (actual
);
1385 if (!attr
.allocatable
)
1393 /* Given a symbol of a formal argument list and an expression, if the
1394 formal argument is a pointer, see if the actual argument is a
1395 pointer. Returns nonzero if compatible, zero if not compatible. */
1398 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1400 symbol_attribute attr
;
1402 if (formal
->attr
.pointer
)
1404 attr
= gfc_expr_attr (actual
);
1406 /* Fortran 2008 allows non-pointer actual arguments. */
1407 if (!attr
.pointer
&& attr
.target
&& formal
->attr
.intent
== INTENT_IN
)
1418 /* Emit clear error messages for rank mismatch. */
1421 argument_rank_mismatch (const char *name
, locus
*where
,
1422 int rank1
, int rank2
)
1426 gfc_error ("Rank mismatch in argument '%s' at %L "
1427 "(scalar and rank-%d)", name
, where
, rank2
);
1429 else if (rank2
== 0)
1431 gfc_error ("Rank mismatch in argument '%s' at %L "
1432 "(rank-%d and scalar)", name
, where
, rank1
);
1436 gfc_error ("Rank mismatch in argument '%s' at %L "
1437 "(rank-%d and rank-%d)", name
, where
, rank1
, rank2
);
1442 /* Given a symbol of a formal argument list and an expression, see if
1443 the two are compatible as arguments. Returns nonzero if
1444 compatible, zero if not compatible. */
1447 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1448 int ranks_must_agree
, int is_elemental
, locus
*where
)
1453 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1454 procs c_f_pointer or c_f_procpointer, and we need to accept most
1455 pointers the user could give us. This should allow that. */
1456 if (formal
->ts
.type
== BT_VOID
)
1459 if (formal
->ts
.type
== BT_DERIVED
1460 && formal
->ts
.u
.derived
&& formal
->ts
.u
.derived
->ts
.is_iso_c
1461 && actual
->ts
.type
== BT_DERIVED
1462 && actual
->ts
.u
.derived
&& actual
->ts
.u
.derived
->ts
.is_iso_c
)
1465 if (formal
->ts
.type
== BT_CLASS
&& actual
->ts
.type
== BT_DERIVED
)
1466 /* Make sure the vtab symbol is present when
1467 the module variables are generated. */
1468 gfc_find_derived_vtab (actual
->ts
.u
.derived
);
1470 if (actual
->ts
.type
== BT_PROCEDURE
)
1473 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1475 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1478 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1482 if (!gfc_compare_interfaces (formal
, act_sym
, act_sym
->name
, 0, 1, err
,
1486 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1487 formal
->name
, &actual
->where
, err
);
1491 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1493 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1494 &act_sym
->declared_at
);
1495 if (act_sym
->ts
.type
== BT_UNKNOWN
1496 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1499 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1500 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1501 &act_sym
->declared_at
);
1507 if (formal
->attr
.pointer
&& formal
->attr
.contiguous
1508 && !gfc_is_simply_contiguous (actual
, true))
1511 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1512 "must be simply contigous", formal
->name
, &actual
->where
);
1516 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1517 && actual
->ts
.type
!= BT_HOLLERITH
1518 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1521 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1522 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1523 gfc_typename (&formal
->ts
));
1527 /* F2003, 12.5.2.5. */
1528 if (formal
->ts
.type
== BT_CLASS
1529 && (CLASS_DATA (formal
)->attr
.class_pointer
1530 || CLASS_DATA (formal
)->attr
.allocatable
))
1532 if (actual
->ts
.type
!= BT_CLASS
)
1535 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1536 formal
->name
, &actual
->where
);
1539 if (CLASS_DATA (actual
)->ts
.u
.derived
1540 != CLASS_DATA (formal
)->ts
.u
.derived
)
1543 gfc_error ("Actual argument to '%s' at %L must have the same "
1544 "declared type", formal
->name
, &actual
->where
);
1549 if (formal
->attr
.codimension
)
1551 gfc_ref
*last
= NULL
;
1553 if (actual
->expr_type
!= EXPR_VARIABLE
1554 || (actual
->ref
== NULL
1555 && !actual
->symtree
->n
.sym
->attr
.codimension
))
1558 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1559 formal
->name
, &actual
->where
);
1563 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1565 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
!= 0)
1568 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1569 "and not coindexed", formal
->name
, &ref
->u
.ar
.where
);
1572 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
->corank
1573 && ref
->u
.ar
.type
!= AR_FULL
&& ref
->u
.ar
.dimen
!= 0)
1576 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1577 "and thus shall not have an array designator",
1578 formal
->name
, &ref
->u
.ar
.where
);
1581 if (ref
->type
== REF_COMPONENT
)
1585 if (last
&& !last
->u
.c
.component
->attr
.codimension
)
1588 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1589 formal
->name
, &actual
->where
);
1593 /* F2008, 12.5.2.6. */
1594 if (formal
->attr
.allocatable
&&
1595 ((last
&& last
->u
.c
.component
->as
->corank
!= formal
->as
->corank
)
1597 && actual
->symtree
->n
.sym
->as
->corank
!= formal
->as
->corank
)))
1600 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1601 formal
->name
, &actual
->where
, formal
->as
->corank
,
1602 last
? last
->u
.c
.component
->as
->corank
1603 : actual
->symtree
->n
.sym
->as
->corank
);
1607 /* F2008, 12.5.2.8. */
1608 if (formal
->attr
.dimension
1609 && (formal
->attr
.contiguous
|| formal
->as
->type
!= AS_ASSUMED_SHAPE
)
1610 && !gfc_is_simply_contiguous (actual
, true))
1613 gfc_error ("Actual argument to '%s' at %L must be simply "
1614 "contiguous", formal
->name
, &actual
->where
);
1619 /* F2008, C1239/C1240. */
1620 if (actual
->expr_type
== EXPR_VARIABLE
1621 && (actual
->symtree
->n
.sym
->attr
.asynchronous
1622 || actual
->symtree
->n
.sym
->attr
.volatile_
)
1623 && (formal
->attr
.asynchronous
|| formal
->attr
.volatile_
)
1624 && actual
->rank
&& !gfc_is_simply_contiguous (actual
, true)
1625 && ((formal
->as
->type
!= AS_ASSUMED_SHAPE
&& !formal
->attr
.pointer
)
1626 || formal
->attr
.contiguous
))
1629 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1630 "array without CONTIGUOUS attribute - as actual argument at"
1631 " %L is not simply contiguous and both are ASYNCHRONOUS "
1632 "or VOLATILE", formal
->name
, &actual
->where
);
1636 if (symbol_rank (formal
) == actual
->rank
)
1639 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1640 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1641 || formal
->as
->type
== AS_DEFERRED
)
1642 && actual
->expr_type
!= EXPR_NULL
;
1644 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1645 if (rank_check
|| ranks_must_agree
1646 || (formal
->attr
.pointer
&& actual
->expr_type
!= EXPR_NULL
)
1647 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1648 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
1649 && actual
->expr_type
!= EXPR_NULL
)
1650 || (actual
->rank
== 0 && formal
->attr
.dimension
1651 && gfc_is_coindexed (actual
)))
1654 argument_rank_mismatch (formal
->name
, &actual
->where
,
1655 symbol_rank (formal
), actual
->rank
);
1658 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1661 /* At this point, we are considering a scalar passed to an array. This
1662 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1663 - if the actual argument is (a substring of) an element of a
1664 non-assumed-shape/non-pointer array;
1665 - (F2003) if the actual argument is of type character. */
1667 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1668 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1669 && ref
->u
.ar
.dimen
> 0)
1672 /* Not an array element. */
1673 if (formal
->ts
.type
== BT_CHARACTER
1675 || (actual
->expr_type
== EXPR_VARIABLE
1676 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1677 || actual
->symtree
->n
.sym
->attr
.pointer
))))
1679 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1681 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1682 "array dummy argument '%s' at %L",
1683 formal
->name
, &actual
->where
);
1686 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1691 else if (ref
== NULL
&& actual
->expr_type
!= EXPR_NULL
)
1694 argument_rank_mismatch (formal
->name
, &actual
->where
,
1695 symbol_rank (formal
), actual
->rank
);
1699 if (actual
->expr_type
== EXPR_VARIABLE
1700 && actual
->symtree
->n
.sym
->as
1701 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1702 || actual
->symtree
->n
.sym
->attr
.pointer
))
1705 gfc_error ("Element of assumed-shaped array passed to dummy "
1706 "argument '%s' at %L", formal
->name
, &actual
->where
);
1714 /* Returns the storage size of a symbol (formal argument) or
1715 zero if it cannot be determined. */
1717 static unsigned long
1718 get_sym_storage_size (gfc_symbol
*sym
)
1721 unsigned long strlen
, elements
;
1723 if (sym
->ts
.type
== BT_CHARACTER
)
1725 if (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1726 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1727 strlen
= mpz_get_ui (sym
->ts
.u
.cl
->length
->value
.integer
);
1734 if (symbol_rank (sym
) == 0)
1738 if (sym
->as
->type
!= AS_EXPLICIT
)
1740 for (i
= 0; i
< sym
->as
->rank
; i
++)
1742 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1743 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1746 elements
*= mpz_get_si (sym
->as
->upper
[i
]->value
.integer
)
1747 - mpz_get_si (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1750 return strlen
*elements
;
1754 /* Returns the storage size of an expression (actual argument) or
1755 zero if it cannot be determined. For an array element, it returns
1756 the remaining size as the element sequence consists of all storage
1757 units of the actual argument up to the end of the array. */
1759 static unsigned long
1760 get_expr_storage_size (gfc_expr
*e
)
1763 long int strlen
, elements
;
1764 long int substrlen
= 0;
1765 bool is_str_storage
= false;
1771 if (e
->ts
.type
== BT_CHARACTER
)
1773 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
1774 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1775 strlen
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
1776 else if (e
->expr_type
== EXPR_CONSTANT
1777 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
1778 strlen
= e
->value
.character
.length
;
1783 strlen
= 1; /* Length per element. */
1785 if (e
->rank
== 0 && !e
->ref
)
1793 for (i
= 0; i
< e
->rank
; i
++)
1794 elements
*= mpz_get_si (e
->shape
[i
]);
1795 return elements
*strlen
;
1798 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1800 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1801 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1805 /* The string length is the substring length.
1806 Set now to full string length. */
1807 if (ref
->u
.ss
.length
== NULL
1808 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1811 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1813 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1817 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1818 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1819 && ref
->u
.ar
.as
->upper
)
1820 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1822 long int start
, end
, stride
;
1825 if (ref
->u
.ar
.stride
[i
])
1827 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1828 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1833 if (ref
->u
.ar
.start
[i
])
1835 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1836 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1840 else if (ref
->u
.ar
.as
->lower
[i
]
1841 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1842 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1846 if (ref
->u
.ar
.end
[i
])
1848 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1849 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1853 else if (ref
->u
.ar
.as
->upper
[i
]
1854 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1855 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1859 elements
*= (end
- start
)/stride
+ 1L;
1861 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1862 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1863 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1865 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1866 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1867 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1868 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1869 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1874 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1875 && e
->expr_type
== EXPR_VARIABLE
)
1877 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1878 || e
->symtree
->n
.sym
->attr
.pointer
)
1884 /* Determine the number of remaining elements in the element
1885 sequence for array element designators. */
1886 is_str_storage
= true;
1887 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1889 if (ref
->u
.ar
.start
[i
] == NULL
1890 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1891 || ref
->u
.ar
.as
->upper
[i
] == NULL
1892 || ref
->u
.ar
.as
->lower
[i
] == NULL
1893 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1894 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1899 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1900 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1902 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1903 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1911 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1914 return elements
*strlen
;
1918 /* Given an expression, check whether it is an array section
1919 which has a vector subscript. If it has, one is returned,
1923 gfc_has_vector_subscript (gfc_expr
*e
)
1928 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1931 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1932 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1933 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1934 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1941 /* Given formal and actual argument lists, see if they are compatible.
1942 If they are compatible, the actual argument list is sorted to
1943 correspond with the formal list, and elements for missing optional
1944 arguments are inserted. If WHERE pointer is nonnull, then we issue
1945 errors when things don't match instead of just returning the status
1949 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1950 int ranks_must_agree
, int is_elemental
, locus
*where
)
1952 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
1953 gfc_formal_arglist
*f
;
1955 unsigned long actual_size
, formal_size
;
1959 if (actual
== NULL
&& formal
== NULL
)
1963 for (f
= formal
; f
; f
= f
->next
)
1966 new_arg
= XALLOCAVEC (gfc_actual_arglist
*, n
);
1968 for (i
= 0; i
< n
; i
++)
1975 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1977 /* Look for keywords but ignore g77 extensions like %VAL. */
1978 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1981 for (f
= formal
; f
; f
= f
->next
, i
++)
1985 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1992 gfc_error ("Keyword argument '%s' at %L is not in "
1993 "the procedure", a
->name
, &a
->expr
->where
);
1997 if (new_arg
[i
] != NULL
)
2000 gfc_error ("Keyword argument '%s' at %L is already associated "
2001 "with another actual argument", a
->name
,
2010 gfc_error ("More actual than formal arguments in procedure "
2011 "call at %L", where
);
2016 if (f
->sym
== NULL
&& a
->expr
== NULL
)
2022 gfc_error ("Missing alternate return spec in subroutine call "
2027 if (a
->expr
== NULL
)
2030 gfc_error ("Unexpected alternate return spec in subroutine "
2031 "call at %L", where
);
2035 if (a
->expr
->expr_type
== EXPR_NULL
&& !f
->sym
->attr
.pointer
2036 && (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
2037 || (gfc_option
.allow_std
& GFC_STD_F2008
) == 0))
2039 if (where
&& (f
->sym
->attr
.allocatable
|| !f
->sym
->attr
.optional
))
2040 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2041 where
, f
->sym
->name
);
2043 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2044 "dummy '%s'", where
, f
->sym
->name
);
2049 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
2050 is_elemental
, where
))
2053 /* Special case for character arguments. For allocatable, pointer
2054 and assumed-shape dummies, the string length needs to match
2056 if (a
->expr
->ts
.type
== BT_CHARACTER
2057 && a
->expr
->ts
.u
.cl
&& a
->expr
->ts
.u
.cl
->length
2058 && a
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2059 && f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
&& f
->sym
->ts
.u
.cl
->length
2060 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2061 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
2062 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2063 && (mpz_cmp (a
->expr
->ts
.u
.cl
->length
->value
.integer
,
2064 f
->sym
->ts
.u
.cl
->length
->value
.integer
) != 0))
2066 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
2067 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2068 "argument and pointer or allocatable dummy argument "
2070 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2071 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2072 f
->sym
->name
, &a
->expr
->where
);
2074 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2075 "argument and assumed-shape dummy argument '%s' "
2077 mpz_get_si (a
->expr
->ts
.u
.cl
->length
->value
.integer
),
2078 mpz_get_si (f
->sym
->ts
.u
.cl
->length
->value
.integer
),
2079 f
->sym
->name
, &a
->expr
->where
);
2083 actual_size
= get_expr_storage_size (a
->expr
);
2084 formal_size
= get_sym_storage_size (f
->sym
);
2085 if (actual_size
!= 0
2086 && actual_size
< formal_size
2087 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
2089 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
2090 gfc_warning ("Character length of actual argument shorter "
2091 "than of dummy argument '%s' (%lu/%lu) at %L",
2092 f
->sym
->name
, actual_size
, formal_size
,
2095 gfc_warning ("Actual argument contains too few "
2096 "elements for dummy argument '%s' (%lu/%lu) at %L",
2097 f
->sym
->name
, actual_size
, formal_size
,
2102 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2103 is provided for a procedure pointer formal argument. */
2104 if (f
->sym
->attr
.proc_pointer
2105 && !((a
->expr
->expr_type
== EXPR_VARIABLE
2106 && a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
2107 || (a
->expr
->expr_type
== EXPR_FUNCTION
2108 && a
->expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2109 || gfc_is_proc_ptr_comp (a
->expr
, NULL
)))
2112 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2113 f
->sym
->name
, &a
->expr
->where
);
2117 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2118 provided for a procedure formal argument. */
2119 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !gfc_is_proc_ptr_comp (a
->expr
, NULL
)
2120 && a
->expr
->expr_type
== EXPR_VARIABLE
2121 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2124 gfc_error ("Expected a procedure for argument '%s' at %L",
2125 f
->sym
->name
, &a
->expr
->where
);
2129 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
2130 && a
->expr
->ts
.type
== BT_PROCEDURE
2131 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
2134 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2135 f
->sym
->name
, &a
->expr
->where
);
2139 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2140 && a
->expr
->expr_type
== EXPR_VARIABLE
2141 && a
->expr
->symtree
->n
.sym
->as
2142 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
2143 && (a
->expr
->ref
== NULL
2144 || (a
->expr
->ref
->type
== REF_ARRAY
2145 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2148 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2149 " array at %L", f
->sym
->name
, where
);
2153 if (a
->expr
->expr_type
!= EXPR_NULL
2154 && compare_pointer (f
->sym
, a
->expr
) == 0)
2157 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2158 f
->sym
->name
, &a
->expr
->where
);
2162 if (a
->expr
->expr_type
!= EXPR_NULL
2163 && (gfc_option
.allow_std
& GFC_STD_F2008
) == 0
2164 && compare_pointer (f
->sym
, a
->expr
) == 2)
2167 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2168 "pointer dummy '%s'", &a
->expr
->where
,f
->sym
->name
);
2173 /* Fortran 2008, C1242. */
2174 if (f
->sym
->attr
.pointer
&& gfc_is_coindexed (a
->expr
))
2177 gfc_error ("Coindexed actual argument at %L to pointer "
2179 &a
->expr
->where
, f
->sym
->name
);
2183 /* Fortran 2008, 12.5.2.5 (no constraint). */
2184 if (a
->expr
->expr_type
== EXPR_VARIABLE
2185 && f
->sym
->attr
.intent
!= INTENT_IN
2186 && f
->sym
->attr
.allocatable
2187 && gfc_is_coindexed (a
->expr
))
2190 gfc_error ("Coindexed actual argument at %L to allocatable "
2191 "dummy '%s' requires INTENT(IN)",
2192 &a
->expr
->where
, f
->sym
->name
);
2196 /* Fortran 2008, C1237. */
2197 if (a
->expr
->expr_type
== EXPR_VARIABLE
2198 && (f
->sym
->attr
.asynchronous
|| f
->sym
->attr
.volatile_
)
2199 && gfc_is_coindexed (a
->expr
)
2200 && (a
->expr
->symtree
->n
.sym
->attr
.volatile_
2201 || a
->expr
->symtree
->n
.sym
->attr
.asynchronous
))
2204 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2205 "at %L requires that dummy %s' has neither "
2206 "ASYNCHRONOUS nor VOLATILE", &a
->expr
->where
,
2211 /* Fortran 2008, 12.5.2.4 (no constraint). */
2212 if (a
->expr
->expr_type
== EXPR_VARIABLE
2213 && f
->sym
->attr
.intent
!= INTENT_IN
&& !f
->sym
->attr
.value
2214 && gfc_is_coindexed (a
->expr
)
2215 && gfc_has_ultimate_allocatable (a
->expr
))
2218 gfc_error ("Coindexed actual argument at %L with allocatable "
2219 "ultimate component to dummy '%s' requires either VALUE "
2220 "or INTENT(IN)", &a
->expr
->where
, f
->sym
->name
);
2224 if (a
->expr
->expr_type
!= EXPR_NULL
2225 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2228 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2229 f
->sym
->name
, &a
->expr
->where
);
2233 /* Check intent = OUT/INOUT for definable actual argument. */
2234 if ((f
->sym
->attr
.intent
== INTENT_OUT
2235 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2237 const char* context
= (where
2238 ? _("actual argument to INTENT = OUT/INOUT")
2241 if (f
->sym
->attr
.pointer
2242 && gfc_check_vardef_context (a
->expr
, true, context
)
2245 if (gfc_check_vardef_context (a
->expr
, false, context
)
2250 if ((f
->sym
->attr
.intent
== INTENT_OUT
2251 || f
->sym
->attr
.intent
== INTENT_INOUT
2252 || f
->sym
->attr
.volatile_
2253 || f
->sym
->attr
.asynchronous
)
2254 && gfc_has_vector_subscript (a
->expr
))
2257 gfc_error ("Array-section actual argument with vector "
2258 "subscripts at %L is incompatible with INTENT(OUT), "
2259 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2260 "of the dummy argument '%s'",
2261 &a
->expr
->where
, f
->sym
->name
);
2265 /* C1232 (R1221) For an actual argument which is an array section or
2266 an assumed-shape array, the dummy argument shall be an assumed-
2267 shape array, if the dummy argument has the VOLATILE attribute. */
2269 if (f
->sym
->attr
.volatile_
2270 && a
->expr
->symtree
->n
.sym
->as
2271 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2272 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2275 gfc_error ("Assumed-shape actual argument at %L is "
2276 "incompatible with the non-assumed-shape "
2277 "dummy argument '%s' due to VOLATILE attribute",
2278 &a
->expr
->where
,f
->sym
->name
);
2282 if (f
->sym
->attr
.volatile_
2283 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2284 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2287 gfc_error ("Array-section actual argument at %L is "
2288 "incompatible with the non-assumed-shape "
2289 "dummy argument '%s' due to VOLATILE attribute",
2290 &a
->expr
->where
,f
->sym
->name
);
2294 /* C1233 (R1221) For an actual argument which is a pointer array, the
2295 dummy argument shall be an assumed-shape or pointer array, if the
2296 dummy argument has the VOLATILE attribute. */
2298 if (f
->sym
->attr
.volatile_
2299 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2300 && a
->expr
->symtree
->n
.sym
->as
2302 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2303 || f
->sym
->attr
.pointer
)))
2306 gfc_error ("Pointer-array actual argument at %L requires "
2307 "an assumed-shape or pointer-array dummy "
2308 "argument '%s' due to VOLATILE attribute",
2309 &a
->expr
->where
,f
->sym
->name
);
2320 /* Make sure missing actual arguments are optional. */
2322 for (f
= formal
; f
; f
= f
->next
, i
++)
2324 if (new_arg
[i
] != NULL
)
2329 gfc_error ("Missing alternate return spec in subroutine call "
2333 if (!f
->sym
->attr
.optional
)
2336 gfc_error ("Missing actual argument for argument '%s' at %L",
2337 f
->sym
->name
, where
);
2342 /* The argument lists are compatible. We now relink a new actual
2343 argument list with null arguments in the right places. The head
2344 of the list remains the head. */
2345 for (i
= 0; i
< n
; i
++)
2346 if (new_arg
[i
] == NULL
)
2347 new_arg
[i
] = gfc_get_actual_arglist ();
2352 *new_arg
[0] = *actual
;
2356 new_arg
[0] = new_arg
[na
];
2360 for (i
= 0; i
< n
- 1; i
++)
2361 new_arg
[i
]->next
= new_arg
[i
+ 1];
2363 new_arg
[i
]->next
= NULL
;
2365 if (*ap
== NULL
&& n
> 0)
2368 /* Note the types of omitted optional arguments. */
2369 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2370 if (a
->expr
== NULL
&& a
->label
== NULL
)
2371 a
->missing_arg_type
= f
->sym
->ts
.type
;
2379 gfc_formal_arglist
*f
;
2380 gfc_actual_arglist
*a
;
2384 /* qsort comparison function for argument pairs, with the following
2386 - p->a->expr == NULL
2387 - p->a->expr->expr_type != EXPR_VARIABLE
2388 - growing p->a->expr->symbol. */
2391 pair_cmp (const void *p1
, const void *p2
)
2393 const gfc_actual_arglist
*a1
, *a2
;
2395 /* *p1 and *p2 are elements of the to-be-sorted array. */
2396 a1
= ((const argpair
*) p1
)->a
;
2397 a2
= ((const argpair
*) p2
)->a
;
2406 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2408 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2412 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2414 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2418 /* Given two expressions from some actual arguments, test whether they
2419 refer to the same expression. The analysis is conservative.
2420 Returning FAILURE will produce no warning. */
2423 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2425 const gfc_ref
*r1
, *r2
;
2428 || e1
->expr_type
!= EXPR_VARIABLE
2429 || e2
->expr_type
!= EXPR_VARIABLE
2430 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2433 /* TODO: improve comparison, see expr.c:show_ref(). */
2434 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2436 if (r1
->type
!= r2
->type
)
2441 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2443 /* TODO: At the moment, consider only full arrays;
2444 we could do better. */
2445 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2450 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2458 gfc_internal_error ("compare_actual_expr(): Bad component code");
2467 /* Given formal and actual argument lists that correspond to one
2468 another, check that identical actual arguments aren't not
2469 associated with some incompatible INTENTs. */
2472 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2474 sym_intent f1_intent
, f2_intent
;
2475 gfc_formal_arglist
*f1
;
2476 gfc_actual_arglist
*a1
;
2479 gfc_try t
= SUCCESS
;
2482 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2484 if (f1
== NULL
&& a1
== NULL
)
2486 if (f1
== NULL
|| a1
== NULL
)
2487 gfc_internal_error ("check_some_aliasing(): List mismatch");
2492 p
= XALLOCAVEC (argpair
, n
);
2494 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2500 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2502 for (i
= 0; i
< n
; i
++)
2505 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2506 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2508 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2509 for (j
= i
+ 1; j
< n
; j
++)
2511 /* Expected order after the sort. */
2512 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2513 gfc_internal_error ("check_some_aliasing(): corrupted data");
2515 /* Are the expression the same? */
2516 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2518 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2519 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2520 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2522 gfc_warning ("Same actual argument associated with INTENT(%s) "
2523 "argument '%s' and INTENT(%s) argument '%s' at %L",
2524 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2525 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2526 &p
[i
].a
->expr
->where
);
2536 /* Given a symbol of a formal argument list and an expression,
2537 return nonzero if their intents are compatible, zero otherwise. */
2540 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2542 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2545 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2548 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2555 /* Given formal and actual argument lists that correspond to one
2556 another, check that they are compatible in the sense that intents
2557 are not mismatched. */
2560 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2562 sym_intent f_intent
;
2564 for (;; f
= f
->next
, a
= a
->next
)
2566 if (f
== NULL
&& a
== NULL
)
2568 if (f
== NULL
|| a
== NULL
)
2569 gfc_internal_error ("check_intents(): List mismatch");
2571 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2574 f_intent
= f
->sym
->attr
.intent
;
2576 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2578 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2579 "specifies INTENT(%s)", &a
->expr
->where
,
2580 gfc_intent_string (f_intent
));
2584 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2586 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2588 gfc_error ("Procedure argument at %L is local to a PURE "
2589 "procedure and is passed to an INTENT(%s) argument",
2590 &a
->expr
->where
, gfc_intent_string (f_intent
));
2594 if (f
->sym
->attr
.pointer
)
2596 gfc_error ("Procedure argument at %L is local to a PURE "
2597 "procedure and has the POINTER attribute",
2603 /* Fortran 2008, C1283. */
2604 if (gfc_pure (NULL
) && gfc_is_coindexed (a
->expr
))
2606 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2608 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2609 "is passed to an INTENT(%s) argument",
2610 &a
->expr
->where
, gfc_intent_string (f_intent
));
2614 if (f
->sym
->attr
.pointer
)
2616 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2617 "is passed to a POINTER dummy argument",
2623 /* F2008, Section 12.5.2.4. */
2624 if (a
->expr
->ts
.type
== BT_CLASS
&& f
->sym
->ts
.type
== BT_CLASS
2625 && gfc_is_coindexed (a
->expr
))
2627 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2628 "polymorphic dummy argument '%s'",
2629 &a
->expr
->where
, f
->sym
->name
);
2638 /* Check how a procedure is used against its interface. If all goes
2639 well, the actual argument list will also end up being properly
2643 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2646 /* Warn about calls with an implicit interface. Special case
2647 for calling a ISO_C_BINDING becase c_loc and c_funloc
2648 are pseudo-unknown. Additionally, warn about procedures not
2649 explicitly declared at all if requested. */
2650 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
&& ! sym
->attr
.is_iso_c
)
2652 if (gfc_option
.warn_implicit_interface
)
2653 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2655 else if (gfc_option
.warn_implicit_procedure
2656 && sym
->attr
.proc
== PROC_UNKNOWN
)
2657 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2661 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2663 gfc_actual_arglist
*a
;
2664 for (a
= *ap
; a
; a
= a
->next
)
2666 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2667 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2669 gfc_error("Keyword argument requires explicit interface "
2670 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2678 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2681 check_intents (sym
->formal
, *ap
);
2682 if (gfc_option
.warn_aliasing
)
2683 check_some_aliasing (sym
->formal
, *ap
);
2687 /* Check how a procedure pointer component is used against its interface.
2688 If all goes well, the actual argument list will also end up being properly
2689 sorted. Completely analogous to gfc_procedure_use. */
2692 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2695 /* Warn about calls with an implicit interface. Special case
2696 for calling a ISO_C_BINDING becase c_loc and c_funloc
2697 are pseudo-unknown. */
2698 if (gfc_option
.warn_implicit_interface
2699 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2700 && !comp
->attr
.is_iso_c
)
2701 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2702 "interface at %L", comp
->name
, where
);
2704 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2706 gfc_actual_arglist
*a
;
2707 for (a
= *ap
; a
; a
= a
->next
)
2709 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2710 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2712 gfc_error("Keyword argument requires explicit interface "
2713 "for procedure pointer component '%s' at %L",
2714 comp
->name
, &a
->expr
->where
);
2722 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2725 check_intents (comp
->formal
, *ap
);
2726 if (gfc_option
.warn_aliasing
)
2727 check_some_aliasing (comp
->formal
, *ap
);
2731 /* Try if an actual argument list matches the formal list of a symbol,
2732 respecting the symbol's attributes like ELEMENTAL. This is used for
2733 GENERIC resolution. */
2736 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2740 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2742 r
= !sym
->attr
.elemental
;
2743 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2745 check_intents (sym
->formal
, *args
);
2746 if (gfc_option
.warn_aliasing
)
2747 check_some_aliasing (sym
->formal
, *args
);
2755 /* Given an interface pointer and an actual argument list, search for
2756 a formal argument list that matches the actual. If found, returns
2757 a pointer to the symbol of the correct interface. Returns NULL if
2761 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2762 gfc_actual_arglist
**ap
)
2764 gfc_symbol
*elem_sym
= NULL
;
2765 for (; intr
; intr
= intr
->next
)
2767 if (sub_flag
&& intr
->sym
->attr
.function
)
2769 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2772 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
2774 /* Satisfy 12.4.4.1 such that an elemental match has lower
2775 weight than a non-elemental match. */
2776 if (intr
->sym
->attr
.elemental
)
2778 elem_sym
= intr
->sym
;
2785 return elem_sym
? elem_sym
: NULL
;
2789 /* Do a brute force recursive search for a symbol. */
2791 static gfc_symtree
*
2792 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2796 if (root
->n
.sym
== sym
)
2801 st
= find_symtree0 (root
->left
, sym
);
2802 if (root
->right
&& ! st
)
2803 st
= find_symtree0 (root
->right
, sym
);
2808 /* Find a symtree for a symbol. */
2811 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
2816 /* First try to find it by name. */
2817 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2818 if (st
&& st
->n
.sym
== sym
)
2821 /* If it's been renamed, resort to a brute-force search. */
2822 /* TODO: avoid having to do this search. If the symbol doesn't exist
2823 in the symtree for the current namespace, it should probably be added. */
2824 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2826 st
= find_symtree0 (ns
->sym_root
, sym
);
2830 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2835 /* See if the arglist to an operator-call contains a derived-type argument
2836 with a matching type-bound operator. If so, return the matching specific
2837 procedure defined as operator-target as well as the base-object to use
2838 (which is the found derived-type argument with operator). The generic
2839 name, if any, is transmitted to the final expression via 'gname'. */
2841 static gfc_typebound_proc
*
2842 matching_typebound_op (gfc_expr
** tb_base
,
2843 gfc_actual_arglist
* args
,
2844 gfc_intrinsic_op op
, const char* uop
,
2845 const char ** gname
)
2847 gfc_actual_arglist
* base
;
2849 for (base
= args
; base
; base
= base
->next
)
2850 if (base
->expr
->ts
.type
== BT_DERIVED
|| base
->expr
->ts
.type
== BT_CLASS
)
2852 gfc_typebound_proc
* tb
;
2853 gfc_symbol
* derived
;
2856 if (base
->expr
->ts
.type
== BT_CLASS
)
2857 derived
= CLASS_DATA (base
->expr
)->ts
.u
.derived
;
2859 derived
= base
->expr
->ts
.u
.derived
;
2861 if (op
== INTRINSIC_USER
)
2863 gfc_symtree
* tb_uop
;
2866 tb_uop
= gfc_find_typebound_user_op (derived
, &result
, uop
,
2875 tb
= gfc_find_typebound_intrinsic_op (derived
, &result
, op
,
2878 /* This means we hit a PRIVATE operator which is use-associated and
2879 should thus not be seen. */
2880 if (result
== FAILURE
)
2883 /* Look through the super-type hierarchy for a matching specific
2885 for (; tb
; tb
= tb
->overridden
)
2889 gcc_assert (tb
->is_generic
);
2890 for (g
= tb
->u
.generic
; g
; g
= g
->next
)
2893 gfc_actual_arglist
* argcopy
;
2896 gcc_assert (g
->specific
);
2897 if (g
->specific
->error
)
2900 target
= g
->specific
->u
.specific
->n
.sym
;
2902 /* Check if this arglist matches the formal. */
2903 argcopy
= gfc_copy_actual_arglist (args
);
2904 matches
= gfc_arglist_matches_symbol (&argcopy
, target
);
2905 gfc_free_actual_arglist (argcopy
);
2907 /* Return if we found a match. */
2910 *tb_base
= base
->expr
;
2911 *gname
= g
->specific_st
->name
;
2922 /* For the 'actual arglist' of an operator call and a specific typebound
2923 procedure that has been found the target of a type-bound operator, build the
2924 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
2925 type-bound procedures rather than resolving type-bound operators 'directly'
2926 so that we can reuse the existing logic. */
2929 build_compcall_for_operator (gfc_expr
* e
, gfc_actual_arglist
* actual
,
2930 gfc_expr
* base
, gfc_typebound_proc
* target
,
2933 e
->expr_type
= EXPR_COMPCALL
;
2934 e
->value
.compcall
.tbp
= target
;
2935 e
->value
.compcall
.name
= gname
? gname
: "$op";
2936 e
->value
.compcall
.actual
= actual
;
2937 e
->value
.compcall
.base_object
= base
;
2938 e
->value
.compcall
.ignore_pass
= 1;
2939 e
->value
.compcall
.assign
= 0;
2943 /* This subroutine is called when an expression is being resolved.
2944 The expression node in question is either a user defined operator
2945 or an intrinsic operator with arguments that aren't compatible
2946 with the operator. This subroutine builds an actual argument list
2947 corresponding to the operands, then searches for a compatible
2948 interface. If one is found, the expression node is replaced with
2949 the appropriate function call.
2950 real_error is an additional output argument that specifies if FAILURE
2951 is because of some real error and not because no match was found. */
2954 gfc_extend_expr (gfc_expr
*e
, bool *real_error
)
2956 gfc_actual_arglist
*actual
;
2965 actual
= gfc_get_actual_arglist ();
2966 actual
->expr
= e
->value
.op
.op1
;
2968 *real_error
= false;
2971 if (e
->value
.op
.op2
!= NULL
)
2973 actual
->next
= gfc_get_actual_arglist ();
2974 actual
->next
->expr
= e
->value
.op
.op2
;
2977 i
= fold_unary_intrinsic (e
->value
.op
.op
);
2979 if (i
== INTRINSIC_USER
)
2981 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2983 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2987 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
2994 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2996 /* Due to the distinction between '==' and '.eq.' and friends, one has
2997 to check if either is defined. */
3000 #define CHECK_OS_COMPARISON(comp) \
3001 case INTRINSIC_##comp: \
3002 case INTRINSIC_##comp##_OS: \
3003 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3005 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3007 CHECK_OS_COMPARISON(EQ
)
3008 CHECK_OS_COMPARISON(NE
)
3009 CHECK_OS_COMPARISON(GT
)
3010 CHECK_OS_COMPARISON(GE
)
3011 CHECK_OS_COMPARISON(LT
)
3012 CHECK_OS_COMPARISON(LE
)
3013 #undef CHECK_OS_COMPARISON
3016 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
3024 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3025 found rather than just taking the first one and not checking further. */
3029 gfc_typebound_proc
* tbo
;
3032 /* See if we find a matching type-bound operator. */
3033 if (i
== INTRINSIC_USER
)
3034 tbo
= matching_typebound_op (&tb_base
, actual
,
3035 i
, e
->value
.op
.uop
->name
, &gname
);
3039 #define CHECK_OS_COMPARISON(comp) \
3040 case INTRINSIC_##comp: \
3041 case INTRINSIC_##comp##_OS: \
3042 tbo = matching_typebound_op (&tb_base, actual, \
3043 INTRINSIC_##comp, NULL, &gname); \
3045 tbo = matching_typebound_op (&tb_base, actual, \
3046 INTRINSIC_##comp##_OS, NULL, &gname); \
3048 CHECK_OS_COMPARISON(EQ
)
3049 CHECK_OS_COMPARISON(NE
)
3050 CHECK_OS_COMPARISON(GT
)
3051 CHECK_OS_COMPARISON(GE
)
3052 CHECK_OS_COMPARISON(LT
)
3053 CHECK_OS_COMPARISON(LE
)
3054 #undef CHECK_OS_COMPARISON
3057 tbo
= matching_typebound_op (&tb_base
, actual
, i
, NULL
, &gname
);
3061 /* If there is a matching typebound-operator, replace the expression with
3062 a call to it and succeed. */
3067 gcc_assert (tb_base
);
3068 build_compcall_for_operator (e
, actual
, tb_base
, tbo
, gname
);
3070 result
= gfc_resolve_expr (e
);
3071 if (result
== FAILURE
)
3077 /* Don't use gfc_free_actual_arglist(). */
3078 if (actual
->next
!= NULL
)
3079 gfc_free (actual
->next
);
3085 /* Change the expression node to a function call. */
3086 e
->expr_type
= EXPR_FUNCTION
;
3087 e
->symtree
= gfc_find_sym_in_symtree (sym
);
3088 e
->value
.function
.actual
= actual
;
3089 e
->value
.function
.esym
= NULL
;
3090 e
->value
.function
.isym
= NULL
;
3091 e
->value
.function
.name
= NULL
;
3092 e
->user_operator
= 1;
3094 if (gfc_resolve_expr (e
) == FAILURE
)
3104 /* Tries to replace an assignment code node with a subroutine call to
3105 the subroutine associated with the assignment operator. Return
3106 SUCCESS if the node was replaced. On FAILURE, no error is
3110 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
3112 gfc_actual_arglist
*actual
;
3113 gfc_expr
*lhs
, *rhs
;
3122 /* Don't allow an intrinsic assignment to be replaced. */
3123 if (lhs
->ts
.type
!= BT_DERIVED
&& lhs
->ts
.type
!= BT_CLASS
3124 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
3125 && (lhs
->ts
.type
== rhs
->ts
.type
3126 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
3129 actual
= gfc_get_actual_arglist ();
3132 actual
->next
= gfc_get_actual_arglist ();
3133 actual
->next
->expr
= rhs
;
3137 for (; ns
; ns
= ns
->parent
)
3139 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
3144 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3148 gfc_typebound_proc
* tbo
;
3151 /* See if we find a matching type-bound assignment. */
3152 tbo
= matching_typebound_op (&tb_base
, actual
,
3153 INTRINSIC_ASSIGN
, NULL
, &gname
);
3155 /* If there is one, replace the expression with a call to it and
3159 gcc_assert (tb_base
);
3160 c
->expr1
= gfc_get_expr ();
3161 build_compcall_for_operator (c
->expr1
, actual
, tb_base
, tbo
, gname
);
3162 c
->expr1
->value
.compcall
.assign
= 1;
3164 c
->op
= EXEC_COMPCALL
;
3166 /* c is resolved from the caller, so no need to do it here. */
3171 gfc_free (actual
->next
);
3176 /* Replace the assignment with the call. */
3177 c
->op
= EXEC_ASSIGN_CALL
;
3178 c
->symtree
= gfc_find_sym_in_symtree (sym
);
3181 c
->ext
.actual
= actual
;
3187 /* Make sure that the interface just parsed is not already present in
3188 the given interface list. Ambiguity isn't checked yet since module
3189 procedures can be present without interfaces. */
3192 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
3196 for (ip
= base
; ip
; ip
= ip
->next
)
3198 if (ip
->sym
== new_sym
)
3200 gfc_error ("Entity '%s' at %C is already present in the interface",
3210 /* Add a symbol to the current interface. */
3213 gfc_add_interface (gfc_symbol
*new_sym
)
3215 gfc_interface
**head
, *intr
;
3219 switch (current_interface
.type
)
3221 case INTERFACE_NAMELESS
:
3222 case INTERFACE_ABSTRACT
:
3225 case INTERFACE_INTRINSIC_OP
:
3226 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3227 switch (current_interface
.op
)
3230 case INTRINSIC_EQ_OS
:
3231 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
3232 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
3237 case INTRINSIC_NE_OS
:
3238 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
3239 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
3244 case INTRINSIC_GT_OS
:
3245 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
3246 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
3251 case INTRINSIC_GE_OS
:
3252 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
3253 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
3258 case INTRINSIC_LT_OS
:
3259 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
3260 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
3265 case INTRINSIC_LE_OS
:
3266 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
3267 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
3272 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
3276 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
3279 case INTERFACE_GENERIC
:
3280 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
3282 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
3286 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
3290 head
= ¤t_interface
.sym
->generic
;
3293 case INTERFACE_USER_OP
:
3294 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
3298 head
= ¤t_interface
.uop
->op
;
3302 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3305 intr
= gfc_get_interface ();
3306 intr
->sym
= new_sym
;
3307 intr
->where
= gfc_current_locus
;
3317 gfc_current_interface_head (void)
3319 switch (current_interface
.type
)
3321 case INTERFACE_INTRINSIC_OP
:
3322 return current_interface
.ns
->op
[current_interface
.op
];
3325 case INTERFACE_GENERIC
:
3326 return current_interface
.sym
->generic
;
3329 case INTERFACE_USER_OP
:
3330 return current_interface
.uop
->op
;
3340 gfc_set_current_interface_head (gfc_interface
*i
)
3342 switch (current_interface
.type
)
3344 case INTERFACE_INTRINSIC_OP
:
3345 current_interface
.ns
->op
[current_interface
.op
] = i
;
3348 case INTERFACE_GENERIC
:
3349 current_interface
.sym
->generic
= i
;
3352 case INTERFACE_USER_OP
:
3353 current_interface
.uop
->op
= i
;
3362 /* Gets rid of a formal argument list. We do not free symbols.
3363 Symbols are freed when a namespace is freed. */
3366 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
3368 gfc_formal_arglist
*q
;