1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
27 #include "arith.h" /* For gfc_compare_expr(). */
28 #include "dependency.h"
30 /* Types used in equivalence statements. */
34 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
38 /* Stack to push the current if we descend into a block during
39 resolution. See resolve_branch() and resolve_code(). */
41 typedef struct code_stack
43 struct gfc_code
*head
, *current
;
44 struct code_stack
*prev
;
48 static code_stack
*cs_base
= NULL
;
51 /* Nonzero if we're inside a FORALL block. */
53 static int forall_flag
;
55 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
57 static int omp_workshare_flag
;
59 /* Nonzero if we are processing a formal arglist. The corresponding function
60 resets the flag each time that it is read. */
61 static int formal_arg_flag
= 0;
63 /* True if we are resolving a specification expression. */
64 static int specification_expr
= 0;
66 /* The id of the last entry seen. */
67 static int current_entry_id
;
70 gfc_is_formal_arg (void)
72 return formal_arg_flag
;
75 /* Resolve types of formal argument lists. These have to be done early so that
76 the formal argument lists of module procedures can be copied to the
77 containing module before the individual procedures are resolved
78 individually. We also resolve argument lists of procedures in interface
79 blocks because they are self-contained scoping units.
81 Since a dummy argument cannot be a non-dummy procedure, the only
82 resort left for untyped names are the IMPLICIT types. */
85 resolve_formal_arglist (gfc_symbol
*proc
)
87 gfc_formal_arglist
*f
;
91 if (proc
->result
!= NULL
)
96 if (gfc_elemental (proc
)
97 || sym
->attr
.pointer
|| sym
->attr
.allocatable
98 || (sym
->as
&& sym
->as
->rank
> 0))
99 proc
->attr
.always_explicit
= 1;
103 for (f
= proc
->formal
; f
; f
= f
->next
)
109 /* Alternate return placeholder. */
110 if (gfc_elemental (proc
))
111 gfc_error ("Alternate return specifier in elemental subroutine "
112 "'%s' at %L is not allowed", proc
->name
,
114 if (proc
->attr
.function
)
115 gfc_error ("Alternate return specifier in function "
116 "'%s' at %L is not allowed", proc
->name
,
121 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
122 resolve_formal_arglist (sym
);
124 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
126 if (gfc_pure (proc
) && !gfc_pure (sym
))
128 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
129 "also be PURE", sym
->name
, &sym
->declared_at
);
133 if (gfc_elemental (proc
))
135 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
136 "procedure", &sym
->declared_at
);
140 if (sym
->attr
.function
141 && sym
->ts
.type
== BT_UNKNOWN
142 && sym
->attr
.intrinsic
)
144 gfc_intrinsic_sym
*isym
;
145 isym
= gfc_find_function (sym
->name
);
146 if (isym
== NULL
|| !isym
->specific
)
148 gfc_error ("Unable to find a specific INTRINSIC procedure "
149 "for the reference '%s' at %L", sym
->name
,
158 if (sym
->ts
.type
== BT_UNKNOWN
)
160 if (!sym
->attr
.function
|| sym
->result
== sym
)
161 gfc_set_default_type (sym
, 1, sym
->ns
);
164 gfc_resolve_array_spec (sym
->as
, 0);
166 /* We can't tell if an array with dimension (:) is assumed or deferred
167 shape until we know if it has the pointer or allocatable attributes.
169 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
170 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
172 sym
->as
->type
= AS_ASSUMED_SHAPE
;
173 for (i
= 0; i
< sym
->as
->rank
; i
++)
174 sym
->as
->lower
[i
] = gfc_int_expr (1);
177 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
178 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
179 || sym
->attr
.optional
)
180 proc
->attr
.always_explicit
= 1;
182 /* If the flavor is unknown at this point, it has to be a variable.
183 A procedure specification would have already set the type. */
185 if (sym
->attr
.flavor
== FL_UNKNOWN
)
186 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
188 if (gfc_pure (proc
) && !sym
->attr
.pointer
189 && sym
->attr
.flavor
!= FL_PROCEDURE
)
191 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
192 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
193 "INTENT(IN)", sym
->name
, proc
->name
,
196 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
197 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
198 "have its INTENT specified", sym
->name
, proc
->name
,
202 if (gfc_elemental (proc
))
206 gfc_error ("Argument '%s' of elemental procedure at %L must "
207 "be scalar", sym
->name
, &sym
->declared_at
);
211 if (sym
->attr
.pointer
)
213 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
214 "have the POINTER attribute", sym
->name
,
220 /* Each dummy shall be specified to be scalar. */
221 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
225 gfc_error ("Argument '%s' of statement function at %L must "
226 "be scalar", sym
->name
, &sym
->declared_at
);
230 if (sym
->ts
.type
== BT_CHARACTER
)
232 gfc_charlen
*cl
= sym
->ts
.cl
;
233 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
235 gfc_error ("Character-valued argument '%s' of statement "
236 "function at %L must have constant length",
237 sym
->name
, &sym
->declared_at
);
247 /* Work function called when searching for symbols that have argument lists
248 associated with them. */
251 find_arglists (gfc_symbol
*sym
)
253 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
256 resolve_formal_arglist (sym
);
260 /* Given a namespace, resolve all formal argument lists within the namespace.
264 resolve_formal_arglists (gfc_namespace
*ns
)
269 gfc_traverse_ns (ns
, find_arglists
);
274 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
278 /* If this namespace is not a function, ignore it. */
279 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
))
282 /* Try to find out of what the return type is. */
283 if (sym
->result
!= NULL
)
286 if (sym
->ts
.type
== BT_UNKNOWN
)
288 t
= gfc_set_default_type (sym
, 0, ns
);
290 if (t
== FAILURE
&& !sym
->attr
.untyped
)
292 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293 sym
->name
, &sym
->declared_at
); /* FIXME */
294 sym
->attr
.untyped
= 1;
298 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
299 type, lists the only ways a character length value of * can be used:
300 dummy arguments of procedures, named constants, and function results
301 in external functions. Internal function results are not on that list;
302 ergo, not permitted. */
304 if (sym
->ts
.type
== BT_CHARACTER
)
306 gfc_charlen
*cl
= sym
->ts
.cl
;
307 if (!cl
|| !cl
->length
)
308 gfc_error ("Character-valued internal function '%s' at %L must "
309 "not be assumed length", sym
->name
, &sym
->declared_at
);
314 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
315 introduce duplicates. */
318 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
320 gfc_formal_arglist
*f
, *new_arglist
;
323 for (; new_args
!= NULL
; new_args
= new_args
->next
)
325 new_sym
= new_args
->sym
;
326 /* See if this arg is already in the formal argument list. */
327 for (f
= proc
->formal
; f
; f
= f
->next
)
329 if (new_sym
== f
->sym
)
336 /* Add a new argument. Argument order is not important. */
337 new_arglist
= gfc_get_formal_arglist ();
338 new_arglist
->sym
= new_sym
;
339 new_arglist
->next
= proc
->formal
;
340 proc
->formal
= new_arglist
;
345 /* Flag the arguments that are not present in all entries. */
348 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
350 gfc_formal_arglist
*f
, *head
;
353 for (f
= proc
->formal
; f
; f
= f
->next
)
358 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
360 if (new_args
->sym
== f
->sym
)
367 f
->sym
->attr
.not_always_present
= 1;
372 /* Resolve alternate entry points. If a symbol has multiple entry points we
373 create a new master symbol for the main routine, and turn the existing
374 symbol into an entry point. */
377 resolve_entries (gfc_namespace
*ns
)
379 gfc_namespace
*old_ns
;
383 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
384 static int master_count
= 0;
386 if (ns
->proc_name
== NULL
)
389 /* No need to do anything if this procedure doesn't have alternate entry
394 /* We may already have resolved alternate entry points. */
395 if (ns
->proc_name
->attr
.entry_master
)
398 /* If this isn't a procedure something has gone horribly wrong. */
399 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
401 /* Remember the current namespace. */
402 old_ns
= gfc_current_ns
;
406 /* Add the main entry point to the list of entry points. */
407 el
= gfc_get_entry_list ();
408 el
->sym
= ns
->proc_name
;
410 el
->next
= ns
->entries
;
412 ns
->proc_name
->attr
.entry
= 1;
414 /* If it is a module function, it needs to be in the right namespace
415 so that gfc_get_fake_result_decl can gather up the results. The
416 need for this arose in get_proc_name, where these beasts were
417 left in their own namespace, to keep prior references linked to
418 the entry declaration.*/
419 if (ns
->proc_name
->attr
.function
420 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
423 /* Add an entry statement for it. */
430 /* Create a new symbol for the master function. */
431 /* Give the internal function a unique name (within this file).
432 Also include the function name so the user has some hope of figuring
433 out what is going on. */
434 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
435 master_count
++, ns
->proc_name
->name
);
436 gfc_get_ha_symbol (name
, &proc
);
437 gcc_assert (proc
!= NULL
);
439 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
440 if (ns
->proc_name
->attr
.subroutine
)
441 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
445 gfc_typespec
*ts
, *fts
;
446 gfc_array_spec
*as
, *fas
;
447 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
449 fas
= ns
->entries
->sym
->as
;
450 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
451 fts
= &ns
->entries
->sym
->result
->ts
;
452 if (fts
->type
== BT_UNKNOWN
)
453 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
454 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
456 ts
= &el
->sym
->result
->ts
;
458 as
= as
? as
: el
->sym
->result
->as
;
459 if (ts
->type
== BT_UNKNOWN
)
460 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
462 if (! gfc_compare_types (ts
, fts
)
463 || (el
->sym
->result
->attr
.dimension
464 != ns
->entries
->sym
->result
->attr
.dimension
)
465 || (el
->sym
->result
->attr
.pointer
466 != ns
->entries
->sym
->result
->attr
.pointer
))
469 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
470 gfc_error ("Procedure %s at %L has entries with mismatched "
471 "array specifications", ns
->entries
->sym
->name
,
472 &ns
->entries
->sym
->declared_at
);
477 sym
= ns
->entries
->sym
->result
;
478 /* All result types the same. */
480 if (sym
->attr
.dimension
)
481 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
482 if (sym
->attr
.pointer
)
483 gfc_add_pointer (&proc
->attr
, NULL
);
487 /* Otherwise the result will be passed through a union by
489 proc
->attr
.mixed_entry_master
= 1;
490 for (el
= ns
->entries
; el
; el
= el
->next
)
492 sym
= el
->sym
->result
;
493 if (sym
->attr
.dimension
)
495 if (el
== ns
->entries
)
496 gfc_error ("FUNCTION result %s can't be an array in "
497 "FUNCTION %s at %L", sym
->name
,
498 ns
->entries
->sym
->name
, &sym
->declared_at
);
500 gfc_error ("ENTRY result %s can't be an array in "
501 "FUNCTION %s at %L", sym
->name
,
502 ns
->entries
->sym
->name
, &sym
->declared_at
);
504 else if (sym
->attr
.pointer
)
506 if (el
== ns
->entries
)
507 gfc_error ("FUNCTION result %s can't be a POINTER in "
508 "FUNCTION %s at %L", sym
->name
,
509 ns
->entries
->sym
->name
, &sym
->declared_at
);
511 gfc_error ("ENTRY result %s can't be a POINTER in "
512 "FUNCTION %s at %L", sym
->name
,
513 ns
->entries
->sym
->name
, &sym
->declared_at
);
518 if (ts
->type
== BT_UNKNOWN
)
519 ts
= gfc_get_default_type (sym
, NULL
);
523 if (ts
->kind
== gfc_default_integer_kind
)
527 if (ts
->kind
== gfc_default_real_kind
528 || ts
->kind
== gfc_default_double_kind
)
532 if (ts
->kind
== gfc_default_complex_kind
)
536 if (ts
->kind
== gfc_default_logical_kind
)
540 /* We will issue error elsewhere. */
548 if (el
== ns
->entries
)
549 gfc_error ("FUNCTION result %s can't be of type %s "
550 "in FUNCTION %s at %L", sym
->name
,
551 gfc_typename (ts
), ns
->entries
->sym
->name
,
554 gfc_error ("ENTRY result %s can't be of type %s "
555 "in FUNCTION %s at %L", sym
->name
,
556 gfc_typename (ts
), ns
->entries
->sym
->name
,
563 proc
->attr
.access
= ACCESS_PRIVATE
;
564 proc
->attr
.entry_master
= 1;
566 /* Merge all the entry point arguments. */
567 for (el
= ns
->entries
; el
; el
= el
->next
)
568 merge_argument_lists (proc
, el
->sym
->formal
);
570 /* Check the master formal arguments for any that are not
571 present in all entry points. */
572 for (el
= ns
->entries
; el
; el
= el
->next
)
573 check_argument_lists (proc
, el
->sym
->formal
);
575 /* Use the master function for the function body. */
576 ns
->proc_name
= proc
;
578 /* Finalize the new symbols. */
579 gfc_commit_symbols ();
581 /* Restore the original namespace. */
582 gfc_current_ns
= old_ns
;
586 /* Resolve contained function types. Because contained functions can call one
587 another, they have to be worked out before any of the contained procedures
590 The good news is that if a function doesn't already have a type, the only
591 way it can get one is through an IMPLICIT type or a RESULT variable, because
592 by definition contained functions are contained namespace they're contained
593 in, not in a sibling or parent namespace. */
596 resolve_contained_functions (gfc_namespace
*ns
)
598 gfc_namespace
*child
;
601 resolve_formal_arglists (ns
);
603 for (child
= ns
->contained
; child
; child
= child
->sibling
)
605 /* Resolve alternate entry points first. */
606 resolve_entries (child
);
608 /* Then check function return types. */
609 resolve_contained_fntype (child
->proc_name
, child
);
610 for (el
= child
->entries
; el
; el
= el
->next
)
611 resolve_contained_fntype (el
->sym
, child
);
616 /* Resolve all of the elements of a structure constructor and make sure that
617 the types are correct. */
620 resolve_structure_cons (gfc_expr
*expr
)
622 gfc_constructor
*cons
;
628 cons
= expr
->value
.constructor
;
629 /* A constructor may have references if it is the result of substituting a
630 parameter variable. In this case we just pull out the component we
633 comp
= expr
->ref
->u
.c
.sym
->components
;
635 comp
= expr
->ts
.derived
->components
;
637 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
642 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
648 if (cons
->expr
->expr_type
!= EXPR_NULL
649 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
650 && (comp
->allocatable
|| cons
->expr
->rank
))
652 gfc_error ("The rank of the element in the derived type "
653 "constructor at %L does not match that of the "
654 "component (%d/%d)", &cons
->expr
->where
,
655 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
659 /* If we don't have the right type, try to convert it. */
661 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
664 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
665 gfc_error ("The element in the derived type constructor at %L, "
666 "for pointer component '%s', is %s but should be %s",
667 &cons
->expr
->where
, comp
->name
,
668 gfc_basic_typename (cons
->expr
->ts
.type
),
669 gfc_basic_typename (comp
->ts
.type
));
671 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
674 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
677 a
= gfc_expr_attr (cons
->expr
);
679 if (!a
.pointer
&& !a
.target
)
682 gfc_error ("The element in the derived type constructor at %L, "
683 "for pointer component '%s' should be a POINTER or "
684 "a TARGET", &cons
->expr
->where
, comp
->name
);
692 /****************** Expression name resolution ******************/
694 /* Returns 0 if a symbol was not declared with a type or
695 attribute declaration statement, nonzero otherwise. */
698 was_declared (gfc_symbol
*sym
)
704 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
707 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
708 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
709 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
716 /* Determine if a symbol is generic or not. */
719 generic_sym (gfc_symbol
*sym
)
723 if (sym
->attr
.generic
||
724 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
727 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
730 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
732 return (s
== NULL
) ? 0 : generic_sym (s
);
736 /* Determine if a symbol is specific or not. */
739 specific_sym (gfc_symbol
*sym
)
743 if (sym
->attr
.if_source
== IFSRC_IFBODY
744 || sym
->attr
.proc
== PROC_MODULE
745 || sym
->attr
.proc
== PROC_INTERNAL
746 || sym
->attr
.proc
== PROC_ST_FUNCTION
747 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
748 || sym
->attr
.external
)
751 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
754 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
756 return (s
== NULL
) ? 0 : specific_sym (s
);
760 /* Figure out if the procedure is specific, generic or unknown. */
763 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
767 procedure_kind (gfc_symbol
*sym
)
769 if (generic_sym (sym
))
770 return PTYPE_GENERIC
;
772 if (specific_sym (sym
))
773 return PTYPE_SPECIFIC
;
775 return PTYPE_UNKNOWN
;
778 /* Check references to assumed size arrays. The flag need_full_assumed_size
779 is nonzero when matching actual arguments. */
781 static int need_full_assumed_size
= 0;
784 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
790 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
793 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
794 if (ref
->type
== REF_ARRAY
)
795 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
796 last
= (ref
->u
.ar
.end
[dim
] == NULL
)
797 && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
801 gfc_error ("The upper bound in the last dimension must "
802 "appear in the reference to the assumed size "
803 "array '%s' at %L", sym
->name
, &e
->where
);
810 /* Look for bad assumed size array references in argument expressions
811 of elemental and array valued intrinsic procedures. Since this is
812 called from procedure resolution functions, it only recurses at
816 resolve_assumed_size_actual (gfc_expr
*e
)
821 switch (e
->expr_type
)
824 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
829 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
830 || resolve_assumed_size_actual (e
->value
.op
.op2
))
841 /* Resolve an actual argument list. Most of the time, this is just
842 resolving the expressions in the list.
843 The exception is that we sometimes have to decide whether arguments
844 that look like procedure arguments are really simple variable
848 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
)
851 gfc_symtree
*parent_st
;
854 for (; arg
; arg
= arg
->next
)
859 /* Check the label is a valid branching target. */
862 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
864 gfc_error ("Label %d referenced at %L is never defined",
865 arg
->label
->value
, &arg
->label
->where
);
872 if (e
->ts
.type
!= BT_PROCEDURE
)
874 if (gfc_resolve_expr (e
) != SUCCESS
)
879 /* See if the expression node should really be a variable reference. */
881 sym
= e
->symtree
->n
.sym
;
883 if (sym
->attr
.flavor
== FL_PROCEDURE
884 || sym
->attr
.intrinsic
885 || sym
->attr
.external
)
889 /* If a procedure is not already determined to be something else
890 check if it is intrinsic. */
891 if (!sym
->attr
.intrinsic
892 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
893 || sym
->attr
.if_source
== IFSRC_IFBODY
)
894 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
895 sym
->attr
.intrinsic
= 1;
897 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
899 gfc_error ("Statement function '%s' at %L is not allowed as an "
900 "actual argument", sym
->name
, &e
->where
);
903 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
904 sym
->attr
.subroutine
);
905 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
907 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
908 "actual argument", sym
->name
, &e
->where
);
911 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
912 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
914 gfc_error ("Internal procedure '%s' is not allowed as an "
915 "actual argument at %L", sym
->name
, &e
->where
);
918 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
920 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
921 "allowed as an actual argument at %L", sym
->name
,
925 if (sym
->attr
.generic
)
927 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
928 "allowed as an actual argument at %L", sym
->name
,
932 /* If the symbol is the function that names the current (or
933 parent) scope, then we really have a variable reference. */
935 if (sym
->attr
.function
&& sym
->result
== sym
936 && (sym
->ns
->proc_name
== sym
937 || (sym
->ns
->parent
!= NULL
938 && sym
->ns
->parent
->proc_name
== sym
)))
941 /* If all else fails, see if we have a specific intrinsic. */
942 if (sym
->attr
.function
943 && sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
945 gfc_intrinsic_sym
*isym
;
946 isym
= gfc_find_function (sym
->name
);
947 if (isym
== NULL
|| !isym
->specific
)
949 gfc_error ("Unable to find a specific INTRINSIC procedure "
950 "for the reference '%s' at %L", sym
->name
,
958 /* See if the name is a module procedure in a parent unit. */
960 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
963 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
965 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
969 if (parent_st
== NULL
)
972 sym
= parent_st
->n
.sym
;
973 e
->symtree
= parent_st
; /* Point to the right thing. */
975 if (sym
->attr
.flavor
== FL_PROCEDURE
976 || sym
->attr
.intrinsic
977 || sym
->attr
.external
)
983 e
->expr_type
= EXPR_VARIABLE
;
987 e
->rank
= sym
->as
->rank
;
988 e
->ref
= gfc_get_ref ();
989 e
->ref
->type
= REF_ARRAY
;
990 e
->ref
->u
.ar
.type
= AR_FULL
;
991 e
->ref
->u
.ar
.as
= sym
->as
;
995 /* Check argument list functions %VAL, %LOC and %REF. There is
996 nothing to do for %REF. */
997 if (arg
->name
&& arg
->name
[0] == '%')
999 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1001 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1003 gfc_error ("By-value argument at %L is not of numeric "
1010 gfc_error ("By-value argument at %L cannot be an array or "
1011 "an array section", &e
->where
);
1015 /* Intrinsics are still PROC_UNKNOWN here. However,
1016 since same file external procedures are not resolvable
1017 in gfortran, it is a good deal easier to leave them to
1019 if (ptype
!= PROC_UNKNOWN
&& ptype
!= PROC_EXTERNAL
)
1021 gfc_error ("By-value argument at %L is not allowed "
1022 "in this context", &e
->where
);
1026 if (((e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_COMPLEX
)
1027 && e
->ts
.kind
> gfc_default_real_kind
)
1028 || (e
->ts
.kind
> gfc_default_integer_kind
))
1030 gfc_error ("Kind of by-value argument at %L is larger "
1031 "than default kind", &e
->where
);
1037 /* Statement functions have already been excluded above. */
1038 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1039 && e
->ts
.type
== BT_PROCEDURE
)
1041 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1043 gfc_error ("Passing internal procedure at %L by location "
1044 "not allowed", &e
->where
);
1055 /* Do the checks of the actual argument list that are specific to elemental
1056 procedures. If called with c == NULL, we have a function, otherwise if
1057 expr == NULL, we have a subroutine. */
1060 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1062 gfc_actual_arglist
*arg0
;
1063 gfc_actual_arglist
*arg
;
1064 gfc_symbol
*esym
= NULL
;
1065 gfc_intrinsic_sym
*isym
= NULL
;
1067 gfc_intrinsic_arg
*iformal
= NULL
;
1068 gfc_formal_arglist
*eformal
= NULL
;
1069 bool formal_optional
= false;
1070 bool set_by_optional
= false;
1074 /* Is this an elemental procedure? */
1075 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1077 if (expr
->value
.function
.esym
!= NULL
1078 && expr
->value
.function
.esym
->attr
.elemental
)
1080 arg0
= expr
->value
.function
.actual
;
1081 esym
= expr
->value
.function
.esym
;
1083 else if (expr
->value
.function
.isym
!= NULL
1084 && expr
->value
.function
.isym
->elemental
)
1086 arg0
= expr
->value
.function
.actual
;
1087 isym
= expr
->value
.function
.isym
;
1092 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1094 arg0
= c
->ext
.actual
;
1095 esym
= c
->symtree
->n
.sym
;
1100 /* The rank of an elemental is the rank of its array argument(s). */
1101 for (arg
= arg0
; arg
; arg
= arg
->next
)
1103 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1105 rank
= arg
->expr
->rank
;
1106 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1107 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1108 set_by_optional
= true;
1110 /* Function specific; set the result rank and shape. */
1114 if (!expr
->shape
&& arg
->expr
->shape
)
1116 expr
->shape
= gfc_get_shape (rank
);
1117 for (i
= 0; i
< rank
; i
++)
1118 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1125 /* If it is an array, it shall not be supplied as an actual argument
1126 to an elemental procedure unless an array of the same rank is supplied
1127 as an actual argument corresponding to a nonoptional dummy argument of
1128 that elemental procedure(12.4.1.5). */
1129 formal_optional
= false;
1131 iformal
= isym
->formal
;
1133 eformal
= esym
->formal
;
1135 for (arg
= arg0
; arg
; arg
= arg
->next
)
1139 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1140 formal_optional
= true;
1141 eformal
= eformal
->next
;
1143 else if (isym
&& iformal
)
1145 if (iformal
->optional
)
1146 formal_optional
= true;
1147 iformal
= iformal
->next
;
1150 formal_optional
= true;
1152 if (pedantic
&& arg
->expr
!= NULL
1153 && arg
->expr
->expr_type
== EXPR_VARIABLE
1154 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1157 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1158 && !(isym
&& isym
->generic_id
== GFC_ISYM_CONVERSION
))
1160 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1161 "MISSING, it cannot be the actual argument of an "
1162 "ELEMENTAL procedure unless there is a non-optional "
1163 "argument with the same rank (12.4.1.5)",
1164 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1169 for (arg
= arg0
; arg
; arg
= arg
->next
)
1171 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1174 /* Being elemental, the last upper bound of an assumed size array
1175 argument must be present. */
1176 if (resolve_assumed_size_actual (arg
->expr
))
1182 /* Elemental subroutine array actual arguments must conform. */
1185 if (gfc_check_conformance ("elemental subroutine", arg
->expr
, e
)
1197 /* Go through each actual argument in ACTUAL and see if it can be
1198 implemented as an inlined, non-copying intrinsic. FNSYM is the
1199 function being called, or NULL if not known. */
1202 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1204 gfc_actual_arglist
*ap
;
1207 for (ap
= actual
; ap
; ap
= ap
->next
)
1209 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1210 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1211 ap
->expr
->inline_noncopying_intrinsic
= 1;
1215 /* This function does the checking of references to global procedures
1216 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1217 77 and 95 standards. It checks for a gsymbol for the name, making
1218 one if it does not already exist. If it already exists, then the
1219 reference being resolved must correspond to the type of gsymbol.
1220 Otherwise, the new symbol is equipped with the attributes of the
1221 reference. The corresponding code that is called in creating
1222 global entities is parse.c. */
1225 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1230 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1232 gsym
= gfc_get_gsymbol (sym
->name
);
1234 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1235 global_used (gsym
, where
);
1237 if (gsym
->type
== GSYM_UNKNOWN
)
1240 gsym
->where
= *where
;
1247 /************* Function resolution *************/
1249 /* Resolve a function call known to be generic.
1250 Section 14.1.2.4.1. */
1253 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1257 if (sym
->attr
.generic
)
1259 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1262 expr
->value
.function
.name
= s
->name
;
1263 expr
->value
.function
.esym
= s
;
1265 if (s
->ts
.type
!= BT_UNKNOWN
)
1267 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1268 expr
->ts
= s
->result
->ts
;
1271 expr
->rank
= s
->as
->rank
;
1272 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1273 expr
->rank
= s
->result
->as
->rank
;
1278 /* TODO: Need to search for elemental references in generic
1282 if (sym
->attr
.intrinsic
)
1283 return gfc_intrinsic_func_interface (expr
, 0);
1290 resolve_generic_f (gfc_expr
*expr
)
1295 sym
= expr
->symtree
->n
.sym
;
1299 m
= resolve_generic_f0 (expr
, sym
);
1302 else if (m
== MATCH_ERROR
)
1306 if (sym
->ns
->parent
== NULL
)
1308 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1312 if (!generic_sym (sym
))
1316 /* Last ditch attempt. See if the reference is to an intrinsic
1317 that possesses a matching interface. 14.1.2.4 */
1318 if (!gfc_intrinsic_name (sym
->name
, 0))
1320 gfc_error ("There is no specific function for the generic '%s' at %L",
1321 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1325 m
= gfc_intrinsic_func_interface (expr
, 0);
1329 gfc_error ("Generic function '%s' at %L is not consistent with a "
1330 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1337 /* Resolve a function call known to be specific. */
1340 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1344 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1346 if (sym
->attr
.dummy
)
1348 sym
->attr
.proc
= PROC_DUMMY
;
1352 sym
->attr
.proc
= PROC_EXTERNAL
;
1356 if (sym
->attr
.proc
== PROC_MODULE
1357 || sym
->attr
.proc
== PROC_ST_FUNCTION
1358 || sym
->attr
.proc
== PROC_INTERNAL
)
1361 if (sym
->attr
.intrinsic
)
1363 m
= gfc_intrinsic_func_interface (expr
, 1);
1367 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1368 "with an intrinsic", sym
->name
, &expr
->where
);
1376 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1379 expr
->value
.function
.name
= sym
->name
;
1380 expr
->value
.function
.esym
= sym
;
1381 if (sym
->as
!= NULL
)
1382 expr
->rank
= sym
->as
->rank
;
1389 resolve_specific_f (gfc_expr
*expr
)
1394 sym
= expr
->symtree
->n
.sym
;
1398 m
= resolve_specific_f0 (sym
, expr
);
1401 if (m
== MATCH_ERROR
)
1404 if (sym
->ns
->parent
== NULL
)
1407 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1413 gfc_error ("Unable to resolve the specific function '%s' at %L",
1414 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1420 /* Resolve a procedure call not known to be generic nor specific. */
1423 resolve_unknown_f (gfc_expr
*expr
)
1428 sym
= expr
->symtree
->n
.sym
;
1430 if (sym
->attr
.dummy
)
1432 sym
->attr
.proc
= PROC_DUMMY
;
1433 expr
->value
.function
.name
= sym
->name
;
1437 /* See if we have an intrinsic function reference. */
1439 if (gfc_intrinsic_name (sym
->name
, 0))
1441 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1446 /* The reference is to an external name. */
1448 sym
->attr
.proc
= PROC_EXTERNAL
;
1449 expr
->value
.function
.name
= sym
->name
;
1450 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1452 if (sym
->as
!= NULL
)
1453 expr
->rank
= sym
->as
->rank
;
1455 /* Type of the expression is either the type of the symbol or the
1456 default type of the symbol. */
1459 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1461 if (sym
->ts
.type
!= BT_UNKNOWN
)
1465 ts
= gfc_get_default_type (sym
, sym
->ns
);
1467 if (ts
->type
== BT_UNKNOWN
)
1469 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1470 sym
->name
, &expr
->where
);
1481 /* Figure out if a function reference is pure or not. Also set the name
1482 of the function for a potential error message. Return nonzero if the
1483 function is PURE, zero if not. */
1486 pure_function (gfc_expr
*e
, const char **name
)
1490 if (e
->symtree
!= NULL
1491 && e
->symtree
->n
.sym
!= NULL
1492 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1495 if (e
->value
.function
.esym
)
1497 pure
= gfc_pure (e
->value
.function
.esym
);
1498 *name
= e
->value
.function
.esym
->name
;
1500 else if (e
->value
.function
.isym
)
1502 pure
= e
->value
.function
.isym
->pure
1503 || e
->value
.function
.isym
->elemental
;
1504 *name
= e
->value
.function
.isym
->name
;
1508 /* Implicit functions are not pure. */
1510 *name
= e
->value
.function
.name
;
1517 /* Resolve a function call, which means resolving the arguments, then figuring
1518 out which entity the name refers to. */
1519 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1520 to INTENT(OUT) or INTENT(INOUT). */
1523 resolve_function (gfc_expr
*expr
)
1525 gfc_actual_arglist
*arg
;
1530 procedure_type p
= PROC_INTRINSIC
;
1534 sym
= expr
->symtree
->n
.sym
;
1536 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
1538 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
1542 /* If the procedure is not internal, a statement function or a module
1543 procedure,it must be external and should be checked for usage. */
1544 if (sym
&& !sym
->attr
.dummy
&& !sym
->attr
.contained
1545 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1546 && !sym
->attr
.use_assoc
)
1547 resolve_global_procedure (sym
, &expr
->where
, 0);
1549 /* Switch off assumed size checking and do this again for certain kinds
1550 of procedure, once the procedure itself is resolved. */
1551 need_full_assumed_size
++;
1553 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
1554 p
= expr
->symtree
->n
.sym
->attr
.proc
;
1556 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
1559 /* Resume assumed_size checking. */
1560 need_full_assumed_size
--;
1562 if (sym
&& sym
->ts
.type
== BT_CHARACTER
1564 && sym
->ts
.cl
->length
== NULL
1566 && expr
->value
.function
.esym
== NULL
1567 && !sym
->attr
.contained
)
1569 /* Internal procedures are taken care of in resolve_contained_fntype. */
1570 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1571 "be used at %L since it is not a dummy argument",
1572 sym
->name
, &expr
->where
);
1576 /* See if function is already resolved. */
1578 if (expr
->value
.function
.name
!= NULL
)
1580 if (expr
->ts
.type
== BT_UNKNOWN
)
1586 /* Apply the rules of section 14.1.2. */
1588 switch (procedure_kind (sym
))
1591 t
= resolve_generic_f (expr
);
1594 case PTYPE_SPECIFIC
:
1595 t
= resolve_specific_f (expr
);
1599 t
= resolve_unknown_f (expr
);
1603 gfc_internal_error ("resolve_function(): bad function type");
1607 /* If the expression is still a function (it might have simplified),
1608 then we check to see if we are calling an elemental function. */
1610 if (expr
->expr_type
!= EXPR_FUNCTION
)
1613 temp
= need_full_assumed_size
;
1614 need_full_assumed_size
= 0;
1616 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
1619 if (omp_workshare_flag
1620 && expr
->value
.function
.esym
1621 && ! gfc_elemental (expr
->value
.function
.esym
))
1623 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
1624 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
1629 #define GENERIC_ID expr->value.function.isym->generic_id
1630 else if (expr
->value
.function
.actual
!= NULL
1631 && expr
->value
.function
.isym
!= NULL
1632 && GENERIC_ID
!= GFC_ISYM_LBOUND
1633 && GENERIC_ID
!= GFC_ISYM_LEN
1634 && GENERIC_ID
!= GFC_ISYM_LOC
1635 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
1637 /* Array intrinsics must also have the last upper bound of an
1638 assumed size array argument. UBOUND and SIZE have to be
1639 excluded from the check if the second argument is anything
1642 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
1643 || GENERIC_ID
== GFC_ISYM_SIZE
;
1645 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1647 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
)
1649 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
1652 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
1657 if (arg
->expr
!= NULL
1658 && arg
->expr
->rank
> 0
1659 && resolve_assumed_size_actual (arg
->expr
))
1665 need_full_assumed_size
= temp
;
1667 if (!pure_function (expr
, &name
) && name
)
1671 gfc_error ("reference to non-PURE function '%s' at %L inside a "
1672 "FORALL %s", name
, &expr
->where
,
1673 forall_flag
== 2 ? "mask" : "block");
1676 else if (gfc_pure (NULL
))
1678 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1679 "procedure within a PURE procedure", name
, &expr
->where
);
1684 /* Functions without the RECURSIVE attribution are not allowed to
1685 * call themselves. */
1686 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
1688 gfc_symbol
*esym
, *proc
;
1689 esym
= expr
->value
.function
.esym
;
1690 proc
= gfc_current_ns
->proc_name
;
1693 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1694 "RECURSIVE", name
, &expr
->where
);
1698 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
1699 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1701 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1702 "'%s' is not declared as RECURSIVE",
1703 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
1708 /* Character lengths of use associated functions may contains references to
1709 symbols not referenced from the current program unit otherwise. Make sure
1710 those symbols are marked as referenced. */
1712 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
1713 && expr
->value
.function
.esym
->attr
.use_assoc
)
1715 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
1719 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1720 expr
->value
.function
.actual
);
1722 /* Make sure that the expression has a typespec that works. */
1723 if (expr
->ts
.type
== BT_UNKNOWN
)
1725 if (expr
->symtree
->n
.sym
->result
1726 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
1727 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
1729 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
1736 /************* Subroutine resolution *************/
1739 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
1745 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1746 sym
->name
, &c
->loc
);
1747 else if (gfc_pure (NULL
))
1748 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1754 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
1758 if (sym
->attr
.generic
)
1760 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1763 c
->resolved_sym
= s
;
1764 pure_subroutine (c
, s
);
1768 /* TODO: Need to search for elemental references in generic interface. */
1771 if (sym
->attr
.intrinsic
)
1772 return gfc_intrinsic_sub_interface (c
, 0);
1779 resolve_generic_s (gfc_code
*c
)
1784 sym
= c
->symtree
->n
.sym
;
1788 m
= resolve_generic_s0 (c
, sym
);
1791 else if (m
== MATCH_ERROR
)
1795 if (sym
->ns
->parent
== NULL
)
1797 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1801 if (!generic_sym (sym
))
1805 /* Last ditch attempt. See if the reference is to an intrinsic
1806 that possesses a matching interface. 14.1.2.4 */
1807 sym
= c
->symtree
->n
.sym
;
1809 if (!gfc_intrinsic_name (sym
->name
, 1))
1811 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
1812 sym
->name
, &c
->loc
);
1816 m
= gfc_intrinsic_sub_interface (c
, 0);
1820 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1821 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1827 /* Resolve a subroutine call known to be specific. */
1830 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
1834 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1836 if (sym
->attr
.dummy
)
1838 sym
->attr
.proc
= PROC_DUMMY
;
1842 sym
->attr
.proc
= PROC_EXTERNAL
;
1846 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1849 if (sym
->attr
.intrinsic
)
1851 m
= gfc_intrinsic_sub_interface (c
, 1);
1855 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1856 "with an intrinsic", sym
->name
, &c
->loc
);
1864 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1866 c
->resolved_sym
= sym
;
1867 pure_subroutine (c
, sym
);
1874 resolve_specific_s (gfc_code
*c
)
1879 sym
= c
->symtree
->n
.sym
;
1883 m
= resolve_specific_s0 (c
, sym
);
1886 if (m
== MATCH_ERROR
)
1889 if (sym
->ns
->parent
== NULL
)
1892 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1898 sym
= c
->symtree
->n
.sym
;
1899 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1900 sym
->name
, &c
->loc
);
1906 /* Resolve a subroutine call not known to be generic nor specific. */
1909 resolve_unknown_s (gfc_code
*c
)
1913 sym
= c
->symtree
->n
.sym
;
1915 if (sym
->attr
.dummy
)
1917 sym
->attr
.proc
= PROC_DUMMY
;
1921 /* See if we have an intrinsic function reference. */
1923 if (gfc_intrinsic_name (sym
->name
, 1))
1925 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1930 /* The reference is to an external name. */
1933 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1935 c
->resolved_sym
= sym
;
1937 pure_subroutine (c
, sym
);
1943 /* Resolve a subroutine call. Although it was tempting to use the same code
1944 for functions, subroutines and functions are stored differently and this
1945 makes things awkward. */
1948 resolve_call (gfc_code
*c
)
1951 procedure_type ptype
= PROC_INTRINSIC
;
1953 if (c
->symtree
&& c
->symtree
->n
.sym
1954 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
1956 gfc_error ("'%s' at %L has a type, which is not consistent with "
1957 "the CALL at %L", c
->symtree
->n
.sym
->name
,
1958 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
1962 /* If the procedure is not internal or module, it must be external and
1963 should be checked for usage. */
1964 if (c
->symtree
&& c
->symtree
->n
.sym
1965 && !c
->symtree
->n
.sym
->attr
.dummy
1966 && !c
->symtree
->n
.sym
->attr
.contained
1967 && !c
->symtree
->n
.sym
->attr
.use_assoc
)
1968 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
1970 /* Subroutines without the RECURSIVE attribution are not allowed to
1971 * call themselves. */
1972 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
1974 gfc_symbol
*csym
, *proc
;
1975 csym
= c
->symtree
->n
.sym
;
1976 proc
= gfc_current_ns
->proc_name
;
1979 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1980 "RECURSIVE", csym
->name
, &c
->loc
);
1984 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
1985 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1987 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1988 "'%s' is not declared as RECURSIVE",
1989 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
1994 /* Switch off assumed size checking and do this again for certain kinds
1995 of procedure, once the procedure itself is resolved. */
1996 need_full_assumed_size
++;
1998 if (c
->symtree
&& c
->symtree
->n
.sym
)
1999 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
2001 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
2004 /* Resume assumed_size checking. */
2005 need_full_assumed_size
--;
2008 if (c
->resolved_sym
== NULL
)
2009 switch (procedure_kind (c
->symtree
->n
.sym
))
2012 t
= resolve_generic_s (c
);
2015 case PTYPE_SPECIFIC
:
2016 t
= resolve_specific_s (c
);
2020 t
= resolve_unknown_s (c
);
2024 gfc_internal_error ("resolve_subroutine(): bad function type");
2027 /* Some checks of elemental subroutine actual arguments. */
2028 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2032 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2037 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2038 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2039 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2040 if their shapes do not match. If either op1->shape or op2->shape is
2041 NULL, return SUCCESS. */
2044 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2051 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2053 for (i
= 0; i
< op1
->rank
; i
++)
2055 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2057 gfc_error ("Shapes for operands at %L and %L are not conformable",
2058 &op1
->where
, &op2
->where
);
2069 /* Resolve an operator expression node. This can involve replacing the
2070 operation with a user defined function call. */
2073 resolve_operator (gfc_expr
*e
)
2075 gfc_expr
*op1
, *op2
;
2079 /* Resolve all subnodes-- give them types. */
2081 switch (e
->value
.op
.operator)
2084 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2087 /* Fall through... */
2090 case INTRINSIC_UPLUS
:
2091 case INTRINSIC_UMINUS
:
2092 case INTRINSIC_PARENTHESES
:
2093 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2098 /* Typecheck the new node. */
2100 op1
= e
->value
.op
.op1
;
2101 op2
= e
->value
.op
.op2
;
2103 switch (e
->value
.op
.operator)
2105 case INTRINSIC_UPLUS
:
2106 case INTRINSIC_UMINUS
:
2107 if (op1
->ts
.type
== BT_INTEGER
2108 || op1
->ts
.type
== BT_REAL
2109 || op1
->ts
.type
== BT_COMPLEX
)
2115 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2116 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2119 case INTRINSIC_PLUS
:
2120 case INTRINSIC_MINUS
:
2121 case INTRINSIC_TIMES
:
2122 case INTRINSIC_DIVIDE
:
2123 case INTRINSIC_POWER
:
2124 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2126 gfc_type_convert_binary (e
);
2131 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2132 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2133 gfc_typename (&op2
->ts
));
2136 case INTRINSIC_CONCAT
:
2137 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2139 e
->ts
.type
= BT_CHARACTER
;
2140 e
->ts
.kind
= op1
->ts
.kind
;
2145 _("Operands of string concatenation operator at %%L are %s/%s"),
2146 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2152 case INTRINSIC_NEQV
:
2153 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2155 e
->ts
.type
= BT_LOGICAL
;
2156 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2157 if (op1
->ts
.kind
< e
->ts
.kind
)
2158 gfc_convert_type (op1
, &e
->ts
, 2);
2159 else if (op2
->ts
.kind
< e
->ts
.kind
)
2160 gfc_convert_type (op2
, &e
->ts
, 2);
2164 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2165 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2166 gfc_typename (&op2
->ts
));
2171 if (op1
->ts
.type
== BT_LOGICAL
)
2173 e
->ts
.type
= BT_LOGICAL
;
2174 e
->ts
.kind
= op1
->ts
.kind
;
2178 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
2179 gfc_typename (&op1
->ts
));
2186 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2188 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2192 /* Fall through... */
2196 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2198 e
->ts
.type
= BT_LOGICAL
;
2199 e
->ts
.kind
= gfc_default_logical_kind
;
2203 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2205 gfc_type_convert_binary (e
);
2207 e
->ts
.type
= BT_LOGICAL
;
2208 e
->ts
.kind
= gfc_default_logical_kind
;
2212 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2214 _("Logicals at %%L must be compared with %s instead of %s"),
2215 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
2216 gfc_op2string (e
->value
.op
.operator));
2219 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2220 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2221 gfc_typename (&op2
->ts
));
2225 case INTRINSIC_USER
:
2227 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2228 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2230 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2231 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2232 gfc_typename (&op2
->ts
));
2236 case INTRINSIC_PARENTHESES
:
2240 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2243 /* Deal with arrayness of an operand through an operator. */
2247 switch (e
->value
.op
.operator)
2249 case INTRINSIC_PLUS
:
2250 case INTRINSIC_MINUS
:
2251 case INTRINSIC_TIMES
:
2252 case INTRINSIC_DIVIDE
:
2253 case INTRINSIC_POWER
:
2254 case INTRINSIC_CONCAT
:
2258 case INTRINSIC_NEQV
:
2266 if (op1
->rank
== 0 && op2
->rank
== 0)
2269 if (op1
->rank
== 0 && op2
->rank
!= 0)
2271 e
->rank
= op2
->rank
;
2273 if (e
->shape
== NULL
)
2274 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2277 if (op1
->rank
!= 0 && op2
->rank
== 0)
2279 e
->rank
= op1
->rank
;
2281 if (e
->shape
== NULL
)
2282 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2285 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2287 if (op1
->rank
== op2
->rank
)
2289 e
->rank
= op1
->rank
;
2290 if (e
->shape
== NULL
)
2292 t
= compare_shapes(op1
, op2
);
2296 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2301 gfc_error ("Inconsistent ranks for operator at %L and %L",
2302 &op1
->where
, &op2
->where
);
2305 /* Allow higher level expressions to work. */
2313 case INTRINSIC_UPLUS
:
2314 case INTRINSIC_UMINUS
:
2315 case INTRINSIC_PARENTHESES
:
2316 e
->rank
= op1
->rank
;
2318 if (e
->shape
== NULL
)
2319 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2321 /* Simply copy arrayness attribute */
2328 /* Attempt to simplify the expression. */
2331 t
= gfc_simplify_expr (e
, 0);
2332 /* Some calls do not succeed in simplification and return FAILURE
2333 even though there is no error; eg. variable references to
2334 PARAMETER arrays. */
2335 if (!gfc_is_constant_expr (e
))
2342 if (gfc_extend_expr (e
) == SUCCESS
)
2345 gfc_error (msg
, &e
->where
);
2351 /************** Array resolution subroutines **************/
2354 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
2357 /* Compare two integer expressions. */
2360 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
2364 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
2365 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
2368 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
2369 gfc_internal_error ("compare_bound(): Bad expression");
2371 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
2381 /* Compare an integer expression with an integer. */
2384 compare_bound_int (gfc_expr
*a
, int b
)
2388 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2391 if (a
->ts
.type
!= BT_INTEGER
)
2392 gfc_internal_error ("compare_bound_int(): Bad expression");
2394 i
= mpz_cmp_si (a
->value
.integer
, b
);
2404 /* Compare an integer expression with a mpz_t. */
2407 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
2411 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2414 if (a
->ts
.type
!= BT_INTEGER
)
2415 gfc_internal_error ("compare_bound_int(): Bad expression");
2417 i
= mpz_cmp (a
->value
.integer
, b
);
2427 /* Compute the last value of a sequence given by a triplet.
2428 Return 0 if it wasn't able to compute the last value, or if the
2429 sequence if empty, and 1 otherwise. */
2432 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
2433 gfc_expr
*stride
, mpz_t last
)
2437 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
2438 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2439 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
2442 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
2443 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
2446 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
2448 if (compare_bound (start
, end
) == CMP_GT
)
2450 mpz_set (last
, end
->value
.integer
);
2454 if (compare_bound_int (stride
, 0) == CMP_GT
)
2456 /* Stride is positive */
2457 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
2462 /* Stride is negative */
2463 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
2468 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
2469 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
2470 mpz_sub (last
, end
->value
.integer
, rem
);
2477 /* Compare a single dimension of an array reference to the array
2481 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
2485 /* Given start, end and stride values, calculate the minimum and
2486 maximum referenced indexes. */
2494 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2496 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2502 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
2504 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
2508 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2509 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2511 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
2512 && (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
2513 || compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
))
2516 if (((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
2517 || ar
->stride
[i
] == NULL
)
2518 && compare_bound (AR_START
, AR_END
) != CMP_GT
)
2519 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
2520 && compare_bound (AR_START
, AR_END
) != CMP_LT
))
2522 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
2524 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
2528 mpz_init (last_value
);
2529 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
2532 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
2533 || compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
2535 mpz_clear (last_value
);
2539 mpz_clear (last_value
);
2547 gfc_internal_error ("check_dimension(): Bad array reference");
2553 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
2558 /* Compare an array reference with an array specification. */
2561 compare_spec_to_ref (gfc_array_ref
*ar
)
2568 /* TODO: Full array sections are only allowed as actual parameters. */
2569 if (as
->type
== AS_ASSUMED_SIZE
2570 && (/*ar->type == AR_FULL
2571 ||*/ (ar
->type
== AR_SECTION
2572 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
2574 gfc_error ("Rightmost upper bound of assumed size array section "
2575 "not specified at %L", &ar
->where
);
2579 if (ar
->type
== AR_FULL
)
2582 if (as
->rank
!= ar
->dimen
)
2584 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2585 &ar
->where
, ar
->dimen
, as
->rank
);
2589 for (i
= 0; i
< as
->rank
; i
++)
2590 if (check_dimension (i
, ar
, as
) == FAILURE
)
2597 /* Resolve one part of an array index. */
2600 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
2607 if (gfc_resolve_expr (index
) == FAILURE
)
2610 if (check_scalar
&& index
->rank
!= 0)
2612 gfc_error ("Array index at %L must be scalar", &index
->where
);
2616 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
2618 gfc_error ("Array index at %L must be of INTEGER type",
2623 if (index
->ts
.type
== BT_REAL
)
2624 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
2625 &index
->where
) == FAILURE
)
2628 if (index
->ts
.kind
!= gfc_index_integer_kind
2629 || index
->ts
.type
!= BT_INTEGER
)
2632 ts
.type
= BT_INTEGER
;
2633 ts
.kind
= gfc_index_integer_kind
;
2635 gfc_convert_type_warn (index
, &ts
, 2, 0);
2641 /* Resolve a dim argument to an intrinsic function. */
2644 gfc_resolve_dim_arg (gfc_expr
*dim
)
2649 if (gfc_resolve_expr (dim
) == FAILURE
)
2654 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
2658 if (dim
->ts
.type
!= BT_INTEGER
)
2660 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
2663 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
2667 ts
.type
= BT_INTEGER
;
2668 ts
.kind
= gfc_index_integer_kind
;
2670 gfc_convert_type_warn (dim
, &ts
, 2, 0);
2676 /* Given an expression that contains array references, update those array
2677 references to point to the right array specifications. While this is
2678 filled in during matching, this information is difficult to save and load
2679 in a module, so we take care of it here.
2681 The idea here is that the original array reference comes from the
2682 base symbol. We traverse the list of reference structures, setting
2683 the stored reference to references. Component references can
2684 provide an additional array specification. */
2687 find_array_spec (gfc_expr
*e
)
2691 gfc_symbol
*derived
;
2694 as
= e
->symtree
->n
.sym
->as
;
2697 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2702 gfc_internal_error ("find_array_spec(): Missing spec");
2709 if (derived
== NULL
)
2710 derived
= e
->symtree
->n
.sym
->ts
.derived
;
2712 c
= derived
->components
;
2714 for (; c
; c
= c
->next
)
2715 if (c
== ref
->u
.c
.component
)
2717 /* Track the sequence of component references. */
2718 if (c
->ts
.type
== BT_DERIVED
)
2719 derived
= c
->ts
.derived
;
2724 gfc_internal_error ("find_array_spec(): Component not found");
2729 gfc_internal_error ("find_array_spec(): unused as(1)");
2740 gfc_internal_error ("find_array_spec(): unused as(2)");
2744 /* Resolve an array reference. */
2747 resolve_array_ref (gfc_array_ref
*ar
)
2749 int i
, check_scalar
;
2752 for (i
= 0; i
< ar
->dimen
; i
++)
2754 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2756 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2758 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2760 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2765 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2769 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2773 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2774 if (e
->expr_type
== EXPR_VARIABLE
2775 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
2776 ar
->start
[i
] = gfc_get_parentheses (e
);
2780 gfc_error ("Array index at %L is an array of rank %d",
2781 &ar
->c_where
[i
], e
->rank
);
2786 /* If the reference type is unknown, figure out what kind it is. */
2788 if (ar
->type
== AR_UNKNOWN
)
2790 ar
->type
= AR_ELEMENT
;
2791 for (i
= 0; i
< ar
->dimen
; i
++)
2792 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2793 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2795 ar
->type
= AR_SECTION
;
2800 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2808 resolve_substring (gfc_ref
*ref
)
2810 if (ref
->u
.ss
.start
!= NULL
)
2812 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2815 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2817 gfc_error ("Substring start index at %L must be of type INTEGER",
2818 &ref
->u
.ss
.start
->where
);
2822 if (ref
->u
.ss
.start
->rank
!= 0)
2824 gfc_error ("Substring start index at %L must be scalar",
2825 &ref
->u
.ss
.start
->where
);
2829 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
2830 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2831 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2833 gfc_error ("Substring start index at %L is less than one",
2834 &ref
->u
.ss
.start
->where
);
2839 if (ref
->u
.ss
.end
!= NULL
)
2841 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2844 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2846 gfc_error ("Substring end index at %L must be of type INTEGER",
2847 &ref
->u
.ss
.end
->where
);
2851 if (ref
->u
.ss
.end
->rank
!= 0)
2853 gfc_error ("Substring end index at %L must be scalar",
2854 &ref
->u
.ss
.end
->where
);
2858 if (ref
->u
.ss
.length
!= NULL
2859 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
2860 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2861 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2863 gfc_error ("Substring end index at %L exceeds the string length",
2864 &ref
->u
.ss
.start
->where
);
2873 /* Resolve subtype references. */
2876 resolve_ref (gfc_expr
*expr
)
2878 int current_part_dimension
, n_components
, seen_part_dimension
;
2881 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2882 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2884 find_array_spec (expr
);
2888 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2892 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2900 resolve_substring (ref
);
2904 /* Check constraints on part references. */
2906 current_part_dimension
= 0;
2907 seen_part_dimension
= 0;
2910 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2915 switch (ref
->u
.ar
.type
)
2919 current_part_dimension
= 1;
2923 current_part_dimension
= 0;
2927 gfc_internal_error ("resolve_ref(): Bad array reference");
2933 if (current_part_dimension
|| seen_part_dimension
)
2935 if (ref
->u
.c
.component
->pointer
)
2937 gfc_error ("Component to the right of a part reference "
2938 "with nonzero rank must not have the POINTER "
2939 "attribute at %L", &expr
->where
);
2942 else if (ref
->u
.c
.component
->allocatable
)
2944 gfc_error ("Component to the right of a part reference "
2945 "with nonzero rank must not have the ALLOCATABLE "
2946 "attribute at %L", &expr
->where
);
2958 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2959 || ref
->next
== NULL
)
2960 && current_part_dimension
2961 && seen_part_dimension
)
2963 gfc_error ("Two or more part references with nonzero rank must "
2964 "not be specified at %L", &expr
->where
);
2968 if (ref
->type
== REF_COMPONENT
)
2970 if (current_part_dimension
)
2971 seen_part_dimension
= 1;
2973 /* reset to make sure */
2974 current_part_dimension
= 0;
2982 /* Given an expression, determine its shape. This is easier than it sounds.
2983 Leaves the shape array NULL if it is not possible to determine the shape. */
2986 expression_shape (gfc_expr
*e
)
2988 mpz_t array
[GFC_MAX_DIMENSIONS
];
2991 if (e
->rank
== 0 || e
->shape
!= NULL
)
2994 for (i
= 0; i
< e
->rank
; i
++)
2995 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2998 e
->shape
= gfc_get_shape (e
->rank
);
3000 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3005 for (i
--; i
>= 0; i
--)
3006 mpz_clear (array
[i
]);
3010 /* Given a variable expression node, compute the rank of the expression by
3011 examining the base symbol and any reference structures it may have. */
3014 expression_rank (gfc_expr
*e
)
3021 if (e
->expr_type
== EXPR_ARRAY
)
3023 /* Constructors can have a rank different from one via RESHAPE(). */
3025 if (e
->symtree
== NULL
)
3031 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3032 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3038 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3040 if (ref
->type
!= REF_ARRAY
)
3043 if (ref
->u
.ar
.type
== AR_FULL
)
3045 rank
= ref
->u
.ar
.as
->rank
;
3049 if (ref
->u
.ar
.type
== AR_SECTION
)
3051 /* Figure out the rank of the section. */
3053 gfc_internal_error ("expression_rank(): Two array specs");
3055 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3056 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
3057 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
3067 expression_shape (e
);
3071 /* Resolve a variable expression. */
3074 resolve_variable (gfc_expr
*e
)
3081 if (e
->symtree
== NULL
)
3084 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
3087 sym
= e
->symtree
->n
.sym
;
3088 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
3090 e
->ts
.type
= BT_PROCEDURE
;
3094 if (sym
->ts
.type
!= BT_UNKNOWN
)
3095 gfc_variable_attr (e
, &e
->ts
);
3098 /* Must be a simple variable reference. */
3099 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
3104 if (check_assumed_size_reference (sym
, e
))
3107 /* Deal with forward references to entries during resolve_code, to
3108 satisfy, at least partially, 12.5.2.5. */
3109 if (gfc_current_ns
->entries
3110 && current_entry_id
== sym
->entry_id
3113 && cs_base
->current
->op
!= EXEC_ENTRY
)
3115 gfc_entry_list
*entry
;
3116 gfc_formal_arglist
*formal
;
3120 /* If the symbol is a dummy... */
3121 if (sym
->attr
.dummy
)
3123 entry
= gfc_current_ns
->entries
;
3126 /* ...test if the symbol is a parameter of previous entries. */
3127 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
3128 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
3130 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
3134 /* If it has not been seen as a dummy, this is an error. */
3137 if (specification_expr
)
3138 gfc_error ("Variable '%s',used in a specification expression, "
3139 "is referenced at %L before the ENTRY statement "
3140 "in which it is a parameter",
3141 sym
->name
, &cs_base
->current
->loc
);
3143 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3144 "statement in which it is a parameter",
3145 sym
->name
, &cs_base
->current
->loc
);
3150 /* Now do the same check on the specification expressions. */
3151 specification_expr
= 1;
3152 if (sym
->ts
.type
== BT_CHARACTER
3153 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3157 for (n
= 0; n
< sym
->as
->rank
; n
++)
3159 specification_expr
= 1;
3160 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3162 specification_expr
= 1;
3163 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3166 specification_expr
= 0;
3169 /* Update the symbol's entry level. */
3170 sym
->entry_id
= current_entry_id
+ 1;
3177 /* Resolve an expression. That is, make sure that types of operands agree
3178 with their operators, intrinsic operators are converted to function calls
3179 for overloaded types and unresolved function references are resolved. */
3182 gfc_resolve_expr (gfc_expr
*e
)
3189 switch (e
->expr_type
)
3192 t
= resolve_operator (e
);
3196 t
= resolve_function (e
);
3200 t
= resolve_variable (e
);
3202 expression_rank (e
);
3205 case EXPR_SUBSTRING
:
3206 t
= resolve_ref (e
);
3216 if (resolve_ref (e
) == FAILURE
)
3219 t
= gfc_resolve_array_constructor (e
);
3220 /* Also try to expand a constructor. */
3223 expression_rank (e
);
3224 gfc_expand_constructor (e
);
3227 /* This provides the opportunity for the length of constructors with
3228 character valued function elements to propogate the string length
3229 to the expression. */
3230 if (e
->ts
.type
== BT_CHARACTER
)
3231 gfc_resolve_character_array_constructor (e
);
3235 case EXPR_STRUCTURE
:
3236 t
= resolve_ref (e
);
3240 t
= resolve_structure_cons (e
);
3244 t
= gfc_simplify_expr (e
, 0);
3248 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3255 /* Resolve an expression from an iterator. They must be scalar and have
3256 INTEGER or (optionally) REAL type. */
3259 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
3260 const char *name_msgid
)
3262 if (gfc_resolve_expr (expr
) == FAILURE
)
3265 if (expr
->rank
!= 0)
3267 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
3271 if (!(expr
->ts
.type
== BT_INTEGER
3272 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
3275 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
3278 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
3285 /* Resolve the expressions in an iterator structure. If REAL_OK is
3286 false allow only INTEGER type iterators, otherwise allow REAL types. */
3289 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
3292 if (iter
->var
->ts
.type
== BT_REAL
)
3293 gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: REAL DO loop iterator at %L",
3296 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
3300 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
3302 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3307 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
3308 "Start expression in DO loop") == FAILURE
)
3311 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
3312 "End expression in DO loop") == FAILURE
)
3315 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
3316 "Step expression in DO loop") == FAILURE
)
3319 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
3321 if ((iter
->step
->ts
.type
== BT_INTEGER
3322 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
3323 || (iter
->step
->ts
.type
== BT_REAL
3324 && mpfr_sgn (iter
->step
->value
.real
) == 0))
3326 gfc_error ("Step expression in DO loop at %L cannot be zero",
3327 &iter
->step
->where
);
3332 /* Convert start, end, and step to the same type as var. */
3333 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
3334 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
3335 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3337 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
3338 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
3339 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3341 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
3342 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
3343 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
3349 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3350 to be a scalar INTEGER variable. The subscripts and stride are scalar
3351 INTEGERs, and if stride is a constant it must be nonzero. */
3354 resolve_forall_iterators (gfc_forall_iterator
*iter
)
3358 if (gfc_resolve_expr (iter
->var
) == SUCCESS
3359 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
3360 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3363 if (gfc_resolve_expr (iter
->start
) == SUCCESS
3364 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
3365 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3366 &iter
->start
->where
);
3367 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
3368 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3370 if (gfc_resolve_expr (iter
->end
) == SUCCESS
3371 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
3372 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3374 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
3375 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3377 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
3379 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
3380 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3381 &iter
->stride
->where
, "INTEGER");
3383 if (iter
->stride
->expr_type
== EXPR_CONSTANT
3384 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
3385 gfc_error ("FORALL stride expression at %L cannot be zero",
3386 &iter
->stride
->where
);
3388 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
3389 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
3396 /* Given a pointer to a symbol that is a derived type, see if any components
3397 have the POINTER attribute. The search is recursive if necessary.
3398 Returns zero if no pointer components are found, nonzero otherwise. */
3401 derived_pointer (gfc_symbol
*sym
)
3405 for (c
= sym
->components
; c
; c
= c
->next
)
3410 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
3418 /* Given a pointer to a symbol that is a derived type, see if it's
3419 inaccessible, i.e. if it's defined in another module and the components are
3420 PRIVATE. The search is recursive if necessary. Returns zero if no
3421 inaccessible components are found, nonzero otherwise. */
3424 derived_inaccessible (gfc_symbol
*sym
)
3428 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
3431 for (c
= sym
->components
; c
; c
= c
->next
)
3433 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
3441 /* Resolve the argument of a deallocate expression. The expression must be
3442 a pointer or a full array. */
3445 resolve_deallocate_expr (gfc_expr
*e
)
3447 symbol_attribute attr
;
3448 int allocatable
, pointer
, check_intent_in
;
3451 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3452 check_intent_in
= 1;
3454 if (gfc_resolve_expr (e
) == FAILURE
)
3457 if (e
->expr_type
!= EXPR_VARIABLE
)
3460 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3461 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3462 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3465 check_intent_in
= 0;
3470 if (ref
->u
.ar
.type
!= AR_FULL
)
3475 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3476 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3477 pointer
= ref
->u
.c
.component
->pointer
;
3486 attr
= gfc_expr_attr (e
);
3488 if (allocatable
== 0 && attr
.pointer
== 0)
3491 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3492 "ALLOCATABLE or a POINTER", &e
->where
);
3496 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3498 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
3499 e
->symtree
->n
.sym
->name
, &e
->where
);
3507 /* Returns true if the expression e contains a reference the symbol sym. */
3509 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
3511 gfc_actual_arglist
*arg
;
3519 switch (e
->expr_type
)
3522 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3523 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
3526 /* If the variable is not the same as the dependent, 'sym', and
3527 it is not marked as being declared and it is in the same
3528 namespace as 'sym', add it to the local declarations. */
3530 if (sym
== e
->symtree
->n
.sym
)
3535 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
3536 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
3545 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3550 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3552 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
3553 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
3554 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
3559 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
3560 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
3564 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3565 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3568 || find_sym_in_expr (sym
,
3569 ref
->u
.c
.component
->ts
.cl
->length
);
3571 if (ref
->u
.c
.component
->as
)
3572 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3575 || find_sym_in_expr (sym
,
3576 ref
->u
.c
.component
->as
->lower
[i
]);
3578 || find_sym_in_expr (sym
,
3579 ref
->u
.c
.component
->as
->upper
[i
]);
3589 /* Given the expression node e for an allocatable/pointer of derived type to be
3590 allocated, get the expression node to be initialized afterwards (needed for
3591 derived types with default initializers, and derived types with allocatable
3592 components that need nullification.) */
3595 expr_to_initialize (gfc_expr
*e
)
3601 result
= gfc_copy_expr (e
);
3603 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3604 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
3605 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3607 ref
->u
.ar
.type
= AR_FULL
;
3609 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3610 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
3612 result
->rank
= ref
->u
.ar
.dimen
;
3620 /* Resolve the expression in an ALLOCATE statement, doing the additional
3621 checks to see whether the expression is OK or not. The expression must
3622 have a trailing array reference that gives the size of the array. */
3625 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
3627 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
3628 symbol_attribute attr
;
3629 gfc_ref
*ref
, *ref2
;
3636 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3637 check_intent_in
= 1;
3639 if (gfc_resolve_expr (e
) == FAILURE
)
3642 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
3643 sym
= code
->expr
->symtree
->n
.sym
;
3647 /* Make sure the expression is allocatable or a pointer. If it is
3648 pointer, the next-to-last reference must be a pointer. */
3652 if (e
->expr_type
!= EXPR_VARIABLE
)
3655 attr
= gfc_expr_attr (e
);
3656 pointer
= attr
.pointer
;
3657 dimension
= attr
.dimension
;
3661 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3662 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3663 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
3665 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
3667 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3668 "not be allocated in the same statement at %L",
3669 sym
->name
, &e
->where
);
3673 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
3676 check_intent_in
= 0;
3681 if (ref
->next
!= NULL
)
3686 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3687 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3689 pointer
= ref
->u
.c
.component
->pointer
;
3690 dimension
= ref
->u
.c
.component
->dimension
;
3701 if (allocatable
== 0 && pointer
== 0)
3703 gfc_error ("Expression in ALLOCATE statement at %L must be "
3704 "ALLOCATABLE or a POINTER", &e
->where
);
3709 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3711 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
3712 e
->symtree
->n
.sym
->name
, &e
->where
);
3716 /* Add default initializer for those derived types that need them. */
3717 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
3719 init_st
= gfc_get_code ();
3720 init_st
->loc
= code
->loc
;
3721 init_st
->op
= EXEC_INIT_ASSIGN
;
3722 init_st
->expr
= expr_to_initialize (e
);
3723 init_st
->expr2
= init_e
;
3724 init_st
->next
= code
->next
;
3725 code
->next
= init_st
;
3728 if (pointer
&& dimension
== 0)
3731 /* Make sure the next-to-last reference node is an array specification. */
3733 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
3735 gfc_error ("Array specification required in ALLOCATE statement "
3736 "at %L", &e
->where
);
3740 /* Make sure that the array section reference makes sense in the
3741 context of an ALLOCATE specification. */
3745 for (i
= 0; i
< ar
->dimen
; i
++)
3747 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
3750 switch (ar
->dimen_type
[i
])
3756 if (ar
->start
[i
] != NULL
3757 && ar
->end
[i
] != NULL
3758 && ar
->stride
[i
] == NULL
)
3761 /* Fall Through... */
3765 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3772 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3774 sym
= a
->expr
->symtree
->n
.sym
;
3776 /* TODO - check derived type components. */
3777 if (sym
->ts
.type
== BT_DERIVED
)
3780 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
3781 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
3783 gfc_error ("'%s' must not appear an the array specification at "
3784 "%L in the same ALLOCATE statement where it is "
3785 "itself allocated", sym
->name
, &ar
->where
);
3795 /************ SELECT CASE resolution subroutines ************/
3797 /* Callback function for our mergesort variant. Determines interval
3798 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3799 op1 > op2. Assumes we're not dealing with the default case.
3800 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3801 There are nine situations to check. */
3804 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
3808 if (op1
->low
== NULL
) /* op1 = (:L) */
3810 /* op2 = (:N), so overlap. */
3812 /* op2 = (M:) or (M:N), L < M */
3813 if (op2
->low
!= NULL
3814 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3817 else if (op1
->high
== NULL
) /* op1 = (K:) */
3819 /* op2 = (M:), so overlap. */
3821 /* op2 = (:N) or (M:N), K > N */
3822 if (op2
->high
!= NULL
3823 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3826 else /* op1 = (K:L) */
3828 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
3829 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
3830 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
3831 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
3832 else /* op2 = (M:N) */
3836 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3839 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3848 /* Merge-sort a double linked case list, detecting overlap in the
3849 process. LIST is the head of the double linked case list before it
3850 is sorted. Returns the head of the sorted list if we don't see any
3851 overlap, or NULL otherwise. */
3854 check_case_overlap (gfc_case
*list
)
3856 gfc_case
*p
, *q
, *e
, *tail
;
3857 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
3859 /* If the passed list was empty, return immediately. */
3866 /* Loop unconditionally. The only exit from this loop is a return
3867 statement, when we've finished sorting the case list. */
3874 /* Count the number of merges we do in this pass. */
3877 /* Loop while there exists a merge to be done. */
3882 /* Count this merge. */
3885 /* Cut the list in two pieces by stepping INSIZE places
3886 forward in the list, starting from P. */
3889 for (i
= 0; i
< insize
; i
++)
3898 /* Now we have two lists. Merge them! */
3899 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
3901 /* See from which the next case to merge comes from. */
3904 /* P is empty so the next case must come from Q. */
3909 else if (qsize
== 0 || q
== NULL
)
3918 cmp
= compare_cases (p
, q
);
3921 /* The whole case range for P is less than the
3929 /* The whole case range for Q is greater than
3930 the case range for P. */
3937 /* The cases overlap, or they are the same
3938 element in the list. Either way, we must
3939 issue an error and get the next case from P. */
3940 /* FIXME: Sort P and Q by line number. */
3941 gfc_error ("CASE label at %L overlaps with CASE "
3942 "label at %L", &p
->where
, &q
->where
);
3950 /* Add the next element to the merged list. */
3959 /* P has now stepped INSIZE places along, and so has Q. So
3960 they're the same. */
3965 /* If we have done only one merge or none at all, we've
3966 finished sorting the cases. */
3975 /* Otherwise repeat, merging lists twice the size. */
3981 /* Check to see if an expression is suitable for use in a CASE statement.
3982 Makes sure that all case expressions are scalar constants of the same
3983 type. Return FAILURE if anything is wrong. */
3986 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
3988 if (e
== NULL
) return SUCCESS
;
3990 if (e
->ts
.type
!= case_expr
->ts
.type
)
3992 gfc_error ("Expression in CASE statement at %L must be of type %s",
3993 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
3997 /* C805 (R808) For a given case-construct, each case-value shall be of
3998 the same type as case-expr. For character type, length differences
3999 are allowed, but the kind type parameters shall be the same. */
4001 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
4003 gfc_error("Expression in CASE statement at %L must be kind %d",
4004 &e
->where
, case_expr
->ts
.kind
);
4008 /* Convert the case value kind to that of case expression kind, if needed.
4009 FIXME: Should a warning be issued? */
4010 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
4011 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
4015 gfc_error ("Expression in CASE statement at %L must be scalar",
4024 /* Given a completely parsed select statement, we:
4026 - Validate all expressions and code within the SELECT.
4027 - Make sure that the selection expression is not of the wrong type.
4028 - Make sure that no case ranges overlap.
4029 - Eliminate unreachable cases and unreachable code resulting from
4030 removing case labels.
4032 The standard does allow unreachable cases, e.g. CASE (5:3). But
4033 they are a hassle for code generation, and to prevent that, we just
4034 cut them out here. This is not necessary for overlapping cases
4035 because they are illegal and we never even try to generate code.
4037 We have the additional caveat that a SELECT construct could have
4038 been a computed GOTO in the source code. Fortunately we can fairly
4039 easily work around that here: The case_expr for a "real" SELECT CASE
4040 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4041 we have to do is make sure that the case_expr is a scalar integer
4045 resolve_select (gfc_code
*code
)
4048 gfc_expr
*case_expr
;
4049 gfc_case
*cp
, *default_case
, *tail
, *head
;
4050 int seen_unreachable
;
4056 if (code
->expr
== NULL
)
4058 /* This was actually a computed GOTO statement. */
4059 case_expr
= code
->expr2
;
4060 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
4061 gfc_error ("Selection expression in computed GOTO statement "
4062 "at %L must be a scalar integer expression",
4065 /* Further checking is not necessary because this SELECT was built
4066 by the compiler, so it should always be OK. Just move the
4067 case_expr from expr2 to expr so that we can handle computed
4068 GOTOs as normal SELECTs from here on. */
4069 code
->expr
= code
->expr2
;
4074 case_expr
= code
->expr
;
4076 type
= case_expr
->ts
.type
;
4077 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
4079 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4080 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
4082 /* Punt. Going on here just produce more garbage error messages. */
4086 if (case_expr
->rank
!= 0)
4088 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4089 "expression", &case_expr
->where
);
4095 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4096 of the SELECT CASE expression and its CASE values. Walk the lists
4097 of case values, and if we find a mismatch, promote case_expr to
4098 the appropriate kind. */
4100 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
4102 for (body
= code
->block
; body
; body
= body
->block
)
4104 /* Walk the case label list. */
4105 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4107 /* Intercept the DEFAULT case. It does not have a kind. */
4108 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4111 /* Unreachable case ranges are discarded, so ignore. */
4112 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4113 && cp
->low
!= cp
->high
4114 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4117 /* FIXME: Should a warning be issued? */
4119 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
4120 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
4122 if (cp
->high
!= NULL
4123 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
4124 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
4129 /* Assume there is no DEFAULT case. */
4130 default_case
= NULL
;
4135 for (body
= code
->block
; body
; body
= body
->block
)
4137 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4139 seen_unreachable
= 0;
4141 /* Walk the case label list, making sure that all case labels
4143 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4145 /* Count the number of cases in the whole construct. */
4148 /* Intercept the DEFAULT case. */
4149 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4151 if (default_case
!= NULL
)
4153 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4154 "by a second DEFAULT CASE at %L",
4155 &default_case
->where
, &cp
->where
);
4166 /* Deal with single value cases and case ranges. Errors are
4167 issued from the validation function. */
4168 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
4169 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
4175 if (type
== BT_LOGICAL
4176 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
4177 || cp
->low
!= cp
->high
))
4179 gfc_error ("Logical range in CASE statement at %L is not "
4180 "allowed", &cp
->low
->where
);
4185 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
4188 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
4189 if (value
& seen_logical
)
4191 gfc_error ("constant logical value in CASE statement "
4192 "is repeated at %L",
4197 seen_logical
|= value
;
4200 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4201 && cp
->low
!= cp
->high
4202 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4204 if (gfc_option
.warn_surprising
)
4205 gfc_warning ("Range specification at %L can never "
4206 "be matched", &cp
->where
);
4208 cp
->unreachable
= 1;
4209 seen_unreachable
= 1;
4213 /* If the case range can be matched, it can also overlap with
4214 other cases. To make sure it does not, we put it in a
4215 double linked list here. We sort that with a merge sort
4216 later on to detect any overlapping cases. */
4220 head
->right
= head
->left
= NULL
;
4225 tail
->right
->left
= tail
;
4232 /* It there was a failure in the previous case label, give up
4233 for this case label list. Continue with the next block. */
4237 /* See if any case labels that are unreachable have been seen.
4238 If so, we eliminate them. This is a bit of a kludge because
4239 the case lists for a single case statement (label) is a
4240 single forward linked lists. */
4241 if (seen_unreachable
)
4243 /* Advance until the first case in the list is reachable. */
4244 while (body
->ext
.case_list
!= NULL
4245 && body
->ext
.case_list
->unreachable
)
4247 gfc_case
*n
= body
->ext
.case_list
;
4248 body
->ext
.case_list
= body
->ext
.case_list
->next
;
4250 gfc_free_case_list (n
);
4253 /* Strip all other unreachable cases. */
4254 if (body
->ext
.case_list
)
4256 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
4258 if (cp
->next
->unreachable
)
4260 gfc_case
*n
= cp
->next
;
4261 cp
->next
= cp
->next
->next
;
4263 gfc_free_case_list (n
);
4270 /* See if there were overlapping cases. If the check returns NULL,
4271 there was overlap. In that case we don't do anything. If head
4272 is non-NULL, we prepend the DEFAULT case. The sorted list can
4273 then used during code generation for SELECT CASE constructs with
4274 a case expression of a CHARACTER type. */
4277 head
= check_case_overlap (head
);
4279 /* Prepend the default_case if it is there. */
4280 if (head
!= NULL
&& default_case
)
4282 default_case
->left
= NULL
;
4283 default_case
->right
= head
;
4284 head
->left
= default_case
;
4288 /* Eliminate dead blocks that may be the result if we've seen
4289 unreachable case labels for a block. */
4290 for (body
= code
; body
&& body
->block
; body
= body
->block
)
4292 if (body
->block
->ext
.case_list
== NULL
)
4294 /* Cut the unreachable block from the code chain. */
4295 gfc_code
*c
= body
->block
;
4296 body
->block
= c
->block
;
4298 /* Kill the dead block, but not the blocks below it. */
4300 gfc_free_statements (c
);
4304 /* More than two cases is legal but insane for logical selects.
4305 Issue a warning for it. */
4306 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
4308 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4313 /* Resolve a transfer statement. This is making sure that:
4314 -- a derived type being transferred has only non-pointer components
4315 -- a derived type being transferred doesn't have private components, unless
4316 it's being transferred from the module where the type was defined
4317 -- we're not trying to transfer a whole assumed size array. */
4320 resolve_transfer (gfc_code
*code
)
4329 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
4332 sym
= exp
->symtree
->n
.sym
;
4335 /* Go to actual component transferred. */
4336 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
4337 if (ref
->type
== REF_COMPONENT
)
4338 ts
= &ref
->u
.c
.component
->ts
;
4340 if (ts
->type
== BT_DERIVED
)
4342 /* Check that transferred derived type doesn't contain POINTER
4344 if (derived_pointer (ts
->derived
))
4346 gfc_error ("Data transfer element at %L cannot have "
4347 "POINTER components", &code
->loc
);
4351 if (ts
->derived
->attr
.alloc_comp
)
4353 gfc_error ("Data transfer element at %L cannot have "
4354 "ALLOCATABLE components", &code
->loc
);
4358 if (derived_inaccessible (ts
->derived
))
4360 gfc_error ("Data transfer element at %L cannot have "
4361 "PRIVATE components",&code
->loc
);
4366 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
4367 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
4369 gfc_error ("Data transfer element at %L cannot be a full reference to "
4370 "an assumed-size array", &code
->loc
);
4376 /*********** Toplevel code resolution subroutines ***********/
4378 /* Given a branch to a label and a namespace, if the branch is conforming.
4379 The code node described where the branch is located. */
4382 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
4384 gfc_code
*block
, *found
;
4392 /* Step one: is this a valid branching target? */
4394 if (lp
->defined
== ST_LABEL_UNKNOWN
)
4396 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
4401 if (lp
->defined
!= ST_LABEL_TARGET
)
4403 gfc_error ("Statement at %L is not a valid branch target statement "
4404 "for the branch statement at %L", &lp
->where
, &code
->loc
);
4408 /* Step two: make sure this branch is not a branch to itself ;-) */
4410 if (code
->here
== label
)
4412 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
4416 /* Step three: Try to find the label in the parse tree. To do this,
4417 we traverse the tree block-by-block: first the block that
4418 contains this GOTO, then the block that it is nested in, etc. We
4419 can ignore other blocks because branching into another block is
4424 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4426 for (block
= stack
->head
; block
; block
= block
->next
)
4428 if (block
->here
== label
)
4441 /* The label is not in an enclosing block, so illegal. This was
4442 allowed in Fortran 66, so we allow it as extension. We also
4443 forego further checks if we run into this. */
4444 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
4445 "as the GOTO statement at %L", &lp
->where
, &code
->loc
);
4449 /* Step four: Make sure that the branching target is legal if
4450 the statement is an END {SELECT,DO,IF}. */
4452 if (found
->op
== EXEC_NOP
)
4454 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4455 if (stack
->current
->next
== found
)
4459 gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: GOTO at %L jumps to END "
4460 "of construct at %L", &code
->loc
, &found
->loc
);
4465 /* Check whether EXPR1 has the same shape as EXPR2. */
4468 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
4470 mpz_t shape
[GFC_MAX_DIMENSIONS
];
4471 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
4472 try result
= FAILURE
;
4475 /* Compare the rank. */
4476 if (expr1
->rank
!= expr2
->rank
)
4479 /* Compare the size of each dimension. */
4480 for (i
=0; i
<expr1
->rank
; i
++)
4482 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
4485 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
4488 if (mpz_cmp (shape
[i
], shape2
[i
]))
4492 /* When either of the two expression is an assumed size array, we
4493 ignore the comparison of dimension sizes. */
4498 for (i
--; i
>= 0; i
--)
4500 mpz_clear (shape
[i
]);
4501 mpz_clear (shape2
[i
]);
4507 /* Check whether a WHERE assignment target or a WHERE mask expression
4508 has the same shape as the outmost WHERE mask expression. */
4511 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
4517 cblock
= code
->block
;
4519 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4520 In case of nested WHERE, only the outmost one is stored. */
4521 if (mask
== NULL
) /* outmost WHERE */
4523 else /* inner WHERE */
4530 /* Check if the mask-expr has a consistent shape with the
4531 outmost WHERE mask-expr. */
4532 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
4533 gfc_error ("WHERE mask at %L has inconsistent shape",
4534 &cblock
->expr
->where
);
4537 /* the assignment statement of a WHERE statement, or the first
4538 statement in where-body-construct of a WHERE construct */
4539 cnext
= cblock
->next
;
4544 /* WHERE assignment statement */
4547 /* Check shape consistent for WHERE assignment target. */
4548 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
4549 gfc_error ("WHERE assignment target at %L has "
4550 "inconsistent shape", &cnext
->expr
->where
);
4553 /* WHERE or WHERE construct is part of a where-body-construct */
4555 resolve_where (cnext
, e
);
4559 gfc_error ("Unsupported statement inside WHERE at %L",
4562 /* the next statement within the same where-body-construct */
4563 cnext
= cnext
->next
;
4565 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4566 cblock
= cblock
->block
;
4571 /* Check whether the FORALL index appears in the expression or not. */
4574 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4578 gfc_actual_arglist
*args
;
4581 switch (expr
->expr_type
)
4584 gcc_assert (expr
->symtree
->n
.sym
);
4586 /* A scalar assignment */
4589 if (expr
->symtree
->n
.sym
== symbol
)
4595 /* the expr is array ref, substring or struct component. */
4602 /* Check if the symbol appears in the array subscript. */
4604 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4607 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4611 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4615 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4621 if (expr
->symtree
->n
.sym
== symbol
)
4624 /* Check if the symbol appears in the substring section. */
4625 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4627 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4635 gfc_error("expression reference type error at %L", &expr
->where
);
4641 /* If the expression is a function call, then check if the symbol
4642 appears in the actual arglist of the function. */
4644 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4646 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4651 /* It seems not to happen. */
4652 case EXPR_SUBSTRING
:
4656 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4657 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4659 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4664 /* It seems not to happen. */
4665 case EXPR_STRUCTURE
:
4667 gfc_error ("Unsupported statement while finding forall index in "
4672 /* Find the FORALL index in the first operand. */
4673 if (expr
->value
.op
.op1
)
4675 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4679 /* Find the FORALL index in the second operand. */
4680 if (expr
->value
.op
.op2
)
4682 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4695 /* Resolve assignment in FORALL construct.
4696 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4697 FORALL index variables. */
4700 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4704 for (n
= 0; n
< nvar
; n
++)
4706 gfc_symbol
*forall_index
;
4708 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
4710 /* Check whether the assignment target is one of the FORALL index
4712 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
4713 && (code
->expr
->symtree
->n
.sym
== forall_index
))
4714 gfc_error ("Assignment to a FORALL index variable at %L",
4715 &code
->expr
->where
);
4718 /* If one of the FORALL index variables doesn't appear in the
4719 assignment target, then there will be a many-to-one
4721 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4722 gfc_error ("The FORALL with index '%s' cause more than one "
4723 "assignment to this object at %L",
4724 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4730 /* Resolve WHERE statement in FORALL construct. */
4733 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
4734 gfc_expr
**var_expr
)
4739 cblock
= code
->block
;
4742 /* the assignment statement of a WHERE statement, or the first
4743 statement in where-body-construct of a WHERE construct */
4744 cnext
= cblock
->next
;
4749 /* WHERE assignment statement */
4751 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4754 /* WHERE or WHERE construct is part of a where-body-construct */
4756 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4760 gfc_error ("Unsupported statement inside WHERE at %L",
4763 /* the next statement within the same where-body-construct */
4764 cnext
= cnext
->next
;
4766 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4767 cblock
= cblock
->block
;
4772 /* Traverse the FORALL body to check whether the following errors exist:
4773 1. For assignment, check if a many-to-one assignment happens.
4774 2. For WHERE statement, check the WHERE body to see if there is any
4775 many-to-one assignment. */
4778 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4782 c
= code
->block
->next
;
4788 case EXEC_POINTER_ASSIGN
:
4789 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4792 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4793 there is no need to handle it here. */
4797 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4802 /* The next statement in the FORALL body. */
4808 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4809 gfc_resolve_forall_body to resolve the FORALL body. */
4812 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4814 static gfc_expr
**var_expr
;
4815 static int total_var
= 0;
4816 static int nvar
= 0;
4817 gfc_forall_iterator
*fa
;
4818 gfc_symbol
*forall_index
;
4822 /* Start to resolve a FORALL construct */
4823 if (forall_save
== 0)
4825 /* Count the total number of FORALL index in the nested FORALL
4826 construct in order to allocate the VAR_EXPR with proper size. */
4828 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4830 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4832 next
= next
->block
->next
;
4835 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4836 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4839 /* The information about FORALL iterator, including FORALL index start, end
4840 and stride. The FORALL index can not appear in start, end or stride. */
4841 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4843 /* Check if any outer FORALL index name is the same as the current
4845 for (i
= 0; i
< nvar
; i
++)
4847 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4849 gfc_error ("An outer FORALL construct already has an index "
4850 "with this name %L", &fa
->var
->where
);
4854 /* Record the current FORALL index. */
4855 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4857 forall_index
= fa
->var
->symtree
->n
.sym
;
4859 /* Check if the FORALL index appears in start, end or stride. */
4860 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4861 gfc_error ("A FORALL index must not appear in a limit or stride "
4862 "expression in the same FORALL at %L", &fa
->start
->where
);
4863 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4864 gfc_error ("A FORALL index must not appear in a limit or stride "
4865 "expression in the same FORALL at %L", &fa
->end
->where
);
4866 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4867 gfc_error ("A FORALL index must not appear in a limit or stride "
4868 "expression in the same FORALL at %L", &fa
->stride
->where
);
4872 /* Resolve the FORALL body. */
4873 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4875 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4876 gfc_resolve_blocks (code
->block
, ns
);
4878 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4879 for (i
= 0; i
< total_var
; i
++)
4880 gfc_free_expr (var_expr
[i
]);
4882 /* Reset the counters. */
4888 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4891 static void resolve_code (gfc_code
*, gfc_namespace
*);
4894 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
4898 for (; b
; b
= b
->block
)
4900 t
= gfc_resolve_expr (b
->expr
);
4901 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4907 if (t
== SUCCESS
&& b
->expr
!= NULL
4908 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4909 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4916 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
4917 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4922 resolve_branch (b
->label
, b
);
4934 case EXEC_OMP_ATOMIC
:
4935 case EXEC_OMP_CRITICAL
:
4937 case EXEC_OMP_MASTER
:
4938 case EXEC_OMP_ORDERED
:
4939 case EXEC_OMP_PARALLEL
:
4940 case EXEC_OMP_PARALLEL_DO
:
4941 case EXEC_OMP_PARALLEL_SECTIONS
:
4942 case EXEC_OMP_PARALLEL_WORKSHARE
:
4943 case EXEC_OMP_SECTIONS
:
4944 case EXEC_OMP_SINGLE
:
4945 case EXEC_OMP_WORKSHARE
:
4949 gfc_internal_error ("resolve_block(): Bad block type");
4952 resolve_code (b
->next
, ns
);
4957 /* Given a block of code, recursively resolve everything pointed to by this
4961 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
4963 int omp_workshare_save
;
4969 frame
.prev
= cs_base
;
4973 for (; code
; code
= code
->next
)
4975 frame
.current
= code
;
4976 forall_save
= forall_flag
;
4978 if (code
->op
== EXEC_FORALL
)
4981 gfc_resolve_forall (code
, ns
, forall_save
);
4984 else if (code
->block
)
4986 omp_workshare_save
= -1;
4989 case EXEC_OMP_PARALLEL_WORKSHARE
:
4990 omp_workshare_save
= omp_workshare_flag
;
4991 omp_workshare_flag
= 1;
4992 gfc_resolve_omp_parallel_blocks (code
, ns
);
4994 case EXEC_OMP_PARALLEL
:
4995 case EXEC_OMP_PARALLEL_DO
:
4996 case EXEC_OMP_PARALLEL_SECTIONS
:
4997 omp_workshare_save
= omp_workshare_flag
;
4998 omp_workshare_flag
= 0;
4999 gfc_resolve_omp_parallel_blocks (code
, ns
);
5002 gfc_resolve_omp_do_blocks (code
, ns
);
5004 case EXEC_OMP_WORKSHARE
:
5005 omp_workshare_save
= omp_workshare_flag
;
5006 omp_workshare_flag
= 1;
5009 gfc_resolve_blocks (code
->block
, ns
);
5013 if (omp_workshare_save
!= -1)
5014 omp_workshare_flag
= omp_workshare_save
;
5017 t
= gfc_resolve_expr (code
->expr
);
5018 forall_flag
= forall_save
;
5020 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
5035 /* Keep track of which entry we are up to. */
5036 current_entry_id
= code
->ext
.entry
->id
;
5040 resolve_where (code
, NULL
);
5044 if (code
->expr
!= NULL
)
5046 if (code
->expr
->ts
.type
!= BT_INTEGER
)
5047 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5048 "INTEGER variable", &code
->expr
->where
);
5049 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
5050 gfc_error ("Variable '%s' has not been assigned a target "
5051 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
5052 &code
->expr
->where
);
5055 resolve_branch (code
->label
, code
);
5059 if (code
->expr
!= NULL
5060 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
5061 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5062 "INTEGER return specifier", &code
->expr
->where
);
5065 case EXEC_INIT_ASSIGN
:
5072 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5074 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5076 gfc_error ("Subroutine '%s' called instead of assignment at "
5077 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5084 if (code
->expr
->ts
.type
== BT_CHARACTER
5085 && gfc_option
.warn_character_truncation
)
5087 int llen
= 0, rlen
= 0;
5089 if (code
->expr
->ts
.cl
!= NULL
5090 && code
->expr
->ts
.cl
->length
!= NULL
5091 && code
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5092 llen
= mpz_get_si (code
->expr
->ts
.cl
->length
->value
.integer
);
5094 if (code
->expr2
->expr_type
== EXPR_CONSTANT
)
5095 rlen
= code
->expr2
->value
.character
.length
;
5097 else if (code
->expr2
->ts
.cl
!= NULL
5098 && code
->expr2
->ts
.cl
->length
!= NULL
5099 && code
->expr2
->ts
.cl
->length
->expr_type
5101 rlen
= mpz_get_si (code
->expr2
->ts
.cl
->length
->value
.integer
);
5103 if (rlen
&& llen
&& rlen
> llen
)
5104 gfc_warning_now ("rhs of CHARACTER assignment at %L will be "
5105 "truncated (%d/%d)", &code
->loc
, rlen
, llen
);
5108 if (gfc_pure (NULL
))
5110 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
5112 gfc_error ("Cannot assign to variable '%s' in PURE "
5114 code
->expr
->symtree
->n
.sym
->name
,
5115 &code
->expr
->where
);
5119 if (code
->expr2
->ts
.type
== BT_DERIVED
5120 && derived_pointer (code
->expr2
->ts
.derived
))
5122 gfc_error ("Right side of assignment at %L is a derived "
5123 "type containing a POINTER in a PURE procedure",
5124 &code
->expr2
->where
);
5129 gfc_check_assign (code
->expr
, code
->expr2
, 1);
5132 case EXEC_LABEL_ASSIGN
:
5133 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
5134 gfc_error ("Label %d referenced at %L is never defined",
5135 code
->label
->value
, &code
->label
->where
);
5137 && (code
->expr
->expr_type
!= EXPR_VARIABLE
5138 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
5139 || code
->expr
->symtree
->n
.sym
->ts
.kind
5140 != gfc_default_integer_kind
5141 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
5142 gfc_error ("ASSIGN statement at %L requires a scalar "
5143 "default INTEGER variable", &code
->expr
->where
);
5146 case EXEC_POINTER_ASSIGN
:
5150 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
5153 case EXEC_ARITHMETIC_IF
:
5155 && code
->expr
->ts
.type
!= BT_INTEGER
5156 && code
->expr
->ts
.type
!= BT_REAL
)
5157 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5158 "expression", &code
->expr
->where
);
5160 resolve_branch (code
->label
, code
);
5161 resolve_branch (code
->label2
, code
);
5162 resolve_branch (code
->label3
, code
);
5166 if (t
== SUCCESS
&& code
->expr
!= NULL
5167 && (code
->expr
->ts
.type
!= BT_LOGICAL
5168 || code
->expr
->rank
!= 0))
5169 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5170 &code
->expr
->where
);
5175 resolve_call (code
);
5179 /* Select is complicated. Also, a SELECT construct could be
5180 a transformed computed GOTO. */
5181 resolve_select (code
);
5185 if (code
->ext
.iterator
!= NULL
)
5187 gfc_iterator
*iter
= code
->ext
.iterator
;
5188 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
5189 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
5194 if (code
->expr
== NULL
)
5195 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5197 && (code
->expr
->rank
!= 0
5198 || code
->expr
->ts
.type
!= BT_LOGICAL
))
5199 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5200 "a scalar LOGICAL expression", &code
->expr
->where
);
5204 if (t
== SUCCESS
&& code
->expr
!= NULL
5205 && code
->expr
->ts
.type
!= BT_INTEGER
)
5206 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5207 "of type INTEGER", &code
->expr
->where
);
5209 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5210 resolve_allocate_expr (a
->expr
, code
);
5214 case EXEC_DEALLOCATE
:
5215 if (t
== SUCCESS
&& code
->expr
!= NULL
5216 && code
->expr
->ts
.type
!= BT_INTEGER
)
5218 ("STAT tag in DEALLOCATE statement at %L must be of type "
5219 "INTEGER", &code
->expr
->where
);
5221 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5222 resolve_deallocate_expr (a
->expr
);
5227 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
5230 resolve_branch (code
->ext
.open
->err
, code
);
5234 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
5237 resolve_branch (code
->ext
.close
->err
, code
);
5240 case EXEC_BACKSPACE
:
5244 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
5247 resolve_branch (code
->ext
.filepos
->err
, code
);
5251 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5254 resolve_branch (code
->ext
.inquire
->err
, code
);
5258 gcc_assert (code
->ext
.inquire
!= NULL
);
5259 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5262 resolve_branch (code
->ext
.inquire
->err
, code
);
5267 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
5270 resolve_branch (code
->ext
.dt
->err
, code
);
5271 resolve_branch (code
->ext
.dt
->end
, code
);
5272 resolve_branch (code
->ext
.dt
->eor
, code
);
5276 resolve_transfer (code
);
5280 resolve_forall_iterators (code
->ext
.forall_iterator
);
5282 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
5283 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
5284 "expression", &code
->expr
->where
);
5287 case EXEC_OMP_ATOMIC
:
5288 case EXEC_OMP_BARRIER
:
5289 case EXEC_OMP_CRITICAL
:
5290 case EXEC_OMP_FLUSH
:
5292 case EXEC_OMP_MASTER
:
5293 case EXEC_OMP_ORDERED
:
5294 case EXEC_OMP_SECTIONS
:
5295 case EXEC_OMP_SINGLE
:
5296 case EXEC_OMP_WORKSHARE
:
5297 gfc_resolve_omp_directive (code
, ns
);
5300 case EXEC_OMP_PARALLEL
:
5301 case EXEC_OMP_PARALLEL_DO
:
5302 case EXEC_OMP_PARALLEL_SECTIONS
:
5303 case EXEC_OMP_PARALLEL_WORKSHARE
:
5304 omp_workshare_save
= omp_workshare_flag
;
5305 omp_workshare_flag
= 0;
5306 gfc_resolve_omp_directive (code
, ns
);
5307 omp_workshare_flag
= omp_workshare_save
;
5311 gfc_internal_error ("resolve_code(): Bad statement code");
5315 cs_base
= frame
.prev
;
5319 /* Resolve initial values and make sure they are compatible with
5323 resolve_values (gfc_symbol
*sym
)
5325 if (sym
->value
== NULL
)
5328 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
5331 gfc_check_assign_symbol (sym
, sym
->value
);
5335 /* Resolve an index expression. */
5338 resolve_index_expr (gfc_expr
*e
)
5340 if (gfc_resolve_expr (e
) == FAILURE
)
5343 if (gfc_simplify_expr (e
, 0) == FAILURE
)
5346 if (gfc_specification_expr (e
) == FAILURE
)
5352 /* Resolve a charlen structure. */
5355 resolve_charlen (gfc_charlen
*cl
)
5362 specification_expr
= 1;
5364 if (resolve_index_expr (cl
->length
) == FAILURE
)
5366 specification_expr
= 0;
5374 /* Test for non-constant shape arrays. */
5377 is_non_constant_shape_array (gfc_symbol
*sym
)
5383 not_constant
= false;
5384 if (sym
->as
!= NULL
)
5386 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5387 has not been simplified; parameter array references. Do the
5388 simplification now. */
5389 for (i
= 0; i
< sym
->as
->rank
; i
++)
5391 e
= sym
->as
->lower
[i
];
5392 if (e
&& (resolve_index_expr (e
) == FAILURE
5393 || !gfc_is_constant_expr (e
)))
5394 not_constant
= true;
5396 e
= sym
->as
->upper
[i
];
5397 if (e
&& (resolve_index_expr (e
) == FAILURE
5398 || !gfc_is_constant_expr (e
)))
5399 not_constant
= true;
5402 return not_constant
;
5406 /* Assign the default initializer to a derived type variable or result. */
5409 apply_default_init (gfc_symbol
*sym
)
5412 gfc_expr
*init
= NULL
;
5414 gfc_namespace
*ns
= sym
->ns
;
5416 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
5419 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
5420 init
= gfc_default_initializer (&sym
->ts
);
5425 /* Search for the function namespace if this is a contained
5426 function without an explicit result. */
5427 if (sym
->attr
.function
&& sym
== sym
->result
5428 && sym
->name
!= sym
->ns
->proc_name
->name
)
5431 for (;ns
; ns
= ns
->sibling
)
5432 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
5438 gfc_free_expr (init
);
5442 /* Build an l-value expression for the result. */
5443 lval
= gfc_get_expr ();
5444 lval
->expr_type
= EXPR_VARIABLE
;
5445 lval
->where
= sym
->declared_at
;
5447 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5449 /* It will always be a full array. */
5450 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
5453 lval
->ref
= gfc_get_ref ();
5454 lval
->ref
->type
= REF_ARRAY
;
5455 lval
->ref
->u
.ar
.type
= AR_FULL
;
5456 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
5457 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
5458 lval
->ref
->u
.ar
.as
= sym
->as
;
5461 /* Add the code at scope entry. */
5462 init_st
= gfc_get_code ();
5463 init_st
->next
= ns
->code
;
5466 /* Assign the default initializer to the l-value. */
5467 init_st
->loc
= sym
->declared_at
;
5468 init_st
->op
= EXEC_INIT_ASSIGN
;
5469 init_st
->expr
= lval
;
5470 init_st
->expr2
= init
;
5474 /* Resolution of common features of flavors variable and procedure. */
5477 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
5479 /* Constraints on deferred shape variable. */
5480 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
5482 if (sym
->attr
.allocatable
)
5484 if (sym
->attr
.dimension
)
5485 gfc_error ("Allocatable array '%s' at %L must have "
5486 "a deferred shape", sym
->name
, &sym
->declared_at
);
5488 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5489 sym
->name
, &sym
->declared_at
);
5493 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
5495 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5496 sym
->name
, &sym
->declared_at
);
5503 if (!mp_flag
&& !sym
->attr
.allocatable
5504 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
5506 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5507 sym
->name
, &sym
->declared_at
);
5515 /* Resolve symbols with flavor variable. */
5518 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
5523 gfc_expr
*constructor_expr
;
5524 const char *auto_save_msg
;
5526 auto_save_msg
= "automatic object '%s' at %L cannot have the "
5529 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5532 /* Set this flag to check that variables are parameters of all entries.
5533 This check is effected by the call to gfc_resolve_expr through
5534 is_non_constant_shape_array. */
5535 specification_expr
= 1;
5537 if (!sym
->attr
.use_assoc
5538 && !sym
->attr
.allocatable
5539 && !sym
->attr
.pointer
5540 && is_non_constant_shape_array (sym
))
5542 /* The shape of a main program or module array needs to be
5544 if (sym
->ns
->proc_name
5545 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5546 || sym
->ns
->proc_name
->attr
.is_main_program
))
5548 gfc_error ("The module or main program array '%s' at %L must "
5549 "have constant shape", sym
->name
, &sym
->declared_at
);
5550 specification_expr
= 0;
5555 if (sym
->ts
.type
== BT_CHARACTER
)
5557 /* Make sure that character string variables with assumed length are
5559 e
= sym
->ts
.cl
->length
;
5560 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
5562 gfc_error ("Entity with assumed character length at %L must be a "
5563 "dummy argument or a PARAMETER", &sym
->declared_at
);
5567 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
5569 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5573 if (!gfc_is_constant_expr (e
)
5574 && !(e
->expr_type
== EXPR_VARIABLE
5575 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
5576 && sym
->ns
->proc_name
5577 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5578 || sym
->ns
->proc_name
->attr
.is_main_program
)
5579 && !sym
->attr
.use_assoc
)
5581 gfc_error ("'%s' at %L must have constant character length "
5582 "in this context", sym
->name
, &sym
->declared_at
);
5587 /* Can the symbol have an initializer? */
5589 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
5590 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
5592 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
5594 /* Don't allow initialization of automatic arrays. */
5595 for (i
= 0; i
< sym
->as
->rank
; i
++)
5597 if (sym
->as
->lower
[i
] == NULL
5598 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5599 || sym
->as
->upper
[i
] == NULL
5600 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
5607 /* Also, they must not have the SAVE attribute. */
5608 if (flag
&& sym
->attr
.save
)
5610 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5615 /* Reject illegal initializers. */
5616 if (sym
->value
&& flag
)
5618 if (sym
->attr
.allocatable
)
5619 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5620 sym
->name
, &sym
->declared_at
);
5621 else if (sym
->attr
.external
)
5622 gfc_error ("External '%s' at %L cannot have an initializer",
5623 sym
->name
, &sym
->declared_at
);
5624 else if (sym
->attr
.dummy
)
5625 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5626 sym
->name
, &sym
->declared_at
);
5627 else if (sym
->attr
.intrinsic
)
5628 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5629 sym
->name
, &sym
->declared_at
);
5630 else if (sym
->attr
.result
)
5631 gfc_error ("Function result '%s' at %L cannot have an initializer",
5632 sym
->name
, &sym
->declared_at
);
5634 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5635 sym
->name
, &sym
->declared_at
);
5639 /* Check to see if a derived type is blocked from being host associated
5640 by the presence of another class I symbol in the same namespace.
5641 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5642 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
)
5645 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
5646 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
5647 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
5649 gfc_error ("The type %s cannot be host associated at %L because "
5650 "it is blocked by an incompatible object of the same "
5651 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
5657 /* 4th constraint in section 11.3: "If an object of a type for which
5658 component-initialization is specified (R429) appears in the
5659 specification-part of a module and does not have the ALLOCATABLE
5660 or POINTER attribute, the object shall have the SAVE attribute." */
5662 constructor_expr
= NULL
;
5663 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
5664 constructor_expr
= gfc_default_initializer (&sym
->ts
);
5666 if (sym
->ns
->proc_name
5667 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5669 && !sym
->ns
->save_all
&& !sym
->attr
.save
5670 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
5672 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5673 sym
->name
, &sym
->declared_at
,
5674 "for default initialization of a component");
5678 /* Assign default initializer. */
5679 if (sym
->ts
.type
== BT_DERIVED
5681 && !sym
->attr
.pointer
5682 && !sym
->attr
.allocatable
5683 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
5684 sym
->value
= gfc_default_initializer (&sym
->ts
);
5690 /* Resolve a procedure. */
5693 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
5695 gfc_formal_arglist
*arg
;
5697 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
5698 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5699 "interfaces", sym
->name
, &sym
->declared_at
);
5701 if (sym
->attr
.function
5702 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5705 if (sym
->ts
.type
== BT_CHARACTER
)
5707 gfc_charlen
*cl
= sym
->ts
.cl
;
5708 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
5710 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5712 gfc_error ("Character-valued statement function '%s' at %L must "
5713 "have constant length", sym
->name
, &sym
->declared_at
);
5717 if (sym
->attr
.external
&& sym
->formal
== NULL
5718 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
5720 gfc_error ("Automatic character length function '%s' at %L must "
5721 "have an explicit interface", sym
->name
,
5728 /* Ensure that derived type for are not of a private type. Internal
5729 module procedures are excluded by 2.2.3.3 - ie. they are not
5730 externally accessible and can access all the objects accessible in
5732 if (!(sym
->ns
->parent
5733 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5734 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5736 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
5739 && arg
->sym
->ts
.type
== BT_DERIVED
5740 && !arg
->sym
->ts
.derived
->attr
.use_assoc
5741 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
5742 arg
->sym
->ts
.derived
->ns
->default_access
))
5744 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5745 "a dummy argument of '%s', which is "
5746 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
5748 /* Stop this message from recurring. */
5749 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
5755 /* An external symbol may not have an initializer because it is taken to be
5757 if (sym
->attr
.external
&& sym
->value
)
5759 gfc_error ("External object '%s' at %L may not have an initializer",
5760 sym
->name
, &sym
->declared_at
);
5764 /* An elemental function is required to return a scalar 12.7.1 */
5765 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
5767 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5768 "result", sym
->name
, &sym
->declared_at
);
5769 /* Reset so that the error only occurs once. */
5770 sym
->attr
.elemental
= 0;
5774 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5775 char-len-param shall not be array-valued, pointer-valued, recursive
5776 or pure. ....snip... A character value of * may only be used in the
5777 following ways: (i) Dummy arg of procedure - dummy associates with
5778 actual length; (ii) To declare a named constant; or (iii) External
5779 function - but length must be declared in calling scoping unit. */
5780 if (sym
->attr
.function
5781 && sym
->ts
.type
== BT_CHARACTER
5782 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
5784 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
5785 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
5787 if (sym
->as
&& sym
->as
->rank
)
5788 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5789 "array-valued", sym
->name
, &sym
->declared_at
);
5791 if (sym
->attr
.pointer
)
5792 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5793 "pointer-valued", sym
->name
, &sym
->declared_at
);
5796 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5797 "pure", sym
->name
, &sym
->declared_at
);
5799 if (sym
->attr
.recursive
)
5800 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5801 "recursive", sym
->name
, &sym
->declared_at
);
5806 /* Appendix B.2 of the standard. Contained functions give an
5807 error anyway. Fixed-form is likely to be F77/legacy. */
5808 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
5809 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
5810 "'%s' at %L is obsolescent in fortran 95",
5811 sym
->name
, &sym
->declared_at
);
5817 /* Resolve the components of a derived type. */
5820 resolve_fl_derived (gfc_symbol
*sym
)
5823 gfc_dt_list
* dt_list
;
5826 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
5828 if (c
->ts
.type
== BT_CHARACTER
)
5830 if (c
->ts
.cl
->length
== NULL
5831 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
5832 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
5834 gfc_error ("Character length of component '%s' needs to "
5835 "be a constant specification expression at %L",
5837 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
5842 if (c
->ts
.type
== BT_DERIVED
5843 && sym
->component_access
!= ACCESS_PRIVATE
5844 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
5845 && !c
->ts
.derived
->attr
.use_assoc
5846 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
5847 c
->ts
.derived
->ns
->default_access
))
5849 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5850 "a component of '%s', which is PUBLIC at %L",
5851 c
->name
, sym
->name
, &sym
->declared_at
);
5855 if (sym
->attr
.sequence
)
5857 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
5859 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5860 "not have the SEQUENCE attribute",
5861 c
->ts
.derived
->name
, &sym
->declared_at
);
5866 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
5867 && c
->ts
.derived
->components
== NULL
)
5869 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5870 "that has not been declared", c
->name
, sym
->name
,
5875 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
5878 for (i
= 0; i
< c
->as
->rank
; i
++)
5880 if (c
->as
->lower
[i
] == NULL
5881 || !gfc_is_constant_expr (c
->as
->lower
[i
])
5882 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
5883 || c
->as
->upper
[i
] == NULL
5884 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
5885 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
5887 gfc_error ("Component '%s' of '%s' at %L must have "
5888 "constant array bounds",
5889 c
->name
, sym
->name
, &c
->loc
);
5895 /* Add derived type to the derived type list. */
5896 for (dt_list
= sym
->ns
->derived_types
; dt_list
; dt_list
= dt_list
->next
)
5897 if (sym
== dt_list
->derived
)
5900 if (dt_list
== NULL
)
5902 dt_list
= gfc_get_dt_list ();
5903 dt_list
->next
= sym
->ns
->derived_types
;
5904 dt_list
->derived
= sym
;
5905 sym
->ns
->derived_types
= dt_list
;
5913 resolve_fl_namelist (gfc_symbol
*sym
)
5918 /* Reject PRIVATE objects in a PUBLIC namelist. */
5919 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5921 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5923 if (!nl
->sym
->attr
.use_assoc
5924 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5925 && !gfc_check_access(nl
->sym
->attr
.access
,
5926 nl
->sym
->ns
->default_access
))
5928 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5929 "PUBLIC namelist at %L", nl
->sym
->name
,
5936 /* Reject namelist arrays that are not constant shape. */
5937 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5939 if (is_non_constant_shape_array (nl
->sym
))
5941 gfc_error ("The array '%s' must have constant shape to be "
5942 "a NAMELIST object at %L", nl
->sym
->name
,
5948 /* Namelist objects cannot have allocatable components. */
5949 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5951 if (nl
->sym
->ts
.type
== BT_DERIVED
5952 && nl
->sym
->ts
.derived
->attr
.alloc_comp
)
5954 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5955 "components", nl
->sym
->name
, &sym
->declared_at
);
5960 /* 14.1.2 A module or internal procedure represent local entities
5961 of the same type as a namelist member and so are not allowed.
5962 Note that this is sometimes caught by check_conflict so the
5963 same message has been used. */
5964 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5966 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
5969 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5970 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5971 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5973 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5974 "attribute in '%s' at %L", nlsym
->name
,
5985 resolve_fl_parameter (gfc_symbol
*sym
)
5987 /* A parameter array's shape needs to be constant. */
5988 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
5990 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5991 "or assumed shape", sym
->name
, &sym
->declared_at
);
5995 /* Make sure a parameter that has been implicitly typed still
5996 matches the implicit type, since PARAMETER statements can precede
5997 IMPLICIT statements. */
5998 if (sym
->attr
.implicit_type
5999 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
6001 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
6002 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
6006 /* Make sure the types of derived parameters are consistent. This
6007 type checking is deferred until resolution because the type may
6008 refer to a derived type from the host. */
6009 if (sym
->ts
.type
== BT_DERIVED
6010 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
6012 gfc_error ("Incompatible derived type in PARAMETER at %L",
6013 &sym
->value
->where
);
6020 /* Do anything necessary to resolve a symbol. Right now, we just
6021 assume that an otherwise unknown symbol is a variable. This sort
6022 of thing commonly happens for symbols in module. */
6025 resolve_symbol (gfc_symbol
*sym
)
6027 /* Zero if we are checking a formal namespace. */
6028 static int formal_ns_flag
= 1;
6029 int formal_ns_save
, check_constant
, mp_flag
;
6030 gfc_symtree
*symtree
;
6031 gfc_symtree
*this_symtree
;
6035 if (sym
->attr
.flavor
== FL_UNKNOWN
)
6038 /* If we find that a flavorless symbol is an interface in one of the
6039 parent namespaces, find its symtree in this namespace, free the
6040 symbol and set the symtree to point to the interface symbol. */
6041 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
6043 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6044 if (symtree
&& symtree
->n
.sym
->generic
)
6046 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
6050 gfc_free_symbol (sym
);
6051 symtree
->n
.sym
->refs
++;
6052 this_symtree
->n
.sym
= symtree
->n
.sym
;
6057 /* Otherwise give it a flavor according to such attributes as
6059 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
6060 sym
->attr
.flavor
= FL_VARIABLE
;
6063 sym
->attr
.flavor
= FL_PROCEDURE
;
6064 if (sym
->attr
.dimension
)
6065 sym
->attr
.function
= 1;
6069 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
6072 /* Symbols that are module procedures with results (functions) have
6073 the types and array specification copied for type checking in
6074 procedures that call them, as well as for saving to a module
6075 file. These symbols can't stand the scrutiny that their results
6077 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
6079 /* Assign default type to symbols that need one and don't have one. */
6080 if (sym
->ts
.type
== BT_UNKNOWN
)
6082 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
6083 gfc_set_default_type (sym
, 1, NULL
);
6085 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
6087 /* The specific case of an external procedure should emit an error
6088 in the case that there is no implicit type. */
6090 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
6093 /* Result may be in another namespace. */
6094 resolve_symbol (sym
->result
);
6096 sym
->ts
= sym
->result
->ts
;
6097 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
6098 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
6099 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
6100 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
6105 /* Assumed size arrays and assumed shape arrays must be dummy
6109 && (sym
->as
->type
== AS_ASSUMED_SIZE
6110 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
6111 && sym
->attr
.dummy
== 0)
6113 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
6114 gfc_error ("Assumed size array at %L must be a dummy argument",
6117 gfc_error ("Assumed shape array at %L must be a dummy argument",
6122 /* Make sure symbols with known intent or optional are really dummy
6123 variable. Because of ENTRY statement, this has to be deferred
6124 until resolution time. */
6126 if (!sym
->attr
.dummy
6127 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
6129 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
6133 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
6135 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
6136 "it is not a dummy", sym
->name
, &sym
->declared_at
);
6140 /* If a derived type symbol has reached this point, without its
6141 type being declared, we have an error. Notice that most
6142 conditions that produce undefined derived types have already
6143 been dealt with. However, the likes of:
6144 implicit type(t) (t) ..... call foo (t) will get us here if
6145 the type is not declared in the scope of the implicit
6146 statement. Change the type to BT_UNKNOWN, both because it is so
6147 and to prevent an ICE. */
6148 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
)
6150 gfc_error ("The derived type '%s' at %L is of type '%s', "
6151 "which has not been defined", sym
->name
,
6152 &sym
->declared_at
, sym
->ts
.derived
->name
);
6153 sym
->ts
.type
= BT_UNKNOWN
;
6157 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6158 default initialization is defined (5.1.2.4.4). */
6159 if (sym
->ts
.type
== BT_DERIVED
6161 && sym
->attr
.intent
== INTENT_OUT
6163 && sym
->as
->type
== AS_ASSUMED_SIZE
)
6165 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
6169 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6170 "ASSUMED SIZE and so cannot have a default initializer",
6171 sym
->name
, &sym
->declared_at
);
6177 switch (sym
->attr
.flavor
)
6180 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
6185 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
6190 if (resolve_fl_namelist (sym
) == FAILURE
)
6195 if (resolve_fl_parameter (sym
) == FAILURE
)
6203 /* Make sure that intrinsic exist */
6204 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
6205 && !gfc_intrinsic_name(sym
->name
, 0)
6206 && !gfc_intrinsic_name(sym
->name
, 1))
6207 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
6209 /* Resolve array specifier. Check as well some constraints
6210 on COMMON blocks. */
6212 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
6214 /* Set the formal_arg_flag so that check_conflict will not throw
6215 an error for host associated variables in the specification
6216 expression for an array_valued function. */
6217 if (sym
->attr
.function
&& sym
->as
)
6218 formal_arg_flag
= 1;
6220 gfc_resolve_array_spec (sym
->as
, check_constant
);
6222 formal_arg_flag
= 0;
6224 /* Resolve formal namespaces. */
6226 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
6228 formal_ns_save
= formal_ns_flag
;
6230 gfc_resolve (sym
->formal_ns
);
6231 formal_ns_flag
= formal_ns_save
;
6234 /* Check threadprivate restrictions. */
6235 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
6236 && (!sym
->attr
.in_common
6237 && sym
->module
== NULL
6238 && (sym
->ns
->proc_name
== NULL
6239 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
6240 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
6242 /* If we have come this far we can apply default-initializers, as
6243 described in 14.7.5, to those variables that have not already
6244 been assigned one. */
6245 if (sym
->ts
.type
== BT_DERIVED
6246 && sym
->attr
.referenced
6247 && sym
->ns
== gfc_current_ns
6249 && !sym
->attr
.allocatable
6250 && !sym
->attr
.alloc_comp
)
6252 symbol_attribute
*a
= &sym
->attr
;
6254 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
6255 && !a
->in_common
&& !a
->use_assoc
6256 && !(a
->function
&& sym
!= sym
->result
))
6257 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
6258 apply_default_init (sym
);
6263 /************* Resolve DATA statements *************/
6267 gfc_data_value
*vnode
;
6273 /* Advance the values structure to point to the next value in the data list. */
6276 next_data_value (void)
6278 while (values
.left
== 0)
6280 if (values
.vnode
->next
== NULL
)
6283 values
.vnode
= values
.vnode
->next
;
6284 values
.left
= values
.vnode
->repeat
;
6292 check_data_variable (gfc_data_variable
*var
, locus
*where
)
6298 ar_type mark
= AR_UNKNOWN
;
6300 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
6304 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
6308 mpz_init_set_si (offset
, 0);
6311 if (e
->expr_type
!= EXPR_VARIABLE
)
6312 gfc_internal_error ("check_data_variable(): Bad expression");
6314 if (e
->symtree
->n
.sym
->ns
->is_block_data
6315 && !e
->symtree
->n
.sym
->attr
.in_common
)
6317 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6318 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
6323 mpz_init_set_ui (size
, 1);
6330 /* Find the array section reference. */
6331 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6333 if (ref
->type
!= REF_ARRAY
)
6335 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6341 /* Set marks according to the reference pattern. */
6342 switch (ref
->u
.ar
.type
)
6350 /* Get the start position of array section. */
6351 gfc_get_section_index (ar
, section_index
, &offset
);
6359 if (gfc_array_size (e
, &size
) == FAILURE
)
6361 gfc_error ("Nonconstant array section at %L in DATA statement",
6370 while (mpz_cmp_ui (size
, 0) > 0)
6372 if (next_data_value () == FAILURE
)
6374 gfc_error ("DATA statement at %L has more variables than values",
6380 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
6384 /* If we have more than one element left in the repeat count,
6385 and we have more than one element left in the target variable,
6386 then create a range assignment. */
6387 /* ??? Only done for full arrays for now, since array sections
6389 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
6390 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
6394 if (mpz_cmp_ui (size
, values
.left
) >= 0)
6396 mpz_init_set_ui (range
, values
.left
);
6397 mpz_sub_ui (size
, size
, values
.left
);
6402 mpz_init_set (range
, size
);
6403 values
.left
-= mpz_get_ui (size
);
6404 mpz_set_ui (size
, 0);
6407 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
6410 mpz_add (offset
, offset
, range
);
6414 /* Assign initial value to symbol. */
6418 mpz_sub_ui (size
, size
, 1);
6420 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
6422 if (mark
== AR_FULL
)
6423 mpz_add_ui (offset
, offset
, 1);
6425 /* Modify the array section indexes and recalculate the offset
6426 for next element. */
6427 else if (mark
== AR_SECTION
)
6428 gfc_advance_section (section_index
, ar
, &offset
);
6432 if (mark
== AR_SECTION
)
6434 for (i
= 0; i
< ar
->dimen
; i
++)
6435 mpz_clear (section_index
[i
]);
6445 static try traverse_data_var (gfc_data_variable
*, locus
*);
6447 /* Iterate over a list of elements in a DATA statement. */
6450 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
6453 iterator_stack frame
;
6454 gfc_expr
*e
, *start
, *end
, *step
;
6455 try retval
= SUCCESS
;
6457 mpz_init (frame
.value
);
6459 start
= gfc_copy_expr (var
->iter
.start
);
6460 end
= gfc_copy_expr (var
->iter
.end
);
6461 step
= gfc_copy_expr (var
->iter
.step
);
6463 if (gfc_simplify_expr (start
, 1) == FAILURE
6464 || start
->expr_type
!= EXPR_CONSTANT
)
6466 gfc_error ("iterator start at %L does not simplify", &start
->where
);
6470 if (gfc_simplify_expr (end
, 1) == FAILURE
6471 || end
->expr_type
!= EXPR_CONSTANT
)
6473 gfc_error ("iterator end at %L does not simplify", &end
->where
);
6477 if (gfc_simplify_expr (step
, 1) == FAILURE
6478 || step
->expr_type
!= EXPR_CONSTANT
)
6480 gfc_error ("iterator step at %L does not simplify", &step
->where
);
6485 mpz_init_set (trip
, end
->value
.integer
);
6486 mpz_sub (trip
, trip
, start
->value
.integer
);
6487 mpz_add (trip
, trip
, step
->value
.integer
);
6489 mpz_div (trip
, trip
, step
->value
.integer
);
6491 mpz_set (frame
.value
, start
->value
.integer
);
6493 frame
.prev
= iter_stack
;
6494 frame
.variable
= var
->iter
.var
->symtree
;
6495 iter_stack
= &frame
;
6497 while (mpz_cmp_ui (trip
, 0) > 0)
6499 if (traverse_data_var (var
->list
, where
) == FAILURE
)
6506 e
= gfc_copy_expr (var
->expr
);
6507 if (gfc_simplify_expr (e
, 1) == FAILURE
)
6515 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
6517 mpz_sub_ui (trip
, trip
, 1);
6522 mpz_clear (frame
.value
);
6524 gfc_free_expr (start
);
6525 gfc_free_expr (end
);
6526 gfc_free_expr (step
);
6528 iter_stack
= frame
.prev
;
6533 /* Type resolve variables in the variable list of a DATA statement. */
6536 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
6540 for (; var
; var
= var
->next
)
6542 if (var
->expr
== NULL
)
6543 t
= traverse_data_list (var
, where
);
6545 t
= check_data_variable (var
, where
);
6555 /* Resolve the expressions and iterators associated with a data statement.
6556 This is separate from the assignment checking because data lists should
6557 only be resolved once. */
6560 resolve_data_variables (gfc_data_variable
*d
)
6562 for (; d
; d
= d
->next
)
6564 if (d
->list
== NULL
)
6566 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
6571 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
6574 if (resolve_data_variables (d
->list
) == FAILURE
)
6583 /* Resolve a single DATA statement. We implement this by storing a pointer to
6584 the value list into static variables, and then recursively traversing the
6585 variables list, expanding iterators and such. */
6588 resolve_data (gfc_data
* d
)
6590 if (resolve_data_variables (d
->var
) == FAILURE
)
6593 values
.vnode
= d
->value
;
6594 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
6596 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
6599 /* At this point, we better not have any values left. */
6601 if (next_data_value () == SUCCESS
)
6602 gfc_error ("DATA statement at %L has more values than variables",
6607 /* Determines if a variable is not 'pure', ie not assignable within a pure
6608 procedure. Returns zero if assignment is OK, nonzero if there is a
6612 gfc_impure_variable (gfc_symbol
*sym
)
6614 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
6617 if (sym
->ns
!= gfc_current_ns
)
6618 return !sym
->attr
.function
;
6620 /* TODO: Check storage association through EQUIVALENCE statements */
6626 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6627 symbol of the current procedure. */
6630 gfc_pure (gfc_symbol
*sym
)
6632 symbol_attribute attr
;
6635 sym
= gfc_current_ns
->proc_name
;
6641 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
6645 /* Test whether the current procedure is elemental or not. */
6648 gfc_elemental (gfc_symbol
*sym
)
6650 symbol_attribute attr
;
6653 sym
= gfc_current_ns
->proc_name
;
6658 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
6662 /* Warn about unused labels. */
6665 warn_unused_fortran_label (gfc_st_label
*label
)
6670 warn_unused_fortran_label (label
->left
);
6672 if (label
->defined
== ST_LABEL_UNKNOWN
)
6675 switch (label
->referenced
)
6677 case ST_LABEL_UNKNOWN
:
6678 gfc_warning ("Label %d at %L defined but not used", label
->value
,
6682 case ST_LABEL_BAD_TARGET
:
6683 gfc_warning ("Label %d at %L defined but cannot be used",
6684 label
->value
, &label
->where
);
6691 warn_unused_fortran_label (label
->right
);
6695 /* Returns the sequence type of a symbol or sequence. */
6698 sequence_type (gfc_typespec ts
)
6707 if (ts
.derived
->components
== NULL
)
6708 return SEQ_NONDEFAULT
;
6710 result
= sequence_type (ts
.derived
->components
->ts
);
6711 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
6712 if (sequence_type (c
->ts
) != result
)
6718 if (ts
.kind
!= gfc_default_character_kind
)
6719 return SEQ_NONDEFAULT
;
6721 return SEQ_CHARACTER
;
6724 if (ts
.kind
!= gfc_default_integer_kind
)
6725 return SEQ_NONDEFAULT
;
6730 if (!(ts
.kind
== gfc_default_real_kind
6731 || ts
.kind
== gfc_default_double_kind
))
6732 return SEQ_NONDEFAULT
;
6737 if (ts
.kind
!= gfc_default_complex_kind
)
6738 return SEQ_NONDEFAULT
;
6743 if (ts
.kind
!= gfc_default_logical_kind
)
6744 return SEQ_NONDEFAULT
;
6749 return SEQ_NONDEFAULT
;
6754 /* Resolve derived type EQUIVALENCE object. */
6757 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
6760 gfc_component
*c
= derived
->components
;
6765 /* Shall not be an object of nonsequence derived type. */
6766 if (!derived
->attr
.sequence
)
6768 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6769 "attribute to be an EQUIVALENCE object", sym
->name
,
6774 /* Shall not have allocatable components. */
6775 if (derived
->attr
.alloc_comp
)
6777 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6778 "components to be an EQUIVALENCE object",sym
->name
,
6783 for (; c
; c
= c
->next
)
6787 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
6790 /* Shall not be an object of sequence derived type containing a pointer
6791 in the structure. */
6794 gfc_error ("Derived type variable '%s' at %L with pointer "
6795 "component(s) cannot be an EQUIVALENCE object",
6796 sym
->name
, &e
->where
);
6802 gfc_error ("Derived type variable '%s' at %L with default "
6803 "initializer cannot be an EQUIVALENCE object",
6804 sym
->name
, &e
->where
);
6812 /* Resolve equivalence object.
6813 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6814 an allocatable array, an object of nonsequence derived type, an object of
6815 sequence derived type containing a pointer at any level of component
6816 selection, an automatic object, a function name, an entry name, a result
6817 name, a named constant, a structure component, or a subobject of any of
6818 the preceding objects. A substring shall not have length zero. A
6819 derived type shall not have components with default initialization nor
6820 shall two objects of an equivalence group be initialized.
6821 Either all or none of the objects shall have an protected attribute.
6822 The simple constraints are done in symbol.c(check_conflict) and the rest
6823 are implemented here. */
6826 resolve_equivalence (gfc_equiv
*eq
)
6829 gfc_symbol
*derived
;
6830 gfc_symbol
*first_sym
;
6833 locus
*last_where
= NULL
;
6834 seq_type eq_type
, last_eq_type
;
6835 gfc_typespec
*last_ts
;
6836 int object
, cnt_protected
;
6837 const char *value_name
;
6841 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
6843 first_sym
= eq
->expr
->symtree
->n
.sym
;
6847 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
6851 e
->ts
= e
->symtree
->n
.sym
->ts
;
6852 /* match_varspec might not know yet if it is seeing
6853 array reference or substring reference, as it doesn't
6855 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
6857 gfc_ref
*ref
= e
->ref
;
6858 sym
= e
->symtree
->n
.sym
;
6860 if (sym
->attr
.dimension
)
6862 ref
->u
.ar
.as
= sym
->as
;
6866 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6867 if (e
->ts
.type
== BT_CHARACTER
6869 && ref
->type
== REF_ARRAY
6870 && ref
->u
.ar
.dimen
== 1
6871 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
6872 && ref
->u
.ar
.stride
[0] == NULL
)
6874 gfc_expr
*start
= ref
->u
.ar
.start
[0];
6875 gfc_expr
*end
= ref
->u
.ar
.end
[0];
6878 /* Optimize away the (:) reference. */
6879 if (start
== NULL
&& end
== NULL
)
6884 e
->ref
->next
= ref
->next
;
6889 ref
->type
= REF_SUBSTRING
;
6891 start
= gfc_int_expr (1);
6892 ref
->u
.ss
.start
= start
;
6893 if (end
== NULL
&& e
->ts
.cl
)
6894 end
= gfc_copy_expr (e
->ts
.cl
->length
);
6895 ref
->u
.ss
.end
= end
;
6896 ref
->u
.ss
.length
= e
->ts
.cl
;
6903 /* Any further ref is an error. */
6906 gcc_assert (ref
->type
== REF_ARRAY
);
6907 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6913 if (gfc_resolve_expr (e
) == FAILURE
)
6916 sym
= e
->symtree
->n
.sym
;
6918 if (sym
->attr
.protected)
6920 if (cnt_protected
> 0 && cnt_protected
!= object
)
6922 gfc_error ("Either all or none of the objects in the "
6923 "EQUIVALENCE set at %L shall have the "
6924 "PROTECTED attribute",
6929 /* An equivalence statement cannot have more than one initialized
6933 if (value_name
!= NULL
)
6935 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6936 "be in the EQUIVALENCE statement at %L",
6937 value_name
, sym
->name
, &e
->where
);
6941 value_name
= sym
->name
;
6944 /* Shall not equivalence common block variables in a PURE procedure. */
6945 if (sym
->ns
->proc_name
6946 && sym
->ns
->proc_name
->attr
.pure
6947 && sym
->attr
.in_common
)
6949 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6950 "object in the pure procedure '%s'",
6951 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
6955 /* Shall not be a named constant. */
6956 if (e
->expr_type
== EXPR_CONSTANT
)
6958 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6959 "object", sym
->name
, &e
->where
);
6963 derived
= e
->ts
.derived
;
6964 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
6967 /* Check that the types correspond correctly:
6969 A numeric sequence structure may be equivalenced to another sequence
6970 structure, an object of default integer type, default real type, double
6971 precision real type, default logical type such that components of the
6972 structure ultimately only become associated to objects of the same
6973 kind. A character sequence structure may be equivalenced to an object
6974 of default character kind or another character sequence structure.
6975 Other objects may be equivalenced only to objects of the same type and
6978 /* Identical types are unconditionally OK. */
6979 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
6980 goto identical_types
;
6982 last_eq_type
= sequence_type (*last_ts
);
6983 eq_type
= sequence_type (sym
->ts
);
6985 /* Since the pair of objects is not of the same type, mixed or
6986 non-default sequences can be rejected. */
6988 msg
= "Sequence %s with mixed components in EQUIVALENCE "
6989 "statement at %L with different type objects";
6991 && last_eq_type
== SEQ_MIXED
6992 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
6994 || (eq_type
== SEQ_MIXED
6995 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6996 &e
->where
) == FAILURE
))
6999 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
7000 "statement at %L with objects of different type";
7002 && last_eq_type
== SEQ_NONDEFAULT
7003 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
7004 last_where
) == FAILURE
)
7005 || (eq_type
== SEQ_NONDEFAULT
7006 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7007 &e
->where
) == FAILURE
))
7010 msg
="Non-CHARACTER object '%s' in default CHARACTER "
7011 "EQUIVALENCE statement at %L";
7012 if (last_eq_type
== SEQ_CHARACTER
7013 && eq_type
!= SEQ_CHARACTER
7014 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7015 &e
->where
) == FAILURE
)
7018 msg
="Non-NUMERIC object '%s' in default NUMERIC "
7019 "EQUIVALENCE statement at %L";
7020 if (last_eq_type
== SEQ_NUMERIC
7021 && eq_type
!= SEQ_NUMERIC
7022 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7023 &e
->where
) == FAILURE
)
7028 last_where
= &e
->where
;
7033 /* Shall not be an automatic array. */
7034 if (e
->ref
->type
== REF_ARRAY
7035 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
7037 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
7038 "an EQUIVALENCE object", sym
->name
, &e
->where
);
7045 /* Shall not be a structure component. */
7046 if (r
->type
== REF_COMPONENT
)
7048 gfc_error ("Structure component '%s' at %L cannot be an "
7049 "EQUIVALENCE object",
7050 r
->u
.c
.component
->name
, &e
->where
);
7054 /* A substring shall not have length zero. */
7055 if (r
->type
== REF_SUBSTRING
)
7057 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
7059 gfc_error ("Substring at %L has length zero",
7060 &r
->u
.ss
.start
->where
);
7070 /* Resolve function and ENTRY types, issue diagnostics if needed. */
7073 resolve_fntype (gfc_namespace
*ns
)
7078 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
7081 /* If there are any entries, ns->proc_name is the entry master
7082 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
7084 sym
= ns
->entries
->sym
;
7086 sym
= ns
->proc_name
;
7087 if (sym
->result
== sym
7088 && sym
->ts
.type
== BT_UNKNOWN
7089 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
7090 && !sym
->attr
.untyped
)
7092 gfc_error ("Function '%s' at %L has no IMPLICIT type",
7093 sym
->name
, &sym
->declared_at
);
7094 sym
->attr
.untyped
= 1;
7097 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
7098 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7099 sym
->ts
.derived
->ns
->default_access
)
7100 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
7102 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
7103 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
7106 /* Make sure that the type of a module derived type function is in the
7107 module namespace, by copying it from the namespace's derived type
7108 list, if necessary. */
7109 if (sym
->ts
.type
== BT_DERIVED
7110 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7111 && sym
->ts
.derived
->ns
7112 && sym
->ns
!= sym
->ts
.derived
->ns
)
7114 gfc_dt_list
*dt
= sym
->ns
->derived_types
;
7116 for (; dt
; dt
= dt
->next
)
7117 if (gfc_compare_derived_types (sym
->ts
.derived
, dt
->derived
))
7118 sym
->ts
.derived
= dt
->derived
;
7122 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
7124 if (el
->sym
->result
== el
->sym
7125 && el
->sym
->ts
.type
== BT_UNKNOWN
7126 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
7127 && !el
->sym
->attr
.untyped
)
7129 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
7130 el
->sym
->name
, &el
->sym
->declared_at
);
7131 el
->sym
->attr
.untyped
= 1;
7136 /* 12.3.2.1.1 Defined operators. */
7139 gfc_resolve_uops (gfc_symtree
*symtree
)
7143 gfc_formal_arglist
*formal
;
7145 if (symtree
== NULL
)
7148 gfc_resolve_uops (symtree
->left
);
7149 gfc_resolve_uops (symtree
->right
);
7151 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
7154 if (!sym
->attr
.function
)
7155 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
7156 sym
->name
, &sym
->declared_at
);
7158 if (sym
->ts
.type
== BT_CHARACTER
7159 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
7160 && !(sym
->result
&& sym
->result
->ts
.cl
7161 && sym
->result
->ts
.cl
->length
))
7162 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
7163 "character length", sym
->name
, &sym
->declared_at
);
7165 formal
= sym
->formal
;
7166 if (!formal
|| !formal
->sym
)
7168 gfc_error ("User operator procedure '%s' at %L must have at least "
7169 "one argument", sym
->name
, &sym
->declared_at
);
7173 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7174 gfc_error ("First argument of operator interface at %L must be "
7175 "INTENT(IN)", &sym
->declared_at
);
7177 if (formal
->sym
->attr
.optional
)
7178 gfc_error ("First argument of operator interface at %L cannot be "
7179 "optional", &sym
->declared_at
);
7181 formal
= formal
->next
;
7182 if (!formal
|| !formal
->sym
)
7185 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7186 gfc_error ("Second argument of operator interface at %L must be "
7187 "INTENT(IN)", &sym
->declared_at
);
7189 if (formal
->sym
->attr
.optional
)
7190 gfc_error ("Second argument of operator interface at %L cannot be "
7191 "optional", &sym
->declared_at
);
7194 gfc_error ("Operator interface at %L must have, at most, two "
7195 "arguments", &sym
->declared_at
);
7200 /* Examine all of the expressions associated with a program unit,
7201 assign types to all intermediate expressions, make sure that all
7202 assignments are to compatible types and figure out which names
7203 refer to which functions or subroutines. It doesn't check code
7204 block, which is handled by resolve_code. */
7207 resolve_types (gfc_namespace
*ns
)
7214 gfc_current_ns
= ns
;
7216 resolve_entries (ns
);
7218 resolve_contained_functions (ns
);
7220 gfc_traverse_ns (ns
, resolve_symbol
);
7222 resolve_fntype (ns
);
7224 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7226 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
7227 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7228 "also be PURE", n
->proc_name
->name
,
7229 &n
->proc_name
->declared_at
);
7235 gfc_check_interfaces (ns
);
7237 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
7238 resolve_charlen (cl
);
7240 gfc_traverse_ns (ns
, resolve_values
);
7246 for (d
= ns
->data
; d
; d
= d
->next
)
7250 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
7252 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
7253 resolve_equivalence (eq
);
7255 /* Warn about unused labels. */
7256 if (warn_unused_label
)
7257 warn_unused_fortran_label (ns
->st_labels
);
7259 gfc_resolve_uops (ns
->uop_root
);
7263 /* Call resolve_code recursively. */
7266 resolve_codes (gfc_namespace
*ns
)
7270 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7273 gfc_current_ns
= ns
;
7275 /* Set to an out of range value. */
7276 current_entry_id
= -1;
7277 resolve_code (ns
->code
, ns
);
7281 /* This function is called after a complete program unit has been compiled.
7282 Its purpose is to examine all of the expressions associated with a program
7283 unit, assign types to all intermediate expressions, make sure that all
7284 assignments are to compatible types and figure out which names refer to
7285 which functions or subroutines. */
7288 gfc_resolve (gfc_namespace
*ns
)
7290 gfc_namespace
*old_ns
;
7292 old_ns
= gfc_current_ns
;
7297 gfc_current_ns
= old_ns
;