1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Deal with interfaces. An explicit interface is represented as a
24 singly linked list of formal argument structures attached to the
25 relevant symbols. For an implicit interface, the arguments don't
26 point to symbols. Explicit interfaces point to namespaces that
27 contain the symbols within that interface.
29 Implicit interfaces are linked together in a singly linked list
30 along the next_if member of symbol nodes. Since a particular
31 symbol can only have a single explicit interface, the symbol cannot
32 be part of multiple lists and a single next-member suffices.
34 This is not the case for general classes, though. An operator
35 definition is independent of just about all other uses and has it's
39 Nameless interfaces create symbols with explicit interfaces within
40 the current namespace. They are otherwise unlinked.
43 The generic name points to a linked list of symbols. Each symbol
44 has an explicit interface. Each explicit interface has its own
45 namespace containing the arguments. Module procedures are symbols in
46 which the interface is added later when the module procedure is parsed.
49 User-defined operators are stored in a their own set of symtrees
50 separate from regular symbols. The symtrees point to gfc_user_op
51 structures which in turn head up a list of relevant interfaces.
53 Extended intrinsics and assignment:
54 The head of these interface lists are stored in the containing namespace.
57 An implicit interface is represented as a singly linked list of
58 formal argument list structures that don't point to any symbol
59 nodes -- they just contain types.
62 When a subprogram is defined, the program unit's name points to an
63 interface as usual, but the link to the namespace is NULL and the
64 formal argument list points to symbols within the same namespace as
65 the program unit name. */
72 /* The current_interface structure holds information about the
73 interface currently being parsed. This structure is saved and
74 restored during recursive interfaces. */
76 gfc_interface_info current_interface
;
79 /* Free a singly linked list of gfc_interface structures. */
82 gfc_free_interface (gfc_interface
*intr
)
86 for (; intr
; intr
= next
)
94 /* Change the operators unary plus and minus into binary plus and
95 minus respectively, leaving the rest unchanged. */
97 static gfc_intrinsic_op
98 fold_unary_intrinsic (gfc_intrinsic_op op
)
102 case INTRINSIC_UPLUS
:
105 case INTRINSIC_UMINUS
:
106 op
= INTRINSIC_MINUS
;
116 /* Match a generic specification. Depending on which type of
117 interface is found, the 'name' or 'op' pointers may be set.
118 This subroutine doesn't return MATCH_NO. */
121 gfc_match_generic_spec (interface_type
*type
,
123 gfc_intrinsic_op
*op
)
125 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
129 if (gfc_match (" assignment ( = )") == MATCH_YES
)
131 *type
= INTERFACE_INTRINSIC_OP
;
132 *op
= INTRINSIC_ASSIGN
;
136 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
138 *type
= INTERFACE_INTRINSIC_OP
;
139 *op
= fold_unary_intrinsic (i
);
143 *op
= INTRINSIC_NONE
;
144 if (gfc_match (" operator ( ") == MATCH_YES
)
146 m
= gfc_match_defined_op_name (buffer
, 1);
152 m
= gfc_match_char (')');
158 strcpy (name
, buffer
);
159 *type
= INTERFACE_USER_OP
;
163 if (gfc_match_name (buffer
) == MATCH_YES
)
165 strcpy (name
, buffer
);
166 *type
= INTERFACE_GENERIC
;
170 *type
= INTERFACE_NAMELESS
;
174 gfc_error ("Syntax error in generic specification at %C");
179 /* Match one of the five F95 forms of an interface statement. The
180 matcher for the abstract interface follows. */
183 gfc_match_interface (void)
185 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
191 m
= gfc_match_space ();
193 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
196 /* If we're not looking at the end of the statement now, or if this
197 is not a nameless interface but we did not see a space, punt. */
198 if (gfc_match_eos () != MATCH_YES
199 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
201 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
206 current_interface
.type
= type
;
210 case INTERFACE_GENERIC
:
211 if (gfc_get_symbol (name
, NULL
, &sym
))
214 if (!sym
->attr
.generic
215 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
220 gfc_error ("Dummy procedure '%s' at %C cannot have a "
221 "generic interface", sym
->name
);
225 current_interface
.sym
= gfc_new_block
= sym
;
228 case INTERFACE_USER_OP
:
229 current_interface
.uop
= gfc_get_uop (name
);
232 case INTERFACE_INTRINSIC_OP
:
233 current_interface
.op
= op
;
236 case INTERFACE_NAMELESS
:
237 case INTERFACE_ABSTRACT
:
246 /* Match a F2003 abstract interface. */
249 gfc_match_abstract_interface (void)
253 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ABSTRACT INTERFACE at %C")
257 m
= gfc_match_eos ();
261 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
265 current_interface
.type
= INTERFACE_ABSTRACT
;
271 /* Match the different sort of generic-specs that can be present after
272 the END INTERFACE itself. */
275 gfc_match_end_interface (void)
277 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
282 m
= gfc_match_space ();
284 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
287 /* If we're not looking at the end of the statement now, or if this
288 is not a nameless interface but we did not see a space, punt. */
289 if (gfc_match_eos () != MATCH_YES
290 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
292 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
299 switch (current_interface
.type
)
301 case INTERFACE_NAMELESS
:
302 case INTERFACE_ABSTRACT
:
303 if (type
!= INTERFACE_NAMELESS
)
305 gfc_error ("Expected a nameless interface at %C");
311 case INTERFACE_INTRINSIC_OP
:
312 if (type
!= current_interface
.type
|| op
!= current_interface
.op
)
315 if (current_interface
.op
== INTRINSIC_ASSIGN
)
316 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
318 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
319 gfc_op2string (current_interface
.op
));
326 case INTERFACE_USER_OP
:
327 /* Comparing the symbol node names is OK because only use-associated
328 symbols can be renamed. */
329 if (type
!= current_interface
.type
330 || strcmp (current_interface
.uop
->name
, name
) != 0)
332 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
333 current_interface
.uop
->name
);
339 case INTERFACE_GENERIC
:
340 if (type
!= current_interface
.type
341 || strcmp (current_interface
.sym
->name
, name
) != 0)
343 gfc_error ("Expecting 'END INTERFACE %s' at %C",
344 current_interface
.sym
->name
);
355 /* Compare two derived types using the criteria in 4.4.2 of the standard,
356 recursing through gfc_compare_types for the components. */
359 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
361 gfc_component
*dt1
, *dt2
;
363 /* Special case for comparing derived types across namespaces. If the
364 true names and module names are the same and the module name is
365 nonnull, then they are equal. */
366 if (derived1
!= NULL
&& derived2
!= NULL
367 && strcmp (derived1
->name
, derived2
->name
) == 0
368 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
369 && strcmp (derived1
->module
, derived2
->module
) == 0)
372 /* Compare type via the rules of the standard. Both types must have
373 the SEQUENCE attribute to be equal. */
375 if (strcmp (derived1
->name
, derived2
->name
))
378 if (derived1
->component_access
== ACCESS_PRIVATE
379 || derived2
->component_access
== ACCESS_PRIVATE
)
382 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
385 dt1
= derived1
->components
;
386 dt2
= derived2
->components
;
388 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
389 simple test can speed things up. Otherwise, lots of things have to
393 if (strcmp (dt1
->name
, dt2
->name
) != 0)
396 if (dt1
->attr
.access
!= dt2
->attr
.access
)
399 if (dt1
->attr
.pointer
!= dt2
->attr
.pointer
)
402 if (dt1
->attr
.dimension
!= dt2
->attr
.dimension
)
405 if (dt1
->attr
.allocatable
!= dt2
->attr
.allocatable
)
408 if (dt1
->attr
.dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
411 /* Make sure that link lists do not put this function into an
412 endless recursive loop! */
413 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
414 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
415 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
418 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
419 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
))
422 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
423 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
))
429 if (dt1
== NULL
&& dt2
== NULL
)
431 if (dt1
== NULL
|| dt2
== NULL
)
439 /* Compare two typespecs, recursively if necessary. */
442 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
444 /* See if one of the typespecs is a BT_VOID, which is what is being used
445 to allow the funcs like c_f_pointer to accept any pointer type.
446 TODO: Possibly should narrow this to just the one typespec coming in
447 that is for the formal arg, but oh well. */
448 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
451 if (ts1
->type
!= ts2
->type
)
453 if (ts1
->type
!= BT_DERIVED
)
454 return (ts1
->kind
== ts2
->kind
);
456 /* Compare derived types. */
457 if (ts1
->derived
== ts2
->derived
)
460 return gfc_compare_derived_types (ts1
->derived
,ts2
->derived
);
464 /* Given two symbols that are formal arguments, compare their ranks
465 and types. Returns nonzero if they have the same rank and type,
469 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
473 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
474 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
477 return 0; /* Ranks differ. */
479 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
483 /* Given two symbols that are formal arguments, compare their types
484 and rank and their formal interfaces if they are both dummy
485 procedures. Returns nonzero if the same, zero if different. */
488 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
490 if (s1
== NULL
|| s2
== NULL
)
491 return s1
== s2
? 1 : 0;
496 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
497 return compare_type_rank (s1
, s2
);
499 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
502 /* At this point, both symbols are procedures. It can happen that
503 external procedures are compared, where one is identified by usage
504 to be a function or subroutine but the other is not. Check TKR
505 nonetheless for these cases. */
506 if (s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
507 return s1
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
509 if (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0)
510 return s2
->attr
.external
== 1 ? compare_type_rank (s1
, s2
) : 0;
512 /* Now the type of procedure has been identified. */
513 if (s1
->attr
.function
!= s2
->attr
.function
514 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
517 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
520 /* Originally, gfortran recursed here to check the interfaces of passed
521 procedures. This is explicitly not required by the standard. */
526 /* Given a formal argument list and a keyword name, search the list
527 for that keyword. Returns the correct symbol node if found, NULL
531 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
533 for (; f
; f
= f
->next
)
534 if (strcmp (f
->sym
->name
, name
) == 0)
541 /******** Interface checking subroutines **********/
544 /* Given an operator interface and the operator, make sure that all
545 interfaces for that operator are legal. */
548 check_operator_interface (gfc_interface
*intr
, gfc_intrinsic_op op
)
550 gfc_formal_arglist
*formal
;
554 int args
, r1
, r2
, k1
, k2
;
560 t1
= t2
= BT_UNKNOWN
;
561 i1
= i2
= INTENT_UNKNOWN
;
565 for (formal
= intr
->sym
->formal
; formal
; formal
= formal
->next
)
570 gfc_error ("Alternate return cannot appear in operator "
571 "interface at %L", &intr
->sym
->declared_at
);
577 i1
= sym
->attr
.intent
;
578 r1
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
584 i2
= sym
->attr
.intent
;
585 r2
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
593 /* Only +, - and .not. can be unary operators.
594 .not. cannot be a binary operator. */
595 if (args
== 0 || args
> 2 || (args
== 1 && op
!= INTRINSIC_PLUS
596 && op
!= INTRINSIC_MINUS
597 && op
!= INTRINSIC_NOT
)
598 || (args
== 2 && op
== INTRINSIC_NOT
))
600 gfc_error ("Operator interface at %L has the wrong number of arguments",
601 &intr
->sym
->declared_at
);
605 /* Check that intrinsics are mapped to functions, except
606 INTRINSIC_ASSIGN which should map to a subroutine. */
607 if (op
== INTRINSIC_ASSIGN
)
609 if (!sym
->attr
.subroutine
)
611 gfc_error ("Assignment operator interface at %L must be "
612 "a SUBROUTINE", &intr
->sym
->declared_at
);
617 gfc_error ("Assignment operator interface at %L must have "
618 "two arguments", &intr
->sym
->declared_at
);
622 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
623 - First argument an array with different rank than second,
624 - Types and kinds do not conform, and
625 - First argument is of derived type. */
626 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
627 && (r1
== 0 || r1
== r2
)
628 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
629 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
630 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
632 gfc_error ("Assignment operator interface at %L must not redefine "
633 "an INTRINSIC type assignment", &intr
->sym
->declared_at
);
639 if (!sym
->attr
.function
)
641 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
642 &intr
->sym
->declared_at
);
647 /* Check intents on operator interfaces. */
648 if (op
== INTRINSIC_ASSIGN
)
650 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
651 gfc_error ("First argument of defined assignment at %L must be "
652 "INTENT(OUT) or INTENT(INOUT)", &intr
->sym
->declared_at
);
655 gfc_error ("Second argument of defined assignment at %L must be "
656 "INTENT(IN)", &intr
->sym
->declared_at
);
661 gfc_error ("First argument of operator interface at %L must be "
662 "INTENT(IN)", &intr
->sym
->declared_at
);
664 if (args
== 2 && i2
!= INTENT_IN
)
665 gfc_error ("Second argument of operator interface at %L must be "
666 "INTENT(IN)", &intr
->sym
->declared_at
);
669 /* From now on, all we have to do is check that the operator definition
670 doesn't conflict with an intrinsic operator. The rules for this
671 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
672 as well as 12.3.2.1.1 of Fortran 2003:
674 "If the operator is an intrinsic-operator (R310), the number of
675 function arguments shall be consistent with the intrinsic uses of
676 that operator, and the types, kind type parameters, or ranks of the
677 dummy arguments shall differ from those required for the intrinsic
678 operation (7.1.2)." */
680 #define IS_NUMERIC_TYPE(t) \
681 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
683 /* Unary ops are easy, do them first. */
684 if (op
== INTRINSIC_NOT
)
686 if (t1
== BT_LOGICAL
)
692 if (args
== 1 && (op
== INTRINSIC_PLUS
|| op
== INTRINSIC_MINUS
))
694 if (IS_NUMERIC_TYPE (t1
))
700 /* Character intrinsic operators have same character kind, thus
701 operator definitions with operands of different character kinds
703 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
706 /* Intrinsic operators always perform on arguments of same rank,
707 so different ranks is also always safe. (rank == 0) is an exception
708 to that, because all intrinsic operators are elemental. */
709 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
715 case INTRINSIC_EQ_OS
:
717 case INTRINSIC_NE_OS
:
718 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
723 case INTRINSIC_MINUS
:
724 case INTRINSIC_TIMES
:
725 case INTRINSIC_DIVIDE
:
726 case INTRINSIC_POWER
:
727 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
732 case INTRINSIC_GT_OS
:
734 case INTRINSIC_GE_OS
:
736 case INTRINSIC_LT_OS
:
738 case INTRINSIC_LE_OS
:
739 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
741 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
742 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
746 case INTRINSIC_CONCAT
:
747 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
755 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
765 #undef IS_NUMERIC_TYPE
768 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
774 /* Given a pair of formal argument lists, we see if the two lists can
775 be distinguished by counting the number of nonoptional arguments of
776 a given type/rank in f1 and seeing if there are less then that
777 number of those arguments in f2 (including optional arguments).
778 Since this test is asymmetric, it has to be called twice to make it
779 symmetric. Returns nonzero if the argument lists are incompatible
780 by this test. This subroutine implements rule 1 of section
781 14.1.2.3 in the Fortran 95 standard. */
784 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
786 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
787 gfc_formal_arglist
*f
;
800 for (f
= f1
; f
; f
= f
->next
)
803 /* Build an array of integers that gives the same integer to
804 arguments of the same type/rank. */
805 arg
= XCNEWVEC (arginfo
, n1
);
808 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
816 for (i
= 0; i
< n1
; i
++)
818 if (arg
[i
].flag
!= -1)
821 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
822 continue; /* Skip optional arguments. */
826 /* Find other nonoptional arguments of the same type/rank. */
827 for (j
= i
+ 1; j
< n1
; j
++)
828 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
829 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
835 /* Now loop over each distinct type found in f1. */
839 for (i
= 0; i
< n1
; i
++)
841 if (arg
[i
].flag
!= k
)
845 for (j
= i
+ 1; j
< n1
; j
++)
846 if (arg
[j
].flag
== k
)
849 /* Count the number of arguments in f2 with that type, including
850 those that are optional. */
853 for (f
= f2
; f
; f
= f
->next
)
854 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
872 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
873 Returns zero if no argument is found that satisfies rule 2, nonzero
876 This test is also not symmetric in f1 and f2 and must be called
877 twice. This test finds problems caused by sorting the actual
878 argument list with keywords. For example:
882 INTEGER :: A ; REAL :: B
886 INTEGER :: A ; REAL :: B
890 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
893 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
895 gfc_formal_arglist
*f2_save
, *g
;
902 if (f1
->sym
->attr
.optional
)
905 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
908 /* Now search for a disambiguating keyword argument starting at
909 the current non-match. */
910 for (g
= f1
; g
; g
= g
->next
)
912 if (g
->sym
->attr
.optional
)
915 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
916 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
930 /* 'Compare' two formal interfaces associated with a pair of symbols.
931 We return nonzero if there exists an actual argument list that
932 would be ambiguous between the two interfaces, zero otherwise.
933 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
934 required to match, which is not the case for ambiguity checks.*/
937 gfc_compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, int generic_flag
,
938 int intent_flag
, char *errmsg
, int err_len
)
940 gfc_formal_arglist
*f1
, *f2
;
942 if (s1
->attr
.function
&& (s2
->attr
.subroutine
943 || (!s2
->attr
.function
&& s2
->ts
.type
== BT_UNKNOWN
944 && gfc_get_default_type (s2
->name
, s2
->ns
)->type
== BT_UNKNOWN
)))
947 snprintf (errmsg
, err_len
, "'%s' is not a function", s2
->name
);
951 if (s1
->attr
.subroutine
&& s2
->attr
.function
)
954 snprintf (errmsg
, err_len
, "'%s' is not a subroutine", s2
->name
);
958 /* If the arguments are functions, check type and kind
959 (only for dummy procedures and procedure pointer assignments). */
960 if ((s1
->attr
.dummy
|| s1
->attr
.proc_pointer
)
961 && s1
->attr
.function
&& s2
->attr
.function
)
963 if (s1
->ts
.type
== BT_UNKNOWN
)
965 if ((s1
->ts
.type
!= s2
->ts
.type
) || (s1
->ts
.kind
!= s2
->ts
.kind
))
968 snprintf (errmsg
, err_len
, "Type/kind mismatch in return value "
969 "of '%s'", s2
->name
);
974 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
975 || s2
->attr
.if_source
== IFSRC_UNKNOWN
)
981 if (f1
== NULL
&& f2
== NULL
)
982 return 1; /* Special case: No arguments. */
986 if (generic_correspondence (f1
, f2
) || generic_correspondence (f2
, f1
))
990 /* Perform the abbreviated correspondence test for operators (the
991 arguments cannot be optional and are always ordered correctly).
992 This is also done when comparing interfaces for dummy procedures and in
993 procedure pointer assignments. */
997 /* Check existence. */
998 if (f1
== NULL
&& f2
== NULL
)
1000 if (f1
== NULL
|| f2
== NULL
)
1003 snprintf (errmsg
, err_len
, "'%s' has the wrong number of "
1004 "arguments", s2
->name
);
1008 /* Check type and rank. */
1009 if (!compare_type_rank (f1
->sym
, f2
->sym
))
1012 snprintf (errmsg
, err_len
, "Type/rank mismatch in argument '%s'",
1018 if (intent_flag
&& (f1
->sym
->attr
.intent
!= f2
->sym
->attr
.intent
))
1020 snprintf (errmsg
, err_len
, "INTENT mismatch in argument '%s'",
1025 /* Check OPTIONAL. */
1026 if (intent_flag
&& (f1
->sym
->attr
.optional
!= f2
->sym
->attr
.optional
))
1028 snprintf (errmsg
, err_len
, "OPTIONAL mismatch in argument '%s'",
1037 if (count_types_test (f1
, f2
) || count_types_test (f2
, f1
))
1040 snprintf (errmsg
, err_len
, "Interface not matching");
1048 /* Given a pointer to an interface pointer, remove duplicate
1049 interfaces and make sure that all symbols are either functions or
1050 subroutines. Returns nonzero if something goes wrong. */
1053 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1055 gfc_interface
*psave
, *q
, *qlast
;
1058 /* Make sure all symbols in the interface have been defined as
1059 functions or subroutines. */
1060 for (; p
; p
= p
->next
)
1061 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1062 || !p
->sym
->attr
.if_source
)
1064 if (p
->sym
->attr
.external
)
1065 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1066 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1068 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1069 "subroutine", p
->sym
->name
, interface_name
,
1070 &p
->sym
->declared_at
);
1075 /* Remove duplicate interfaces in this interface list. */
1076 for (; p
; p
= p
->next
)
1080 for (q
= p
->next
; q
;)
1082 if (p
->sym
!= q
->sym
)
1089 /* Duplicate interface. */
1090 qlast
->next
= q
->next
;
1101 /* Check lists of interfaces to make sure that no two interfaces are
1102 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1105 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1106 int generic_flag
, const char *interface_name
,
1110 for (; p
; p
= p
->next
)
1111 for (q
= q0
; q
; q
= q
->next
)
1113 if (p
->sym
== q
->sym
)
1114 continue; /* Duplicates OK here. */
1116 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1119 if (gfc_compare_interfaces (p
->sym
, q
->sym
, generic_flag
, 0, NULL
, 0))
1123 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1124 p
->sym
->name
, q
->sym
->name
, interface_name
,
1128 if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1129 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1130 p
->sym
->name
, q
->sym
->name
, interface_name
,
1139 /* Check the generic and operator interfaces of symbols to make sure
1140 that none of the interfaces conflict. The check has to be done
1141 after all of the symbols are actually loaded. */
1144 check_sym_interfaces (gfc_symbol
*sym
)
1146 char interface_name
[100];
1150 if (sym
->ns
!= gfc_current_ns
)
1153 if (sym
->generic
!= NULL
)
1155 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1156 if (check_interface0 (sym
->generic
, interface_name
))
1159 for (p
= sym
->generic
; p
; p
= p
->next
)
1161 if (p
->sym
->attr
.mod_proc
1162 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1163 || p
->sym
->attr
.procedure
))
1165 gfc_error ("'%s' at %L is not a module procedure",
1166 p
->sym
->name
, &p
->where
);
1171 /* Originally, this test was applied to host interfaces too;
1172 this is incorrect since host associated symbols, from any
1173 source, cannot be ambiguous with local symbols. */
1174 k
= sym
->attr
.referenced
|| !sym
->attr
.use_assoc
;
1175 if (check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
, k
))
1176 sym
->attr
.ambiguous_interfaces
= 1;
1182 check_uop_interfaces (gfc_user_op
*uop
)
1184 char interface_name
[100];
1188 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1189 if (check_interface0 (uop
->op
, interface_name
))
1192 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1194 uop2
= gfc_find_uop (uop
->name
, ns
);
1198 check_interface1 (uop
->op
, uop2
->op
, 0,
1199 interface_name
, true);
1204 /* For the namespace, check generic, user operator and intrinsic
1205 operator interfaces for consistency and to remove duplicate
1206 interfaces. We traverse the whole namespace, counting on the fact
1207 that most symbols will not have generic or operator interfaces. */
1210 gfc_check_interfaces (gfc_namespace
*ns
)
1212 gfc_namespace
*old_ns
, *ns2
;
1213 char interface_name
[100];
1216 old_ns
= gfc_current_ns
;
1217 gfc_current_ns
= ns
;
1219 gfc_traverse_ns (ns
, check_sym_interfaces
);
1221 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1223 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1225 if (i
== INTRINSIC_USER
)
1228 if (i
== INTRINSIC_ASSIGN
)
1229 strcpy (interface_name
, "intrinsic assignment operator");
1231 sprintf (interface_name
, "intrinsic '%s' operator",
1232 gfc_op2string ((gfc_intrinsic_op
) i
));
1234 if (check_interface0 (ns
->op
[i
], interface_name
))
1237 check_operator_interface (ns
->op
[i
], (gfc_intrinsic_op
) i
);
1239 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1241 if (check_interface1 (ns
->op
[i
], ns2
->op
[i
], 0,
1242 interface_name
, true))
1248 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ_OS
],
1249 0, interface_name
, true)) goto done
;
1252 case INTRINSIC_EQ_OS
:
1253 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_EQ
],
1254 0, interface_name
, true)) goto done
;
1258 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE_OS
],
1259 0, interface_name
, true)) goto done
;
1262 case INTRINSIC_NE_OS
:
1263 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_NE
],
1264 0, interface_name
, true)) goto done
;
1268 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT_OS
],
1269 0, interface_name
, true)) goto done
;
1272 case INTRINSIC_GT_OS
:
1273 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GT
],
1274 0, interface_name
, true)) goto done
;
1278 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE_OS
],
1279 0, interface_name
, true)) goto done
;
1282 case INTRINSIC_GE_OS
:
1283 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_GE
],
1284 0, interface_name
, true)) goto done
;
1288 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT_OS
],
1289 0, interface_name
, true)) goto done
;
1292 case INTRINSIC_LT_OS
:
1293 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LT
],
1294 0, interface_name
, true)) goto done
;
1298 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE_OS
],
1299 0, interface_name
, true)) goto done
;
1302 case INTRINSIC_LE_OS
:
1303 if (check_interface1 (ns
->op
[i
], ns2
->op
[INTRINSIC_LE
],
1304 0, interface_name
, true)) goto done
;
1314 gfc_current_ns
= old_ns
;
1319 symbol_rank (gfc_symbol
*sym
)
1321 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1325 /* Given a symbol of a formal argument list and an expression, if the
1326 formal argument is allocatable, check that the actual argument is
1327 allocatable. Returns nonzero if compatible, zero if not compatible. */
1330 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1332 symbol_attribute attr
;
1334 if (formal
->attr
.allocatable
)
1336 attr
= gfc_expr_attr (actual
);
1337 if (!attr
.allocatable
)
1345 /* Given a symbol of a formal argument list and an expression, if the
1346 formal argument is a pointer, see if the actual argument is a
1347 pointer. Returns nonzero if compatible, zero if not compatible. */
1350 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1352 symbol_attribute attr
;
1354 if (formal
->attr
.pointer
)
1356 attr
= gfc_expr_attr (actual
);
1365 /* Given a symbol of a formal argument list and an expression, see if
1366 the two are compatible as arguments. Returns nonzero if
1367 compatible, zero if not compatible. */
1370 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1371 int ranks_must_agree
, int is_elemental
, locus
*where
)
1376 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1377 procs c_f_pointer or c_f_procpointer, and we need to accept most
1378 pointers the user could give us. This should allow that. */
1379 if (formal
->ts
.type
== BT_VOID
)
1382 if (formal
->ts
.type
== BT_DERIVED
1383 && formal
->ts
.derived
&& formal
->ts
.derived
->ts
.is_iso_c
1384 && actual
->ts
.type
== BT_DERIVED
1385 && actual
->ts
.derived
&& actual
->ts
.derived
->ts
.is_iso_c
)
1388 if (actual
->ts
.type
== BT_PROCEDURE
)
1391 gfc_symbol
*act_sym
= actual
->symtree
->n
.sym
;
1393 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1396 gfc_error ("Invalid procedure argument at %L", &actual
->where
);
1400 if (!gfc_compare_interfaces (formal
, act_sym
, 0, 1, err
,
1404 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1405 formal
->name
, &actual
->where
, err
);
1409 if (formal
->attr
.function
&& !act_sym
->attr
.function
)
1411 gfc_add_function (&act_sym
->attr
, act_sym
->name
,
1412 &act_sym
->declared_at
);
1413 if (act_sym
->ts
.type
== BT_UNKNOWN
1414 && gfc_set_default_type (act_sym
, 1, act_sym
->ns
) == FAILURE
)
1417 else if (formal
->attr
.subroutine
&& !act_sym
->attr
.subroutine
)
1418 gfc_add_subroutine (&act_sym
->attr
, act_sym
->name
,
1419 &act_sym
->declared_at
);
1424 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1425 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1428 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1429 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1430 gfc_typename (&formal
->ts
));
1434 if (symbol_rank (formal
) == actual
->rank
)
1437 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1438 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1439 || formal
->as
->type
== AS_DEFERRED
);
1441 if (rank_check
|| ranks_must_agree
|| formal
->attr
.pointer
1442 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1443 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
1446 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1447 formal
->name
, &actual
->where
, symbol_rank (formal
),
1451 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1454 /* At this point, we are considering a scalar passed to an array. This
1455 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1456 - if the actual argument is (a substring of) an element of a
1457 non-assumed-shape/non-pointer array;
1458 - (F2003) if the actual argument is of type character. */
1460 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1461 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1464 /* Not an array element. */
1465 if (formal
->ts
.type
== BT_CHARACTER
1467 || (actual
->expr_type
== EXPR_VARIABLE
1468 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1469 || actual
->symtree
->n
.sym
->attr
.pointer
))))
1471 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1473 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1474 "array dummy argument '%s' at %L",
1475 formal
->name
, &actual
->where
);
1478 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1483 else if (ref
== NULL
)
1486 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1487 formal
->name
, &actual
->where
, symbol_rank (formal
),
1492 if (actual
->expr_type
== EXPR_VARIABLE
1493 && actual
->symtree
->n
.sym
->as
1494 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1495 || actual
->symtree
->n
.sym
->attr
.pointer
))
1498 gfc_error ("Element of assumed-shaped array passed to dummy "
1499 "argument '%s' at %L", formal
->name
, &actual
->where
);
1507 /* Given a symbol of a formal argument list and an expression, see if
1508 the two are compatible as arguments. Returns nonzero if
1509 compatible, zero if not compatible. */
1512 compare_parameter_protected (gfc_symbol
*formal
, gfc_expr
*actual
)
1514 if (actual
->expr_type
!= EXPR_VARIABLE
)
1517 if (!actual
->symtree
->n
.sym
->attr
.is_protected
)
1520 if (!actual
->symtree
->n
.sym
->attr
.use_assoc
)
1523 if (formal
->attr
.intent
== INTENT_IN
1524 || formal
->attr
.intent
== INTENT_UNKNOWN
)
1527 if (!actual
->symtree
->n
.sym
->attr
.pointer
)
1530 if (actual
->symtree
->n
.sym
->attr
.pointer
&& formal
->attr
.pointer
)
1537 /* Returns the storage size of a symbol (formal argument) or
1538 zero if it cannot be determined. */
1540 static unsigned long
1541 get_sym_storage_size (gfc_symbol
*sym
)
1544 unsigned long strlen
, elements
;
1546 if (sym
->ts
.type
== BT_CHARACTER
)
1548 if (sym
->ts
.cl
&& sym
->ts
.cl
->length
1549 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1550 strlen
= mpz_get_ui (sym
->ts
.cl
->length
->value
.integer
);
1557 if (symbol_rank (sym
) == 0)
1561 if (sym
->as
->type
!= AS_EXPLICIT
)
1563 for (i
= 0; i
< sym
->as
->rank
; i
++)
1565 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1566 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1569 elements
*= mpz_get_ui (sym
->as
->upper
[i
]->value
.integer
)
1570 - mpz_get_ui (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1573 return strlen
*elements
;
1577 /* Returns the storage size of an expression (actual argument) or
1578 zero if it cannot be determined. For an array element, it returns
1579 the remaining size as the element sequence consists of all storage
1580 units of the actual argument up to the end of the array. */
1582 static unsigned long
1583 get_expr_storage_size (gfc_expr
*e
)
1586 long int strlen
, elements
;
1587 long int substrlen
= 0;
1588 bool is_str_storage
= false;
1594 if (e
->ts
.type
== BT_CHARACTER
)
1596 if (e
->ts
.cl
&& e
->ts
.cl
->length
1597 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1598 strlen
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
1599 else if (e
->expr_type
== EXPR_CONSTANT
1600 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
1601 strlen
= e
->value
.character
.length
;
1606 strlen
= 1; /* Length per element. */
1608 if (e
->rank
== 0 && !e
->ref
)
1616 for (i
= 0; i
< e
->rank
; i
++)
1617 elements
*= mpz_get_si (e
->shape
[i
]);
1618 return elements
*strlen
;
1621 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1623 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1624 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1628 /* The string length is the substring length.
1629 Set now to full string length. */
1630 if (ref
->u
.ss
.length
== NULL
1631 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1634 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1636 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1640 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1641 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1642 && ref
->u
.ar
.as
->upper
)
1643 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1645 long int start
, end
, stride
;
1648 if (ref
->u
.ar
.stride
[i
])
1650 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1651 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1656 if (ref
->u
.ar
.start
[i
])
1658 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1659 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1663 else if (ref
->u
.ar
.as
->lower
[i
]
1664 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1665 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1669 if (ref
->u
.ar
.end
[i
])
1671 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1672 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1676 else if (ref
->u
.ar
.as
->upper
[i
]
1677 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1678 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1682 elements
*= (end
- start
)/stride
+ 1L;
1684 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1685 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1686 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1688 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1689 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1690 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1691 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1692 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1697 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1698 && e
->expr_type
== EXPR_VARIABLE
)
1700 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1701 || e
->symtree
->n
.sym
->attr
.pointer
)
1707 /* Determine the number of remaining elements in the element
1708 sequence for array element designators. */
1709 is_str_storage
= true;
1710 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1712 if (ref
->u
.ar
.start
[i
] == NULL
1713 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1714 || ref
->u
.ar
.as
->upper
[i
] == NULL
1715 || ref
->u
.ar
.as
->lower
[i
] == NULL
1716 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1717 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1722 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1723 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1725 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1726 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1734 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1737 return elements
*strlen
;
1741 /* Given an expression, check whether it is an array section
1742 which has a vector subscript. If it has, one is returned,
1746 has_vector_subscript (gfc_expr
*e
)
1751 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1754 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1755 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1756 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1757 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1764 /* Given formal and actual argument lists, see if they are compatible.
1765 If they are compatible, the actual argument list is sorted to
1766 correspond with the formal list, and elements for missing optional
1767 arguments are inserted. If WHERE pointer is nonnull, then we issue
1768 errors when things don't match instead of just returning the status
1772 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1773 int ranks_must_agree
, int is_elemental
, locus
*where
)
1775 gfc_actual_arglist
**new_arg
, *a
, *actual
, temp
;
1776 gfc_formal_arglist
*f
;
1778 unsigned long actual_size
, formal_size
;
1782 if (actual
== NULL
&& formal
== NULL
)
1786 for (f
= formal
; f
; f
= f
->next
)
1789 new_arg
= (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1791 for (i
= 0; i
< n
; i
++)
1798 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1800 /* Look for keywords but ignore g77 extensions like %VAL. */
1801 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1804 for (f
= formal
; f
; f
= f
->next
, i
++)
1808 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1815 gfc_error ("Keyword argument '%s' at %L is not in "
1816 "the procedure", a
->name
, &a
->expr
->where
);
1820 if (new_arg
[i
] != NULL
)
1823 gfc_error ("Keyword argument '%s' at %L is already associated "
1824 "with another actual argument", a
->name
,
1833 gfc_error ("More actual than formal arguments in procedure "
1834 "call at %L", where
);
1839 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1845 gfc_error ("Missing alternate return spec in subroutine call "
1850 if (a
->expr
== NULL
)
1853 gfc_error ("Unexpected alternate return spec in subroutine "
1854 "call at %L", where
);
1858 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
1859 is_elemental
, where
))
1862 /* Special case for character arguments. For allocatable, pointer
1863 and assumed-shape dummies, the string length needs to match
1865 if (a
->expr
->ts
.type
== BT_CHARACTER
1866 && a
->expr
->ts
.cl
&& a
->expr
->ts
.cl
->length
1867 && a
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
1868 && f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
->length
1869 && f
->sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
1870 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
1871 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1872 && (mpz_cmp (a
->expr
->ts
.cl
->length
->value
.integer
,
1873 f
->sym
->ts
.cl
->length
->value
.integer
) != 0))
1875 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
1876 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1877 "argument and pointer or allocatable dummy argument "
1879 mpz_get_si (a
->expr
->ts
.cl
->length
->value
.integer
),
1880 mpz_get_si (f
->sym
->ts
.cl
->length
->value
.integer
),
1881 f
->sym
->name
, &a
->expr
->where
);
1883 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1884 "argument and assumed-shape dummy argument '%s' "
1886 mpz_get_si (a
->expr
->ts
.cl
->length
->value
.integer
),
1887 mpz_get_si (f
->sym
->ts
.cl
->length
->value
.integer
),
1888 f
->sym
->name
, &a
->expr
->where
);
1892 actual_size
= get_expr_storage_size (a
->expr
);
1893 formal_size
= get_sym_storage_size (f
->sym
);
1894 if (actual_size
!= 0
1895 && actual_size
< formal_size
1896 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
1898 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
1899 gfc_warning ("Character length of actual argument shorter "
1900 "than of dummy argument '%s' (%lu/%lu) at %L",
1901 f
->sym
->name
, actual_size
, formal_size
,
1904 gfc_warning ("Actual argument contains too few "
1905 "elements for dummy argument '%s' (%lu/%lu) at %L",
1906 f
->sym
->name
, actual_size
, formal_size
,
1911 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1912 is provided for a procedure pointer formal argument. */
1913 if (f
->sym
->attr
.proc_pointer
1914 && !(a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
1915 || is_proc_ptr_comp (a
->expr
, NULL
)))
1918 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1919 f
->sym
->name
, &a
->expr
->where
);
1923 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1924 provided for a procedure formal argument. */
1925 if (a
->expr
->ts
.type
!= BT_PROCEDURE
&& !is_proc_ptr_comp (a
->expr
, NULL
)
1926 && a
->expr
->expr_type
== EXPR_VARIABLE
1927 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1930 gfc_error ("Expected a procedure for argument '%s' at %L",
1931 f
->sym
->name
, &a
->expr
->where
);
1935 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
1936 && a
->expr
->ts
.type
== BT_PROCEDURE
1937 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
1940 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1941 f
->sym
->name
, &a
->expr
->where
);
1945 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1946 && a
->expr
->expr_type
== EXPR_VARIABLE
1947 && a
->expr
->symtree
->n
.sym
->as
1948 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
1949 && (a
->expr
->ref
== NULL
1950 || (a
->expr
->ref
->type
== REF_ARRAY
1951 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
1954 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1955 " array at %L", f
->sym
->name
, where
);
1959 if (a
->expr
->expr_type
!= EXPR_NULL
1960 && compare_pointer (f
->sym
, a
->expr
) == 0)
1963 gfc_error ("Actual argument for '%s' must be a pointer at %L",
1964 f
->sym
->name
, &a
->expr
->where
);
1968 if (a
->expr
->expr_type
!= EXPR_NULL
1969 && compare_allocatable (f
->sym
, a
->expr
) == 0)
1972 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1973 f
->sym
->name
, &a
->expr
->where
);
1977 /* Check intent = OUT/INOUT for definable actual argument. */
1978 if ((a
->expr
->expr_type
!= EXPR_VARIABLE
1979 || (a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
1980 && a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
))
1981 && (f
->sym
->attr
.intent
== INTENT_OUT
1982 || f
->sym
->attr
.intent
== INTENT_INOUT
))
1985 gfc_error ("Actual argument at %L must be definable as "
1986 "the dummy argument '%s' is INTENT = OUT/INOUT",
1987 &a
->expr
->where
, f
->sym
->name
);
1991 if (!compare_parameter_protected(f
->sym
, a
->expr
))
1994 gfc_error ("Actual argument at %L is use-associated with "
1995 "PROTECTED attribute and dummy argument '%s' is "
1996 "INTENT = OUT/INOUT",
1997 &a
->expr
->where
,f
->sym
->name
);
2001 if ((f
->sym
->attr
.intent
== INTENT_OUT
2002 || f
->sym
->attr
.intent
== INTENT_INOUT
2003 || f
->sym
->attr
.volatile_
)
2004 && has_vector_subscript (a
->expr
))
2007 gfc_error ("Array-section actual argument with vector subscripts "
2008 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2009 "or VOLATILE attribute of the dummy argument '%s'",
2010 &a
->expr
->where
, f
->sym
->name
);
2014 /* C1232 (R1221) For an actual argument which is an array section or
2015 an assumed-shape array, the dummy argument shall be an assumed-
2016 shape array, if the dummy argument has the VOLATILE attribute. */
2018 if (f
->sym
->attr
.volatile_
2019 && a
->expr
->symtree
->n
.sym
->as
2020 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2021 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2024 gfc_error ("Assumed-shape actual argument at %L is "
2025 "incompatible with the non-assumed-shape "
2026 "dummy argument '%s' due to VOLATILE attribute",
2027 &a
->expr
->where
,f
->sym
->name
);
2031 if (f
->sym
->attr
.volatile_
2032 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2033 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2036 gfc_error ("Array-section actual argument at %L is "
2037 "incompatible with the non-assumed-shape "
2038 "dummy argument '%s' due to VOLATILE attribute",
2039 &a
->expr
->where
,f
->sym
->name
);
2043 /* C1233 (R1221) For an actual argument which is a pointer array, the
2044 dummy argument shall be an assumed-shape or pointer array, if the
2045 dummy argument has the VOLATILE attribute. */
2047 if (f
->sym
->attr
.volatile_
2048 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2049 && a
->expr
->symtree
->n
.sym
->as
2051 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2052 || f
->sym
->attr
.pointer
)))
2055 gfc_error ("Pointer-array actual argument at %L requires "
2056 "an assumed-shape or pointer-array dummy "
2057 "argument '%s' due to VOLATILE attribute",
2058 &a
->expr
->where
,f
->sym
->name
);
2069 /* Make sure missing actual arguments are optional. */
2071 for (f
= formal
; f
; f
= f
->next
, i
++)
2073 if (new_arg
[i
] != NULL
)
2078 gfc_error ("Missing alternate return spec in subroutine call "
2082 if (!f
->sym
->attr
.optional
)
2085 gfc_error ("Missing actual argument for argument '%s' at %L",
2086 f
->sym
->name
, where
);
2091 /* The argument lists are compatible. We now relink a new actual
2092 argument list with null arguments in the right places. The head
2093 of the list remains the head. */
2094 for (i
= 0; i
< n
; i
++)
2095 if (new_arg
[i
] == NULL
)
2096 new_arg
[i
] = gfc_get_actual_arglist ();
2101 *new_arg
[0] = *actual
;
2105 new_arg
[0] = new_arg
[na
];
2109 for (i
= 0; i
< n
- 1; i
++)
2110 new_arg
[i
]->next
= new_arg
[i
+ 1];
2112 new_arg
[i
]->next
= NULL
;
2114 if (*ap
== NULL
&& n
> 0)
2117 /* Note the types of omitted optional arguments. */
2118 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2119 if (a
->expr
== NULL
&& a
->label
== NULL
)
2120 a
->missing_arg_type
= f
->sym
->ts
.type
;
2128 gfc_formal_arglist
*f
;
2129 gfc_actual_arglist
*a
;
2133 /* qsort comparison function for argument pairs, with the following
2135 - p->a->expr == NULL
2136 - p->a->expr->expr_type != EXPR_VARIABLE
2137 - growing p->a->expr->symbol. */
2140 pair_cmp (const void *p1
, const void *p2
)
2142 const gfc_actual_arglist
*a1
, *a2
;
2144 /* *p1 and *p2 are elements of the to-be-sorted array. */
2145 a1
= ((const argpair
*) p1
)->a
;
2146 a2
= ((const argpair
*) p2
)->a
;
2155 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2157 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2161 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2163 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2167 /* Given two expressions from some actual arguments, test whether they
2168 refer to the same expression. The analysis is conservative.
2169 Returning FAILURE will produce no warning. */
2172 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2174 const gfc_ref
*r1
, *r2
;
2177 || e1
->expr_type
!= EXPR_VARIABLE
2178 || e2
->expr_type
!= EXPR_VARIABLE
2179 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2182 /* TODO: improve comparison, see expr.c:show_ref(). */
2183 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2185 if (r1
->type
!= r2
->type
)
2190 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2192 /* TODO: At the moment, consider only full arrays;
2193 we could do better. */
2194 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2199 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2207 gfc_internal_error ("compare_actual_expr(): Bad component code");
2216 /* Given formal and actual argument lists that correspond to one
2217 another, check that identical actual arguments aren't not
2218 associated with some incompatible INTENTs. */
2221 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2223 sym_intent f1_intent
, f2_intent
;
2224 gfc_formal_arglist
*f1
;
2225 gfc_actual_arglist
*a1
;
2228 gfc_try t
= SUCCESS
;
2231 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2233 if (f1
== NULL
&& a1
== NULL
)
2235 if (f1
== NULL
|| a1
== NULL
)
2236 gfc_internal_error ("check_some_aliasing(): List mismatch");
2241 p
= (argpair
*) alloca (n
* sizeof (argpair
));
2243 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2249 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2251 for (i
= 0; i
< n
; i
++)
2254 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2255 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2257 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2258 for (j
= i
+ 1; j
< n
; j
++)
2260 /* Expected order after the sort. */
2261 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2262 gfc_internal_error ("check_some_aliasing(): corrupted data");
2264 /* Are the expression the same? */
2265 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2267 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2268 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2269 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2271 gfc_warning ("Same actual argument associated with INTENT(%s) "
2272 "argument '%s' and INTENT(%s) argument '%s' at %L",
2273 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2274 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2275 &p
[i
].a
->expr
->where
);
2285 /* Given a symbol of a formal argument list and an expression,
2286 return nonzero if their intents are compatible, zero otherwise. */
2289 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2291 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2294 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2297 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2304 /* Given formal and actual argument lists that correspond to one
2305 another, check that they are compatible in the sense that intents
2306 are not mismatched. */
2309 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2311 sym_intent f_intent
;
2313 for (;; f
= f
->next
, a
= a
->next
)
2315 if (f
== NULL
&& a
== NULL
)
2317 if (f
== NULL
|| a
== NULL
)
2318 gfc_internal_error ("check_intents(): List mismatch");
2320 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2323 f_intent
= f
->sym
->attr
.intent
;
2325 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2327 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2328 "specifies INTENT(%s)", &a
->expr
->where
,
2329 gfc_intent_string (f_intent
));
2333 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2335 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2337 gfc_error ("Procedure argument at %L is local to a PURE "
2338 "procedure and is passed to an INTENT(%s) argument",
2339 &a
->expr
->where
, gfc_intent_string (f_intent
));
2343 if (f
->sym
->attr
.pointer
)
2345 gfc_error ("Procedure argument at %L is local to a PURE "
2346 "procedure and has the POINTER attribute",
2357 /* Check how a procedure is used against its interface. If all goes
2358 well, the actual argument list will also end up being properly
2362 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2365 /* Warn about calls with an implicit interface. Special case
2366 for calling a ISO_C_BINDING becase c_loc and c_funloc
2367 are pseudo-unknown. */
2368 if (gfc_option
.warn_implicit_interface
2369 && sym
->attr
.if_source
== IFSRC_UNKNOWN
2370 && ! sym
->attr
.is_iso_c
)
2371 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2374 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2376 gfc_actual_arglist
*a
;
2377 for (a
= *ap
; a
; a
= a
->next
)
2379 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2380 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2382 gfc_error("Keyword argument requires explicit interface "
2383 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2391 if (!compare_actual_formal (ap
, sym
->formal
, 0, sym
->attr
.elemental
, where
))
2394 check_intents (sym
->formal
, *ap
);
2395 if (gfc_option
.warn_aliasing
)
2396 check_some_aliasing (sym
->formal
, *ap
);
2400 /* Check how a procedure pointer component is used against its interface.
2401 If all goes well, the actual argument list will also end up being properly
2402 sorted. Completely analogous to gfc_procedure_use. */
2405 gfc_ppc_use (gfc_component
*comp
, gfc_actual_arglist
**ap
, locus
*where
)
2408 /* Warn about calls with an implicit interface. Special case
2409 for calling a ISO_C_BINDING becase c_loc and c_funloc
2410 are pseudo-unknown. */
2411 if (gfc_option
.warn_implicit_interface
2412 && comp
->attr
.if_source
== IFSRC_UNKNOWN
2413 && !comp
->attr
.is_iso_c
)
2414 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2415 "interface at %L", comp
->name
, where
);
2417 if (comp
->attr
.if_source
== IFSRC_UNKNOWN
)
2419 gfc_actual_arglist
*a
;
2420 for (a
= *ap
; a
; a
= a
->next
)
2422 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2423 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2425 gfc_error("Keyword argument requires explicit interface "
2426 "for procedure pointer component '%s' at %L",
2427 comp
->name
, &a
->expr
->where
);
2435 if (!compare_actual_formal (ap
, comp
->formal
, 0, comp
->attr
.elemental
, where
))
2438 check_intents (comp
->formal
, *ap
);
2439 if (gfc_option
.warn_aliasing
)
2440 check_some_aliasing (comp
->formal
, *ap
);
2444 /* Try if an actual argument list matches the formal list of a symbol,
2445 respecting the symbol's attributes like ELEMENTAL. This is used for
2446 GENERIC resolution. */
2449 gfc_arglist_matches_symbol (gfc_actual_arglist
** args
, gfc_symbol
* sym
)
2453 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
2455 r
= !sym
->attr
.elemental
;
2456 if (compare_actual_formal (args
, sym
->formal
, r
, !r
, NULL
))
2458 check_intents (sym
->formal
, *args
);
2459 if (gfc_option
.warn_aliasing
)
2460 check_some_aliasing (sym
->formal
, *args
);
2468 /* Given an interface pointer and an actual argument list, search for
2469 a formal argument list that matches the actual. If found, returns
2470 a pointer to the symbol of the correct interface. Returns NULL if
2474 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2475 gfc_actual_arglist
**ap
)
2477 gfc_symbol
*elem_sym
= NULL
;
2478 for (; intr
; intr
= intr
->next
)
2480 if (sub_flag
&& intr
->sym
->attr
.function
)
2482 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2485 if (gfc_arglist_matches_symbol (ap
, intr
->sym
))
2487 /* Satisfy 12.4.4.1 such that an elemental match has lower
2488 weight than a non-elemental match. */
2489 if (intr
->sym
->attr
.elemental
)
2491 elem_sym
= intr
->sym
;
2498 return elem_sym
? elem_sym
: NULL
;
2502 /* Do a brute force recursive search for a symbol. */
2504 static gfc_symtree
*
2505 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2509 if (root
->n
.sym
== sym
)
2514 st
= find_symtree0 (root
->left
, sym
);
2515 if (root
->right
&& ! st
)
2516 st
= find_symtree0 (root
->right
, sym
);
2521 /* Find a symtree for a symbol. */
2524 gfc_find_sym_in_symtree (gfc_symbol
*sym
)
2529 /* First try to find it by name. */
2530 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2531 if (st
&& st
->n
.sym
== sym
)
2534 /* If it's been renamed, resort to a brute-force search. */
2535 /* TODO: avoid having to do this search. If the symbol doesn't exist
2536 in the symtree for the current namespace, it should probably be added. */
2537 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2539 st
= find_symtree0 (ns
->sym_root
, sym
);
2543 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2548 /* This subroutine is called when an expression is being resolved.
2549 The expression node in question is either a user defined operator
2550 or an intrinsic operator with arguments that aren't compatible
2551 with the operator. This subroutine builds an actual argument list
2552 corresponding to the operands, then searches for a compatible
2553 interface. If one is found, the expression node is replaced with
2554 the appropriate function call. */
2557 gfc_extend_expr (gfc_expr
*e
)
2559 gfc_actual_arglist
*actual
;
2567 actual
= gfc_get_actual_arglist ();
2568 actual
->expr
= e
->value
.op
.op1
;
2570 if (e
->value
.op
.op2
!= NULL
)
2572 actual
->next
= gfc_get_actual_arglist ();
2573 actual
->next
->expr
= e
->value
.op
.op2
;
2576 i
= fold_unary_intrinsic (e
->value
.op
.op
);
2578 if (i
== INTRINSIC_USER
)
2580 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2582 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2586 sym
= gfc_search_interface (uop
->op
, 0, &actual
);
2593 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2595 /* Due to the distinction between '==' and '.eq.' and friends, one has
2596 to check if either is defined. */
2600 case INTRINSIC_EQ_OS
:
2601 sym
= gfc_search_interface (ns
->op
[INTRINSIC_EQ
], 0, &actual
);
2603 sym
= gfc_search_interface (ns
->op
[INTRINSIC_EQ_OS
], 0, &actual
);
2607 case INTRINSIC_NE_OS
:
2608 sym
= gfc_search_interface (ns
->op
[INTRINSIC_NE
], 0, &actual
);
2610 sym
= gfc_search_interface (ns
->op
[INTRINSIC_NE_OS
], 0, &actual
);
2614 case INTRINSIC_GT_OS
:
2615 sym
= gfc_search_interface (ns
->op
[INTRINSIC_GT
], 0, &actual
);
2617 sym
= gfc_search_interface (ns
->op
[INTRINSIC_GT_OS
], 0, &actual
);
2621 case INTRINSIC_GE_OS
:
2622 sym
= gfc_search_interface (ns
->op
[INTRINSIC_GE
], 0, &actual
);
2624 sym
= gfc_search_interface (ns
->op
[INTRINSIC_GE_OS
], 0, &actual
);
2628 case INTRINSIC_LT_OS
:
2629 sym
= gfc_search_interface (ns
->op
[INTRINSIC_LT
], 0, &actual
);
2631 sym
= gfc_search_interface (ns
->op
[INTRINSIC_LT_OS
], 0, &actual
);
2635 case INTRINSIC_LE_OS
:
2636 sym
= gfc_search_interface (ns
->op
[INTRINSIC_LE
], 0, &actual
);
2638 sym
= gfc_search_interface (ns
->op
[INTRINSIC_LE_OS
], 0, &actual
);
2642 sym
= gfc_search_interface (ns
->op
[i
], 0, &actual
);
2652 /* Don't use gfc_free_actual_arglist(). */
2653 if (actual
->next
!= NULL
)
2654 gfc_free (actual
->next
);
2660 /* Change the expression node to a function call. */
2661 e
->expr_type
= EXPR_FUNCTION
;
2662 e
->symtree
= gfc_find_sym_in_symtree (sym
);
2663 e
->value
.function
.actual
= actual
;
2664 e
->value
.function
.esym
= NULL
;
2665 e
->value
.function
.isym
= NULL
;
2666 e
->value
.function
.name
= NULL
;
2667 e
->user_operator
= 1;
2669 if (gfc_pure (NULL
) && !gfc_pure (sym
))
2671 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2672 "be PURE", sym
->name
, &e
->where
);
2676 if (gfc_resolve_expr (e
) == FAILURE
)
2683 /* Tries to replace an assignment code node with a subroutine call to
2684 the subroutine associated with the assignment operator. Return
2685 SUCCESS if the node was replaced. On FAILURE, no error is
2689 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
2691 gfc_actual_arglist
*actual
;
2692 gfc_expr
*lhs
, *rhs
;
2698 /* Don't allow an intrinsic assignment to be replaced. */
2699 if (lhs
->ts
.type
!= BT_DERIVED
2700 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
2701 && (lhs
->ts
.type
== rhs
->ts
.type
2702 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
2705 actual
= gfc_get_actual_arglist ();
2708 actual
->next
= gfc_get_actual_arglist ();
2709 actual
->next
->expr
= rhs
;
2713 for (; ns
; ns
= ns
->parent
)
2715 sym
= gfc_search_interface (ns
->op
[INTRINSIC_ASSIGN
], 1, &actual
);
2722 gfc_free (actual
->next
);
2727 /* Replace the assignment with the call. */
2728 c
->op
= EXEC_ASSIGN_CALL
;
2729 c
->symtree
= gfc_find_sym_in_symtree (sym
);
2732 c
->ext
.actual
= actual
;
2738 /* Make sure that the interface just parsed is not already present in
2739 the given interface list. Ambiguity isn't checked yet since module
2740 procedures can be present without interfaces. */
2743 check_new_interface (gfc_interface
*base
, gfc_symbol
*new_sym
)
2747 for (ip
= base
; ip
; ip
= ip
->next
)
2749 if (ip
->sym
== new_sym
)
2751 gfc_error ("Entity '%s' at %C is already present in the interface",
2761 /* Add a symbol to the current interface. */
2764 gfc_add_interface (gfc_symbol
*new_sym
)
2766 gfc_interface
**head
, *intr
;
2770 switch (current_interface
.type
)
2772 case INTERFACE_NAMELESS
:
2773 case INTERFACE_ABSTRACT
:
2776 case INTERFACE_INTRINSIC_OP
:
2777 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2778 switch (current_interface
.op
)
2781 case INTRINSIC_EQ_OS
:
2782 if (check_new_interface (ns
->op
[INTRINSIC_EQ
], new_sym
) == FAILURE
||
2783 check_new_interface (ns
->op
[INTRINSIC_EQ_OS
], new_sym
) == FAILURE
)
2788 case INTRINSIC_NE_OS
:
2789 if (check_new_interface (ns
->op
[INTRINSIC_NE
], new_sym
) == FAILURE
||
2790 check_new_interface (ns
->op
[INTRINSIC_NE_OS
], new_sym
) == FAILURE
)
2795 case INTRINSIC_GT_OS
:
2796 if (check_new_interface (ns
->op
[INTRINSIC_GT
], new_sym
) == FAILURE
||
2797 check_new_interface (ns
->op
[INTRINSIC_GT_OS
], new_sym
) == FAILURE
)
2802 case INTRINSIC_GE_OS
:
2803 if (check_new_interface (ns
->op
[INTRINSIC_GE
], new_sym
) == FAILURE
||
2804 check_new_interface (ns
->op
[INTRINSIC_GE_OS
], new_sym
) == FAILURE
)
2809 case INTRINSIC_LT_OS
:
2810 if (check_new_interface (ns
->op
[INTRINSIC_LT
], new_sym
) == FAILURE
||
2811 check_new_interface (ns
->op
[INTRINSIC_LT_OS
], new_sym
) == FAILURE
)
2816 case INTRINSIC_LE_OS
:
2817 if (check_new_interface (ns
->op
[INTRINSIC_LE
], new_sym
) == FAILURE
||
2818 check_new_interface (ns
->op
[INTRINSIC_LE_OS
], new_sym
) == FAILURE
)
2823 if (check_new_interface (ns
->op
[current_interface
.op
], new_sym
) == FAILURE
)
2827 head
= ¤t_interface
.ns
->op
[current_interface
.op
];
2830 case INTERFACE_GENERIC
:
2831 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2833 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
2837 if (check_new_interface (sym
->generic
, new_sym
) == FAILURE
)
2841 head
= ¤t_interface
.sym
->generic
;
2844 case INTERFACE_USER_OP
:
2845 if (check_new_interface (current_interface
.uop
->op
, new_sym
)
2849 head
= ¤t_interface
.uop
->op
;
2853 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2856 intr
= gfc_get_interface ();
2857 intr
->sym
= new_sym
;
2858 intr
->where
= gfc_current_locus
;
2868 gfc_current_interface_head (void)
2870 switch (current_interface
.type
)
2872 case INTERFACE_INTRINSIC_OP
:
2873 return current_interface
.ns
->op
[current_interface
.op
];
2876 case INTERFACE_GENERIC
:
2877 return current_interface
.sym
->generic
;
2880 case INTERFACE_USER_OP
:
2881 return current_interface
.uop
->op
;
2891 gfc_set_current_interface_head (gfc_interface
*i
)
2893 switch (current_interface
.type
)
2895 case INTERFACE_INTRINSIC_OP
:
2896 current_interface
.ns
->op
[current_interface
.op
] = i
;
2899 case INTERFACE_GENERIC
:
2900 current_interface
.sym
->generic
= i
;
2903 case INTERFACE_USER_OP
:
2904 current_interface
.uop
->op
= i
;
2913 /* Gets rid of a formal argument list. We do not free symbols.
2914 Symbols are freed when a namespace is freed. */
2917 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
2919 gfc_formal_arglist
*q
;