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 (sym
&& !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
);
4554 case EXEC_ASSIGN_CALL
:
4555 resolve_call (cnext
);
4558 /* WHERE or WHERE construct is part of a where-body-construct */
4560 resolve_where (cnext
, e
);
4564 gfc_error ("Unsupported statement inside WHERE at %L",
4567 /* the next statement within the same where-body-construct */
4568 cnext
= cnext
->next
;
4570 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4571 cblock
= cblock
->block
;
4576 /* Check whether the FORALL index appears in the expression or not. */
4579 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4583 gfc_actual_arglist
*args
;
4586 switch (expr
->expr_type
)
4589 gcc_assert (expr
->symtree
->n
.sym
);
4591 /* A scalar assignment */
4594 if (expr
->symtree
->n
.sym
== symbol
)
4600 /* the expr is array ref, substring or struct component. */
4607 /* Check if the symbol appears in the array subscript. */
4609 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4612 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4616 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4620 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4626 if (expr
->symtree
->n
.sym
== symbol
)
4629 /* Check if the symbol appears in the substring section. */
4630 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4632 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4640 gfc_error("expression reference type error at %L", &expr
->where
);
4646 /* If the expression is a function call, then check if the symbol
4647 appears in the actual arglist of the function. */
4649 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4651 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4656 /* It seems not to happen. */
4657 case EXPR_SUBSTRING
:
4661 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4662 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4664 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4669 /* It seems not to happen. */
4670 case EXPR_STRUCTURE
:
4672 gfc_error ("Unsupported statement while finding forall index in "
4677 /* Find the FORALL index in the first operand. */
4678 if (expr
->value
.op
.op1
)
4680 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4684 /* Find the FORALL index in the second operand. */
4685 if (expr
->value
.op
.op2
)
4687 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4700 /* Resolve assignment in FORALL construct.
4701 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4702 FORALL index variables. */
4705 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4709 for (n
= 0; n
< nvar
; n
++)
4711 gfc_symbol
*forall_index
;
4713 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
4715 /* Check whether the assignment target is one of the FORALL index
4717 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
4718 && (code
->expr
->symtree
->n
.sym
== forall_index
))
4719 gfc_error ("Assignment to a FORALL index variable at %L",
4720 &code
->expr
->where
);
4723 /* If one of the FORALL index variables doesn't appear in the
4724 assignment target, then there will be a many-to-one
4726 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4727 gfc_error ("The FORALL with index '%s' cause more than one "
4728 "assignment to this object at %L",
4729 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4735 /* Resolve WHERE statement in FORALL construct. */
4738 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
4739 gfc_expr
**var_expr
)
4744 cblock
= code
->block
;
4747 /* the assignment statement of a WHERE statement, or the first
4748 statement in where-body-construct of a WHERE construct */
4749 cnext
= cblock
->next
;
4754 /* WHERE assignment statement */
4756 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4759 /* WHERE operator assignment statement */
4760 case EXEC_ASSIGN_CALL
:
4761 resolve_call (cnext
);
4764 /* WHERE or WHERE construct is part of a where-body-construct */
4766 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4770 gfc_error ("Unsupported statement inside WHERE at %L",
4773 /* the next statement within the same where-body-construct */
4774 cnext
= cnext
->next
;
4776 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4777 cblock
= cblock
->block
;
4782 /* Traverse the FORALL body to check whether the following errors exist:
4783 1. For assignment, check if a many-to-one assignment happens.
4784 2. For WHERE statement, check the WHERE body to see if there is any
4785 many-to-one assignment. */
4788 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4792 c
= code
->block
->next
;
4798 case EXEC_POINTER_ASSIGN
:
4799 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4802 case EXEC_ASSIGN_CALL
:
4806 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4807 there is no need to handle it here. */
4811 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4816 /* The next statement in the FORALL body. */
4822 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4823 gfc_resolve_forall_body to resolve the FORALL body. */
4826 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4828 static gfc_expr
**var_expr
;
4829 static int total_var
= 0;
4830 static int nvar
= 0;
4831 gfc_forall_iterator
*fa
;
4832 gfc_symbol
*forall_index
;
4836 /* Start to resolve a FORALL construct */
4837 if (forall_save
== 0)
4839 /* Count the total number of FORALL index in the nested FORALL
4840 construct in order to allocate the VAR_EXPR with proper size. */
4842 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4844 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4846 next
= next
->block
->next
;
4849 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4850 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4853 /* The information about FORALL iterator, including FORALL index start, end
4854 and stride. The FORALL index can not appear in start, end or stride. */
4855 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4857 /* Check if any outer FORALL index name is the same as the current
4859 for (i
= 0; i
< nvar
; i
++)
4861 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4863 gfc_error ("An outer FORALL construct already has an index "
4864 "with this name %L", &fa
->var
->where
);
4868 /* Record the current FORALL index. */
4869 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4871 forall_index
= fa
->var
->symtree
->n
.sym
;
4873 /* Check if the FORALL index appears in start, end or stride. */
4874 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4875 gfc_error ("A FORALL index must not appear in a limit or stride "
4876 "expression in the same FORALL at %L", &fa
->start
->where
);
4877 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4878 gfc_error ("A FORALL index must not appear in a limit or stride "
4879 "expression in the same FORALL at %L", &fa
->end
->where
);
4880 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4881 gfc_error ("A FORALL index must not appear in a limit or stride "
4882 "expression in the same FORALL at %L", &fa
->stride
->where
);
4886 /* Resolve the FORALL body. */
4887 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4889 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4890 gfc_resolve_blocks (code
->block
, ns
);
4892 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4893 for (i
= 0; i
< total_var
; i
++)
4894 gfc_free_expr (var_expr
[i
]);
4896 /* Reset the counters. */
4902 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4905 static void resolve_code (gfc_code
*, gfc_namespace
*);
4908 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
4912 for (; b
; b
= b
->block
)
4914 t
= gfc_resolve_expr (b
->expr
);
4915 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4921 if (t
== SUCCESS
&& b
->expr
!= NULL
4922 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4923 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4930 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
4931 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4936 resolve_branch (b
->label
, b
);
4948 case EXEC_OMP_ATOMIC
:
4949 case EXEC_OMP_CRITICAL
:
4951 case EXEC_OMP_MASTER
:
4952 case EXEC_OMP_ORDERED
:
4953 case EXEC_OMP_PARALLEL
:
4954 case EXEC_OMP_PARALLEL_DO
:
4955 case EXEC_OMP_PARALLEL_SECTIONS
:
4956 case EXEC_OMP_PARALLEL_WORKSHARE
:
4957 case EXEC_OMP_SECTIONS
:
4958 case EXEC_OMP_SINGLE
:
4959 case EXEC_OMP_WORKSHARE
:
4963 gfc_internal_error ("resolve_block(): Bad block type");
4966 resolve_code (b
->next
, ns
);
4971 /* Given a block of code, recursively resolve everything pointed to by this
4975 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
4977 int omp_workshare_save
;
4983 frame
.prev
= cs_base
;
4987 for (; code
; code
= code
->next
)
4989 frame
.current
= code
;
4990 forall_save
= forall_flag
;
4992 if (code
->op
== EXEC_FORALL
)
4995 gfc_resolve_forall (code
, ns
, forall_save
);
4998 else if (code
->block
)
5000 omp_workshare_save
= -1;
5003 case EXEC_OMP_PARALLEL_WORKSHARE
:
5004 omp_workshare_save
= omp_workshare_flag
;
5005 omp_workshare_flag
= 1;
5006 gfc_resolve_omp_parallel_blocks (code
, ns
);
5008 case EXEC_OMP_PARALLEL
:
5009 case EXEC_OMP_PARALLEL_DO
:
5010 case EXEC_OMP_PARALLEL_SECTIONS
:
5011 omp_workshare_save
= omp_workshare_flag
;
5012 omp_workshare_flag
= 0;
5013 gfc_resolve_omp_parallel_blocks (code
, ns
);
5016 gfc_resolve_omp_do_blocks (code
, ns
);
5018 case EXEC_OMP_WORKSHARE
:
5019 omp_workshare_save
= omp_workshare_flag
;
5020 omp_workshare_flag
= 1;
5023 gfc_resolve_blocks (code
->block
, ns
);
5027 if (omp_workshare_save
!= -1)
5028 omp_workshare_flag
= omp_workshare_save
;
5031 t
= gfc_resolve_expr (code
->expr
);
5032 forall_flag
= forall_save
;
5034 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
5049 /* Keep track of which entry we are up to. */
5050 current_entry_id
= code
->ext
.entry
->id
;
5054 resolve_where (code
, NULL
);
5058 if (code
->expr
!= NULL
)
5060 if (code
->expr
->ts
.type
!= BT_INTEGER
)
5061 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5062 "INTEGER variable", &code
->expr
->where
);
5063 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
5064 gfc_error ("Variable '%s' has not been assigned a target "
5065 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
5066 &code
->expr
->where
);
5069 resolve_branch (code
->label
, code
);
5073 if (code
->expr
!= NULL
5074 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
5075 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5076 "INTEGER return specifier", &code
->expr
->where
);
5079 case EXEC_INIT_ASSIGN
:
5086 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5088 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5090 gfc_error ("Subroutine '%s' called instead of assignment at "
5091 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5098 if (code
->expr
->ts
.type
== BT_CHARACTER
5099 && gfc_option
.warn_character_truncation
)
5101 int llen
= 0, rlen
= 0;
5103 if (code
->expr
->ts
.cl
!= NULL
5104 && code
->expr
->ts
.cl
->length
!= NULL
5105 && code
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5106 llen
= mpz_get_si (code
->expr
->ts
.cl
->length
->value
.integer
);
5108 if (code
->expr2
->expr_type
== EXPR_CONSTANT
)
5109 rlen
= code
->expr2
->value
.character
.length
;
5111 else if (code
->expr2
->ts
.cl
!= NULL
5112 && code
->expr2
->ts
.cl
->length
!= NULL
5113 && code
->expr2
->ts
.cl
->length
->expr_type
5115 rlen
= mpz_get_si (code
->expr2
->ts
.cl
->length
->value
.integer
);
5117 if (rlen
&& llen
&& rlen
> llen
)
5118 gfc_warning_now ("rhs of CHARACTER assignment at %L will be "
5119 "truncated (%d/%d)", &code
->loc
, rlen
, llen
);
5122 if (gfc_pure (NULL
))
5124 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
5126 gfc_error ("Cannot assign to variable '%s' in PURE "
5128 code
->expr
->symtree
->n
.sym
->name
,
5129 &code
->expr
->where
);
5133 if (code
->expr2
->ts
.type
== BT_DERIVED
5134 && derived_pointer (code
->expr2
->ts
.derived
))
5136 gfc_error ("Right side of assignment at %L is a derived "
5137 "type containing a POINTER in a PURE procedure",
5138 &code
->expr2
->where
);
5143 gfc_check_assign (code
->expr
, code
->expr2
, 1);
5146 case EXEC_LABEL_ASSIGN
:
5147 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
5148 gfc_error ("Label %d referenced at %L is never defined",
5149 code
->label
->value
, &code
->label
->where
);
5151 && (code
->expr
->expr_type
!= EXPR_VARIABLE
5152 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
5153 || code
->expr
->symtree
->n
.sym
->ts
.kind
5154 != gfc_default_integer_kind
5155 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
5156 gfc_error ("ASSIGN statement at %L requires a scalar "
5157 "default INTEGER variable", &code
->expr
->where
);
5160 case EXEC_POINTER_ASSIGN
:
5164 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
5167 case EXEC_ARITHMETIC_IF
:
5169 && code
->expr
->ts
.type
!= BT_INTEGER
5170 && code
->expr
->ts
.type
!= BT_REAL
)
5171 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5172 "expression", &code
->expr
->where
);
5174 resolve_branch (code
->label
, code
);
5175 resolve_branch (code
->label2
, code
);
5176 resolve_branch (code
->label3
, code
);
5180 if (t
== SUCCESS
&& code
->expr
!= NULL
5181 && (code
->expr
->ts
.type
!= BT_LOGICAL
5182 || code
->expr
->rank
!= 0))
5183 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5184 &code
->expr
->where
);
5189 resolve_call (code
);
5193 /* Select is complicated. Also, a SELECT construct could be
5194 a transformed computed GOTO. */
5195 resolve_select (code
);
5199 if (code
->ext
.iterator
!= NULL
)
5201 gfc_iterator
*iter
= code
->ext
.iterator
;
5202 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
5203 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
5208 if (code
->expr
== NULL
)
5209 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5211 && (code
->expr
->rank
!= 0
5212 || code
->expr
->ts
.type
!= BT_LOGICAL
))
5213 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5214 "a scalar LOGICAL expression", &code
->expr
->where
);
5218 if (t
== SUCCESS
&& code
->expr
!= NULL
5219 && code
->expr
->ts
.type
!= BT_INTEGER
)
5220 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5221 "of type INTEGER", &code
->expr
->where
);
5223 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5224 resolve_allocate_expr (a
->expr
, code
);
5228 case EXEC_DEALLOCATE
:
5229 if (t
== SUCCESS
&& code
->expr
!= NULL
5230 && code
->expr
->ts
.type
!= BT_INTEGER
)
5232 ("STAT tag in DEALLOCATE statement at %L must be of type "
5233 "INTEGER", &code
->expr
->where
);
5235 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5236 resolve_deallocate_expr (a
->expr
);
5241 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
5244 resolve_branch (code
->ext
.open
->err
, code
);
5248 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
5251 resolve_branch (code
->ext
.close
->err
, code
);
5254 case EXEC_BACKSPACE
:
5258 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
5261 resolve_branch (code
->ext
.filepos
->err
, code
);
5265 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5268 resolve_branch (code
->ext
.inquire
->err
, code
);
5272 gcc_assert (code
->ext
.inquire
!= NULL
);
5273 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5276 resolve_branch (code
->ext
.inquire
->err
, code
);
5281 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
5284 resolve_branch (code
->ext
.dt
->err
, code
);
5285 resolve_branch (code
->ext
.dt
->end
, code
);
5286 resolve_branch (code
->ext
.dt
->eor
, code
);
5290 resolve_transfer (code
);
5294 resolve_forall_iterators (code
->ext
.forall_iterator
);
5296 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
5297 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
5298 "expression", &code
->expr
->where
);
5301 case EXEC_OMP_ATOMIC
:
5302 case EXEC_OMP_BARRIER
:
5303 case EXEC_OMP_CRITICAL
:
5304 case EXEC_OMP_FLUSH
:
5306 case EXEC_OMP_MASTER
:
5307 case EXEC_OMP_ORDERED
:
5308 case EXEC_OMP_SECTIONS
:
5309 case EXEC_OMP_SINGLE
:
5310 case EXEC_OMP_WORKSHARE
:
5311 gfc_resolve_omp_directive (code
, ns
);
5314 case EXEC_OMP_PARALLEL
:
5315 case EXEC_OMP_PARALLEL_DO
:
5316 case EXEC_OMP_PARALLEL_SECTIONS
:
5317 case EXEC_OMP_PARALLEL_WORKSHARE
:
5318 omp_workshare_save
= omp_workshare_flag
;
5319 omp_workshare_flag
= 0;
5320 gfc_resolve_omp_directive (code
, ns
);
5321 omp_workshare_flag
= omp_workshare_save
;
5325 gfc_internal_error ("resolve_code(): Bad statement code");
5329 cs_base
= frame
.prev
;
5333 /* Resolve initial values and make sure they are compatible with
5337 resolve_values (gfc_symbol
*sym
)
5339 if (sym
->value
== NULL
)
5342 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
5345 gfc_check_assign_symbol (sym
, sym
->value
);
5349 /* Resolve an index expression. */
5352 resolve_index_expr (gfc_expr
*e
)
5354 if (gfc_resolve_expr (e
) == FAILURE
)
5357 if (gfc_simplify_expr (e
, 0) == FAILURE
)
5360 if (gfc_specification_expr (e
) == FAILURE
)
5366 /* Resolve a charlen structure. */
5369 resolve_charlen (gfc_charlen
*cl
)
5376 specification_expr
= 1;
5378 if (resolve_index_expr (cl
->length
) == FAILURE
)
5380 specification_expr
= 0;
5388 /* Test for non-constant shape arrays. */
5391 is_non_constant_shape_array (gfc_symbol
*sym
)
5397 not_constant
= false;
5398 if (sym
->as
!= NULL
)
5400 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5401 has not been simplified; parameter array references. Do the
5402 simplification now. */
5403 for (i
= 0; i
< sym
->as
->rank
; i
++)
5405 e
= sym
->as
->lower
[i
];
5406 if (e
&& (resolve_index_expr (e
) == FAILURE
5407 || !gfc_is_constant_expr (e
)))
5408 not_constant
= true;
5410 e
= sym
->as
->upper
[i
];
5411 if (e
&& (resolve_index_expr (e
) == FAILURE
5412 || !gfc_is_constant_expr (e
)))
5413 not_constant
= true;
5416 return not_constant
;
5420 /* Assign the default initializer to a derived type variable or result. */
5423 apply_default_init (gfc_symbol
*sym
)
5426 gfc_expr
*init
= NULL
;
5428 gfc_namespace
*ns
= sym
->ns
;
5430 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
5433 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
5434 init
= gfc_default_initializer (&sym
->ts
);
5439 /* Search for the function namespace if this is a contained
5440 function without an explicit result. */
5441 if (sym
->attr
.function
&& sym
== sym
->result
5442 && sym
->name
!= sym
->ns
->proc_name
->name
)
5445 for (;ns
; ns
= ns
->sibling
)
5446 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
5452 gfc_free_expr (init
);
5456 /* Build an l-value expression for the result. */
5457 lval
= gfc_get_expr ();
5458 lval
->expr_type
= EXPR_VARIABLE
;
5459 lval
->where
= sym
->declared_at
;
5461 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5463 /* It will always be a full array. */
5464 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
5467 lval
->ref
= gfc_get_ref ();
5468 lval
->ref
->type
= REF_ARRAY
;
5469 lval
->ref
->u
.ar
.type
= AR_FULL
;
5470 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
5471 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
5472 lval
->ref
->u
.ar
.as
= sym
->as
;
5475 /* Add the code at scope entry. */
5476 init_st
= gfc_get_code ();
5477 init_st
->next
= ns
->code
;
5480 /* Assign the default initializer to the l-value. */
5481 init_st
->loc
= sym
->declared_at
;
5482 init_st
->op
= EXEC_INIT_ASSIGN
;
5483 init_st
->expr
= lval
;
5484 init_st
->expr2
= init
;
5488 /* Resolution of common features of flavors variable and procedure. */
5491 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
5493 /* Constraints on deferred shape variable. */
5494 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
5496 if (sym
->attr
.allocatable
)
5498 if (sym
->attr
.dimension
)
5499 gfc_error ("Allocatable array '%s' at %L must have "
5500 "a deferred shape", sym
->name
, &sym
->declared_at
);
5502 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5503 sym
->name
, &sym
->declared_at
);
5507 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
5509 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5510 sym
->name
, &sym
->declared_at
);
5517 if (!mp_flag
&& !sym
->attr
.allocatable
5518 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
5520 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5521 sym
->name
, &sym
->declared_at
);
5529 /* Resolve symbols with flavor variable. */
5532 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
5537 gfc_expr
*constructor_expr
;
5538 const char *auto_save_msg
;
5540 auto_save_msg
= "automatic object '%s' at %L cannot have the "
5543 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5546 /* Set this flag to check that variables are parameters of all entries.
5547 This check is effected by the call to gfc_resolve_expr through
5548 is_non_constant_shape_array. */
5549 specification_expr
= 1;
5551 if (!sym
->attr
.use_assoc
5552 && !sym
->attr
.allocatable
5553 && !sym
->attr
.pointer
5554 && is_non_constant_shape_array (sym
))
5556 /* The shape of a main program or module array needs to be
5558 if (sym
->ns
->proc_name
5559 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5560 || sym
->ns
->proc_name
->attr
.is_main_program
))
5562 gfc_error ("The module or main program array '%s' at %L must "
5563 "have constant shape", sym
->name
, &sym
->declared_at
);
5564 specification_expr
= 0;
5569 if (sym
->ts
.type
== BT_CHARACTER
)
5571 /* Make sure that character string variables with assumed length are
5573 e
= sym
->ts
.cl
->length
;
5574 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
5576 gfc_error ("Entity with assumed character length at %L must be a "
5577 "dummy argument or a PARAMETER", &sym
->declared_at
);
5581 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
5583 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5587 if (!gfc_is_constant_expr (e
)
5588 && !(e
->expr_type
== EXPR_VARIABLE
5589 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
5590 && sym
->ns
->proc_name
5591 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5592 || sym
->ns
->proc_name
->attr
.is_main_program
)
5593 && !sym
->attr
.use_assoc
)
5595 gfc_error ("'%s' at %L must have constant character length "
5596 "in this context", sym
->name
, &sym
->declared_at
);
5601 /* Can the symbol have an initializer? */
5603 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
5604 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
5606 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
5608 /* Don't allow initialization of automatic arrays. */
5609 for (i
= 0; i
< sym
->as
->rank
; i
++)
5611 if (sym
->as
->lower
[i
] == NULL
5612 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5613 || sym
->as
->upper
[i
] == NULL
5614 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
5621 /* Also, they must not have the SAVE attribute. */
5622 if (flag
&& sym
->attr
.save
)
5624 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5629 /* Reject illegal initializers. */
5630 if (sym
->value
&& flag
)
5632 if (sym
->attr
.allocatable
)
5633 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5634 sym
->name
, &sym
->declared_at
);
5635 else if (sym
->attr
.external
)
5636 gfc_error ("External '%s' at %L cannot have an initializer",
5637 sym
->name
, &sym
->declared_at
);
5638 else if (sym
->attr
.dummy
)
5639 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5640 sym
->name
, &sym
->declared_at
);
5641 else if (sym
->attr
.intrinsic
)
5642 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5643 sym
->name
, &sym
->declared_at
);
5644 else if (sym
->attr
.result
)
5645 gfc_error ("Function result '%s' at %L cannot have an initializer",
5646 sym
->name
, &sym
->declared_at
);
5648 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5649 sym
->name
, &sym
->declared_at
);
5653 /* Check to see if a derived type is blocked from being host associated
5654 by the presence of another class I symbol in the same namespace.
5655 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5656 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
)
5659 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
5660 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
5661 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
5663 gfc_error ("The type %s cannot be host associated at %L because "
5664 "it is blocked by an incompatible object of the same "
5665 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
5671 /* 4th constraint in section 11.3: "If an object of a type for which
5672 component-initialization is specified (R429) appears in the
5673 specification-part of a module and does not have the ALLOCATABLE
5674 or POINTER attribute, the object shall have the SAVE attribute." */
5676 constructor_expr
= NULL
;
5677 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
5678 constructor_expr
= gfc_default_initializer (&sym
->ts
);
5680 if (sym
->ns
->proc_name
5681 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5683 && !sym
->ns
->save_all
&& !sym
->attr
.save
5684 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
5686 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5687 sym
->name
, &sym
->declared_at
,
5688 "for default initialization of a component");
5692 /* Assign default initializer. */
5693 if (sym
->ts
.type
== BT_DERIVED
5695 && !sym
->attr
.pointer
5696 && !sym
->attr
.allocatable
5697 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
5698 sym
->value
= gfc_default_initializer (&sym
->ts
);
5704 /* Resolve a procedure. */
5707 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
5709 gfc_formal_arglist
*arg
;
5711 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
5712 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5713 "interfaces", sym
->name
, &sym
->declared_at
);
5715 if (sym
->attr
.function
5716 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5719 if (sym
->ts
.type
== BT_CHARACTER
)
5721 gfc_charlen
*cl
= sym
->ts
.cl
;
5722 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
5724 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5726 gfc_error ("Character-valued statement function '%s' at %L must "
5727 "have constant length", sym
->name
, &sym
->declared_at
);
5731 if (sym
->attr
.external
&& sym
->formal
== NULL
5732 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
5734 gfc_error ("Automatic character length function '%s' at %L must "
5735 "have an explicit interface", sym
->name
,
5742 /* Ensure that derived type for are not of a private type. Internal
5743 module procedures are excluded by 2.2.3.3 - ie. they are not
5744 externally accessible and can access all the objects accessible in
5746 if (!(sym
->ns
->parent
5747 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5748 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5750 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
5753 && arg
->sym
->ts
.type
== BT_DERIVED
5754 && !arg
->sym
->ts
.derived
->attr
.use_assoc
5755 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
5756 arg
->sym
->ts
.derived
->ns
->default_access
))
5758 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5759 "a dummy argument of '%s', which is "
5760 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
5762 /* Stop this message from recurring. */
5763 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
5769 /* An external symbol may not have an initializer because it is taken to be
5771 if (sym
->attr
.external
&& sym
->value
)
5773 gfc_error ("External object '%s' at %L may not have an initializer",
5774 sym
->name
, &sym
->declared_at
);
5778 /* An elemental function is required to return a scalar 12.7.1 */
5779 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
5781 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5782 "result", sym
->name
, &sym
->declared_at
);
5783 /* Reset so that the error only occurs once. */
5784 sym
->attr
.elemental
= 0;
5788 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5789 char-len-param shall not be array-valued, pointer-valued, recursive
5790 or pure. ....snip... A character value of * may only be used in the
5791 following ways: (i) Dummy arg of procedure - dummy associates with
5792 actual length; (ii) To declare a named constant; or (iii) External
5793 function - but length must be declared in calling scoping unit. */
5794 if (sym
->attr
.function
5795 && sym
->ts
.type
== BT_CHARACTER
5796 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
5798 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
5799 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
5801 if (sym
->as
&& sym
->as
->rank
)
5802 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5803 "array-valued", sym
->name
, &sym
->declared_at
);
5805 if (sym
->attr
.pointer
)
5806 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5807 "pointer-valued", sym
->name
, &sym
->declared_at
);
5810 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5811 "pure", sym
->name
, &sym
->declared_at
);
5813 if (sym
->attr
.recursive
)
5814 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5815 "recursive", sym
->name
, &sym
->declared_at
);
5820 /* Appendix B.2 of the standard. Contained functions give an
5821 error anyway. Fixed-form is likely to be F77/legacy. */
5822 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
5823 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
5824 "'%s' at %L is obsolescent in fortran 95",
5825 sym
->name
, &sym
->declared_at
);
5831 /* Resolve the components of a derived type. */
5834 resolve_fl_derived (gfc_symbol
*sym
)
5837 gfc_dt_list
* dt_list
;
5840 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
5842 if (c
->ts
.type
== BT_CHARACTER
)
5844 if (c
->ts
.cl
->length
== NULL
5845 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
5846 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
5848 gfc_error ("Character length of component '%s' needs to "
5849 "be a constant specification expression at %L",
5851 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
5856 if (c
->ts
.type
== BT_DERIVED
5857 && sym
->component_access
!= ACCESS_PRIVATE
5858 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
5859 && !c
->ts
.derived
->attr
.use_assoc
5860 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
5861 c
->ts
.derived
->ns
->default_access
))
5863 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5864 "a component of '%s', which is PUBLIC at %L",
5865 c
->name
, sym
->name
, &sym
->declared_at
);
5869 if (sym
->attr
.sequence
)
5871 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
5873 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5874 "not have the SEQUENCE attribute",
5875 c
->ts
.derived
->name
, &sym
->declared_at
);
5880 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
5881 && c
->ts
.derived
->components
== NULL
)
5883 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5884 "that has not been declared", c
->name
, sym
->name
,
5889 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
5892 for (i
= 0; i
< c
->as
->rank
; i
++)
5894 if (c
->as
->lower
[i
] == NULL
5895 || !gfc_is_constant_expr (c
->as
->lower
[i
])
5896 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
5897 || c
->as
->upper
[i
] == NULL
5898 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
5899 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
5901 gfc_error ("Component '%s' of '%s' at %L must have "
5902 "constant array bounds",
5903 c
->name
, sym
->name
, &c
->loc
);
5909 /* Add derived type to the derived type list. */
5910 for (dt_list
= sym
->ns
->derived_types
; dt_list
; dt_list
= dt_list
->next
)
5911 if (sym
== dt_list
->derived
)
5914 if (dt_list
== NULL
)
5916 dt_list
= gfc_get_dt_list ();
5917 dt_list
->next
= sym
->ns
->derived_types
;
5918 dt_list
->derived
= sym
;
5919 sym
->ns
->derived_types
= dt_list
;
5927 resolve_fl_namelist (gfc_symbol
*sym
)
5932 /* Reject PRIVATE objects in a PUBLIC namelist. */
5933 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5935 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5937 if (!nl
->sym
->attr
.use_assoc
5938 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5939 && !gfc_check_access(nl
->sym
->attr
.access
,
5940 nl
->sym
->ns
->default_access
))
5942 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5943 "PUBLIC namelist at %L", nl
->sym
->name
,
5950 /* Reject namelist arrays that are not constant shape. */
5951 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5953 if (is_non_constant_shape_array (nl
->sym
))
5955 gfc_error ("The array '%s' must have constant shape to be "
5956 "a NAMELIST object at %L", nl
->sym
->name
,
5962 /* Namelist objects cannot have allocatable components. */
5963 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5965 if (nl
->sym
->ts
.type
== BT_DERIVED
5966 && nl
->sym
->ts
.derived
->attr
.alloc_comp
)
5968 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5969 "components", nl
->sym
->name
, &sym
->declared_at
);
5974 /* 14.1.2 A module or internal procedure represent local entities
5975 of the same type as a namelist member and so are not allowed.
5976 Note that this is sometimes caught by check_conflict so the
5977 same message has been used. */
5978 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5980 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
5983 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5984 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5985 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5987 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5988 "attribute in '%s' at %L", nlsym
->name
,
5999 resolve_fl_parameter (gfc_symbol
*sym
)
6001 /* A parameter array's shape needs to be constant. */
6002 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
6004 gfc_error ("Parameter array '%s' at %L cannot be automatic "
6005 "or assumed shape", sym
->name
, &sym
->declared_at
);
6009 /* Make sure a parameter that has been implicitly typed still
6010 matches the implicit type, since PARAMETER statements can precede
6011 IMPLICIT statements. */
6012 if (sym
->attr
.implicit_type
6013 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
6015 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
6016 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
6020 /* Make sure the types of derived parameters are consistent. This
6021 type checking is deferred until resolution because the type may
6022 refer to a derived type from the host. */
6023 if (sym
->ts
.type
== BT_DERIVED
6024 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
6026 gfc_error ("Incompatible derived type in PARAMETER at %L",
6027 &sym
->value
->where
);
6034 /* Do anything necessary to resolve a symbol. Right now, we just
6035 assume that an otherwise unknown symbol is a variable. This sort
6036 of thing commonly happens for symbols in module. */
6039 resolve_symbol (gfc_symbol
*sym
)
6041 /* Zero if we are checking a formal namespace. */
6042 static int formal_ns_flag
= 1;
6043 int formal_ns_save
, check_constant
, mp_flag
;
6044 gfc_symtree
*symtree
;
6045 gfc_symtree
*this_symtree
;
6049 if (sym
->attr
.flavor
== FL_UNKNOWN
)
6052 /* If we find that a flavorless symbol is an interface in one of the
6053 parent namespaces, find its symtree in this namespace, free the
6054 symbol and set the symtree to point to the interface symbol. */
6055 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
6057 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6058 if (symtree
&& symtree
->n
.sym
->generic
)
6060 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
6064 gfc_free_symbol (sym
);
6065 symtree
->n
.sym
->refs
++;
6066 this_symtree
->n
.sym
= symtree
->n
.sym
;
6071 /* Otherwise give it a flavor according to such attributes as
6073 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
6074 sym
->attr
.flavor
= FL_VARIABLE
;
6077 sym
->attr
.flavor
= FL_PROCEDURE
;
6078 if (sym
->attr
.dimension
)
6079 sym
->attr
.function
= 1;
6083 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
6086 /* Symbols that are module procedures with results (functions) have
6087 the types and array specification copied for type checking in
6088 procedures that call them, as well as for saving to a module
6089 file. These symbols can't stand the scrutiny that their results
6091 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
6093 /* Assign default type to symbols that need one and don't have one. */
6094 if (sym
->ts
.type
== BT_UNKNOWN
)
6096 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
6097 gfc_set_default_type (sym
, 1, NULL
);
6099 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
6101 /* The specific case of an external procedure should emit an error
6102 in the case that there is no implicit type. */
6104 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
6107 /* Result may be in another namespace. */
6108 resolve_symbol (sym
->result
);
6110 sym
->ts
= sym
->result
->ts
;
6111 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
6112 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
6113 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
6114 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
6119 /* Assumed size arrays and assumed shape arrays must be dummy
6123 && (sym
->as
->type
== AS_ASSUMED_SIZE
6124 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
6125 && sym
->attr
.dummy
== 0)
6127 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
6128 gfc_error ("Assumed size array at %L must be a dummy argument",
6131 gfc_error ("Assumed shape array at %L must be a dummy argument",
6136 /* Make sure symbols with known intent or optional are really dummy
6137 variable. Because of ENTRY statement, this has to be deferred
6138 until resolution time. */
6140 if (!sym
->attr
.dummy
6141 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
6143 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
6147 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
6149 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
6150 "it is not a dummy", sym
->name
, &sym
->declared_at
);
6154 /* If a derived type symbol has reached this point, without its
6155 type being declared, we have an error. Notice that most
6156 conditions that produce undefined derived types have already
6157 been dealt with. However, the likes of:
6158 implicit type(t) (t) ..... call foo (t) will get us here if
6159 the type is not declared in the scope of the implicit
6160 statement. Change the type to BT_UNKNOWN, both because it is so
6161 and to prevent an ICE. */
6162 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
)
6164 gfc_error ("The derived type '%s' at %L is of type '%s', "
6165 "which has not been defined", sym
->name
,
6166 &sym
->declared_at
, sym
->ts
.derived
->name
);
6167 sym
->ts
.type
= BT_UNKNOWN
;
6171 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6172 default initialization is defined (5.1.2.4.4). */
6173 if (sym
->ts
.type
== BT_DERIVED
6175 && sym
->attr
.intent
== INTENT_OUT
6177 && sym
->as
->type
== AS_ASSUMED_SIZE
)
6179 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
6183 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6184 "ASSUMED SIZE and so cannot have a default initializer",
6185 sym
->name
, &sym
->declared_at
);
6191 switch (sym
->attr
.flavor
)
6194 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
6199 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
6204 if (resolve_fl_namelist (sym
) == FAILURE
)
6209 if (resolve_fl_parameter (sym
) == FAILURE
)
6217 /* Make sure that intrinsic exist */
6218 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
6219 && !gfc_intrinsic_name(sym
->name
, 0)
6220 && !gfc_intrinsic_name(sym
->name
, 1))
6221 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
6223 /* Resolve array specifier. Check as well some constraints
6224 on COMMON blocks. */
6226 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
6228 /* Set the formal_arg_flag so that check_conflict will not throw
6229 an error for host associated variables in the specification
6230 expression for an array_valued function. */
6231 if (sym
->attr
.function
&& sym
->as
)
6232 formal_arg_flag
= 1;
6234 gfc_resolve_array_spec (sym
->as
, check_constant
);
6236 formal_arg_flag
= 0;
6238 /* Resolve formal namespaces. */
6240 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
6242 formal_ns_save
= formal_ns_flag
;
6244 gfc_resolve (sym
->formal_ns
);
6245 formal_ns_flag
= formal_ns_save
;
6248 /* Check threadprivate restrictions. */
6249 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
6250 && (!sym
->attr
.in_common
6251 && sym
->module
== NULL
6252 && (sym
->ns
->proc_name
== NULL
6253 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
6254 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
6256 /* If we have come this far we can apply default-initializers, as
6257 described in 14.7.5, to those variables that have not already
6258 been assigned one. */
6259 if (sym
->ts
.type
== BT_DERIVED
6260 && sym
->attr
.referenced
6261 && sym
->ns
== gfc_current_ns
6263 && !sym
->attr
.allocatable
6264 && !sym
->attr
.alloc_comp
)
6266 symbol_attribute
*a
= &sym
->attr
;
6268 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
6269 && !a
->in_common
&& !a
->use_assoc
6270 && !(a
->function
&& sym
!= sym
->result
))
6271 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
6272 apply_default_init (sym
);
6277 /************* Resolve DATA statements *************/
6281 gfc_data_value
*vnode
;
6287 /* Advance the values structure to point to the next value in the data list. */
6290 next_data_value (void)
6292 while (values
.left
== 0)
6294 if (values
.vnode
->next
== NULL
)
6297 values
.vnode
= values
.vnode
->next
;
6298 values
.left
= values
.vnode
->repeat
;
6306 check_data_variable (gfc_data_variable
*var
, locus
*where
)
6312 ar_type mark
= AR_UNKNOWN
;
6314 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
6318 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
6322 mpz_init_set_si (offset
, 0);
6325 if (e
->expr_type
!= EXPR_VARIABLE
)
6326 gfc_internal_error ("check_data_variable(): Bad expression");
6328 if (e
->symtree
->n
.sym
->ns
->is_block_data
6329 && !e
->symtree
->n
.sym
->attr
.in_common
)
6331 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6332 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
6337 mpz_init_set_ui (size
, 1);
6344 /* Find the array section reference. */
6345 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6347 if (ref
->type
!= REF_ARRAY
)
6349 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6355 /* Set marks according to the reference pattern. */
6356 switch (ref
->u
.ar
.type
)
6364 /* Get the start position of array section. */
6365 gfc_get_section_index (ar
, section_index
, &offset
);
6373 if (gfc_array_size (e
, &size
) == FAILURE
)
6375 gfc_error ("Nonconstant array section at %L in DATA statement",
6384 while (mpz_cmp_ui (size
, 0) > 0)
6386 if (next_data_value () == FAILURE
)
6388 gfc_error ("DATA statement at %L has more variables than values",
6394 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
6398 /* If we have more than one element left in the repeat count,
6399 and we have more than one element left in the target variable,
6400 then create a range assignment. */
6401 /* ??? Only done for full arrays for now, since array sections
6403 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
6404 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
6408 if (mpz_cmp_ui (size
, values
.left
) >= 0)
6410 mpz_init_set_ui (range
, values
.left
);
6411 mpz_sub_ui (size
, size
, values
.left
);
6416 mpz_init_set (range
, size
);
6417 values
.left
-= mpz_get_ui (size
);
6418 mpz_set_ui (size
, 0);
6421 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
6424 mpz_add (offset
, offset
, range
);
6428 /* Assign initial value to symbol. */
6432 mpz_sub_ui (size
, size
, 1);
6434 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
6436 if (mark
== AR_FULL
)
6437 mpz_add_ui (offset
, offset
, 1);
6439 /* Modify the array section indexes and recalculate the offset
6440 for next element. */
6441 else if (mark
== AR_SECTION
)
6442 gfc_advance_section (section_index
, ar
, &offset
);
6446 if (mark
== AR_SECTION
)
6448 for (i
= 0; i
< ar
->dimen
; i
++)
6449 mpz_clear (section_index
[i
]);
6459 static try traverse_data_var (gfc_data_variable
*, locus
*);
6461 /* Iterate over a list of elements in a DATA statement. */
6464 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
6467 iterator_stack frame
;
6468 gfc_expr
*e
, *start
, *end
, *step
;
6469 try retval
= SUCCESS
;
6471 mpz_init (frame
.value
);
6473 start
= gfc_copy_expr (var
->iter
.start
);
6474 end
= gfc_copy_expr (var
->iter
.end
);
6475 step
= gfc_copy_expr (var
->iter
.step
);
6477 if (gfc_simplify_expr (start
, 1) == FAILURE
6478 || start
->expr_type
!= EXPR_CONSTANT
)
6480 gfc_error ("iterator start at %L does not simplify", &start
->where
);
6484 if (gfc_simplify_expr (end
, 1) == FAILURE
6485 || end
->expr_type
!= EXPR_CONSTANT
)
6487 gfc_error ("iterator end at %L does not simplify", &end
->where
);
6491 if (gfc_simplify_expr (step
, 1) == FAILURE
6492 || step
->expr_type
!= EXPR_CONSTANT
)
6494 gfc_error ("iterator step at %L does not simplify", &step
->where
);
6499 mpz_init_set (trip
, end
->value
.integer
);
6500 mpz_sub (trip
, trip
, start
->value
.integer
);
6501 mpz_add (trip
, trip
, step
->value
.integer
);
6503 mpz_div (trip
, trip
, step
->value
.integer
);
6505 mpz_set (frame
.value
, start
->value
.integer
);
6507 frame
.prev
= iter_stack
;
6508 frame
.variable
= var
->iter
.var
->symtree
;
6509 iter_stack
= &frame
;
6511 while (mpz_cmp_ui (trip
, 0) > 0)
6513 if (traverse_data_var (var
->list
, where
) == FAILURE
)
6520 e
= gfc_copy_expr (var
->expr
);
6521 if (gfc_simplify_expr (e
, 1) == FAILURE
)
6529 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
6531 mpz_sub_ui (trip
, trip
, 1);
6536 mpz_clear (frame
.value
);
6538 gfc_free_expr (start
);
6539 gfc_free_expr (end
);
6540 gfc_free_expr (step
);
6542 iter_stack
= frame
.prev
;
6547 /* Type resolve variables in the variable list of a DATA statement. */
6550 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
6554 for (; var
; var
= var
->next
)
6556 if (var
->expr
== NULL
)
6557 t
= traverse_data_list (var
, where
);
6559 t
= check_data_variable (var
, where
);
6569 /* Resolve the expressions and iterators associated with a data statement.
6570 This is separate from the assignment checking because data lists should
6571 only be resolved once. */
6574 resolve_data_variables (gfc_data_variable
*d
)
6576 for (; d
; d
= d
->next
)
6578 if (d
->list
== NULL
)
6580 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
6585 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
6588 if (resolve_data_variables (d
->list
) == FAILURE
)
6597 /* Resolve a single DATA statement. We implement this by storing a pointer to
6598 the value list into static variables, and then recursively traversing the
6599 variables list, expanding iterators and such. */
6602 resolve_data (gfc_data
* d
)
6604 if (resolve_data_variables (d
->var
) == FAILURE
)
6607 values
.vnode
= d
->value
;
6608 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
6610 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
6613 /* At this point, we better not have any values left. */
6615 if (next_data_value () == SUCCESS
)
6616 gfc_error ("DATA statement at %L has more values than variables",
6621 /* Determines if a variable is not 'pure', ie not assignable within a pure
6622 procedure. Returns zero if assignment is OK, nonzero if there is a
6626 gfc_impure_variable (gfc_symbol
*sym
)
6628 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
6631 if (sym
->ns
!= gfc_current_ns
)
6632 return !sym
->attr
.function
;
6634 /* TODO: Check storage association through EQUIVALENCE statements */
6640 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6641 symbol of the current procedure. */
6644 gfc_pure (gfc_symbol
*sym
)
6646 symbol_attribute attr
;
6649 sym
= gfc_current_ns
->proc_name
;
6655 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
6659 /* Test whether the current procedure is elemental or not. */
6662 gfc_elemental (gfc_symbol
*sym
)
6664 symbol_attribute attr
;
6667 sym
= gfc_current_ns
->proc_name
;
6672 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
6676 /* Warn about unused labels. */
6679 warn_unused_fortran_label (gfc_st_label
*label
)
6684 warn_unused_fortran_label (label
->left
);
6686 if (label
->defined
== ST_LABEL_UNKNOWN
)
6689 switch (label
->referenced
)
6691 case ST_LABEL_UNKNOWN
:
6692 gfc_warning ("Label %d at %L defined but not used", label
->value
,
6696 case ST_LABEL_BAD_TARGET
:
6697 gfc_warning ("Label %d at %L defined but cannot be used",
6698 label
->value
, &label
->where
);
6705 warn_unused_fortran_label (label
->right
);
6709 /* Returns the sequence type of a symbol or sequence. */
6712 sequence_type (gfc_typespec ts
)
6721 if (ts
.derived
->components
== NULL
)
6722 return SEQ_NONDEFAULT
;
6724 result
= sequence_type (ts
.derived
->components
->ts
);
6725 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
6726 if (sequence_type (c
->ts
) != result
)
6732 if (ts
.kind
!= gfc_default_character_kind
)
6733 return SEQ_NONDEFAULT
;
6735 return SEQ_CHARACTER
;
6738 if (ts
.kind
!= gfc_default_integer_kind
)
6739 return SEQ_NONDEFAULT
;
6744 if (!(ts
.kind
== gfc_default_real_kind
6745 || ts
.kind
== gfc_default_double_kind
))
6746 return SEQ_NONDEFAULT
;
6751 if (ts
.kind
!= gfc_default_complex_kind
)
6752 return SEQ_NONDEFAULT
;
6757 if (ts
.kind
!= gfc_default_logical_kind
)
6758 return SEQ_NONDEFAULT
;
6763 return SEQ_NONDEFAULT
;
6768 /* Resolve derived type EQUIVALENCE object. */
6771 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
6774 gfc_component
*c
= derived
->components
;
6779 /* Shall not be an object of nonsequence derived type. */
6780 if (!derived
->attr
.sequence
)
6782 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6783 "attribute to be an EQUIVALENCE object", sym
->name
,
6788 /* Shall not have allocatable components. */
6789 if (derived
->attr
.alloc_comp
)
6791 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6792 "components to be an EQUIVALENCE object",sym
->name
,
6797 for (; c
; c
= c
->next
)
6801 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
6804 /* Shall not be an object of sequence derived type containing a pointer
6805 in the structure. */
6808 gfc_error ("Derived type variable '%s' at %L with pointer "
6809 "component(s) cannot be an EQUIVALENCE object",
6810 sym
->name
, &e
->where
);
6816 gfc_error ("Derived type variable '%s' at %L with default "
6817 "initializer cannot be an EQUIVALENCE object",
6818 sym
->name
, &e
->where
);
6826 /* Resolve equivalence object.
6827 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6828 an allocatable array, an object of nonsequence derived type, an object of
6829 sequence derived type containing a pointer at any level of component
6830 selection, an automatic object, a function name, an entry name, a result
6831 name, a named constant, a structure component, or a subobject of any of
6832 the preceding objects. A substring shall not have length zero. A
6833 derived type shall not have components with default initialization nor
6834 shall two objects of an equivalence group be initialized.
6835 Either all or none of the objects shall have an protected attribute.
6836 The simple constraints are done in symbol.c(check_conflict) and the rest
6837 are implemented here. */
6840 resolve_equivalence (gfc_equiv
*eq
)
6843 gfc_symbol
*derived
;
6844 gfc_symbol
*first_sym
;
6847 locus
*last_where
= NULL
;
6848 seq_type eq_type
, last_eq_type
;
6849 gfc_typespec
*last_ts
;
6850 int object
, cnt_protected
;
6851 const char *value_name
;
6855 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
6857 first_sym
= eq
->expr
->symtree
->n
.sym
;
6861 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
6865 e
->ts
= e
->symtree
->n
.sym
->ts
;
6866 /* match_varspec might not know yet if it is seeing
6867 array reference or substring reference, as it doesn't
6869 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
6871 gfc_ref
*ref
= e
->ref
;
6872 sym
= e
->symtree
->n
.sym
;
6874 if (sym
->attr
.dimension
)
6876 ref
->u
.ar
.as
= sym
->as
;
6880 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6881 if (e
->ts
.type
== BT_CHARACTER
6883 && ref
->type
== REF_ARRAY
6884 && ref
->u
.ar
.dimen
== 1
6885 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
6886 && ref
->u
.ar
.stride
[0] == NULL
)
6888 gfc_expr
*start
= ref
->u
.ar
.start
[0];
6889 gfc_expr
*end
= ref
->u
.ar
.end
[0];
6892 /* Optimize away the (:) reference. */
6893 if (start
== NULL
&& end
== NULL
)
6898 e
->ref
->next
= ref
->next
;
6903 ref
->type
= REF_SUBSTRING
;
6905 start
= gfc_int_expr (1);
6906 ref
->u
.ss
.start
= start
;
6907 if (end
== NULL
&& e
->ts
.cl
)
6908 end
= gfc_copy_expr (e
->ts
.cl
->length
);
6909 ref
->u
.ss
.end
= end
;
6910 ref
->u
.ss
.length
= e
->ts
.cl
;
6917 /* Any further ref is an error. */
6920 gcc_assert (ref
->type
== REF_ARRAY
);
6921 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6927 if (gfc_resolve_expr (e
) == FAILURE
)
6930 sym
= e
->symtree
->n
.sym
;
6932 if (sym
->attr
.protected)
6934 if (cnt_protected
> 0 && cnt_protected
!= object
)
6936 gfc_error ("Either all or none of the objects in the "
6937 "EQUIVALENCE set at %L shall have the "
6938 "PROTECTED attribute",
6943 /* An equivalence statement cannot have more than one initialized
6947 if (value_name
!= NULL
)
6949 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6950 "be in the EQUIVALENCE statement at %L",
6951 value_name
, sym
->name
, &e
->where
);
6955 value_name
= sym
->name
;
6958 /* Shall not equivalence common block variables in a PURE procedure. */
6959 if (sym
->ns
->proc_name
6960 && sym
->ns
->proc_name
->attr
.pure
6961 && sym
->attr
.in_common
)
6963 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6964 "object in the pure procedure '%s'",
6965 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
6969 /* Shall not be a named constant. */
6970 if (e
->expr_type
== EXPR_CONSTANT
)
6972 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6973 "object", sym
->name
, &e
->where
);
6977 derived
= e
->ts
.derived
;
6978 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
6981 /* Check that the types correspond correctly:
6983 A numeric sequence structure may be equivalenced to another sequence
6984 structure, an object of default integer type, default real type, double
6985 precision real type, default logical type such that components of the
6986 structure ultimately only become associated to objects of the same
6987 kind. A character sequence structure may be equivalenced to an object
6988 of default character kind or another character sequence structure.
6989 Other objects may be equivalenced only to objects of the same type and
6992 /* Identical types are unconditionally OK. */
6993 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
6994 goto identical_types
;
6996 last_eq_type
= sequence_type (*last_ts
);
6997 eq_type
= sequence_type (sym
->ts
);
6999 /* Since the pair of objects is not of the same type, mixed or
7000 non-default sequences can be rejected. */
7002 msg
= "Sequence %s with mixed components in EQUIVALENCE "
7003 "statement at %L with different type objects";
7005 && last_eq_type
== SEQ_MIXED
7006 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
7008 || (eq_type
== SEQ_MIXED
7009 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7010 &e
->where
) == FAILURE
))
7013 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
7014 "statement at %L with objects of different type";
7016 && last_eq_type
== SEQ_NONDEFAULT
7017 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
7018 last_where
) == FAILURE
)
7019 || (eq_type
== SEQ_NONDEFAULT
7020 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7021 &e
->where
) == FAILURE
))
7024 msg
="Non-CHARACTER object '%s' in default CHARACTER "
7025 "EQUIVALENCE statement at %L";
7026 if (last_eq_type
== SEQ_CHARACTER
7027 && eq_type
!= SEQ_CHARACTER
7028 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7029 &e
->where
) == FAILURE
)
7032 msg
="Non-NUMERIC object '%s' in default NUMERIC "
7033 "EQUIVALENCE statement at %L";
7034 if (last_eq_type
== SEQ_NUMERIC
7035 && eq_type
!= SEQ_NUMERIC
7036 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7037 &e
->where
) == FAILURE
)
7042 last_where
= &e
->where
;
7047 /* Shall not be an automatic array. */
7048 if (e
->ref
->type
== REF_ARRAY
7049 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
7051 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
7052 "an EQUIVALENCE object", sym
->name
, &e
->where
);
7059 /* Shall not be a structure component. */
7060 if (r
->type
== REF_COMPONENT
)
7062 gfc_error ("Structure component '%s' at %L cannot be an "
7063 "EQUIVALENCE object",
7064 r
->u
.c
.component
->name
, &e
->where
);
7068 /* A substring shall not have length zero. */
7069 if (r
->type
== REF_SUBSTRING
)
7071 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
7073 gfc_error ("Substring at %L has length zero",
7074 &r
->u
.ss
.start
->where
);
7084 /* Resolve function and ENTRY types, issue diagnostics if needed. */
7087 resolve_fntype (gfc_namespace
*ns
)
7092 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
7095 /* If there are any entries, ns->proc_name is the entry master
7096 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
7098 sym
= ns
->entries
->sym
;
7100 sym
= ns
->proc_name
;
7101 if (sym
->result
== sym
7102 && sym
->ts
.type
== BT_UNKNOWN
7103 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
7104 && !sym
->attr
.untyped
)
7106 gfc_error ("Function '%s' at %L has no IMPLICIT type",
7107 sym
->name
, &sym
->declared_at
);
7108 sym
->attr
.untyped
= 1;
7111 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
7112 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7113 sym
->ts
.derived
->ns
->default_access
)
7114 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
7116 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
7117 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
7120 /* Make sure that the type of a module derived type function is in the
7121 module namespace, by copying it from the namespace's derived type
7122 list, if necessary. */
7123 if (sym
->ts
.type
== BT_DERIVED
7124 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7125 && sym
->ts
.derived
->ns
7126 && sym
->ns
!= sym
->ts
.derived
->ns
)
7128 gfc_dt_list
*dt
= sym
->ns
->derived_types
;
7130 for (; dt
; dt
= dt
->next
)
7131 if (gfc_compare_derived_types (sym
->ts
.derived
, dt
->derived
))
7132 sym
->ts
.derived
= dt
->derived
;
7136 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
7138 if (el
->sym
->result
== el
->sym
7139 && el
->sym
->ts
.type
== BT_UNKNOWN
7140 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
7141 && !el
->sym
->attr
.untyped
)
7143 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
7144 el
->sym
->name
, &el
->sym
->declared_at
);
7145 el
->sym
->attr
.untyped
= 1;
7150 /* 12.3.2.1.1 Defined operators. */
7153 gfc_resolve_uops (gfc_symtree
*symtree
)
7157 gfc_formal_arglist
*formal
;
7159 if (symtree
== NULL
)
7162 gfc_resolve_uops (symtree
->left
);
7163 gfc_resolve_uops (symtree
->right
);
7165 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
7168 if (!sym
->attr
.function
)
7169 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
7170 sym
->name
, &sym
->declared_at
);
7172 if (sym
->ts
.type
== BT_CHARACTER
7173 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
7174 && !(sym
->result
&& sym
->result
->ts
.cl
7175 && sym
->result
->ts
.cl
->length
))
7176 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
7177 "character length", sym
->name
, &sym
->declared_at
);
7179 formal
= sym
->formal
;
7180 if (!formal
|| !formal
->sym
)
7182 gfc_error ("User operator procedure '%s' at %L must have at least "
7183 "one argument", sym
->name
, &sym
->declared_at
);
7187 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7188 gfc_error ("First argument of operator interface at %L must be "
7189 "INTENT(IN)", &sym
->declared_at
);
7191 if (formal
->sym
->attr
.optional
)
7192 gfc_error ("First argument of operator interface at %L cannot be "
7193 "optional", &sym
->declared_at
);
7195 formal
= formal
->next
;
7196 if (!formal
|| !formal
->sym
)
7199 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7200 gfc_error ("Second argument of operator interface at %L must be "
7201 "INTENT(IN)", &sym
->declared_at
);
7203 if (formal
->sym
->attr
.optional
)
7204 gfc_error ("Second argument of operator interface at %L cannot be "
7205 "optional", &sym
->declared_at
);
7208 gfc_error ("Operator interface at %L must have, at most, two "
7209 "arguments", &sym
->declared_at
);
7214 /* Examine all of the expressions associated with a program unit,
7215 assign types to all intermediate expressions, make sure that all
7216 assignments are to compatible types and figure out which names
7217 refer to which functions or subroutines. It doesn't check code
7218 block, which is handled by resolve_code. */
7221 resolve_types (gfc_namespace
*ns
)
7228 gfc_current_ns
= ns
;
7230 resolve_entries (ns
);
7232 resolve_contained_functions (ns
);
7234 gfc_traverse_ns (ns
, resolve_symbol
);
7236 resolve_fntype (ns
);
7238 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7240 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
7241 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7242 "also be PURE", n
->proc_name
->name
,
7243 &n
->proc_name
->declared_at
);
7249 gfc_check_interfaces (ns
);
7251 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
7252 resolve_charlen (cl
);
7254 gfc_traverse_ns (ns
, resolve_values
);
7260 for (d
= ns
->data
; d
; d
= d
->next
)
7264 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
7266 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
7267 resolve_equivalence (eq
);
7269 /* Warn about unused labels. */
7270 if (warn_unused_label
)
7271 warn_unused_fortran_label (ns
->st_labels
);
7273 gfc_resolve_uops (ns
->uop_root
);
7277 /* Call resolve_code recursively. */
7280 resolve_codes (gfc_namespace
*ns
)
7284 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7287 gfc_current_ns
= ns
;
7289 /* Set to an out of range value. */
7290 current_entry_id
= -1;
7291 resolve_code (ns
->code
, ns
);
7295 /* This function is called after a complete program unit has been compiled.
7296 Its purpose is to examine all of the expressions associated with a program
7297 unit, assign types to all intermediate expressions, make sure that all
7298 assignments are to compatible types and figure out which names refer to
7299 which functions or subroutines. */
7302 gfc_resolve (gfc_namespace
*ns
)
7304 gfc_namespace
*old_ns
;
7306 old_ns
= gfc_current_ns
;
7311 gfc_current_ns
= old_ns
;