1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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 (gfc_intrinsic_op
operator)
102 case INTRINSIC_UPLUS
:
103 operator = INTRINSIC_PLUS
;
105 case INTRINSIC_UMINUS
:
106 operator = INTRINSIC_MINUS
;
116 /* Match a generic specification. Depending on which type of
117 interface is found, the 'name' or 'operator' pointers may be set.
118 This subroutine doesn't return MATCH_NO. */
121 gfc_match_generic_spec (interface_type
*type
,
123 gfc_intrinsic_op
*operator)
125 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
129 if (gfc_match (" assignment ( = )") == MATCH_YES
)
131 *type
= INTERFACE_INTRINSIC_OP
;
132 *operator = INTRINSIC_ASSIGN
;
136 if (gfc_match (" operator ( %o )", &i
) == MATCH_YES
)
138 *type
= INTERFACE_INTRINSIC_OP
;
139 *operator = fold_unary (i
);
143 if (gfc_match (" operator ( ") == MATCH_YES
)
145 m
= gfc_match_defined_op_name (buffer
, 1);
151 m
= gfc_match_char (')');
157 strcpy (name
, buffer
);
158 *type
= INTERFACE_USER_OP
;
162 if (gfc_match_name (buffer
) == MATCH_YES
)
164 strcpy (name
, buffer
);
165 *type
= INTERFACE_GENERIC
;
169 *type
= INTERFACE_NAMELESS
;
173 gfc_error ("Syntax error in generic specification at %C");
178 /* Match one of the five F95 forms of an interface statement. The
179 matcher for the abstract interface follows. */
182 gfc_match_interface (void)
184 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
187 gfc_intrinsic_op
operator;
190 m
= gfc_match_space ();
192 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
195 /* If we're not looking at the end of the statement now, or if this
196 is not a nameless interface but we did not see a space, punt. */
197 if (gfc_match_eos () != MATCH_YES
198 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
200 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
205 current_interface
.type
= type
;
209 case INTERFACE_GENERIC
:
210 if (gfc_get_symbol (name
, NULL
, &sym
))
213 if (!sym
->attr
.generic
214 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
219 gfc_error ("Dummy procedure '%s' at %C cannot have a "
220 "generic interface", sym
->name
);
224 current_interface
.sym
= gfc_new_block
= sym
;
227 case INTERFACE_USER_OP
:
228 current_interface
.uop
= gfc_get_uop (name
);
231 case INTERFACE_INTRINSIC_OP
:
232 current_interface
.op
= operator;
235 case INTERFACE_NAMELESS
:
236 case INTERFACE_ABSTRACT
:
245 /* Match a F2003 abstract interface. */
248 gfc_match_abstract_interface (void)
252 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ABSTRACT INTERFACE at %C")
256 m
= gfc_match_eos ();
260 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
264 current_interface
.type
= INTERFACE_ABSTRACT
;
270 /* Match the different sort of generic-specs that can be present after
271 the END INTERFACE itself. */
274 gfc_match_end_interface (void)
276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
278 gfc_intrinsic_op
operator;
281 m
= gfc_match_space ();
283 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
286 /* If we're not looking at the end of the statement now, or if this
287 is not a nameless interface but we did not see a space, punt. */
288 if (gfc_match_eos () != MATCH_YES
289 || (type
!= INTERFACE_NAMELESS
&& m
!= MATCH_YES
))
291 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
298 switch (current_interface
.type
)
300 case INTERFACE_NAMELESS
:
301 case INTERFACE_ABSTRACT
:
302 if (type
!= INTERFACE_NAMELESS
)
304 gfc_error ("Expected a nameless interface at %C");
310 case INTERFACE_INTRINSIC_OP
:
311 if (type
!= current_interface
.type
|| operator != current_interface
.op
)
314 if (current_interface
.op
== INTRINSIC_ASSIGN
)
315 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
317 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
318 gfc_op2string (current_interface
.op
));
325 case INTERFACE_USER_OP
:
326 /* Comparing the symbol node names is OK because only use-associated
327 symbols can be renamed. */
328 if (type
!= current_interface
.type
329 || strcmp (current_interface
.uop
->name
, name
) != 0)
331 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
332 current_interface
.uop
->name
);
338 case INTERFACE_GENERIC
:
339 if (type
!= current_interface
.type
340 || strcmp (current_interface
.sym
->name
, name
) != 0)
342 gfc_error ("Expecting 'END INTERFACE %s' at %C",
343 current_interface
.sym
->name
);
354 /* Compare two derived types using the criteria in 4.4.2 of the standard,
355 recursing through gfc_compare_types for the components. */
358 gfc_compare_derived_types (gfc_symbol
*derived1
, gfc_symbol
*derived2
)
360 gfc_component
*dt1
, *dt2
;
362 /* Special case for comparing derived types across namespaces. If the
363 true names and module names are the same and the module name is
364 nonnull, then they are equal. */
365 if (derived1
!= NULL
&& derived2
!= NULL
366 && strcmp (derived1
->name
, derived2
->name
) == 0
367 && derived1
->module
!= NULL
&& derived2
->module
!= NULL
368 && strcmp (derived1
->module
, derived2
->module
) == 0)
371 /* Compare type via the rules of the standard. Both types must have
372 the SEQUENCE attribute to be equal. */
374 if (strcmp (derived1
->name
, derived2
->name
))
377 if (derived1
->component_access
== ACCESS_PRIVATE
378 || derived2
->component_access
== ACCESS_PRIVATE
)
381 if (derived1
->attr
.sequence
== 0 || derived2
->attr
.sequence
== 0)
384 dt1
= derived1
->components
;
385 dt2
= derived2
->components
;
387 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
388 simple test can speed things up. Otherwise, lots of things have to
392 if (strcmp (dt1
->name
, dt2
->name
) != 0)
395 if (dt1
->access
!= dt2
->access
)
398 if (dt1
->pointer
!= dt2
->pointer
)
401 if (dt1
->dimension
!= dt2
->dimension
)
404 if (dt1
->allocatable
!= dt2
->allocatable
)
407 if (dt1
->dimension
&& gfc_compare_array_spec (dt1
->as
, dt2
->as
) == 0)
410 /* Make sure that link lists do not put this function into an
411 endless recursive loop! */
412 if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
413 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
414 && gfc_compare_types (&dt1
->ts
, &dt2
->ts
) == 0)
417 else if ((dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
418 && !(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
))
421 else if (!(dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
)
422 && (dt1
->ts
.type
== BT_DERIVED
&& derived1
== dt1
->ts
.derived
))
428 if (dt1
== NULL
&& dt2
== NULL
)
430 if (dt1
== NULL
|| dt2
== NULL
)
438 /* Compare two typespecs, recursively if necessary. */
441 gfc_compare_types (gfc_typespec
*ts1
, gfc_typespec
*ts2
)
443 /* See if one of the typespecs is a BT_VOID, which is what is being used
444 to allow the funcs like c_f_pointer to accept any pointer type.
445 TODO: Possibly should narrow this to just the one typespec coming in
446 that is for the formal arg, but oh well. */
447 if (ts1
->type
== BT_VOID
|| ts2
->type
== BT_VOID
)
450 if (ts1
->type
!= ts2
->type
)
452 if (ts1
->type
!= BT_DERIVED
)
453 return (ts1
->kind
== ts2
->kind
);
455 /* Compare derived types. */
456 if (ts1
->derived
== ts2
->derived
)
459 return gfc_compare_derived_types (ts1
->derived
,ts2
->derived
);
463 /* Given two symbols that are formal arguments, compare their ranks
464 and types. Returns nonzero if they have the same rank and type,
468 compare_type_rank (gfc_symbol
*s1
, gfc_symbol
*s2
)
472 r1
= (s1
->as
!= NULL
) ? s1
->as
->rank
: 0;
473 r2
= (s2
->as
!= NULL
) ? s2
->as
->rank
: 0;
476 return 0; /* Ranks differ. */
478 return gfc_compare_types (&s1
->ts
, &s2
->ts
);
482 static int compare_interfaces (gfc_symbol
*, gfc_symbol
*, int);
483 static int compare_intr_interfaces (gfc_symbol
*, gfc_symbol
*);
485 /* Given two symbols that are formal arguments, compare their types
486 and rank and their formal interfaces if they are both dummy
487 procedures. Returns nonzero if the same, zero if different. */
490 compare_type_rank_if (gfc_symbol
*s1
, gfc_symbol
*s2
)
492 if (s1
== NULL
|| s2
== NULL
)
493 return s1
== s2
? 1 : 0;
495 if (s1
->attr
.flavor
!= FL_PROCEDURE
&& s2
->attr
.flavor
!= FL_PROCEDURE
)
496 return compare_type_rank (s1
, s2
);
498 if (s1
->attr
.flavor
!= FL_PROCEDURE
|| s2
->attr
.flavor
!= FL_PROCEDURE
)
501 /* At this point, both symbols are procedures. */
502 if ((s1
->attr
.function
== 0 && s1
->attr
.subroutine
== 0)
503 || (s2
->attr
.function
== 0 && s2
->attr
.subroutine
== 0))
506 if (s1
->attr
.function
!= s2
->attr
.function
507 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
510 if (s1
->attr
.function
&& compare_type_rank (s1
, s2
) == 0)
513 /* Originally, gfortran recursed here to check the interfaces of passed
514 procedures. This is explicitly not required by the standard. */
519 /* Given a formal argument list and a keyword name, search the list
520 for that keyword. Returns the correct symbol node if found, NULL
524 find_keyword_arg (const char *name
, gfc_formal_arglist
*f
)
526 for (; f
; f
= f
->next
)
527 if (strcmp (f
->sym
->name
, name
) == 0)
534 /******** Interface checking subroutines **********/
537 /* Given an operator interface and the operator, make sure that all
538 interfaces for that operator are legal. */
541 check_operator_interface (gfc_interface
*intr
, gfc_intrinsic_op
operator)
543 gfc_formal_arglist
*formal
;
547 int args
, r1
, r2
, k1
, k2
;
553 t1
= t2
= BT_UNKNOWN
;
554 i1
= i2
= INTENT_UNKNOWN
;
558 for (formal
= intr
->sym
->formal
; formal
; formal
= formal
->next
)
563 gfc_error ("Alternate return cannot appear in operator "
564 "interface at %L", &intr
->sym
->declared_at
);
570 i1
= sym
->attr
.intent
;
571 r1
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
577 i2
= sym
->attr
.intent
;
578 r2
= (sym
->as
!= NULL
) ? sym
->as
->rank
: 0;
586 /* Only +, - and .not. can be unary operators.
587 .not. cannot be a binary operator. */
588 if (args
== 0 || args
> 2 || (args
== 1 && operator != INTRINSIC_PLUS
589 && operator != INTRINSIC_MINUS
590 && operator != INTRINSIC_NOT
)
591 || (args
== 2 && operator == INTRINSIC_NOT
))
593 gfc_error ("Operator interface at %L has the wrong number of arguments",
594 &intr
->sym
->declared_at
);
598 /* Check that intrinsics are mapped to functions, except
599 INTRINSIC_ASSIGN which should map to a subroutine. */
600 if (operator == INTRINSIC_ASSIGN
)
602 if (!sym
->attr
.subroutine
)
604 gfc_error ("Assignment operator interface at %L must be "
605 "a SUBROUTINE", &intr
->sym
->declared_at
);
610 gfc_error ("Assignment operator interface at %L must have "
611 "two arguments", &intr
->sym
->declared_at
);
615 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
616 - First argument an array with different rank than second,
617 - Types and kinds do not conform, and
618 - First argument is of derived type. */
619 if (sym
->formal
->sym
->ts
.type
!= BT_DERIVED
620 && (r1
== 0 || r1
== r2
)
621 && (sym
->formal
->sym
->ts
.type
== sym
->formal
->next
->sym
->ts
.type
622 || (gfc_numeric_ts (&sym
->formal
->sym
->ts
)
623 && gfc_numeric_ts (&sym
->formal
->next
->sym
->ts
))))
625 gfc_error ("Assignment operator interface at %L must not redefine "
626 "an INTRINSIC type assignment", &intr
->sym
->declared_at
);
632 if (!sym
->attr
.function
)
634 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
635 &intr
->sym
->declared_at
);
640 /* Check intents on operator interfaces. */
641 if (operator == INTRINSIC_ASSIGN
)
643 if (i1
!= INTENT_OUT
&& i1
!= INTENT_INOUT
)
644 gfc_error ("First argument of defined assignment at %L must be "
645 "INTENT(OUT) or INTENT(INOUT)", &intr
->sym
->declared_at
);
648 gfc_error ("Second argument of defined assignment at %L must be "
649 "INTENT(IN)", &intr
->sym
->declared_at
);
654 gfc_error ("First argument of operator interface at %L must be "
655 "INTENT(IN)", &intr
->sym
->declared_at
);
657 if (args
== 2 && i2
!= INTENT_IN
)
658 gfc_error ("Second argument of operator interface at %L must be "
659 "INTENT(IN)", &intr
->sym
->declared_at
);
662 /* From now on, all we have to do is check that the operator definition
663 doesn't conflict with an intrinsic operator. The rules for this
664 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
665 as well as 12.3.2.1.1 of Fortran 2003:
667 "If the operator is an intrinsic-operator (R310), the number of
668 function arguments shall be consistent with the intrinsic uses of
669 that operator, and the types, kind type parameters, or ranks of the
670 dummy arguments shall differ from those required for the intrinsic
671 operation (7.1.2)." */
673 #define IS_NUMERIC_TYPE(t) \
674 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
676 /* Unary ops are easy, do them first. */
677 if (operator == INTRINSIC_NOT
)
679 if (t1
== BT_LOGICAL
)
685 if (args
== 1 && (operator == INTRINSIC_PLUS
|| operator == INTRINSIC_MINUS
))
687 if (IS_NUMERIC_TYPE (t1
))
693 /* Character intrinsic operators have same character kind, thus
694 operator definitions with operands of different character kinds
696 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
&& k1
!= k2
)
699 /* Intrinsic operators always perform on arguments of same rank,
700 so different ranks is also always safe. (rank == 0) is an exception
701 to that, because all intrinsic operators are elemental. */
702 if (r1
!= r2
&& r1
!= 0 && r2
!= 0)
708 case INTRINSIC_EQ_OS
:
710 case INTRINSIC_NE_OS
:
711 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
716 case INTRINSIC_MINUS
:
717 case INTRINSIC_TIMES
:
718 case INTRINSIC_DIVIDE
:
719 case INTRINSIC_POWER
:
720 if (IS_NUMERIC_TYPE (t1
) && IS_NUMERIC_TYPE (t2
))
725 case INTRINSIC_GT_OS
:
727 case INTRINSIC_GE_OS
:
729 case INTRINSIC_LT_OS
:
731 case INTRINSIC_LE_OS
:
732 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
734 if ((t1
== BT_INTEGER
|| t1
== BT_REAL
)
735 && (t2
== BT_INTEGER
|| t2
== BT_REAL
))
739 case INTRINSIC_CONCAT
:
740 if (t1
== BT_CHARACTER
&& t2
== BT_CHARACTER
)
748 if (t1
== BT_LOGICAL
&& t2
== BT_LOGICAL
)
758 #undef IS_NUMERIC_TYPE
761 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
767 /* Given a pair of formal argument lists, we see if the two lists can
768 be distinguished by counting the number of nonoptional arguments of
769 a given type/rank in f1 and seeing if there are less then that
770 number of those arguments in f2 (including optional arguments).
771 Since this test is asymmetric, it has to be called twice to make it
772 symmetric. Returns nonzero if the argument lists are incompatible
773 by this test. This subroutine implements rule 1 of section
777 count_types_test (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
779 int rc
, ac1
, ac2
, i
, j
, k
, n1
;
780 gfc_formal_arglist
*f
;
793 for (f
= f1
; f
; f
= f
->next
)
796 /* Build an array of integers that gives the same integer to
797 arguments of the same type/rank. */
798 arg
= XCNEWVEC (arginfo
, n1
);
801 for (i
= 0; i
< n1
; i
++, f
= f
->next
)
809 for (i
= 0; i
< n1
; i
++)
811 if (arg
[i
].flag
!= -1)
814 if (arg
[i
].sym
&& arg
[i
].sym
->attr
.optional
)
815 continue; /* Skip optional arguments. */
819 /* Find other nonoptional arguments of the same type/rank. */
820 for (j
= i
+ 1; j
< n1
; j
++)
821 if ((arg
[j
].sym
== NULL
|| !arg
[j
].sym
->attr
.optional
)
822 && compare_type_rank_if (arg
[i
].sym
, arg
[j
].sym
))
828 /* Now loop over each distinct type found in f1. */
832 for (i
= 0; i
< n1
; i
++)
834 if (arg
[i
].flag
!= k
)
838 for (j
= i
+ 1; j
< n1
; j
++)
839 if (arg
[j
].flag
== k
)
842 /* Count the number of arguments in f2 with that type, including
843 those that are optional. */
846 for (f
= f2
; f
; f
= f
->next
)
847 if (compare_type_rank_if (arg
[i
].sym
, f
->sym
))
865 /* Perform the abbreviated correspondence test for operators. The
866 arguments cannot be optional and are always ordered correctly,
867 which makes this test much easier than that for generic tests.
869 This subroutine is also used when comparing a formal and actual
870 argument list when an actual parameter is a dummy procedure. At
871 that point, two formal interfaces must be compared for equality
872 which is what happens here. */
875 operator_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
879 if (f1
== NULL
&& f2
== NULL
)
881 if (f1
== NULL
|| f2
== NULL
)
884 if (!compare_type_rank (f1
->sym
, f2
->sym
))
895 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
896 Returns zero if no argument is found that satisfies rule 2, nonzero
899 This test is also not symmetric in f1 and f2 and must be called
900 twice. This test finds problems caused by sorting the actual
901 argument list with keywords. For example:
905 INTEGER :: A ; REAL :: B
909 INTEGER :: A ; REAL :: B
913 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
916 generic_correspondence (gfc_formal_arglist
*f1
, gfc_formal_arglist
*f2
)
918 gfc_formal_arglist
*f2_save
, *g
;
925 if (f1
->sym
->attr
.optional
)
928 if (f2
!= NULL
&& compare_type_rank (f1
->sym
, f2
->sym
))
931 /* Now search for a disambiguating keyword argument starting at
932 the current non-match. */
933 for (g
= f1
; g
; g
= g
->next
)
935 if (g
->sym
->attr
.optional
)
938 sym
= find_keyword_arg (g
->sym
->name
, f2_save
);
939 if (sym
== NULL
|| !compare_type_rank (g
->sym
, sym
))
953 /* 'Compare' two formal interfaces associated with a pair of symbols.
954 We return nonzero if there exists an actual argument list that
955 would be ambiguous between the two interfaces, zero otherwise. */
958 compare_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
, int generic_flag
)
960 gfc_formal_arglist
*f1
, *f2
;
962 if (s1
->attr
.function
!= s2
->attr
.function
963 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
964 return 0; /* Disagreement between function/subroutine. */
969 if (f1
== NULL
&& f2
== NULL
)
970 return 1; /* Special case. */
972 if (count_types_test (f1
, f2
))
974 if (count_types_test (f2
, f1
))
979 if (generic_correspondence (f1
, f2
))
981 if (generic_correspondence (f2
, f1
))
986 if (operator_correspondence (f1
, f2
))
995 compare_intr_interfaces (gfc_symbol
*s1
, gfc_symbol
*s2
)
997 gfc_formal_arglist
*f
, *f1
;
998 gfc_intrinsic_arg
*fi
, *f2
;
999 gfc_intrinsic_sym
*isym
;
1001 if (s1
->attr
.function
!= s2
->attr
.function
1002 || s1
->attr
.subroutine
!= s2
->attr
.subroutine
)
1003 return 0; /* Disagreement between function/subroutine. */
1005 /* If the arguments are functions, check type and kind. */
1007 if (s1
->attr
.dummy
&& s1
->attr
.function
&& s2
->attr
.function
)
1009 if (s1
->ts
.type
!= s2
->ts
.type
)
1011 if (s1
->ts
.kind
!= s2
->ts
.kind
)
1013 if (s1
->attr
.if_source
== IFSRC_DECL
)
1017 isym
= gfc_find_function (s2
->name
);
1019 /* This should already have been checked in
1020 resolve.c (resolve_actual_arglist). */
1027 if (f1
== NULL
&& f2
== NULL
)
1030 /* First scan through the formal argument list and check the intrinsic. */
1032 for (f
= f1
; f
; f
= f
->next
)
1036 if ((fi
->ts
.type
!= f
->sym
->ts
.type
) || (fi
->ts
.kind
!= f
->sym
->ts
.kind
))
1041 /* Now scan through the intrinsic argument list and check the formal. */
1043 for (fi
= f2
; fi
; fi
= fi
->next
)
1047 if ((fi
->ts
.type
!= f
->sym
->ts
.type
) || (fi
->ts
.kind
!= f
->sym
->ts
.kind
))
1056 /* Compare an actual argument list with an intrinsic argument list. */
1059 compare_actual_formal_intr (gfc_actual_arglist
**ap
, gfc_symbol
*s2
)
1061 gfc_actual_arglist
*a
;
1062 gfc_intrinsic_arg
*fi
, *f2
;
1063 gfc_intrinsic_sym
*isym
;
1065 isym
= gfc_find_function (s2
->name
);
1067 /* This should already have been checked in
1068 resolve.c (resolve_actual_arglist). */
1074 if (*ap
== NULL
&& f2
== NULL
)
1077 /* First scan through the actual argument list and check the intrinsic. */
1079 for (a
= *ap
; a
; a
= a
->next
)
1083 if ((fi
->ts
.type
!= a
->expr
->ts
.type
)
1084 || (fi
->ts
.kind
!= a
->expr
->ts
.kind
))
1089 /* Now scan through the intrinsic argument list and check the formal. */
1091 for (fi
= f2
; fi
; fi
= fi
->next
)
1095 if ((fi
->ts
.type
!= a
->expr
->ts
.type
)
1096 || (fi
->ts
.kind
!= a
->expr
->ts
.kind
))
1105 /* Given a pointer to an interface pointer, remove duplicate
1106 interfaces and make sure that all symbols are either functions or
1107 subroutines. Returns nonzero if something goes wrong. */
1110 check_interface0 (gfc_interface
*p
, const char *interface_name
)
1112 gfc_interface
*psave
, *q
, *qlast
;
1115 /* Make sure all symbols in the interface have been defined as
1116 functions or subroutines. */
1117 for (; p
; p
= p
->next
)
1118 if ((!p
->sym
->attr
.function
&& !p
->sym
->attr
.subroutine
)
1119 || !p
->sym
->attr
.if_source
)
1121 if (p
->sym
->attr
.external
)
1122 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1123 p
->sym
->name
, interface_name
, &p
->sym
->declared_at
);
1125 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1126 "subroutine", p
->sym
->name
, interface_name
,
1127 &p
->sym
->declared_at
);
1132 /* Remove duplicate interfaces in this interface list. */
1133 for (; p
; p
= p
->next
)
1137 for (q
= p
->next
; q
;)
1139 if (p
->sym
!= q
->sym
)
1146 /* Duplicate interface. */
1147 qlast
->next
= q
->next
;
1158 /* Check lists of interfaces to make sure that no two interfaces are
1159 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1162 check_interface1 (gfc_interface
*p
, gfc_interface
*q0
,
1163 int generic_flag
, const char *interface_name
,
1167 for (; p
; p
= p
->next
)
1168 for (q
= q0
; q
; q
= q
->next
)
1170 if (p
->sym
== q
->sym
)
1171 continue; /* Duplicates OK here. */
1173 if (p
->sym
->name
== q
->sym
->name
&& p
->sym
->module
== q
->sym
->module
)
1176 if (compare_interfaces (p
->sym
, q
->sym
, generic_flag
))
1180 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1181 p
->sym
->name
, q
->sym
->name
, interface_name
,
1185 if (!p
->sym
->attr
.use_assoc
&& q
->sym
->attr
.use_assoc
)
1186 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1187 p
->sym
->name
, q
->sym
->name
, interface_name
,
1196 /* Check the generic and operator interfaces of symbols to make sure
1197 that none of the interfaces conflict. The check has to be done
1198 after all of the symbols are actually loaded. */
1201 check_sym_interfaces (gfc_symbol
*sym
)
1203 char interface_name
[100];
1207 if (sym
->ns
!= gfc_current_ns
)
1210 if (sym
->generic
!= NULL
)
1212 sprintf (interface_name
, "generic interface '%s'", sym
->name
);
1213 if (check_interface0 (sym
->generic
, interface_name
))
1216 for (p
= sym
->generic
; p
; p
= p
->next
)
1218 if (p
->sym
->attr
.mod_proc
1219 && (p
->sym
->attr
.if_source
!= IFSRC_DECL
1220 || p
->sym
->attr
.procedure
))
1222 gfc_error ("'%s' at %L is not a module procedure",
1223 p
->sym
->name
, &p
->where
);
1228 /* Originally, this test was applied to host interfaces too;
1229 this is incorrect since host associated symbols, from any
1230 source, cannot be ambiguous with local symbols. */
1231 k
= sym
->attr
.referenced
|| !sym
->attr
.use_assoc
;
1232 if (check_interface1 (sym
->generic
, sym
->generic
, 1, interface_name
, k
))
1233 sym
->attr
.ambiguous_interfaces
= 1;
1239 check_uop_interfaces (gfc_user_op
*uop
)
1241 char interface_name
[100];
1245 sprintf (interface_name
, "operator interface '%s'", uop
->name
);
1246 if (check_interface0 (uop
->operator, interface_name
))
1249 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
1251 uop2
= gfc_find_uop (uop
->name
, ns
);
1255 check_interface1 (uop
->operator, uop2
->operator, 0,
1256 interface_name
, true);
1261 /* For the namespace, check generic, user operator and intrinsic
1262 operator interfaces for consistency and to remove duplicate
1263 interfaces. We traverse the whole namespace, counting on the fact
1264 that most symbols will not have generic or operator interfaces. */
1267 gfc_check_interfaces (gfc_namespace
*ns
)
1269 gfc_namespace
*old_ns
, *ns2
;
1270 char interface_name
[100];
1273 old_ns
= gfc_current_ns
;
1274 gfc_current_ns
= ns
;
1276 gfc_traverse_ns (ns
, check_sym_interfaces
);
1278 gfc_traverse_user_op (ns
, check_uop_interfaces
);
1280 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
1282 if (i
== INTRINSIC_USER
)
1285 if (i
== INTRINSIC_ASSIGN
)
1286 strcpy (interface_name
, "intrinsic assignment operator");
1288 sprintf (interface_name
, "intrinsic '%s' operator",
1291 if (check_interface0 (ns
->operator[i
], interface_name
))
1294 check_operator_interface (ns
->operator[i
], i
);
1296 for (ns2
= ns
; ns2
; ns2
= ns2
->parent
)
1298 if (check_interface1 (ns
->operator[i
], ns2
->operator[i
], 0,
1299 interface_name
, true))
1305 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_EQ_OS
],
1306 0, interface_name
, true)) goto done
;
1309 case INTRINSIC_EQ_OS
:
1310 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_EQ
],
1311 0, interface_name
, true)) goto done
;
1315 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_NE_OS
],
1316 0, interface_name
, true)) goto done
;
1319 case INTRINSIC_NE_OS
:
1320 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_NE
],
1321 0, interface_name
, true)) goto done
;
1325 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GT_OS
],
1326 0, interface_name
, true)) goto done
;
1329 case INTRINSIC_GT_OS
:
1330 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GT
],
1331 0, interface_name
, true)) goto done
;
1335 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GE_OS
],
1336 0, interface_name
, true)) goto done
;
1339 case INTRINSIC_GE_OS
:
1340 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_GE
],
1341 0, interface_name
, true)) goto done
;
1345 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LT_OS
],
1346 0, interface_name
, true)) goto done
;
1349 case INTRINSIC_LT_OS
:
1350 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LT
],
1351 0, interface_name
, true)) goto done
;
1355 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LE_OS
],
1356 0, interface_name
, true)) goto done
;
1359 case INTRINSIC_LE_OS
:
1360 if (check_interface1 (ns
->operator[i
], ns2
->operator[INTRINSIC_LE
],
1361 0, interface_name
, true)) goto done
;
1371 gfc_current_ns
= old_ns
;
1376 symbol_rank (gfc_symbol
*sym
)
1378 return (sym
->as
== NULL
) ? 0 : sym
->as
->rank
;
1382 /* Given a symbol of a formal argument list and an expression, if the
1383 formal argument is allocatable, check that the actual argument is
1384 allocatable. Returns nonzero if compatible, zero if not compatible. */
1387 compare_allocatable (gfc_symbol
*formal
, gfc_expr
*actual
)
1389 symbol_attribute attr
;
1391 if (formal
->attr
.allocatable
)
1393 attr
= gfc_expr_attr (actual
);
1394 if (!attr
.allocatable
)
1402 /* Given a symbol of a formal argument list and an expression, if the
1403 formal argument is a pointer, see if the actual argument is a
1404 pointer. Returns nonzero if compatible, zero if not compatible. */
1407 compare_pointer (gfc_symbol
*formal
, gfc_expr
*actual
)
1409 symbol_attribute attr
;
1411 if (formal
->attr
.pointer
)
1413 attr
= gfc_expr_attr (actual
);
1422 /* Given a symbol of a formal argument list and an expression, see if
1423 the two are compatible as arguments. Returns nonzero if
1424 compatible, zero if not compatible. */
1427 compare_parameter (gfc_symbol
*formal
, gfc_expr
*actual
,
1428 int ranks_must_agree
, int is_elemental
, locus
*where
)
1433 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1434 procs c_f_pointer or c_f_procpointer, and we need to accept most
1435 pointers the user could give us. This should allow that. */
1436 if (formal
->ts
.type
== BT_VOID
)
1439 if (formal
->ts
.type
== BT_DERIVED
1440 && formal
->ts
.derived
&& formal
->ts
.derived
->ts
.is_iso_c
1441 && actual
->ts
.type
== BT_DERIVED
1442 && actual
->ts
.derived
&& actual
->ts
.derived
->ts
.is_iso_c
)
1445 if (actual
->ts
.type
== BT_PROCEDURE
)
1447 if (formal
->attr
.flavor
!= FL_PROCEDURE
)
1450 if (formal
->attr
.function
1451 && !compare_type_rank (formal
, actual
->symtree
->n
.sym
))
1454 if (formal
->attr
.if_source
== IFSRC_UNKNOWN
1455 || actual
->symtree
->n
.sym
->attr
.external
)
1456 return 1; /* Assume match. */
1458 if (actual
->symtree
->n
.sym
->attr
.intrinsic
)
1460 if (!compare_intr_interfaces (formal
, actual
->symtree
->n
.sym
))
1463 else if (!compare_interfaces (formal
, actual
->symtree
->n
.sym
, 0))
1470 gfc_error ("Type/rank mismatch in argument '%s' at %L",
1471 formal
->name
, &actual
->where
);
1475 if ((actual
->expr_type
!= EXPR_NULL
|| actual
->ts
.type
!= BT_UNKNOWN
)
1476 && !gfc_compare_types (&formal
->ts
, &actual
->ts
))
1479 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1480 formal
->name
, &actual
->where
, gfc_typename (&actual
->ts
),
1481 gfc_typename (&formal
->ts
));
1485 if (symbol_rank (formal
) == actual
->rank
)
1488 rank_check
= where
!= NULL
&& !is_elemental
&& formal
->as
1489 && (formal
->as
->type
== AS_ASSUMED_SHAPE
1490 || formal
->as
->type
== AS_DEFERRED
);
1492 if (rank_check
|| ranks_must_agree
|| formal
->attr
.pointer
1493 || (actual
->rank
!= 0 && !(is_elemental
|| formal
->attr
.dimension
))
1494 || (actual
->rank
== 0 && formal
->as
->type
== AS_ASSUMED_SHAPE
))
1497 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1498 formal
->name
, &actual
->where
, symbol_rank (formal
),
1502 else if (actual
->rank
!= 0 && (is_elemental
|| formal
->attr
.dimension
))
1505 /* At this point, we are considering a scalar passed to an array. This
1506 is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1507 - if the actual argument is (a substring of) an element of a
1508 non-assumed-shape/non-pointer array;
1509 - (F2003) if the actual argument is of type character. */
1511 for (ref
= actual
->ref
; ref
; ref
= ref
->next
)
1512 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
1515 /* Not an array element. */
1516 if (formal
->ts
.type
== BT_CHARACTER
1518 || (actual
->expr_type
== EXPR_VARIABLE
1519 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1520 || actual
->symtree
->n
.sym
->attr
.pointer
))))
1522 if (where
&& (gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1524 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1525 "array dummy argument '%s' at %L",
1526 formal
->name
, &actual
->where
);
1529 else if ((gfc_option
.allow_std
& GFC_STD_F2003
) == 0)
1534 else if (ref
== NULL
)
1537 gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1538 formal
->name
, &actual
->where
, symbol_rank (formal
),
1543 if (actual
->expr_type
== EXPR_VARIABLE
1544 && actual
->symtree
->n
.sym
->as
1545 && (actual
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1546 || actual
->symtree
->n
.sym
->attr
.pointer
))
1549 gfc_error ("Element of assumed-shaped array passed to dummy "
1550 "argument '%s' at %L", formal
->name
, &actual
->where
);
1558 /* Given a symbol of a formal argument list and an expression, see if
1559 the two are compatible as arguments. Returns nonzero if
1560 compatible, zero if not compatible. */
1563 compare_parameter_protected (gfc_symbol
*formal
, gfc_expr
*actual
)
1565 if (actual
->expr_type
!= EXPR_VARIABLE
)
1568 if (!actual
->symtree
->n
.sym
->attr
.protected)
1571 if (!actual
->symtree
->n
.sym
->attr
.use_assoc
)
1574 if (formal
->attr
.intent
== INTENT_IN
1575 || formal
->attr
.intent
== INTENT_UNKNOWN
)
1578 if (!actual
->symtree
->n
.sym
->attr
.pointer
)
1581 if (actual
->symtree
->n
.sym
->attr
.pointer
&& formal
->attr
.pointer
)
1588 /* Returns the storage size of a symbol (formal argument) or
1589 zero if it cannot be determined. */
1591 static unsigned long
1592 get_sym_storage_size (gfc_symbol
*sym
)
1595 unsigned long strlen
, elements
;
1597 if (sym
->ts
.type
== BT_CHARACTER
)
1599 if (sym
->ts
.cl
&& sym
->ts
.cl
->length
1600 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1601 strlen
= mpz_get_ui (sym
->ts
.cl
->length
->value
.integer
);
1608 if (symbol_rank (sym
) == 0)
1612 if (sym
->as
->type
!= AS_EXPLICIT
)
1614 for (i
= 0; i
< sym
->as
->rank
; i
++)
1616 if (!sym
->as
|| sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1617 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1620 elements
*= mpz_get_ui (sym
->as
->upper
[i
]->value
.integer
)
1621 - mpz_get_ui (sym
->as
->lower
[i
]->value
.integer
) + 1L;
1624 return strlen
*elements
;
1628 /* Returns the storage size of an expression (actual argument) or
1629 zero if it cannot be determined. For an array element, it returns
1630 the remaining size as the element sequence consists of all storage
1631 units of the actual argument up to the end of the array. */
1633 static unsigned long
1634 get_expr_storage_size (gfc_expr
*e
)
1637 long int strlen
, elements
;
1638 long int substrlen
= 0;
1639 bool is_str_storage
= false;
1645 if (e
->ts
.type
== BT_CHARACTER
)
1647 if (e
->ts
.cl
&& e
->ts
.cl
->length
1648 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1649 strlen
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
1650 else if (e
->expr_type
== EXPR_CONSTANT
1651 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
1652 strlen
= e
->value
.character
.length
;
1657 strlen
= 1; /* Length per element. */
1659 if (e
->rank
== 0 && !e
->ref
)
1667 for (i
= 0; i
< e
->rank
; i
++)
1668 elements
*= mpz_get_si (e
->shape
[i
]);
1669 return elements
*strlen
;
1672 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1674 if (ref
->type
== REF_SUBSTRING
&& ref
->u
.ss
.start
1675 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
)
1679 /* The string length is the substring length.
1680 Set now to full string length. */
1681 if (ref
->u
.ss
.length
== NULL
1682 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
)
1685 strlen
= mpz_get_ui (ref
->u
.ss
.length
->length
->value
.integer
);
1687 substrlen
= strlen
- mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1691 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
1692 && ref
->u
.ar
.start
&& ref
->u
.ar
.end
&& ref
->u
.ar
.stride
1693 && ref
->u
.ar
.as
->upper
)
1694 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1696 long int start
, end
, stride
;
1699 if (ref
->u
.ar
.stride
[i
])
1701 if (ref
->u
.ar
.stride
[i
]->expr_type
== EXPR_CONSTANT
)
1702 stride
= mpz_get_si (ref
->u
.ar
.stride
[i
]->value
.integer
);
1707 if (ref
->u
.ar
.start
[i
])
1709 if (ref
->u
.ar
.start
[i
]->expr_type
== EXPR_CONSTANT
)
1710 start
= mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
);
1714 else if (ref
->u
.ar
.as
->lower
[i
]
1715 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
)
1716 start
= mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
);
1720 if (ref
->u
.ar
.end
[i
])
1722 if (ref
->u
.ar
.end
[i
]->expr_type
== EXPR_CONSTANT
)
1723 end
= mpz_get_si (ref
->u
.ar
.end
[i
]->value
.integer
);
1727 else if (ref
->u
.ar
.as
->upper
[i
]
1728 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1729 end
= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
);
1733 elements
*= (end
- start
)/stride
+ 1L;
1735 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_FULL
1736 && ref
->u
.ar
.as
->lower
&& ref
->u
.ar
.as
->upper
)
1737 for (i
= 0; i
< ref
->u
.ar
.as
->rank
; i
++)
1739 if (ref
->u
.ar
.as
->lower
[i
] && ref
->u
.ar
.as
->upper
[i
]
1740 && ref
->u
.ar
.as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1741 && ref
->u
.ar
.as
->upper
[i
]->expr_type
== EXPR_CONSTANT
)
1742 elements
*= mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1743 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1748 else if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
1749 && e
->expr_type
== EXPR_VARIABLE
)
1751 if (e
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
1752 || e
->symtree
->n
.sym
->attr
.pointer
)
1758 /* Determine the number of remaining elements in the element
1759 sequence for array element designators. */
1760 is_str_storage
= true;
1761 for (i
= ref
->u
.ar
.dimen
- 1; i
>= 0; i
--)
1763 if (ref
->u
.ar
.start
[i
] == NULL
1764 || ref
->u
.ar
.start
[i
]->expr_type
!= EXPR_CONSTANT
1765 || ref
->u
.ar
.as
->upper
[i
] == NULL
1766 || ref
->u
.ar
.as
->lower
[i
] == NULL
1767 || ref
->u
.ar
.as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1768 || ref
->u
.ar
.as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1773 * (mpz_get_si (ref
->u
.ar
.as
->upper
[i
]->value
.integer
)
1774 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
)
1776 - (mpz_get_si (ref
->u
.ar
.start
[i
]->value
.integer
)
1777 - mpz_get_si (ref
->u
.ar
.as
->lower
[i
]->value
.integer
));
1785 return (is_str_storage
) ? substrlen
+ (elements
-1)*strlen
1788 return elements
*strlen
;
1792 /* Given an expression, check whether it is an array section
1793 which has a vector subscript. If it has, one is returned,
1797 has_vector_subscript (gfc_expr
*e
)
1802 if (e
== NULL
|| e
->rank
== 0 || e
->expr_type
!= EXPR_VARIABLE
)
1805 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1806 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
1807 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1808 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
1815 /* Given formal and actual argument lists, see if they are compatible.
1816 If they are compatible, the actual argument list is sorted to
1817 correspond with the formal list, and elements for missing optional
1818 arguments are inserted. If WHERE pointer is nonnull, then we issue
1819 errors when things don't match instead of just returning the status
1823 compare_actual_formal (gfc_actual_arglist
**ap
, gfc_formal_arglist
*formal
,
1824 int ranks_must_agree
, int is_elemental
, locus
*where
)
1826 gfc_actual_arglist
**new, *a
, *actual
, temp
;
1827 gfc_formal_arglist
*f
;
1829 unsigned long actual_size
, formal_size
;
1833 if (actual
== NULL
&& formal
== NULL
)
1837 for (f
= formal
; f
; f
= f
->next
)
1840 new = (gfc_actual_arglist
**) alloca (n
* sizeof (gfc_actual_arglist
*));
1842 for (i
= 0; i
< n
; i
++)
1849 for (a
= actual
; a
; a
= a
->next
, f
= f
->next
)
1851 /* Look for keywords but ignore g77 extensions like %VAL. */
1852 if (a
->name
!= NULL
&& a
->name
[0] != '%')
1855 for (f
= formal
; f
; f
= f
->next
, i
++)
1859 if (strcmp (f
->sym
->name
, a
->name
) == 0)
1866 gfc_error ("Keyword argument '%s' at %L is not in "
1867 "the procedure", a
->name
, &a
->expr
->where
);
1874 gfc_error ("Keyword argument '%s' at %L is already associated "
1875 "with another actual argument", a
->name
,
1884 gfc_error ("More actual than formal arguments in procedure "
1885 "call at %L", where
);
1890 if (f
->sym
== NULL
&& a
->expr
== NULL
)
1896 gfc_error ("Missing alternate return spec in subroutine call "
1901 if (a
->expr
== NULL
)
1904 gfc_error ("Unexpected alternate return spec in subroutine "
1905 "call at %L", where
);
1909 if (!compare_parameter (f
->sym
, a
->expr
, ranks_must_agree
,
1910 is_elemental
, where
))
1913 /* Special case for character arguments. For allocatable, pointer
1914 and assumed-shape dummies, the string length needs to match
1916 if (a
->expr
->ts
.type
== BT_CHARACTER
1917 && a
->expr
->ts
.cl
&& a
->expr
->ts
.cl
->length
1918 && a
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
1919 && f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
&& f
->sym
->ts
.cl
->length
1920 && f
->sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
1921 && (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
1922 || (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
1923 && (mpz_cmp (a
->expr
->ts
.cl
->length
->value
.integer
,
1924 f
->sym
->ts
.cl
->length
->value
.integer
) != 0))
1926 if (where
&& (f
->sym
->attr
.pointer
|| f
->sym
->attr
.allocatable
))
1927 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1928 "argument and pointer or allocatable dummy argument "
1930 mpz_get_si (a
->expr
->ts
.cl
->length
->value
.integer
),
1931 mpz_get_si (f
->sym
->ts
.cl
->length
->value
.integer
),
1932 f
->sym
->name
, &a
->expr
->where
);
1934 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1935 "argument and assumed-shape dummy argument '%s' "
1937 mpz_get_si (a
->expr
->ts
.cl
->length
->value
.integer
),
1938 mpz_get_si (f
->sym
->ts
.cl
->length
->value
.integer
),
1939 f
->sym
->name
, &a
->expr
->where
);
1943 actual_size
= get_expr_storage_size (a
->expr
);
1944 formal_size
= get_sym_storage_size (f
->sym
);
1945 if (actual_size
!= 0
1946 && actual_size
< formal_size
1947 && a
->expr
->ts
.type
!= BT_PROCEDURE
)
1949 if (a
->expr
->ts
.type
== BT_CHARACTER
&& !f
->sym
->as
&& where
)
1950 gfc_warning ("Character length of actual argument shorter "
1951 "than of dummy argument '%s' (%lu/%lu) at %L",
1952 f
->sym
->name
, actual_size
, formal_size
,
1955 gfc_warning ("Actual argument contains too few "
1956 "elements for dummy argument '%s' (%lu/%lu) at %L",
1957 f
->sym
->name
, actual_size
, formal_size
,
1962 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
1963 is provided for a procedure pointer formal argument. */
1964 if (f
->sym
->attr
.proc_pointer
1965 && !a
->expr
->symtree
->n
.sym
->attr
.proc_pointer
)
1968 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
1969 f
->sym
->name
, &a
->expr
->where
);
1973 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1974 provided for a procedure formal argument. */
1975 if (a
->expr
->ts
.type
!= BT_PROCEDURE
1976 && a
->expr
->expr_type
== EXPR_VARIABLE
1977 && f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1980 gfc_error ("Expected a procedure for argument '%s' at %L",
1981 f
->sym
->name
, &a
->expr
->where
);
1985 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
&& f
->sym
->attr
.pure
1986 && a
->expr
->ts
.type
== BT_PROCEDURE
1987 && !a
->expr
->symtree
->n
.sym
->attr
.pure
)
1990 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1991 f
->sym
->name
, &a
->expr
->where
);
1995 if (f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
1996 && a
->expr
->expr_type
== EXPR_VARIABLE
1997 && a
->expr
->symtree
->n
.sym
->as
1998 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SIZE
1999 && (a
->expr
->ref
== NULL
2000 || (a
->expr
->ref
->type
== REF_ARRAY
2001 && a
->expr
->ref
->u
.ar
.type
== AR_FULL
)))
2004 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2005 " array at %L", f
->sym
->name
, where
);
2009 if (a
->expr
->expr_type
!= EXPR_NULL
2010 && compare_pointer (f
->sym
, a
->expr
) == 0)
2013 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2014 f
->sym
->name
, &a
->expr
->where
);
2018 if (a
->expr
->expr_type
!= EXPR_NULL
2019 && compare_allocatable (f
->sym
, a
->expr
) == 0)
2022 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2023 f
->sym
->name
, &a
->expr
->where
);
2027 /* Check intent = OUT/INOUT for definable actual argument. */
2028 if ((a
->expr
->expr_type
!= EXPR_VARIABLE
2029 || (a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
2030 && a
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
))
2031 && (f
->sym
->attr
.intent
== INTENT_OUT
2032 || f
->sym
->attr
.intent
== INTENT_INOUT
))
2035 gfc_error ("Actual argument at %L must be definable as "
2036 "the dummy argument '%s' is INTENT = OUT/INOUT",
2037 &a
->expr
->where
, f
->sym
->name
);
2041 if (!compare_parameter_protected(f
->sym
, a
->expr
))
2044 gfc_error ("Actual argument at %L is use-associated with "
2045 "PROTECTED attribute and dummy argument '%s' is "
2046 "INTENT = OUT/INOUT",
2047 &a
->expr
->where
,f
->sym
->name
);
2051 if ((f
->sym
->attr
.intent
== INTENT_OUT
2052 || f
->sym
->attr
.intent
== INTENT_INOUT
2053 || f
->sym
->attr
.volatile_
)
2054 && has_vector_subscript (a
->expr
))
2057 gfc_error ("Array-section actual argument with vector subscripts "
2058 "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
2059 "or VOLATILE attribute of the dummy argument '%s'",
2060 &a
->expr
->where
, f
->sym
->name
);
2064 /* C1232 (R1221) For an actual argument which is an array section or
2065 an assumed-shape array, the dummy argument shall be an assumed-
2066 shape array, if the dummy argument has the VOLATILE attribute. */
2068 if (f
->sym
->attr
.volatile_
2069 && a
->expr
->symtree
->n
.sym
->as
2070 && a
->expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
2071 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2074 gfc_error ("Assumed-shape actual argument at %L is "
2075 "incompatible with the non-assumed-shape "
2076 "dummy argument '%s' due to VOLATILE attribute",
2077 &a
->expr
->where
,f
->sym
->name
);
2081 if (f
->sym
->attr
.volatile_
2082 && a
->expr
->ref
&& a
->expr
->ref
->u
.ar
.type
== AR_SECTION
2083 && !(f
->sym
->as
&& f
->sym
->as
->type
== AS_ASSUMED_SHAPE
))
2086 gfc_error ("Array-section actual argument at %L is "
2087 "incompatible with the non-assumed-shape "
2088 "dummy argument '%s' due to VOLATILE attribute",
2089 &a
->expr
->where
,f
->sym
->name
);
2093 /* C1233 (R1221) For an actual argument which is a pointer array, the
2094 dummy argument shall be an assumed-shape or pointer array, if the
2095 dummy argument has the VOLATILE attribute. */
2097 if (f
->sym
->attr
.volatile_
2098 && a
->expr
->symtree
->n
.sym
->attr
.pointer
2099 && a
->expr
->symtree
->n
.sym
->as
2101 && (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
2102 || f
->sym
->attr
.pointer
)))
2105 gfc_error ("Pointer-array actual argument at %L requires "
2106 "an assumed-shape or pointer-array dummy "
2107 "argument '%s' due to VOLATILE attribute",
2108 &a
->expr
->where
,f
->sym
->name
);
2119 /* Make sure missing actual arguments are optional. */
2121 for (f
= formal
; f
; f
= f
->next
, i
++)
2128 gfc_error ("Missing alternate return spec in subroutine call "
2132 if (!f
->sym
->attr
.optional
)
2135 gfc_error ("Missing actual argument for argument '%s' at %L",
2136 f
->sym
->name
, where
);
2141 /* The argument lists are compatible. We now relink a new actual
2142 argument list with null arguments in the right places. The head
2143 of the list remains the head. */
2144 for (i
= 0; i
< n
; i
++)
2146 new[i
] = gfc_get_actual_arglist ();
2159 for (i
= 0; i
< n
- 1; i
++)
2160 new[i
]->next
= new[i
+ 1];
2162 new[i
]->next
= NULL
;
2164 if (*ap
== NULL
&& n
> 0)
2167 /* Note the types of omitted optional arguments. */
2168 for (a
= *ap
, f
= formal
; a
; a
= a
->next
, f
= f
->next
)
2169 if (a
->expr
== NULL
&& a
->label
== NULL
)
2170 a
->missing_arg_type
= f
->sym
->ts
.type
;
2178 gfc_formal_arglist
*f
;
2179 gfc_actual_arglist
*a
;
2183 /* qsort comparison function for argument pairs, with the following
2185 - p->a->expr == NULL
2186 - p->a->expr->expr_type != EXPR_VARIABLE
2187 - growing p->a->expr->symbol. */
2190 pair_cmp (const void *p1
, const void *p2
)
2192 const gfc_actual_arglist
*a1
, *a2
;
2194 /* *p1 and *p2 are elements of the to-be-sorted array. */
2195 a1
= ((const argpair
*) p1
)->a
;
2196 a2
= ((const argpair
*) p2
)->a
;
2205 if (a1
->expr
->expr_type
!= EXPR_VARIABLE
)
2207 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2211 if (a2
->expr
->expr_type
!= EXPR_VARIABLE
)
2213 return a1
->expr
->symtree
->n
.sym
< a2
->expr
->symtree
->n
.sym
;
2217 /* Given two expressions from some actual arguments, test whether they
2218 refer to the same expression. The analysis is conservative.
2219 Returning FAILURE will produce no warning. */
2222 compare_actual_expr (gfc_expr
*e1
, gfc_expr
*e2
)
2224 const gfc_ref
*r1
, *r2
;
2227 || e1
->expr_type
!= EXPR_VARIABLE
2228 || e2
->expr_type
!= EXPR_VARIABLE
2229 || e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
2232 /* TODO: improve comparison, see expr.c:show_ref(). */
2233 for (r1
= e1
->ref
, r2
= e2
->ref
; r1
&& r2
; r1
= r1
->next
, r2
= r2
->next
)
2235 if (r1
->type
!= r2
->type
)
2240 if (r1
->u
.ar
.type
!= r2
->u
.ar
.type
)
2242 /* TODO: At the moment, consider only full arrays;
2243 we could do better. */
2244 if (r1
->u
.ar
.type
!= AR_FULL
|| r2
->u
.ar
.type
!= AR_FULL
)
2249 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
2257 gfc_internal_error ("compare_actual_expr(): Bad component code");
2266 /* Given formal and actual argument lists that correspond to one
2267 another, check that identical actual arguments aren't not
2268 associated with some incompatible INTENTs. */
2271 check_some_aliasing (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2273 sym_intent f1_intent
, f2_intent
;
2274 gfc_formal_arglist
*f1
;
2275 gfc_actual_arglist
*a1
;
2281 for (f1
= f
, a1
= a
;; f1
= f1
->next
, a1
= a1
->next
)
2283 if (f1
== NULL
&& a1
== NULL
)
2285 if (f1
== NULL
|| a1
== NULL
)
2286 gfc_internal_error ("check_some_aliasing(): List mismatch");
2291 p
= (argpair
*) alloca (n
* sizeof (argpair
));
2293 for (i
= 0, f1
= f
, a1
= a
; i
< n
; i
++, f1
= f1
->next
, a1
= a1
->next
)
2299 qsort (p
, n
, sizeof (argpair
), pair_cmp
);
2301 for (i
= 0; i
< n
; i
++)
2304 || p
[i
].a
->expr
->expr_type
!= EXPR_VARIABLE
2305 || p
[i
].a
->expr
->ts
.type
== BT_PROCEDURE
)
2307 f1_intent
= p
[i
].f
->sym
->attr
.intent
;
2308 for (j
= i
+ 1; j
< n
; j
++)
2310 /* Expected order after the sort. */
2311 if (!p
[j
].a
->expr
|| p
[j
].a
->expr
->expr_type
!= EXPR_VARIABLE
)
2312 gfc_internal_error ("check_some_aliasing(): corrupted data");
2314 /* Are the expression the same? */
2315 if (compare_actual_expr (p
[i
].a
->expr
, p
[j
].a
->expr
) == FAILURE
)
2317 f2_intent
= p
[j
].f
->sym
->attr
.intent
;
2318 if ((f1_intent
== INTENT_IN
&& f2_intent
== INTENT_OUT
)
2319 || (f1_intent
== INTENT_OUT
&& f2_intent
== INTENT_IN
))
2321 gfc_warning ("Same actual argument associated with INTENT(%s) "
2322 "argument '%s' and INTENT(%s) argument '%s' at %L",
2323 gfc_intent_string (f1_intent
), p
[i
].f
->sym
->name
,
2324 gfc_intent_string (f2_intent
), p
[j
].f
->sym
->name
,
2325 &p
[i
].a
->expr
->where
);
2335 /* Given a symbol of a formal argument list and an expression,
2336 return nonzero if their intents are compatible, zero otherwise. */
2339 compare_parameter_intent (gfc_symbol
*formal
, gfc_expr
*actual
)
2341 if (actual
->symtree
->n
.sym
->attr
.pointer
&& !formal
->attr
.pointer
)
2344 if (actual
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
)
2347 if (formal
->attr
.intent
== INTENT_INOUT
|| formal
->attr
.intent
== INTENT_OUT
)
2354 /* Given formal and actual argument lists that correspond to one
2355 another, check that they are compatible in the sense that intents
2356 are not mismatched. */
2359 check_intents (gfc_formal_arglist
*f
, gfc_actual_arglist
*a
)
2361 sym_intent f_intent
;
2363 for (;; f
= f
->next
, a
= a
->next
)
2365 if (f
== NULL
&& a
== NULL
)
2367 if (f
== NULL
|| a
== NULL
)
2368 gfc_internal_error ("check_intents(): List mismatch");
2370 if (a
->expr
== NULL
|| a
->expr
->expr_type
!= EXPR_VARIABLE
)
2373 f_intent
= f
->sym
->attr
.intent
;
2375 if (!compare_parameter_intent(f
->sym
, a
->expr
))
2377 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2378 "specifies INTENT(%s)", &a
->expr
->where
,
2379 gfc_intent_string (f_intent
));
2383 if (gfc_pure (NULL
) && gfc_impure_variable (a
->expr
->symtree
->n
.sym
))
2385 if (f_intent
== INTENT_INOUT
|| f_intent
== INTENT_OUT
)
2387 gfc_error ("Procedure argument at %L is local to a PURE "
2388 "procedure and is passed to an INTENT(%s) argument",
2389 &a
->expr
->where
, gfc_intent_string (f_intent
));
2393 if (f
->sym
->attr
.pointer
)
2395 gfc_error ("Procedure argument at %L is local to a PURE "
2396 "procedure and has the POINTER attribute",
2407 /* Check how a procedure is used against its interface. If all goes
2408 well, the actual argument list will also end up being properly
2412 gfc_procedure_use (gfc_symbol
*sym
, gfc_actual_arglist
**ap
, locus
*where
)
2415 /* Warn about calls with an implicit interface. */
2416 if (gfc_option
.warn_implicit_interface
2417 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2418 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2421 if (sym
->ts
.interface
&& sym
->ts
.interface
->attr
.intrinsic
)
2423 gfc_intrinsic_sym
*isym
;
2424 isym
= gfc_find_function (sym
->ts
.interface
->name
);
2427 if (compare_actual_formal_intr (ap
, sym
->ts
.interface
))
2429 gfc_error ("Type/rank mismatch in argument '%s' at %L",
2435 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2437 gfc_actual_arglist
*a
;
2438 for (a
= *ap
; a
; a
= a
->next
)
2440 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2441 if (a
->name
!= NULL
&& a
->name
[0] != '%')
2443 gfc_error("Keyword argument requires explicit interface "
2444 "for procedure '%s' at %L", sym
->name
, &a
->expr
->where
);
2452 if (!compare_actual_formal (ap
, sym
->formal
, 0,
2453 sym
->attr
.elemental
, where
))
2456 check_intents (sym
->formal
, *ap
);
2457 if (gfc_option
.warn_aliasing
)
2458 check_some_aliasing (sym
->formal
, *ap
);
2462 /* Given an interface pointer and an actual argument list, search for
2463 a formal argument list that matches the actual. If found, returns
2464 a pointer to the symbol of the correct interface. Returns NULL if
2468 gfc_search_interface (gfc_interface
*intr
, int sub_flag
,
2469 gfc_actual_arglist
**ap
)
2473 for (; intr
; intr
= intr
->next
)
2475 if (sub_flag
&& intr
->sym
->attr
.function
)
2477 if (!sub_flag
&& intr
->sym
->attr
.subroutine
)
2480 r
= !intr
->sym
->attr
.elemental
;
2482 if (compare_actual_formal (ap
, intr
->sym
->formal
, r
, !r
, NULL
))
2484 check_intents (intr
->sym
->formal
, *ap
);
2485 if (gfc_option
.warn_aliasing
)
2486 check_some_aliasing (intr
->sym
->formal
, *ap
);
2495 /* Do a brute force recursive search for a symbol. */
2497 static gfc_symtree
*
2498 find_symtree0 (gfc_symtree
*root
, gfc_symbol
*sym
)
2502 if (root
->n
.sym
== sym
)
2507 st
= find_symtree0 (root
->left
, sym
);
2508 if (root
->right
&& ! st
)
2509 st
= find_symtree0 (root
->right
, sym
);
2514 /* Find a symtree for a symbol. */
2516 static gfc_symtree
*
2517 find_sym_in_symtree (gfc_symbol
*sym
)
2522 /* First try to find it by name. */
2523 gfc_find_sym_tree (sym
->name
, gfc_current_ns
, 1, &st
);
2524 if (st
&& st
->n
.sym
== sym
)
2527 /* If it's been renamed, resort to a brute-force search. */
2528 /* TODO: avoid having to do this search. If the symbol doesn't exist
2529 in the symtree for the current namespace, it should probably be added. */
2530 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2532 st
= find_symtree0 (ns
->sym_root
, sym
);
2536 gfc_internal_error ("Unable to find symbol %s", sym
->name
);
2541 /* This subroutine is called when an expression is being resolved.
2542 The expression node in question is either a user defined operator
2543 or an intrinsic operator with arguments that aren't compatible
2544 with the operator. This subroutine builds an actual argument list
2545 corresponding to the operands, then searches for a compatible
2546 interface. If one is found, the expression node is replaced with
2547 the appropriate function call. */
2550 gfc_extend_expr (gfc_expr
*e
)
2552 gfc_actual_arglist
*actual
;
2560 actual
= gfc_get_actual_arglist ();
2561 actual
->expr
= e
->value
.op
.op1
;
2563 if (e
->value
.op
.op2
!= NULL
)
2565 actual
->next
= gfc_get_actual_arglist ();
2566 actual
->next
->expr
= e
->value
.op
.op2
;
2569 i
= fold_unary (e
->value
.op
.operator);
2571 if (i
== INTRINSIC_USER
)
2573 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2575 uop
= gfc_find_uop (e
->value
.op
.uop
->name
, ns
);
2579 sym
= gfc_search_interface (uop
->operator, 0, &actual
);
2586 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2588 /* Due to the distinction between '==' and '.eq.' and friends, one has
2589 to check if either is defined. */
2593 case INTRINSIC_EQ_OS
:
2594 sym
= gfc_search_interface (ns
->operator[INTRINSIC_EQ
], 0, &actual
);
2596 sym
= gfc_search_interface (ns
->operator[INTRINSIC_EQ_OS
], 0, &actual
);
2600 case INTRINSIC_NE_OS
:
2601 sym
= gfc_search_interface (ns
->operator[INTRINSIC_NE
], 0, &actual
);
2603 sym
= gfc_search_interface (ns
->operator[INTRINSIC_NE_OS
], 0, &actual
);
2607 case INTRINSIC_GT_OS
:
2608 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GT
], 0, &actual
);
2610 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GT_OS
], 0, &actual
);
2614 case INTRINSIC_GE_OS
:
2615 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GE
], 0, &actual
);
2617 sym
= gfc_search_interface (ns
->operator[INTRINSIC_GE_OS
], 0, &actual
);
2621 case INTRINSIC_LT_OS
:
2622 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LT
], 0, &actual
);
2624 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LT_OS
], 0, &actual
);
2628 case INTRINSIC_LE_OS
:
2629 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LE
], 0, &actual
);
2631 sym
= gfc_search_interface (ns
->operator[INTRINSIC_LE_OS
], 0, &actual
);
2635 sym
= gfc_search_interface (ns
->operator[i
], 0, &actual
);
2645 /* Don't use gfc_free_actual_arglist(). */
2646 if (actual
->next
!= NULL
)
2647 gfc_free (actual
->next
);
2653 /* Change the expression node to a function call. */
2654 e
->expr_type
= EXPR_FUNCTION
;
2655 e
->symtree
= find_sym_in_symtree (sym
);
2656 e
->value
.function
.actual
= actual
;
2657 e
->value
.function
.esym
= NULL
;
2658 e
->value
.function
.isym
= NULL
;
2659 e
->value
.function
.name
= NULL
;
2661 if (gfc_pure (NULL
) && !gfc_pure (sym
))
2663 gfc_error ("Function '%s' called in lieu of an operator at %L must "
2664 "be PURE", sym
->name
, &e
->where
);
2668 if (gfc_resolve_expr (e
) == FAILURE
)
2675 /* Tries to replace an assignment code node with a subroutine call to
2676 the subroutine associated with the assignment operator. Return
2677 SUCCESS if the node was replaced. On FAILURE, no error is
2681 gfc_extend_assign (gfc_code
*c
, gfc_namespace
*ns
)
2683 gfc_actual_arglist
*actual
;
2684 gfc_expr
*lhs
, *rhs
;
2690 /* Don't allow an intrinsic assignment to be replaced. */
2691 if (lhs
->ts
.type
!= BT_DERIVED
2692 && (rhs
->rank
== 0 || rhs
->rank
== lhs
->rank
)
2693 && (lhs
->ts
.type
== rhs
->ts
.type
2694 || (gfc_numeric_ts (&lhs
->ts
) && gfc_numeric_ts (&rhs
->ts
))))
2697 actual
= gfc_get_actual_arglist ();
2700 actual
->next
= gfc_get_actual_arglist ();
2701 actual
->next
->expr
= rhs
;
2705 for (; ns
; ns
= ns
->parent
)
2707 sym
= gfc_search_interface (ns
->operator[INTRINSIC_ASSIGN
], 1, &actual
);
2714 gfc_free (actual
->next
);
2719 /* Replace the assignment with the call. */
2720 c
->op
= EXEC_ASSIGN_CALL
;
2721 c
->symtree
= find_sym_in_symtree (sym
);
2724 c
->ext
.actual
= actual
;
2730 /* Make sure that the interface just parsed is not already present in
2731 the given interface list. Ambiguity isn't checked yet since module
2732 procedures can be present without interfaces. */
2735 check_new_interface (gfc_interface
*base
, gfc_symbol
*new)
2739 for (ip
= base
; ip
; ip
= ip
->next
)
2743 gfc_error ("Entity '%s' at %C is already present in the interface",
2753 /* Add a symbol to the current interface. */
2756 gfc_add_interface (gfc_symbol
*new)
2758 gfc_interface
**head
, *intr
;
2762 switch (current_interface
.type
)
2764 case INTERFACE_NAMELESS
:
2765 case INTERFACE_ABSTRACT
:
2768 case INTERFACE_INTRINSIC_OP
:
2769 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2770 switch (current_interface
.op
)
2773 case INTRINSIC_EQ_OS
:
2774 if (check_new_interface (ns
->operator[INTRINSIC_EQ
], new) == FAILURE
||
2775 check_new_interface (ns
->operator[INTRINSIC_EQ_OS
], new) == FAILURE
)
2780 case INTRINSIC_NE_OS
:
2781 if (check_new_interface (ns
->operator[INTRINSIC_NE
], new) == FAILURE
||
2782 check_new_interface (ns
->operator[INTRINSIC_NE_OS
], new) == FAILURE
)
2787 case INTRINSIC_GT_OS
:
2788 if (check_new_interface (ns
->operator[INTRINSIC_GT
], new) == FAILURE
||
2789 check_new_interface (ns
->operator[INTRINSIC_GT_OS
], new) == FAILURE
)
2794 case INTRINSIC_GE_OS
:
2795 if (check_new_interface (ns
->operator[INTRINSIC_GE
], new) == FAILURE
||
2796 check_new_interface (ns
->operator[INTRINSIC_GE_OS
], new) == FAILURE
)
2801 case INTRINSIC_LT_OS
:
2802 if (check_new_interface (ns
->operator[INTRINSIC_LT
], new) == FAILURE
||
2803 check_new_interface (ns
->operator[INTRINSIC_LT_OS
], new) == FAILURE
)
2808 case INTRINSIC_LE_OS
:
2809 if (check_new_interface (ns
->operator[INTRINSIC_LE
], new) == FAILURE
||
2810 check_new_interface (ns
->operator[INTRINSIC_LE_OS
], new) == FAILURE
)
2815 if (check_new_interface (ns
->operator[current_interface
.op
], new) == FAILURE
)
2819 head
= ¤t_interface
.ns
->operator[current_interface
.op
];
2822 case INTERFACE_GENERIC
:
2823 for (ns
= current_interface
.ns
; ns
; ns
= ns
->parent
)
2825 gfc_find_symbol (current_interface
.sym
->name
, ns
, 0, &sym
);
2829 if (check_new_interface (sym
->generic
, new) == FAILURE
)
2833 head
= ¤t_interface
.sym
->generic
;
2836 case INTERFACE_USER_OP
:
2837 if (check_new_interface (current_interface
.uop
->operator, new)
2841 head
= ¤t_interface
.uop
->operator;
2845 gfc_internal_error ("gfc_add_interface(): Bad interface type");
2848 intr
= gfc_get_interface ();
2850 intr
->where
= gfc_current_locus
;
2860 gfc_current_interface_head (void)
2862 switch (current_interface
.type
)
2864 case INTERFACE_INTRINSIC_OP
:
2865 return current_interface
.ns
->operator[current_interface
.op
];
2868 case INTERFACE_GENERIC
:
2869 return current_interface
.sym
->generic
;
2872 case INTERFACE_USER_OP
:
2873 return current_interface
.uop
->operator;
2883 gfc_set_current_interface_head (gfc_interface
*i
)
2885 switch (current_interface
.type
)
2887 case INTERFACE_INTRINSIC_OP
:
2888 current_interface
.ns
->operator[current_interface
.op
] = i
;
2891 case INTERFACE_GENERIC
:
2892 current_interface
.sym
->generic
= i
;
2895 case INTERFACE_USER_OP
:
2896 current_interface
.uop
->operator = i
;
2905 /* Gets rid of a formal argument list. We do not free symbols.
2906 Symbols are freed when a namespace is freed. */
2909 gfc_free_formal_arglist (gfc_formal_arglist
*p
)
2911 gfc_formal_arglist
*q
;