1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
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
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 /* Types used in equivalence statements. */
35 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
39 /* Stack to push the current if we descend into a block during
40 resolution. See resolve_branch() and resolve_code(). */
42 typedef struct code_stack
44 struct gfc_code
*head
, *current
;
45 struct code_stack
*prev
;
49 static code_stack
*cs_base
= NULL
;
52 /* Nonzero if we're inside a FORALL block. */
54 static int forall_flag
;
56 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
58 static int omp_workshare_flag
;
60 /* Nonzero if we are processing a formal arglist. The corresponding function
61 resets the flag each time that it is read. */
62 static int formal_arg_flag
= 0;
64 /* True if we are resolving a specification expression. */
65 static int specification_expr
= 0;
67 /* The id of the last entry seen. */
68 static int current_entry_id
;
71 gfc_is_formal_arg (void)
73 return formal_arg_flag
;
76 /* Resolve types of formal argument lists. These have to be done early so that
77 the formal argument lists of module procedures can be copied to the
78 containing module before the individual procedures are resolved
79 individually. We also resolve argument lists of procedures in interface
80 blocks because they are self-contained scoping units.
82 Since a dummy argument cannot be a non-dummy procedure, the only
83 resort left for untyped names are the IMPLICIT types. */
86 resolve_formal_arglist (gfc_symbol
* proc
)
88 gfc_formal_arglist
*f
;
92 if (proc
->result
!= NULL
)
97 if (gfc_elemental (proc
)
98 || sym
->attr
.pointer
|| sym
->attr
.allocatable
99 || (sym
->as
&& sym
->as
->rank
> 0))
100 proc
->attr
.always_explicit
= 1;
104 for (f
= proc
->formal
; f
; f
= f
->next
)
110 /* Alternate return placeholder. */
111 if (gfc_elemental (proc
))
112 gfc_error ("Alternate return specifier in elemental subroutine "
113 "'%s' at %L is not allowed", proc
->name
,
115 if (proc
->attr
.function
)
116 gfc_error ("Alternate return specifier in function "
117 "'%s' at %L is not allowed", proc
->name
,
122 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
123 resolve_formal_arglist (sym
);
125 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
127 if (gfc_pure (proc
) && !gfc_pure (sym
))
130 ("Dummy procedure '%s' of PURE procedure at %L must also "
131 "be PURE", sym
->name
, &sym
->declared_at
);
135 if (gfc_elemental (proc
))
138 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
146 if (sym
->ts
.type
== BT_UNKNOWN
)
148 if (!sym
->attr
.function
|| sym
->result
== sym
)
149 gfc_set_default_type (sym
, 1, sym
->ns
);
152 gfc_resolve_array_spec (sym
->as
, 0);
154 /* We can't tell if an array with dimension (:) is assumed or deferred
155 shape until we know if it has the pointer or allocatable attributes.
157 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
158 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
160 sym
->as
->type
= AS_ASSUMED_SHAPE
;
161 for (i
= 0; i
< sym
->as
->rank
; i
++)
162 sym
->as
->lower
[i
] = gfc_int_expr (1);
165 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
166 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
167 || sym
->attr
.optional
)
168 proc
->attr
.always_explicit
= 1;
170 /* If the flavor is unknown at this point, it has to be a variable.
171 A procedure specification would have already set the type. */
173 if (sym
->attr
.flavor
== FL_UNKNOWN
)
174 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
178 if (proc
->attr
.function
&& !sym
->attr
.pointer
179 && sym
->attr
.flavor
!= FL_PROCEDURE
180 && sym
->attr
.intent
!= INTENT_IN
)
182 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
183 "INTENT(IN)", sym
->name
, proc
->name
,
186 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
187 && sym
->attr
.intent
== INTENT_UNKNOWN
)
190 ("Argument '%s' of pure subroutine '%s' at %L must have "
191 "its INTENT specified", sym
->name
, proc
->name
,
196 if (gfc_elemental (proc
))
201 ("Argument '%s' of elemental procedure at %L must be scalar",
202 sym
->name
, &sym
->declared_at
);
206 if (sym
->attr
.pointer
)
209 ("Argument '%s' of elemental procedure at %L cannot have "
210 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
215 /* Each dummy shall be specified to be scalar. */
216 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
221 ("Argument '%s' of statement function at %L must be scalar",
222 sym
->name
, &sym
->declared_at
);
226 if (sym
->ts
.type
== BT_CHARACTER
)
228 gfc_charlen
*cl
= sym
->ts
.cl
;
229 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
232 ("Character-valued argument '%s' of statement function at "
233 "%L must have constant length",
234 sym
->name
, &sym
->declared_at
);
244 /* Work function called when searching for symbols that have argument lists
245 associated with them. */
248 find_arglists (gfc_symbol
* sym
)
251 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
254 resolve_formal_arglist (sym
);
258 /* Given a namespace, resolve all formal argument lists within the namespace.
262 resolve_formal_arglists (gfc_namespace
* ns
)
268 gfc_traverse_ns (ns
, find_arglists
);
273 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
277 /* If this namespace is not a function, ignore it. */
279 || !(sym
->attr
.function
280 || sym
->attr
.flavor
== FL_VARIABLE
))
283 /* Try to find out of what the return type is. */
284 if (sym
->result
!= NULL
)
287 if (sym
->ts
.type
== BT_UNKNOWN
)
289 t
= gfc_set_default_type (sym
, 0, ns
);
291 if (t
== FAILURE
&& !sym
->attr
.untyped
)
293 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
294 sym
->name
, &sym
->declared_at
); /* FIXME */
295 sym
->attr
.untyped
= 1;
299 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
300 lists the only ways a character length value of * can be used: dummy arguments
301 of procedures, named constants, and function results in external functions.
302 Internal function results are not on that list; 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 /* Resolve alternate entry points. If a symbol has multiple entry points we
346 create a new master symbol for the main routine, and turn the existing
347 symbol into an entry point. */
350 resolve_entries (gfc_namespace
* ns
)
352 gfc_namespace
*old_ns
;
356 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
357 static int master_count
= 0;
359 if (ns
->proc_name
== NULL
)
362 /* No need to do anything if this procedure doesn't have alternate entry
367 /* We may already have resolved alternate entry points. */
368 if (ns
->proc_name
->attr
.entry_master
)
371 /* If this isn't a procedure something has gone horribly wrong. */
372 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
374 /* Remember the current namespace. */
375 old_ns
= gfc_current_ns
;
379 /* Add the main entry point to the list of entry points. */
380 el
= gfc_get_entry_list ();
381 el
->sym
= ns
->proc_name
;
383 el
->next
= ns
->entries
;
385 ns
->proc_name
->attr
.entry
= 1;
387 /* If it is a module function, it needs to be in the right namespace
388 so that gfc_get_fake_result_decl can gather up the results. The
389 need for this arose in get_proc_name, where these beasts were
390 left in their own namespace, to keep prior references linked to
391 the entry declaration.*/
392 if (ns
->proc_name
->attr
.function
394 && ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
397 /* Add an entry statement for it. */
404 /* Create a new symbol for the master function. */
405 /* Give the internal function a unique name (within this file).
406 Also include the function name so the user has some hope of figuring
407 out what is going on. */
408 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
409 master_count
++, ns
->proc_name
->name
);
410 gfc_get_ha_symbol (name
, &proc
);
411 gcc_assert (proc
!= NULL
);
413 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
414 if (ns
->proc_name
->attr
.subroutine
)
415 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
419 gfc_typespec
*ts
, *fts
;
420 gfc_array_spec
*as
, *fas
;
421 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
423 fas
= ns
->entries
->sym
->as
;
424 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
425 fts
= &ns
->entries
->sym
->result
->ts
;
426 if (fts
->type
== BT_UNKNOWN
)
427 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
428 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
430 ts
= &el
->sym
->result
->ts
;
432 as
= as
? as
: el
->sym
->result
->as
;
433 if (ts
->type
== BT_UNKNOWN
)
434 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
436 if (! gfc_compare_types (ts
, fts
)
437 || (el
->sym
->result
->attr
.dimension
438 != ns
->entries
->sym
->result
->attr
.dimension
)
439 || (el
->sym
->result
->attr
.pointer
440 != ns
->entries
->sym
->result
->attr
.pointer
))
443 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
444 gfc_error ("Procedure %s at %L has entries with mismatched "
445 "array specifications", ns
->entries
->sym
->name
,
446 &ns
->entries
->sym
->declared_at
);
451 sym
= ns
->entries
->sym
->result
;
452 /* All result types the same. */
454 if (sym
->attr
.dimension
)
455 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
456 if (sym
->attr
.pointer
)
457 gfc_add_pointer (&proc
->attr
, NULL
);
461 /* Otherwise the result will be passed through a union by
463 proc
->attr
.mixed_entry_master
= 1;
464 for (el
= ns
->entries
; el
; el
= el
->next
)
466 sym
= el
->sym
->result
;
467 if (sym
->attr
.dimension
)
469 if (el
== ns
->entries
)
471 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
472 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
475 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
476 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
478 else if (sym
->attr
.pointer
)
480 if (el
== ns
->entries
)
482 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
483 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
486 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
487 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
492 if (ts
->type
== BT_UNKNOWN
)
493 ts
= gfc_get_default_type (sym
, NULL
);
497 if (ts
->kind
== gfc_default_integer_kind
)
501 if (ts
->kind
== gfc_default_real_kind
502 || ts
->kind
== gfc_default_double_kind
)
506 if (ts
->kind
== gfc_default_complex_kind
)
510 if (ts
->kind
== gfc_default_logical_kind
)
514 /* We will issue error elsewhere. */
522 if (el
== ns
->entries
)
524 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
525 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
529 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
530 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
537 proc
->attr
.access
= ACCESS_PRIVATE
;
538 proc
->attr
.entry_master
= 1;
540 /* Merge all the entry point arguments. */
541 for (el
= ns
->entries
; el
; el
= el
->next
)
542 merge_argument_lists (proc
, el
->sym
->formal
);
544 /* Use the master function for the function body. */
545 ns
->proc_name
= proc
;
547 /* Finalize the new symbols. */
548 gfc_commit_symbols ();
550 /* Restore the original namespace. */
551 gfc_current_ns
= old_ns
;
555 /* Resolve contained function types. Because contained functions can call one
556 another, they have to be worked out before any of the contained procedures
559 The good news is that if a function doesn't already have a type, the only
560 way it can get one is through an IMPLICIT type or a RESULT variable, because
561 by definition contained functions are contained namespace they're contained
562 in, not in a sibling or parent namespace. */
565 resolve_contained_functions (gfc_namespace
* ns
)
567 gfc_namespace
*child
;
570 resolve_formal_arglists (ns
);
572 for (child
= ns
->contained
; child
; child
= child
->sibling
)
574 /* Resolve alternate entry points first. */
575 resolve_entries (child
);
577 /* Then check function return types. */
578 resolve_contained_fntype (child
->proc_name
, child
);
579 for (el
= child
->entries
; el
; el
= el
->next
)
580 resolve_contained_fntype (el
->sym
, child
);
585 /* Resolve all of the elements of a structure constructor and make sure that
586 the types are correct. */
589 resolve_structure_cons (gfc_expr
* expr
)
591 gfc_constructor
*cons
;
597 cons
= expr
->value
.constructor
;
598 /* A constructor may have references if it is the result of substituting a
599 parameter variable. In this case we just pull out the component we
602 comp
= expr
->ref
->u
.c
.sym
->components
;
604 comp
= expr
->ts
.derived
->components
;
606 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
611 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
617 if (cons
->expr
->expr_type
!= EXPR_NULL
618 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
619 && (comp
->allocatable
|| cons
->expr
->rank
))
621 gfc_error ("The rank of the element in the derived type "
622 "constructor at %L does not match that of the "
623 "component (%d/%d)", &cons
->expr
->where
,
624 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
628 /* If we don't have the right type, try to convert it. */
630 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
633 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
634 gfc_error ("The element in the derived type constructor at %L, "
635 "for pointer component '%s', is %s but should be %s",
636 &cons
->expr
->where
, comp
->name
,
637 gfc_basic_typename (cons
->expr
->ts
.type
),
638 gfc_basic_typename (comp
->ts
.type
));
640 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
643 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
646 a
= gfc_expr_attr (cons
->expr
);
648 if (!a
.pointer
&& !a
.target
)
651 gfc_error ("The element in the derived type constructor at %L, "
652 "for pointer component '%s' should be a POINTER or "
653 "a TARGET", &cons
->expr
->where
, comp
->name
);
662 /****************** Expression name resolution ******************/
664 /* Returns 0 if a symbol was not declared with a type or
665 attribute declaration statement, nonzero otherwise. */
668 was_declared (gfc_symbol
* sym
)
674 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
677 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
678 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
|| a
.value
679 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
686 /* Determine if a symbol is generic or not. */
689 generic_sym (gfc_symbol
* sym
)
693 if (sym
->attr
.generic
||
694 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
697 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
700 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
702 return (s
== NULL
) ? 0 : generic_sym (s
);
706 /* Determine if a symbol is specific or not. */
709 specific_sym (gfc_symbol
* sym
)
713 if (sym
->attr
.if_source
== IFSRC_IFBODY
714 || sym
->attr
.proc
== PROC_MODULE
715 || sym
->attr
.proc
== PROC_INTERNAL
716 || sym
->attr
.proc
== PROC_ST_FUNCTION
717 || (sym
->attr
.intrinsic
&&
718 gfc_specific_intrinsic (sym
->name
))
719 || sym
->attr
.external
)
722 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
725 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
727 return (s
== NULL
) ? 0 : specific_sym (s
);
731 /* Figure out if the procedure is specific, generic or unknown. */
734 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
738 procedure_kind (gfc_symbol
* sym
)
741 if (generic_sym (sym
))
742 return PTYPE_GENERIC
;
744 if (specific_sym (sym
))
745 return PTYPE_SPECIFIC
;
747 return PTYPE_UNKNOWN
;
750 /* Check references to assumed size arrays. The flag need_full_assumed_size
751 is nonzero when matching actual arguments. */
753 static int need_full_assumed_size
= 0;
756 check_assumed_size_reference (gfc_symbol
* sym
, gfc_expr
* e
)
762 if (need_full_assumed_size
763 || !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
766 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
767 if (ref
->type
== REF_ARRAY
)
768 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
769 last
= (ref
->u
.ar
.end
[dim
] == NULL
) && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
773 gfc_error ("The upper bound in the last dimension must "
774 "appear in the reference to the assumed size "
775 "array '%s' at %L", sym
->name
, &e
->where
);
782 /* Look for bad assumed size array references in argument expressions
783 of elemental and array valued intrinsic procedures. Since this is
784 called from procedure resolution functions, it only recurses at
788 resolve_assumed_size_actual (gfc_expr
*e
)
793 switch (e
->expr_type
)
797 && check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
802 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
803 || resolve_assumed_size_actual (e
->value
.op
.op2
))
814 /* Resolve an actual argument list. Most of the time, this is just
815 resolving the expressions in the list.
816 The exception is that we sometimes have to decide whether arguments
817 that look like procedure arguments are really simple variable
821 resolve_actual_arglist (gfc_actual_arglist
* arg
)
824 gfc_symtree
*parent_st
;
827 for (; arg
; arg
= arg
->next
)
833 /* Check the label is a valid branching target. */
836 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
838 gfc_error ("Label %d referenced at %L is never defined",
839 arg
->label
->value
, &arg
->label
->where
);
846 if (e
->ts
.type
!= BT_PROCEDURE
)
848 if (gfc_resolve_expr (e
) != SUCCESS
)
853 /* See if the expression node should really be a variable
856 sym
= e
->symtree
->n
.sym
;
858 if (sym
->attr
.flavor
== FL_PROCEDURE
859 || sym
->attr
.intrinsic
860 || sym
->attr
.external
)
864 /* If a procedure is not already determined to be something else
865 check if it is intrinsic. */
866 if (!sym
->attr
.intrinsic
867 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
868 || sym
->attr
.if_source
== IFSRC_IFBODY
)
869 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
870 sym
->attr
.intrinsic
= 1;
872 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
874 gfc_error ("Statement function '%s' at %L is not allowed as an "
875 "actual argument", sym
->name
, &e
->where
);
878 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
, sym
->attr
.subroutine
);
879 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
881 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
882 "actual argument", sym
->name
, &e
->where
);
885 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
886 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
888 gfc_error ("Internal procedure '%s' is not allowed as an "
889 "actual argument at %L", sym
->name
, &e
->where
);
892 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
894 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
895 "allowed as an actual argument at %L", sym
->name
,
899 if (sym
->attr
.generic
)
901 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
902 "allowed as an actual argument at %L", sym
->name
,
906 /* If the symbol is the function that names the current (or
907 parent) scope, then we really have a variable reference. */
909 if (sym
->attr
.function
&& sym
->result
== sym
910 && (sym
->ns
->proc_name
== sym
911 || (sym
->ns
->parent
!= NULL
912 && sym
->ns
->parent
->proc_name
== sym
)))
918 /* See if the name is a module procedure in a parent unit. */
920 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
923 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
925 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
929 if (parent_st
== NULL
)
932 sym
= parent_st
->n
.sym
;
933 e
->symtree
= parent_st
; /* Point to the right thing. */
935 if (sym
->attr
.flavor
== FL_PROCEDURE
936 || sym
->attr
.intrinsic
937 || sym
->attr
.external
)
943 e
->expr_type
= EXPR_VARIABLE
;
947 e
->rank
= sym
->as
->rank
;
948 e
->ref
= gfc_get_ref ();
949 e
->ref
->type
= REF_ARRAY
;
950 e
->ref
->u
.ar
.type
= AR_FULL
;
951 e
->ref
->u
.ar
.as
= sym
->as
;
959 /* Do the checks of the actual argument list that are specific to elemental
960 procedures. If called with c == NULL, we have a function, otherwise if
961 expr == NULL, we have a subroutine. */
963 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
965 gfc_actual_arglist
*arg0
;
966 gfc_actual_arglist
*arg
;
967 gfc_symbol
*esym
= NULL
;
968 gfc_intrinsic_sym
*isym
= NULL
;
970 gfc_intrinsic_arg
*iformal
= NULL
;
971 gfc_formal_arglist
*eformal
= NULL
;
972 bool formal_optional
= false;
973 bool set_by_optional
= false;
977 /* Is this an elemental procedure? */
978 if (expr
&& expr
->value
.function
.actual
!= NULL
)
980 if (expr
->value
.function
.esym
!= NULL
981 && expr
->value
.function
.esym
->attr
.elemental
)
983 arg0
= expr
->value
.function
.actual
;
984 esym
= expr
->value
.function
.esym
;
986 else if (expr
->value
.function
.isym
!= NULL
987 && expr
->value
.function
.isym
->elemental
)
989 arg0
= expr
->value
.function
.actual
;
990 isym
= expr
->value
.function
.isym
;
995 else if (c
&& c
->ext
.actual
!= NULL
996 && c
->symtree
->n
.sym
->attr
.elemental
)
998 arg0
= c
->ext
.actual
;
999 esym
= c
->symtree
->n
.sym
;
1004 /* The rank of an elemental is the rank of its array argument(s). */
1005 for (arg
= arg0
; arg
; arg
= arg
->next
)
1007 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1009 rank
= arg
->expr
->rank
;
1010 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1011 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1012 set_by_optional
= true;
1014 /* Function specific; set the result rank and shape. */
1018 if (!expr
->shape
&& arg
->expr
->shape
)
1020 expr
->shape
= gfc_get_shape (rank
);
1021 for (i
= 0; i
< rank
; i
++)
1022 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1029 /* If it is an array, it shall not be supplied as an actual argument
1030 to an elemental procedure unless an array of the same rank is supplied
1031 as an actual argument corresponding to a nonoptional dummy argument of
1032 that elemental procedure(12.4.1.5). */
1033 formal_optional
= false;
1035 iformal
= isym
->formal
;
1037 eformal
= esym
->formal
;
1039 for (arg
= arg0
; arg
; arg
= arg
->next
)
1043 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1044 formal_optional
= true;
1045 eformal
= eformal
->next
;
1047 else if (isym
&& iformal
)
1049 if (iformal
->optional
)
1050 formal_optional
= true;
1051 iformal
= iformal
->next
;
1054 formal_optional
= true;
1056 if (pedantic
&& arg
->expr
!= NULL
1057 && arg
->expr
->expr_type
== EXPR_VARIABLE
1058 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1061 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1062 && !(isym
&& isym
->generic_id
== GFC_ISYM_CONVERSION
))
1064 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1065 "MISSING, it cannot be the actual argument of an "
1066 "ELEMENTAL procedure unless there is a non-optional"
1067 "argument with the same rank (12.4.1.5)",
1068 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1073 for (arg
= arg0
; arg
; arg
= arg
->next
)
1075 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1078 /* Being elemental, the last upper bound of an assumed size array
1079 argument must be present. */
1080 if (resolve_assumed_size_actual (arg
->expr
))
1086 /* Elemental subroutine array actual arguments must conform. */
1089 if (gfc_check_conformance ("elemental subroutine", arg
->expr
, e
)
1101 /* Go through each actual argument in ACTUAL and see if it can be
1102 implemented as an inlined, non-copying intrinsic. FNSYM is the
1103 function being called, or NULL if not known. */
1106 find_noncopying_intrinsics (gfc_symbol
* fnsym
, gfc_actual_arglist
* actual
)
1108 gfc_actual_arglist
*ap
;
1111 for (ap
= actual
; ap
; ap
= ap
->next
)
1113 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1114 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1115 ap
->expr
->inline_noncopying_intrinsic
= 1;
1118 /* This function does the checking of references to global procedures
1119 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1120 77 and 95 standards. It checks for a gsymbol for the name, making
1121 one if it does not already exist. If it already exists, then the
1122 reference being resolved must correspond to the type of gsymbol.
1123 Otherwise, the new symbol is equipped with the attributes of the
1124 reference. The corresponding code that is called in creating
1125 global entities is parse.c. */
1128 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1133 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1135 gsym
= gfc_get_gsymbol (sym
->name
);
1137 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1138 global_used (gsym
, where
);
1140 if (gsym
->type
== GSYM_UNKNOWN
)
1143 gsym
->where
= *where
;
1149 /************* Function resolution *************/
1151 /* Resolve a function call known to be generic.
1152 Section 14.1.2.4.1. */
1155 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
1159 if (sym
->attr
.generic
)
1162 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1165 expr
->value
.function
.name
= s
->name
;
1166 expr
->value
.function
.esym
= s
;
1168 if (s
->ts
.type
!= BT_UNKNOWN
)
1170 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1171 expr
->ts
= s
->result
->ts
;
1174 expr
->rank
= s
->as
->rank
;
1175 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1176 expr
->rank
= s
->result
->as
->rank
;
1181 /* TODO: Need to search for elemental references in generic interface */
1184 if (sym
->attr
.intrinsic
)
1185 return gfc_intrinsic_func_interface (expr
, 0);
1192 resolve_generic_f (gfc_expr
* expr
)
1197 sym
= expr
->symtree
->n
.sym
;
1201 m
= resolve_generic_f0 (expr
, sym
);
1204 else if (m
== MATCH_ERROR
)
1208 if (sym
->ns
->parent
== NULL
)
1210 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1214 if (!generic_sym (sym
))
1218 /* Last ditch attempt. See if the reference is to an intrinsic
1219 that possesses a matching interface. 14.1.2.4 */
1220 if (!gfc_intrinsic_name (sym
->name
, 0))
1222 gfc_error ("There is no specific function for the generic '%s' at %L",
1223 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1227 m
= gfc_intrinsic_func_interface (expr
, 0);
1232 ("Generic function '%s' at %L is not consistent with a specific "
1233 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
1239 /* Resolve a function call known to be specific. */
1242 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
1246 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1248 if (sym
->attr
.dummy
)
1250 sym
->attr
.proc
= PROC_DUMMY
;
1254 sym
->attr
.proc
= PROC_EXTERNAL
;
1258 if (sym
->attr
.proc
== PROC_MODULE
1259 || sym
->attr
.proc
== PROC_ST_FUNCTION
1260 || sym
->attr
.proc
== PROC_INTERNAL
)
1263 if (sym
->attr
.intrinsic
)
1265 m
= gfc_intrinsic_func_interface (expr
, 1);
1270 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1271 "an intrinsic", sym
->name
, &expr
->where
);
1279 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1282 expr
->value
.function
.name
= sym
->name
;
1283 expr
->value
.function
.esym
= sym
;
1284 if (sym
->as
!= NULL
)
1285 expr
->rank
= sym
->as
->rank
;
1292 resolve_specific_f (gfc_expr
* expr
)
1297 sym
= expr
->symtree
->n
.sym
;
1301 m
= resolve_specific_f0 (sym
, expr
);
1304 if (m
== MATCH_ERROR
)
1307 if (sym
->ns
->parent
== NULL
)
1310 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1316 gfc_error ("Unable to resolve the specific function '%s' at %L",
1317 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1323 /* Resolve a procedure call not known to be generic nor specific. */
1326 resolve_unknown_f (gfc_expr
* expr
)
1331 sym
= expr
->symtree
->n
.sym
;
1333 if (sym
->attr
.dummy
)
1335 sym
->attr
.proc
= PROC_DUMMY
;
1336 expr
->value
.function
.name
= sym
->name
;
1340 /* See if we have an intrinsic function reference. */
1342 if (gfc_intrinsic_name (sym
->name
, 0))
1344 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1349 /* The reference is to an external name. */
1351 sym
->attr
.proc
= PROC_EXTERNAL
;
1352 expr
->value
.function
.name
= sym
->name
;
1353 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1355 if (sym
->as
!= NULL
)
1356 expr
->rank
= sym
->as
->rank
;
1358 /* Type of the expression is either the type of the symbol or the
1359 default type of the symbol. */
1362 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1364 if (sym
->ts
.type
!= BT_UNKNOWN
)
1368 ts
= gfc_get_default_type (sym
, sym
->ns
);
1370 if (ts
->type
== BT_UNKNOWN
)
1372 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1373 sym
->name
, &expr
->where
);
1384 /* Figure out if a function reference is pure or not. Also set the name
1385 of the function for a potential error message. Return nonzero if the
1386 function is PURE, zero if not. */
1389 pure_function (gfc_expr
* e
, const char **name
)
1393 if (e
->value
.function
.esym
)
1395 pure
= gfc_pure (e
->value
.function
.esym
);
1396 *name
= e
->value
.function
.esym
->name
;
1398 else if (e
->value
.function
.isym
)
1400 pure
= e
->value
.function
.isym
->pure
1401 || e
->value
.function
.isym
->elemental
;
1402 *name
= e
->value
.function
.isym
->name
;
1406 /* Implicit functions are not pure. */
1408 *name
= e
->value
.function
.name
;
1415 /* Resolve a function call, which means resolving the arguments, then figuring
1416 out which entity the name refers to. */
1417 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1418 to INTENT(OUT) or INTENT(INOUT). */
1421 resolve_function (gfc_expr
* expr
)
1423 gfc_actual_arglist
*arg
;
1431 sym
= expr
->symtree
->n
.sym
;
1433 /* If the procedure is not internal, a statement function or a module
1434 procedure,it must be external and should be checked for usage. */
1435 if (sym
&& !sym
->attr
.dummy
&& !sym
->attr
.contained
1436 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1437 && !sym
->attr
.use_assoc
)
1438 resolve_global_procedure (sym
, &expr
->where
, 0);
1440 /* Switch off assumed size checking and do this again for certain kinds
1441 of procedure, once the procedure itself is resolved. */
1442 need_full_assumed_size
++;
1444 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1447 /* Resume assumed_size checking. */
1448 need_full_assumed_size
--;
1450 if (sym
&& sym
->ts
.type
== BT_CHARACTER
1452 && sym
->ts
.cl
->length
== NULL
1454 && expr
->value
.function
.esym
== NULL
1455 && !sym
->attr
.contained
)
1457 /* Internal procedures are taken care of in resolve_contained_fntype. */
1458 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1459 "be used at %L since it is not a dummy argument",
1460 sym
->name
, &expr
->where
);
1464 /* See if function is already resolved. */
1466 if (expr
->value
.function
.name
!= NULL
)
1468 if (expr
->ts
.type
== BT_UNKNOWN
)
1474 /* Apply the rules of section 14.1.2. */
1476 switch (procedure_kind (sym
))
1479 t
= resolve_generic_f (expr
);
1482 case PTYPE_SPECIFIC
:
1483 t
= resolve_specific_f (expr
);
1487 t
= resolve_unknown_f (expr
);
1491 gfc_internal_error ("resolve_function(): bad function type");
1495 /* If the expression is still a function (it might have simplified),
1496 then we check to see if we are calling an elemental function. */
1498 if (expr
->expr_type
!= EXPR_FUNCTION
)
1501 temp
= need_full_assumed_size
;
1502 need_full_assumed_size
= 0;
1504 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
1507 if (omp_workshare_flag
1508 && expr
->value
.function
.esym
1509 && ! gfc_elemental (expr
->value
.function
.esym
))
1511 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1512 " in WORKSHARE construct", expr
->value
.function
.esym
->name
,
1517 #define GENERIC_ID expr->value.function.isym->generic_id
1518 else if (expr
->value
.function
.actual
!= NULL
1519 && expr
->value
.function
.isym
!= NULL
1520 && GENERIC_ID
!= GFC_ISYM_LBOUND
1521 && GENERIC_ID
!= GFC_ISYM_LEN
1522 && GENERIC_ID
!= GFC_ISYM_LOC
1523 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
1525 /* Array intrinsics must also have the last upper bound of an
1526 assumed size array argument. UBOUND and SIZE have to be
1527 excluded from the check if the second argument is anything
1530 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
1531 || GENERIC_ID
== GFC_ISYM_SIZE
;
1533 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1535 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
1536 && arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
1539 if (arg
->expr
!= NULL
1540 && arg
->expr
->rank
> 0
1541 && resolve_assumed_size_actual (arg
->expr
))
1547 need_full_assumed_size
= temp
;
1549 if (!pure_function (expr
, &name
) && name
)
1554 ("reference to non-PURE function '%s' at %L inside a "
1555 "FORALL %s", name
, &expr
->where
, forall_flag
== 2 ?
1559 else if (gfc_pure (NULL
))
1561 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1562 "procedure within a PURE procedure", name
, &expr
->where
);
1567 /* Functions without the RECURSIVE attribution are not allowed to
1568 * call themselves. */
1569 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
1571 gfc_symbol
*esym
, *proc
;
1572 esym
= expr
->value
.function
.esym
;
1573 proc
= gfc_current_ns
->proc_name
;
1576 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1577 "RECURSIVE", name
, &expr
->where
);
1581 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
1582 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1584 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1585 "'%s' is not declared as RECURSIVE",
1586 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
1591 /* Character lengths of use associated functions may contains references to
1592 symbols not referenced from the current program unit otherwise. Make sure
1593 those symbols are marked as referenced. */
1595 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
1596 && expr
->value
.function
.esym
->attr
.use_assoc
)
1598 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
1602 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1603 expr
->value
.function
.actual
);
1608 /************* Subroutine resolution *************/
1611 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1618 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1619 sym
->name
, &c
->loc
);
1620 else if (gfc_pure (NULL
))
1621 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1627 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1631 if (sym
->attr
.generic
)
1633 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1636 c
->resolved_sym
= s
;
1637 pure_subroutine (c
, s
);
1641 /* TODO: Need to search for elemental references in generic interface. */
1644 if (sym
->attr
.intrinsic
)
1645 return gfc_intrinsic_sub_interface (c
, 0);
1652 resolve_generic_s (gfc_code
* c
)
1657 sym
= c
->symtree
->n
.sym
;
1661 m
= resolve_generic_s0 (c
, sym
);
1664 else if (m
== MATCH_ERROR
)
1668 if (sym
->ns
->parent
== NULL
)
1670 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1674 if (!generic_sym (sym
))
1678 /* Last ditch attempt. See if the reference is to an intrinsic
1679 that possesses a matching interface. 14.1.2.4 */
1680 sym
= c
->symtree
->n
.sym
;
1682 if (!gfc_intrinsic_name (sym
->name
, 1))
1685 ("There is no specific subroutine for the generic '%s' at %L",
1686 sym
->name
, &c
->loc
);
1690 m
= gfc_intrinsic_sub_interface (c
, 0);
1694 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1695 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1701 /* Resolve a subroutine call known to be specific. */
1704 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1708 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1710 if (sym
->attr
.dummy
)
1712 sym
->attr
.proc
= PROC_DUMMY
;
1716 sym
->attr
.proc
= PROC_EXTERNAL
;
1720 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1723 if (sym
->attr
.intrinsic
)
1725 m
= gfc_intrinsic_sub_interface (c
, 1);
1729 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1730 "with an intrinsic", sym
->name
, &c
->loc
);
1738 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1740 c
->resolved_sym
= sym
;
1741 pure_subroutine (c
, sym
);
1748 resolve_specific_s (gfc_code
* c
)
1753 sym
= c
->symtree
->n
.sym
;
1757 m
= resolve_specific_s0 (c
, sym
);
1760 if (m
== MATCH_ERROR
)
1763 if (sym
->ns
->parent
== NULL
)
1766 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1772 sym
= c
->symtree
->n
.sym
;
1773 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1774 sym
->name
, &c
->loc
);
1780 /* Resolve a subroutine call not known to be generic nor specific. */
1783 resolve_unknown_s (gfc_code
* c
)
1787 sym
= c
->symtree
->n
.sym
;
1789 if (sym
->attr
.dummy
)
1791 sym
->attr
.proc
= PROC_DUMMY
;
1795 /* See if we have an intrinsic function reference. */
1797 if (gfc_intrinsic_name (sym
->name
, 1))
1799 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1804 /* The reference is to an external name. */
1807 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1809 c
->resolved_sym
= sym
;
1811 pure_subroutine (c
, sym
);
1817 /* Resolve a subroutine call. Although it was tempting to use the same code
1818 for functions, subroutines and functions are stored differently and this
1819 makes things awkward. */
1822 resolve_call (gfc_code
* c
)
1826 if (c
->symtree
&& c
->symtree
->n
.sym
1827 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
1829 gfc_error ("'%s' at %L has a type, which is not consistent with "
1830 "the CALL at %L", c
->symtree
->n
.sym
->name
,
1831 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
1835 /* If the procedure is not internal or module, it must be external and
1836 should be checked for usage. */
1837 if (c
->symtree
&& c
->symtree
->n
.sym
1838 && !c
->symtree
->n
.sym
->attr
.dummy
1839 && !c
->symtree
->n
.sym
->attr
.contained
1840 && !c
->symtree
->n
.sym
->attr
.use_assoc
)
1841 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
1843 /* Subroutines without the RECURSIVE attribution are not allowed to
1844 * call themselves. */
1845 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
1847 gfc_symbol
*csym
, *proc
;
1848 csym
= c
->symtree
->n
.sym
;
1849 proc
= gfc_current_ns
->proc_name
;
1852 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1853 "RECURSIVE", csym
->name
, &c
->loc
);
1857 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
1858 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1860 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1861 "'%s' is not declared as RECURSIVE",
1862 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
1867 /* Switch off assumed size checking and do this again for certain kinds
1868 of procedure, once the procedure itself is resolved. */
1869 need_full_assumed_size
++;
1871 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1874 /* Resume assumed_size checking. */
1875 need_full_assumed_size
--;
1879 if (c
->resolved_sym
== NULL
)
1880 switch (procedure_kind (c
->symtree
->n
.sym
))
1883 t
= resolve_generic_s (c
);
1886 case PTYPE_SPECIFIC
:
1887 t
= resolve_specific_s (c
);
1891 t
= resolve_unknown_s (c
);
1895 gfc_internal_error ("resolve_subroutine(): bad function type");
1898 /* Some checks of elemental subroutine actual arguments. */
1899 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
1903 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
1907 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1908 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1909 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1910 if their shapes do not match. If either op1->shape or op2->shape is
1911 NULL, return SUCCESS. */
1914 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1921 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1923 for (i
= 0; i
< op1
->rank
; i
++)
1925 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1927 gfc_error ("Shapes for operands at %L and %L are not conformable",
1928 &op1
->where
, &op2
->where
);
1938 /* Resolve an operator expression node. This can involve replacing the
1939 operation with a user defined function call. */
1942 resolve_operator (gfc_expr
* e
)
1944 gfc_expr
*op1
, *op2
;
1948 /* Resolve all subnodes-- give them types. */
1950 switch (e
->value
.op
.operator)
1953 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1956 /* Fall through... */
1959 case INTRINSIC_UPLUS
:
1960 case INTRINSIC_UMINUS
:
1961 case INTRINSIC_PARENTHESES
:
1962 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1967 /* Typecheck the new node. */
1969 op1
= e
->value
.op
.op1
;
1970 op2
= e
->value
.op
.op2
;
1972 switch (e
->value
.op
.operator)
1974 case INTRINSIC_UPLUS
:
1975 case INTRINSIC_UMINUS
:
1976 if (op1
->ts
.type
== BT_INTEGER
1977 || op1
->ts
.type
== BT_REAL
1978 || op1
->ts
.type
== BT_COMPLEX
)
1984 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
1985 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1988 case INTRINSIC_PLUS
:
1989 case INTRINSIC_MINUS
:
1990 case INTRINSIC_TIMES
:
1991 case INTRINSIC_DIVIDE
:
1992 case INTRINSIC_POWER
:
1993 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1995 gfc_type_convert_binary (e
);
2000 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2001 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2002 gfc_typename (&op2
->ts
));
2005 case INTRINSIC_CONCAT
:
2006 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2008 e
->ts
.type
= BT_CHARACTER
;
2009 e
->ts
.kind
= op1
->ts
.kind
;
2014 _("Operands of string concatenation operator at %%L are %s/%s"),
2015 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2021 case INTRINSIC_NEQV
:
2022 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2024 e
->ts
.type
= BT_LOGICAL
;
2025 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2026 if (op1
->ts
.kind
< e
->ts
.kind
)
2027 gfc_convert_type (op1
, &e
->ts
, 2);
2028 else if (op2
->ts
.kind
< e
->ts
.kind
)
2029 gfc_convert_type (op2
, &e
->ts
, 2);
2033 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2034 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2035 gfc_typename (&op2
->ts
));
2040 if (op1
->ts
.type
== BT_LOGICAL
)
2042 e
->ts
.type
= BT_LOGICAL
;
2043 e
->ts
.kind
= op1
->ts
.kind
;
2047 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
2048 gfc_typename (&op1
->ts
));
2055 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2057 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2061 /* Fall through... */
2065 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2067 e
->ts
.type
= BT_LOGICAL
;
2068 e
->ts
.kind
= gfc_default_logical_kind
;
2072 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2074 gfc_type_convert_binary (e
);
2076 e
->ts
.type
= BT_LOGICAL
;
2077 e
->ts
.kind
= gfc_default_logical_kind
;
2081 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2083 _("Logicals at %%L must be compared with %s instead of %s"),
2084 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
2085 gfc_op2string (e
->value
.op
.operator));
2088 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2089 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2090 gfc_typename (&op2
->ts
));
2094 case INTRINSIC_USER
:
2096 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2097 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2099 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2100 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2101 gfc_typename (&op2
->ts
));
2105 case INTRINSIC_PARENTHESES
:
2109 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2112 /* Deal with arrayness of an operand through an operator. */
2116 switch (e
->value
.op
.operator)
2118 case INTRINSIC_PLUS
:
2119 case INTRINSIC_MINUS
:
2120 case INTRINSIC_TIMES
:
2121 case INTRINSIC_DIVIDE
:
2122 case INTRINSIC_POWER
:
2123 case INTRINSIC_CONCAT
:
2127 case INTRINSIC_NEQV
:
2135 if (op1
->rank
== 0 && op2
->rank
== 0)
2138 if (op1
->rank
== 0 && op2
->rank
!= 0)
2140 e
->rank
= op2
->rank
;
2142 if (e
->shape
== NULL
)
2143 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2146 if (op1
->rank
!= 0 && op2
->rank
== 0)
2148 e
->rank
= op1
->rank
;
2150 if (e
->shape
== NULL
)
2151 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2154 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2156 if (op1
->rank
== op2
->rank
)
2158 e
->rank
= op1
->rank
;
2159 if (e
->shape
== NULL
)
2161 t
= compare_shapes(op1
, op2
);
2165 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2170 gfc_error ("Inconsistent ranks for operator at %L and %L",
2171 &op1
->where
, &op2
->where
);
2174 /* Allow higher level expressions to work. */
2182 case INTRINSIC_UPLUS
:
2183 case INTRINSIC_UMINUS
:
2184 case INTRINSIC_PARENTHESES
:
2185 e
->rank
= op1
->rank
;
2187 if (e
->shape
== NULL
)
2188 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2190 /* Simply copy arrayness attribute */
2197 /* Attempt to simplify the expression. */
2200 t
= gfc_simplify_expr (e
, 0);
2201 /* Some calls do not succeed in simplification and return FAILURE
2202 even though there is no error; eg. variable references to
2203 PARAMETER arrays. */
2204 if (!gfc_is_constant_expr (e
))
2211 if (gfc_extend_expr (e
) == SUCCESS
)
2214 gfc_error (msg
, &e
->where
);
2220 /************** Array resolution subroutines **************/
2224 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
2227 /* Compare two integer expressions. */
2230 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
2234 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
2235 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
2238 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
2239 gfc_internal_error ("compare_bound(): Bad expression");
2241 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
2251 /* Compare an integer expression with an integer. */
2254 compare_bound_int (gfc_expr
* a
, int b
)
2258 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2261 if (a
->ts
.type
!= BT_INTEGER
)
2262 gfc_internal_error ("compare_bound_int(): Bad expression");
2264 i
= mpz_cmp_si (a
->value
.integer
, b
);
2274 /* Compare an integer expression with a mpz_t. */
2277 compare_bound_mpz_t (gfc_expr
* a
, mpz_t b
)
2281 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2284 if (a
->ts
.type
!= BT_INTEGER
)
2285 gfc_internal_error ("compare_bound_int(): Bad expression");
2287 i
= mpz_cmp (a
->value
.integer
, b
);
2297 /* Compute the last value of a sequence given by a triplet.
2298 Return 0 if it wasn't able to compute the last value, or if the
2299 sequence if empty, and 1 otherwise. */
2302 compute_last_value_for_triplet (gfc_expr
* start
, gfc_expr
* end
,
2303 gfc_expr
* stride
, mpz_t last
)
2307 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
2308 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2309 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
2312 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
2313 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
2316 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
2318 if (compare_bound (start
, end
) == CMP_GT
)
2320 mpz_set (last
, end
->value
.integer
);
2324 if (compare_bound_int (stride
, 0) == CMP_GT
)
2326 /* Stride is positive */
2327 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
2332 /* Stride is negative */
2333 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
2338 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
2339 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
2340 mpz_sub (last
, end
->value
.integer
, rem
);
2347 /* Compare a single dimension of an array reference to the array
2351 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
2355 /* Given start, end and stride values, calculate the minimum and
2356 maximum referenced indexes. */
2364 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2366 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2372 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
2374 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
2378 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2379 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2381 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
2382 && (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
2383 || compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
))
2386 if (((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
2387 || ar
->stride
[i
] == NULL
)
2388 && compare_bound (AR_START
, AR_END
) != CMP_GT
)
2389 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
2390 && compare_bound (AR_START
, AR_END
) != CMP_LT
))
2392 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
2394 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
2398 mpz_init (last_value
);
2399 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
2402 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
2403 || compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
2405 mpz_clear (last_value
);
2409 mpz_clear (last_value
);
2417 gfc_internal_error ("check_dimension(): Bad array reference");
2423 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
2428 /* Compare an array reference with an array specification. */
2431 compare_spec_to_ref (gfc_array_ref
* ar
)
2438 /* TODO: Full array sections are only allowed as actual parameters. */
2439 if (as
->type
== AS_ASSUMED_SIZE
2440 && (/*ar->type == AR_FULL
2441 ||*/ (ar
->type
== AR_SECTION
2442 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
2444 gfc_error ("Rightmost upper bound of assumed size array section"
2445 " not specified at %L", &ar
->where
);
2449 if (ar
->type
== AR_FULL
)
2452 if (as
->rank
!= ar
->dimen
)
2454 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2455 &ar
->where
, ar
->dimen
, as
->rank
);
2459 for (i
= 0; i
< as
->rank
; i
++)
2460 if (check_dimension (i
, ar
, as
) == FAILURE
)
2467 /* Resolve one part of an array index. */
2470 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
2477 if (gfc_resolve_expr (index
) == FAILURE
)
2480 if (check_scalar
&& index
->rank
!= 0)
2482 gfc_error ("Array index at %L must be scalar", &index
->where
);
2486 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
2488 gfc_error ("Array index at %L must be of INTEGER type",
2493 if (index
->ts
.type
== BT_REAL
)
2494 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
2495 &index
->where
) == FAILURE
)
2498 if (index
->ts
.kind
!= gfc_index_integer_kind
2499 || index
->ts
.type
!= BT_INTEGER
)
2502 ts
.type
= BT_INTEGER
;
2503 ts
.kind
= gfc_index_integer_kind
;
2505 gfc_convert_type_warn (index
, &ts
, 2, 0);
2511 /* Resolve a dim argument to an intrinsic function. */
2514 gfc_resolve_dim_arg (gfc_expr
*dim
)
2519 if (gfc_resolve_expr (dim
) == FAILURE
)
2524 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
2528 if (dim
->ts
.type
!= BT_INTEGER
)
2530 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
2533 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
2537 ts
.type
= BT_INTEGER
;
2538 ts
.kind
= gfc_index_integer_kind
;
2540 gfc_convert_type_warn (dim
, &ts
, 2, 0);
2546 /* Given an expression that contains array references, update those array
2547 references to point to the right array specifications. While this is
2548 filled in during matching, this information is difficult to save and load
2549 in a module, so we take care of it here.
2551 The idea here is that the original array reference comes from the
2552 base symbol. We traverse the list of reference structures, setting
2553 the stored reference to references. Component references can
2554 provide an additional array specification. */
2557 find_array_spec (gfc_expr
* e
)
2561 gfc_symbol
*derived
;
2564 as
= e
->symtree
->n
.sym
->as
;
2567 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2572 gfc_internal_error ("find_array_spec(): Missing spec");
2579 if (derived
== NULL
)
2580 derived
= e
->symtree
->n
.sym
->ts
.derived
;
2582 c
= derived
->components
;
2584 for (; c
; c
= c
->next
)
2585 if (c
== ref
->u
.c
.component
)
2587 /* Track the sequence of component references. */
2588 if (c
->ts
.type
== BT_DERIVED
)
2589 derived
= c
->ts
.derived
;
2594 gfc_internal_error ("find_array_spec(): Component not found");
2599 gfc_internal_error ("find_array_spec(): unused as(1)");
2610 gfc_internal_error ("find_array_spec(): unused as(2)");
2614 /* Resolve an array reference. */
2617 resolve_array_ref (gfc_array_ref
* ar
)
2619 int i
, check_scalar
;
2622 for (i
= 0; i
< ar
->dimen
; i
++)
2624 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2626 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2628 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2630 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2635 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2639 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2643 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2644 if (e
->expr_type
== EXPR_VARIABLE
2645 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
2646 ar
->start
[i
] = gfc_get_parentheses (e
);
2650 gfc_error ("Array index at %L is an array of rank %d",
2651 &ar
->c_where
[i
], e
->rank
);
2656 /* If the reference type is unknown, figure out what kind it is. */
2658 if (ar
->type
== AR_UNKNOWN
)
2660 ar
->type
= AR_ELEMENT
;
2661 for (i
= 0; i
< ar
->dimen
; i
++)
2662 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2663 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2665 ar
->type
= AR_SECTION
;
2670 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2678 resolve_substring (gfc_ref
* ref
)
2681 if (ref
->u
.ss
.start
!= NULL
)
2683 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2686 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2688 gfc_error ("Substring start index at %L must be of type INTEGER",
2689 &ref
->u
.ss
.start
->where
);
2693 if (ref
->u
.ss
.start
->rank
!= 0)
2695 gfc_error ("Substring start index at %L must be scalar",
2696 &ref
->u
.ss
.start
->where
);
2700 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
2701 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2702 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2704 gfc_error ("Substring start index at %L is less than one",
2705 &ref
->u
.ss
.start
->where
);
2710 if (ref
->u
.ss
.end
!= NULL
)
2712 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2715 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2717 gfc_error ("Substring end index at %L must be of type INTEGER",
2718 &ref
->u
.ss
.end
->where
);
2722 if (ref
->u
.ss
.end
->rank
!= 0)
2724 gfc_error ("Substring end index at %L must be scalar",
2725 &ref
->u
.ss
.end
->where
);
2729 if (ref
->u
.ss
.length
!= NULL
2730 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
2731 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2732 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2734 gfc_error ("Substring end index at %L exceeds the string length",
2735 &ref
->u
.ss
.start
->where
);
2744 /* Resolve subtype references. */
2747 resolve_ref (gfc_expr
* expr
)
2749 int current_part_dimension
, n_components
, seen_part_dimension
;
2752 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2753 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2755 find_array_spec (expr
);
2759 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2763 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2771 resolve_substring (ref
);
2775 /* Check constraints on part references. */
2777 current_part_dimension
= 0;
2778 seen_part_dimension
= 0;
2781 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2786 switch (ref
->u
.ar
.type
)
2790 current_part_dimension
= 1;
2794 current_part_dimension
= 0;
2798 gfc_internal_error ("resolve_ref(): Bad array reference");
2804 if (current_part_dimension
|| seen_part_dimension
)
2806 if (ref
->u
.c
.component
->pointer
)
2809 ("Component to the right of a part reference with nonzero "
2810 "rank must not have the POINTER attribute at %L",
2814 else if (ref
->u
.c
.component
->allocatable
)
2817 ("Component to the right of a part reference with nonzero "
2818 "rank must not have the ALLOCATABLE attribute at %L",
2831 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2832 || ref
->next
== NULL
)
2833 && current_part_dimension
2834 && seen_part_dimension
)
2837 gfc_error ("Two or more part references with nonzero rank must "
2838 "not be specified at %L", &expr
->where
);
2842 if (ref
->type
== REF_COMPONENT
)
2844 if (current_part_dimension
)
2845 seen_part_dimension
= 1;
2847 /* reset to make sure */
2848 current_part_dimension
= 0;
2856 /* Given an expression, determine its shape. This is easier than it sounds.
2857 Leaves the shape array NULL if it is not possible to determine the shape. */
2860 expression_shape (gfc_expr
* e
)
2862 mpz_t array
[GFC_MAX_DIMENSIONS
];
2865 if (e
->rank
== 0 || e
->shape
!= NULL
)
2868 for (i
= 0; i
< e
->rank
; i
++)
2869 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2872 e
->shape
= gfc_get_shape (e
->rank
);
2874 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2879 for (i
--; i
>= 0; i
--)
2880 mpz_clear (array
[i
]);
2884 /* Given a variable expression node, compute the rank of the expression by
2885 examining the base symbol and any reference structures it may have. */
2888 expression_rank (gfc_expr
* e
)
2895 if (e
->expr_type
== EXPR_ARRAY
)
2897 /* Constructors can have a rank different from one via RESHAPE(). */
2899 if (e
->symtree
== NULL
)
2905 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2906 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2912 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2914 if (ref
->type
!= REF_ARRAY
)
2917 if (ref
->u
.ar
.type
== AR_FULL
)
2919 rank
= ref
->u
.ar
.as
->rank
;
2923 if (ref
->u
.ar
.type
== AR_SECTION
)
2925 /* Figure out the rank of the section. */
2927 gfc_internal_error ("expression_rank(): Two array specs");
2929 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2930 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2931 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2941 expression_shape (e
);
2945 /* Resolve a variable expression. */
2948 resolve_variable (gfc_expr
* e
)
2955 if (e
->symtree
== NULL
)
2958 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2961 sym
= e
->symtree
->n
.sym
;
2962 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2964 e
->ts
.type
= BT_PROCEDURE
;
2968 if (sym
->ts
.type
!= BT_UNKNOWN
)
2969 gfc_variable_attr (e
, &e
->ts
);
2972 /* Must be a simple variable reference. */
2973 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
2978 if (check_assumed_size_reference (sym
, e
))
2981 /* Deal with forward references to entries during resolve_code, to
2982 satisfy, at least partially, 12.5.2.5. */
2983 if (gfc_current_ns
->entries
2984 && current_entry_id
== sym
->entry_id
2987 && cs_base
->current
->op
!= EXEC_ENTRY
)
2989 gfc_entry_list
*entry
;
2990 gfc_formal_arglist
*formal
;
2994 /* If the symbol is a dummy... */
2995 if (sym
->attr
.dummy
)
2997 entry
= gfc_current_ns
->entries
;
3000 /* ...test if the symbol is a parameter of previous entries. */
3001 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
3002 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
3004 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
3008 /* If it has not been seen as a dummy, this is an error. */
3011 if (specification_expr
)
3012 gfc_error ("Variable '%s',used in a specification expression, "
3013 "is referenced at %L before the ENTRY statement "
3014 "in which it is a parameter",
3015 sym
->name
, &cs_base
->current
->loc
);
3017 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3018 "statement in which it is a parameter",
3019 sym
->name
, &cs_base
->current
->loc
);
3024 /* Now do the same check on the specification expressions. */
3025 specification_expr
= 1;
3026 if (sym
->ts
.type
== BT_CHARACTER
3027 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3031 for (n
= 0; n
< sym
->as
->rank
; n
++)
3033 specification_expr
= 1;
3034 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3036 specification_expr
= 1;
3037 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3040 specification_expr
= 0;
3043 /* Update the symbol's entry level. */
3044 sym
->entry_id
= current_entry_id
+ 1;
3051 /* Resolve an expression. That is, make sure that types of operands agree
3052 with their operators, intrinsic operators are converted to function calls
3053 for overloaded types and unresolved function references are resolved. */
3056 gfc_resolve_expr (gfc_expr
* e
)
3063 switch (e
->expr_type
)
3066 t
= resolve_operator (e
);
3070 t
= resolve_function (e
);
3074 t
= resolve_variable (e
);
3076 expression_rank (e
);
3079 case EXPR_SUBSTRING
:
3080 t
= resolve_ref (e
);
3090 if (resolve_ref (e
) == FAILURE
)
3093 t
= gfc_resolve_array_constructor (e
);
3094 /* Also try to expand a constructor. */
3097 expression_rank (e
);
3098 gfc_expand_constructor (e
);
3101 /* This provides the opportunity for the length of constructors with character
3102 valued function elements to propogate the string length to the expression. */
3103 if (e
->ts
.type
== BT_CHARACTER
)
3104 gfc_resolve_character_array_constructor (e
);
3108 case EXPR_STRUCTURE
:
3109 t
= resolve_ref (e
);
3113 t
= resolve_structure_cons (e
);
3117 t
= gfc_simplify_expr (e
, 0);
3121 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3128 /* Resolve an expression from an iterator. They must be scalar and have
3129 INTEGER or (optionally) REAL type. */
3132 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
,
3133 const char * name_msgid
)
3135 if (gfc_resolve_expr (expr
) == FAILURE
)
3138 if (expr
->rank
!= 0)
3140 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
3144 if (!(expr
->ts
.type
== BT_INTEGER
3145 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
3148 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
3151 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
3158 /* Resolve the expressions in an iterator structure. If REAL_OK is
3159 false allow only INTEGER type iterators, otherwise allow REAL types. */
3162 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
3165 if (iter
->var
->ts
.type
== BT_REAL
)
3166 gfc_notify_std (GFC_STD_F95_DEL
,
3167 "Obsolete: REAL DO loop iterator at %L",
3170 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
3174 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
3176 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3181 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
3182 "Start expression in DO loop") == FAILURE
)
3185 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
3186 "End expression in DO loop") == FAILURE
)
3189 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
3190 "Step expression in DO loop") == FAILURE
)
3193 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
3195 if ((iter
->step
->ts
.type
== BT_INTEGER
3196 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
3197 || (iter
->step
->ts
.type
== BT_REAL
3198 && mpfr_sgn (iter
->step
->value
.real
) == 0))
3200 gfc_error ("Step expression in DO loop at %L cannot be zero",
3201 &iter
->step
->where
);
3206 /* Convert start, end, and step to the same type as var. */
3207 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
3208 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
3209 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3211 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
3212 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
3213 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3215 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
3216 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
3217 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
3223 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3224 to be a scalar INTEGER variable. The subscripts and stride are scalar
3225 INTEGERs, and if stride is a constant it must be nonzero. */
3228 resolve_forall_iterators (gfc_forall_iterator
* iter
)
3233 if (gfc_resolve_expr (iter
->var
) == SUCCESS
3234 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
3235 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3238 if (gfc_resolve_expr (iter
->start
) == SUCCESS
3239 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
3240 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3241 &iter
->start
->where
);
3242 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
3243 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3245 if (gfc_resolve_expr (iter
->end
) == SUCCESS
3246 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
3247 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3249 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
3250 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3252 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
3254 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
3255 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3256 &iter
->stride
->where
, "INTEGER");
3258 if (iter
->stride
->expr_type
== EXPR_CONSTANT
3259 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
3260 gfc_error ("FORALL stride expression at %L cannot be zero",
3261 &iter
->stride
->where
);
3263 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
3264 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
3271 /* Given a pointer to a symbol that is a derived type, see if any components
3272 have the POINTER attribute. The search is recursive if necessary.
3273 Returns zero if no pointer components are found, nonzero otherwise. */
3276 derived_pointer (gfc_symbol
* sym
)
3280 for (c
= sym
->components
; c
; c
= c
->next
)
3285 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
3293 /* Given a pointer to a symbol that is a derived type, see if it's
3294 inaccessible, i.e. if it's defined in another module and the components are
3295 PRIVATE. The search is recursive if necessary. Returns zero if no
3296 inaccessible components are found, nonzero otherwise. */
3299 derived_inaccessible (gfc_symbol
*sym
)
3303 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
3306 for (c
= sym
->components
; c
; c
= c
->next
)
3308 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
3316 /* Resolve the argument of a deallocate expression. The expression must be
3317 a pointer or a full array. */
3320 resolve_deallocate_expr (gfc_expr
* e
)
3322 symbol_attribute attr
;
3326 if (gfc_resolve_expr (e
) == FAILURE
)
3329 attr
= gfc_expr_attr (e
);
3333 if (e
->expr_type
!= EXPR_VARIABLE
)
3336 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3337 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3341 if (ref
->u
.ar
.type
!= AR_FULL
)
3346 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3347 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3355 if (allocatable
== 0)
3358 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3359 "ALLOCATABLE or a POINTER", &e
->where
);
3362 if (e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3364 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3365 e
->symtree
->n
.sym
->name
, &e
->where
);
3372 /* Returns true if the expression e contains a reference the symbol sym. */
3374 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
3376 gfc_actual_arglist
*arg
;
3384 switch (e
->expr_type
)
3387 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3388 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
3391 /* If the variable is not the same as the dependent, 'sym', and
3392 it is not marked as being declared and it is in the same
3393 namespace as 'sym', add it to the local declarations. */
3395 if (sym
== e
->symtree
->n
.sym
)
3400 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
3401 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
3410 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3415 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3417 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
3418 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
3419 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
3424 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
3425 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
3429 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3430 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3432 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->ts
.cl
->length
);
3434 if (ref
->u
.c
.component
->as
)
3435 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3437 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->as
->lower
[i
]);
3438 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->as
->upper
[i
]);
3448 /* Given the expression node e for an allocatable/pointer of derived type to be
3449 allocated, get the expression node to be initialized afterwards (needed for
3450 derived types with default initializers, and derived types with allocatable
3451 components that need nullification.) */
3454 expr_to_initialize (gfc_expr
* e
)
3460 result
= gfc_copy_expr (e
);
3462 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3463 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
3464 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3466 ref
->u
.ar
.type
= AR_FULL
;
3468 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3469 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
3471 result
->rank
= ref
->u
.ar
.dimen
;
3479 /* Resolve the expression in an ALLOCATE statement, doing the additional
3480 checks to see whether the expression is OK or not. The expression must
3481 have a trailing array reference that gives the size of the array. */
3484 resolve_allocate_expr (gfc_expr
* e
, gfc_code
* code
)
3486 int i
, pointer
, allocatable
, dimension
;
3487 symbol_attribute attr
;
3488 gfc_ref
*ref
, *ref2
;
3495 if (gfc_resolve_expr (e
) == FAILURE
)
3498 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
3499 sym
= code
->expr
->symtree
->n
.sym
;
3503 /* Make sure the expression is allocatable or a pointer. If it is
3504 pointer, the next-to-last reference must be a pointer. */
3508 if (e
->expr_type
!= EXPR_VARIABLE
)
3512 attr
= gfc_expr_attr (e
);
3513 pointer
= attr
.pointer
;
3514 dimension
= attr
.dimension
;
3519 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3520 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3521 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
3523 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
3525 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3526 "not be allocated in the same statement at %L",
3527 sym
->name
, &e
->where
);
3531 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
3535 if (ref
->next
!= NULL
)
3540 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3541 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3543 pointer
= ref
->u
.c
.component
->pointer
;
3544 dimension
= ref
->u
.c
.component
->dimension
;
3554 if (allocatable
== 0 && pointer
== 0)
3556 gfc_error ("Expression in ALLOCATE statement at %L must be "
3557 "ALLOCATABLE or a POINTER", &e
->where
);
3561 if (e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3563 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3564 e
->symtree
->n
.sym
->name
, &e
->where
);
3568 /* Add default initializer for those derived types that need them. */
3569 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
3571 init_st
= gfc_get_code ();
3572 init_st
->loc
= code
->loc
;
3573 init_st
->op
= EXEC_INIT_ASSIGN
;
3574 init_st
->expr
= expr_to_initialize (e
);
3575 init_st
->expr2
= init_e
;
3576 init_st
->next
= code
->next
;
3577 code
->next
= init_st
;
3580 if (pointer
&& dimension
== 0)
3583 /* Make sure the next-to-last reference node is an array specification. */
3585 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
3587 gfc_error ("Array specification required in ALLOCATE statement "
3588 "at %L", &e
->where
);
3592 /* Make sure that the array section reference makes sense in the
3593 context of an ALLOCATE specification. */
3597 for (i
= 0; i
< ar
->dimen
; i
++)
3599 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
3602 switch (ar
->dimen_type
[i
])
3608 if (ar
->start
[i
] != NULL
3609 && ar
->end
[i
] != NULL
3610 && ar
->stride
[i
] == NULL
)
3613 /* Fall Through... */
3617 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3624 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3626 sym
= a
->expr
->symtree
->n
.sym
;
3628 /* TODO - check derived type components. */
3629 if (sym
->ts
.type
== BT_DERIVED
)
3632 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
3633 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
3635 gfc_error ("'%s' must not appear an the array specification at "
3636 "%L in the same ALLOCATE statement where it is "
3637 "itself allocated", sym
->name
, &ar
->where
);
3647 /************ SELECT CASE resolution subroutines ************/
3649 /* Callback function for our mergesort variant. Determines interval
3650 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3651 op1 > op2. Assumes we're not dealing with the default case.
3652 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3653 There are nine situations to check. */
3656 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
3660 if (op1
->low
== NULL
) /* op1 = (:L) */
3662 /* op2 = (:N), so overlap. */
3664 /* op2 = (M:) or (M:N), L < M */
3665 if (op2
->low
!= NULL
3666 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3669 else if (op1
->high
== NULL
) /* op1 = (K:) */
3671 /* op2 = (M:), so overlap. */
3673 /* op2 = (:N) or (M:N), K > N */
3674 if (op2
->high
!= NULL
3675 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3678 else /* op1 = (K:L) */
3680 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
3681 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
3682 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
3683 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
3684 else /* op2 = (M:N) */
3688 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3691 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3700 /* Merge-sort a double linked case list, detecting overlap in the
3701 process. LIST is the head of the double linked case list before it
3702 is sorted. Returns the head of the sorted list if we don't see any
3703 overlap, or NULL otherwise. */
3706 check_case_overlap (gfc_case
* list
)
3708 gfc_case
*p
, *q
, *e
, *tail
;
3709 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
3711 /* If the passed list was empty, return immediately. */
3718 /* Loop unconditionally. The only exit from this loop is a return
3719 statement, when we've finished sorting the case list. */
3726 /* Count the number of merges we do in this pass. */
3729 /* Loop while there exists a merge to be done. */
3734 /* Count this merge. */
3737 /* Cut the list in two pieces by stepping INSIZE places
3738 forward in the list, starting from P. */
3741 for (i
= 0; i
< insize
; i
++)
3750 /* Now we have two lists. Merge them! */
3751 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
3754 /* See from which the next case to merge comes from. */
3757 /* P is empty so the next case must come from Q. */
3762 else if (qsize
== 0 || q
== NULL
)
3771 cmp
= compare_cases (p
, q
);
3774 /* The whole case range for P is less than the
3782 /* The whole case range for Q is greater than
3783 the case range for P. */
3790 /* The cases overlap, or they are the same
3791 element in the list. Either way, we must
3792 issue an error and get the next case from P. */
3793 /* FIXME: Sort P and Q by line number. */
3794 gfc_error ("CASE label at %L overlaps with CASE "
3795 "label at %L", &p
->where
, &q
->where
);
3803 /* Add the next element to the merged list. */
3812 /* P has now stepped INSIZE places along, and so has Q. So
3813 they're the same. */
3818 /* If we have done only one merge or none at all, we've
3819 finished sorting the cases. */
3828 /* Otherwise repeat, merging lists twice the size. */
3834 /* Check to see if an expression is suitable for use in a CASE statement.
3835 Makes sure that all case expressions are scalar constants of the same
3836 type. Return FAILURE if anything is wrong. */
3839 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
3841 if (e
== NULL
) return SUCCESS
;
3843 if (e
->ts
.type
!= case_expr
->ts
.type
)
3845 gfc_error ("Expression in CASE statement at %L must be of type %s",
3846 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
3850 /* C805 (R808) For a given case-construct, each case-value shall be of
3851 the same type as case-expr. For character type, length differences
3852 are allowed, but the kind type parameters shall be the same. */
3854 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
3856 gfc_error("Expression in CASE statement at %L must be kind %d",
3857 &e
->where
, case_expr
->ts
.kind
);
3861 /* Convert the case value kind to that of case expression kind, if needed.
3862 FIXME: Should a warning be issued? */
3863 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
3864 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
3868 gfc_error ("Expression in CASE statement at %L must be scalar",
3877 /* Given a completely parsed select statement, we:
3879 - Validate all expressions and code within the SELECT.
3880 - Make sure that the selection expression is not of the wrong type.
3881 - Make sure that no case ranges overlap.
3882 - Eliminate unreachable cases and unreachable code resulting from
3883 removing case labels.
3885 The standard does allow unreachable cases, e.g. CASE (5:3). But
3886 they are a hassle for code generation, and to prevent that, we just
3887 cut them out here. This is not necessary for overlapping cases
3888 because they are illegal and we never even try to generate code.
3890 We have the additional caveat that a SELECT construct could have
3891 been a computed GOTO in the source code. Fortunately we can fairly
3892 easily work around that here: The case_expr for a "real" SELECT CASE
3893 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3894 we have to do is make sure that the case_expr is a scalar integer
3898 resolve_select (gfc_code
* code
)
3901 gfc_expr
*case_expr
;
3902 gfc_case
*cp
, *default_case
, *tail
, *head
;
3903 int seen_unreachable
;
3909 if (code
->expr
== NULL
)
3911 /* This was actually a computed GOTO statement. */
3912 case_expr
= code
->expr2
;
3913 if (case_expr
->ts
.type
!= BT_INTEGER
3914 || case_expr
->rank
!= 0)
3915 gfc_error ("Selection expression in computed GOTO statement "
3916 "at %L must be a scalar integer expression",
3919 /* Further checking is not necessary because this SELECT was built
3920 by the compiler, so it should always be OK. Just move the
3921 case_expr from expr2 to expr so that we can handle computed
3922 GOTOs as normal SELECTs from here on. */
3923 code
->expr
= code
->expr2
;
3928 case_expr
= code
->expr
;
3930 type
= case_expr
->ts
.type
;
3931 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
3933 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3934 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
3936 /* Punt. Going on here just produce more garbage error messages. */
3940 if (case_expr
->rank
!= 0)
3942 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3943 "expression", &case_expr
->where
);
3949 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3950 of the SELECT CASE expression and its CASE values. Walk the lists
3951 of case values, and if we find a mismatch, promote case_expr to
3952 the appropriate kind. */
3954 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
3956 for (body
= code
->block
; body
; body
= body
->block
)
3958 /* Walk the case label list. */
3959 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3961 /* Intercept the DEFAULT case. It does not have a kind. */
3962 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3965 /* Unreachable case ranges are discarded, so ignore. */
3966 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3967 && cp
->low
!= cp
->high
3968 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3971 /* FIXME: Should a warning be issued? */
3973 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
3974 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
3976 if (cp
->high
!= NULL
3977 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
3978 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
3983 /* Assume there is no DEFAULT case. */
3984 default_case
= NULL
;
3989 for (body
= code
->block
; body
; body
= body
->block
)
3991 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3993 seen_unreachable
= 0;
3995 /* Walk the case label list, making sure that all case labels
3997 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3999 /* Count the number of cases in the whole construct. */
4002 /* Intercept the DEFAULT case. */
4003 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4005 if (default_case
!= NULL
)
4007 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4008 "by a second DEFAULT CASE at %L",
4009 &default_case
->where
, &cp
->where
);
4020 /* Deal with single value cases and case ranges. Errors are
4021 issued from the validation function. */
4022 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
4023 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
4029 if (type
== BT_LOGICAL
4030 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
4031 || cp
->low
!= cp
->high
))
4034 ("Logical range in CASE statement at %L is not allowed",
4040 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
4043 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
4044 if (value
& seen_logical
)
4046 gfc_error ("constant logical value in CASE statement "
4047 "is repeated at %L",
4052 seen_logical
|= value
;
4055 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4056 && cp
->low
!= cp
->high
4057 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4059 if (gfc_option
.warn_surprising
)
4060 gfc_warning ("Range specification at %L can never "
4061 "be matched", &cp
->where
);
4063 cp
->unreachable
= 1;
4064 seen_unreachable
= 1;
4068 /* If the case range can be matched, it can also overlap with
4069 other cases. To make sure it does not, we put it in a
4070 double linked list here. We sort that with a merge sort
4071 later on to detect any overlapping cases. */
4075 head
->right
= head
->left
= NULL
;
4080 tail
->right
->left
= tail
;
4087 /* It there was a failure in the previous case label, give up
4088 for this case label list. Continue with the next block. */
4092 /* See if any case labels that are unreachable have been seen.
4093 If so, we eliminate them. This is a bit of a kludge because
4094 the case lists for a single case statement (label) is a
4095 single forward linked lists. */
4096 if (seen_unreachable
)
4098 /* Advance until the first case in the list is reachable. */
4099 while (body
->ext
.case_list
!= NULL
4100 && body
->ext
.case_list
->unreachable
)
4102 gfc_case
*n
= body
->ext
.case_list
;
4103 body
->ext
.case_list
= body
->ext
.case_list
->next
;
4105 gfc_free_case_list (n
);
4108 /* Strip all other unreachable cases. */
4109 if (body
->ext
.case_list
)
4111 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
4113 if (cp
->next
->unreachable
)
4115 gfc_case
*n
= cp
->next
;
4116 cp
->next
= cp
->next
->next
;
4118 gfc_free_case_list (n
);
4125 /* See if there were overlapping cases. If the check returns NULL,
4126 there was overlap. In that case we don't do anything. If head
4127 is non-NULL, we prepend the DEFAULT case. The sorted list can
4128 then used during code generation for SELECT CASE constructs with
4129 a case expression of a CHARACTER type. */
4132 head
= check_case_overlap (head
);
4134 /* Prepend the default_case if it is there. */
4135 if (head
!= NULL
&& default_case
)
4137 default_case
->left
= NULL
;
4138 default_case
->right
= head
;
4139 head
->left
= default_case
;
4143 /* Eliminate dead blocks that may be the result if we've seen
4144 unreachable case labels for a block. */
4145 for (body
= code
; body
&& body
->block
; body
= body
->block
)
4147 if (body
->block
->ext
.case_list
== NULL
)
4149 /* Cut the unreachable block from the code chain. */
4150 gfc_code
*c
= body
->block
;
4151 body
->block
= c
->block
;
4153 /* Kill the dead block, but not the blocks below it. */
4155 gfc_free_statements (c
);
4159 /* More than two cases is legal but insane for logical selects.
4160 Issue a warning for it. */
4161 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
4163 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4168 /* Resolve a transfer statement. This is making sure that:
4169 -- a derived type being transferred has only non-pointer components
4170 -- a derived type being transferred doesn't have private components, unless
4171 it's being transferred from the module where the type was defined
4172 -- we're not trying to transfer a whole assumed size array. */
4175 resolve_transfer (gfc_code
* code
)
4184 if (exp
->expr_type
!= EXPR_VARIABLE
4185 && exp
->expr_type
!= EXPR_FUNCTION
)
4188 sym
= exp
->symtree
->n
.sym
;
4191 /* Go to actual component transferred. */
4192 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
4193 if (ref
->type
== REF_COMPONENT
)
4194 ts
= &ref
->u
.c
.component
->ts
;
4196 if (ts
->type
== BT_DERIVED
)
4198 /* Check that transferred derived type doesn't contain POINTER
4200 if (derived_pointer (ts
->derived
))
4202 gfc_error ("Data transfer element at %L cannot have "
4203 "POINTER components", &code
->loc
);
4207 if (ts
->derived
->attr
.alloc_comp
)
4209 gfc_error ("Data transfer element at %L cannot have "
4210 "ALLOCATABLE components", &code
->loc
);
4214 if (derived_inaccessible (ts
->derived
))
4216 gfc_error ("Data transfer element at %L cannot have "
4217 "PRIVATE components",&code
->loc
);
4222 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
4223 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
4225 gfc_error ("Data transfer element at %L cannot be a full reference to "
4226 "an assumed-size array", &code
->loc
);
4232 /*********** Toplevel code resolution subroutines ***********/
4234 /* Given a branch to a label and a namespace, if the branch is conforming.
4235 The code node described where the branch is located. */
4238 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
4240 gfc_code
*block
, *found
;
4248 /* Step one: is this a valid branching target? */
4250 if (lp
->defined
== ST_LABEL_UNKNOWN
)
4252 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
4257 if (lp
->defined
!= ST_LABEL_TARGET
)
4259 gfc_error ("Statement at %L is not a valid branch target statement "
4260 "for the branch statement at %L", &lp
->where
, &code
->loc
);
4264 /* Step two: make sure this branch is not a branch to itself ;-) */
4266 if (code
->here
== label
)
4268 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
4272 /* Step three: Try to find the label in the parse tree. To do this,
4273 we traverse the tree block-by-block: first the block that
4274 contains this GOTO, then the block that it is nested in, etc. We
4275 can ignore other blocks because branching into another block is
4280 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4282 for (block
= stack
->head
; block
; block
= block
->next
)
4284 if (block
->here
== label
)
4297 /* The label is not in an enclosing block, so illegal. This was
4298 allowed in Fortran 66, so we allow it as extension. We also
4299 forego further checks if we run into this. */
4300 gfc_notify_std (GFC_STD_LEGACY
,
4301 "Label at %L is not in the same block as the "
4302 "GOTO statement at %L", &lp
->where
, &code
->loc
);
4306 /* Step four: Make sure that the branching target is legal if
4307 the statement is an END {SELECT,DO,IF}. */
4309 if (found
->op
== EXEC_NOP
)
4311 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4312 if (stack
->current
->next
== found
)
4316 gfc_notify_std (GFC_STD_F95_DEL
,
4317 "Obsolete: GOTO at %L jumps to END of construct at %L",
4318 &code
->loc
, &found
->loc
);
4323 /* Check whether EXPR1 has the same shape as EXPR2. */
4326 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
4328 mpz_t shape
[GFC_MAX_DIMENSIONS
];
4329 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
4330 try result
= FAILURE
;
4333 /* Compare the rank. */
4334 if (expr1
->rank
!= expr2
->rank
)
4337 /* Compare the size of each dimension. */
4338 for (i
=0; i
<expr1
->rank
; i
++)
4340 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
4343 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
4346 if (mpz_cmp (shape
[i
], shape2
[i
]))
4350 /* When either of the two expression is an assumed size array, we
4351 ignore the comparison of dimension sizes. */
4356 for (i
--; i
>=0; i
--)
4358 mpz_clear (shape
[i
]);
4359 mpz_clear (shape2
[i
]);
4365 /* Check whether a WHERE assignment target or a WHERE mask expression
4366 has the same shape as the outmost WHERE mask expression. */
4369 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
4375 cblock
= code
->block
;
4377 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4378 In case of nested WHERE, only the outmost one is stored. */
4379 if (mask
== NULL
) /* outmost WHERE */
4381 else /* inner WHERE */
4388 /* Check if the mask-expr has a consistent shape with the
4389 outmost WHERE mask-expr. */
4390 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
4391 gfc_error ("WHERE mask at %L has inconsistent shape",
4392 &cblock
->expr
->where
);
4395 /* the assignment statement of a WHERE statement, or the first
4396 statement in where-body-construct of a WHERE construct */
4397 cnext
= cblock
->next
;
4402 /* WHERE assignment statement */
4405 /* Check shape consistent for WHERE assignment target. */
4406 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
4407 gfc_error ("WHERE assignment target at %L has "
4408 "inconsistent shape", &cnext
->expr
->where
);
4411 /* WHERE or WHERE construct is part of a where-body-construct */
4413 resolve_where (cnext
, e
);
4417 gfc_error ("Unsupported statement inside WHERE at %L",
4420 /* the next statement within the same where-body-construct */
4421 cnext
= cnext
->next
;
4423 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4424 cblock
= cblock
->block
;
4429 /* Check whether the FORALL index appears in the expression or not. */
4432 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4436 gfc_actual_arglist
*args
;
4439 switch (expr
->expr_type
)
4442 gcc_assert (expr
->symtree
->n
.sym
);
4444 /* A scalar assignment */
4447 if (expr
->symtree
->n
.sym
== symbol
)
4453 /* the expr is array ref, substring or struct component. */
4460 /* Check if the symbol appears in the array subscript. */
4462 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4465 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4469 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4473 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4479 if (expr
->symtree
->n
.sym
== symbol
)
4482 /* Check if the symbol appears in the substring section. */
4483 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4485 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4493 gfc_error("expression reference type error at %L", &expr
->where
);
4499 /* If the expression is a function call, then check if the symbol
4500 appears in the actual arglist of the function. */
4502 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4504 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4509 /* It seems not to happen. */
4510 case EXPR_SUBSTRING
:
4514 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4515 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4517 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4522 /* It seems not to happen. */
4523 case EXPR_STRUCTURE
:
4525 gfc_error ("Unsupported statement while finding forall index in "
4530 /* Find the FORALL index in the first operand. */
4531 if (expr
->value
.op
.op1
)
4533 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4537 /* Find the FORALL index in the second operand. */
4538 if (expr
->value
.op
.op2
)
4540 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4553 /* Resolve assignment in FORALL construct.
4554 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4555 FORALL index variables. */
4558 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4562 for (n
= 0; n
< nvar
; n
++)
4564 gfc_symbol
*forall_index
;
4566 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
4568 /* Check whether the assignment target is one of the FORALL index
4570 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
4571 && (code
->expr
->symtree
->n
.sym
== forall_index
))
4572 gfc_error ("Assignment to a FORALL index variable at %L",
4573 &code
->expr
->where
);
4576 /* If one of the FORALL index variables doesn't appear in the
4577 assignment target, then there will be a many-to-one
4579 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4580 gfc_error ("The FORALL with index '%s' cause more than one "
4581 "assignment to this object at %L",
4582 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4588 /* Resolve WHERE statement in FORALL construct. */
4591 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
4595 cblock
= code
->block
;
4598 /* the assignment statement of a WHERE statement, or the first
4599 statement in where-body-construct of a WHERE construct */
4600 cnext
= cblock
->next
;
4605 /* WHERE assignment statement */
4607 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4610 /* WHERE or WHERE construct is part of a where-body-construct */
4612 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4616 gfc_error ("Unsupported statement inside WHERE at %L",
4619 /* the next statement within the same where-body-construct */
4620 cnext
= cnext
->next
;
4622 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4623 cblock
= cblock
->block
;
4628 /* Traverse the FORALL body to check whether the following errors exist:
4629 1. For assignment, check if a many-to-one assignment happens.
4630 2. For WHERE statement, check the WHERE body to see if there is any
4631 many-to-one assignment. */
4634 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4638 c
= code
->block
->next
;
4644 case EXEC_POINTER_ASSIGN
:
4645 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4648 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4649 there is no need to handle it here. */
4653 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4658 /* The next statement in the FORALL body. */
4664 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4665 gfc_resolve_forall_body to resolve the FORALL body. */
4668 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4670 static gfc_expr
**var_expr
;
4671 static int total_var
= 0;
4672 static int nvar
= 0;
4673 gfc_forall_iterator
*fa
;
4674 gfc_symbol
*forall_index
;
4678 /* Start to resolve a FORALL construct */
4679 if (forall_save
== 0)
4681 /* Count the total number of FORALL index in the nested FORALL
4682 construct in order to allocate the VAR_EXPR with proper size. */
4684 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4686 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4688 next
= next
->block
->next
;
4691 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4692 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4695 /* The information about FORALL iterator, including FORALL index start, end
4696 and stride. The FORALL index can not appear in start, end or stride. */
4697 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4699 /* Check if any outer FORALL index name is the same as the current
4701 for (i
= 0; i
< nvar
; i
++)
4703 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4705 gfc_error ("An outer FORALL construct already has an index "
4706 "with this name %L", &fa
->var
->where
);
4710 /* Record the current FORALL index. */
4711 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4713 forall_index
= fa
->var
->symtree
->n
.sym
;
4715 /* Check if the FORALL index appears in start, end or stride. */
4716 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4717 gfc_error ("A FORALL index must not appear in a limit or stride "
4718 "expression in the same FORALL at %L", &fa
->start
->where
);
4719 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4720 gfc_error ("A FORALL index must not appear in a limit or stride "
4721 "expression in the same FORALL at %L", &fa
->end
->where
);
4722 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4723 gfc_error ("A FORALL index must not appear in a limit or stride "
4724 "expression in the same FORALL at %L", &fa
->stride
->where
);
4728 /* Resolve the FORALL body. */
4729 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4731 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4732 gfc_resolve_blocks (code
->block
, ns
);
4734 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4735 for (i
= 0; i
< total_var
; i
++)
4736 gfc_free_expr (var_expr
[i
]);
4738 /* Reset the counters. */
4744 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4747 static void resolve_code (gfc_code
*, gfc_namespace
*);
4750 gfc_resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
4754 for (; b
; b
= b
->block
)
4756 t
= gfc_resolve_expr (b
->expr
);
4757 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4763 if (t
== SUCCESS
&& b
->expr
!= NULL
4764 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4766 ("IF clause at %L requires a scalar LOGICAL expression",
4773 && (b
->expr
->ts
.type
!= BT_LOGICAL
4774 || b
->expr
->rank
== 0))
4776 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4781 resolve_branch (b
->label
, b
);
4793 case EXEC_OMP_ATOMIC
:
4794 case EXEC_OMP_CRITICAL
:
4796 case EXEC_OMP_MASTER
:
4797 case EXEC_OMP_ORDERED
:
4798 case EXEC_OMP_PARALLEL
:
4799 case EXEC_OMP_PARALLEL_DO
:
4800 case EXEC_OMP_PARALLEL_SECTIONS
:
4801 case EXEC_OMP_PARALLEL_WORKSHARE
:
4802 case EXEC_OMP_SECTIONS
:
4803 case EXEC_OMP_SINGLE
:
4804 case EXEC_OMP_WORKSHARE
:
4808 gfc_internal_error ("resolve_block(): Bad block type");
4811 resolve_code (b
->next
, ns
);
4816 /* Given a block of code, recursively resolve everything pointed to by this
4820 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
4822 int omp_workshare_save
;
4828 frame
.prev
= cs_base
;
4832 for (; code
; code
= code
->next
)
4834 frame
.current
= code
;
4835 forall_save
= forall_flag
;
4837 if (code
->op
== EXEC_FORALL
)
4840 gfc_resolve_forall (code
, ns
, forall_save
);
4843 else if (code
->block
)
4845 omp_workshare_save
= -1;
4848 case EXEC_OMP_PARALLEL_WORKSHARE
:
4849 omp_workshare_save
= omp_workshare_flag
;
4850 omp_workshare_flag
= 1;
4851 gfc_resolve_omp_parallel_blocks (code
, ns
);
4853 case EXEC_OMP_PARALLEL
:
4854 case EXEC_OMP_PARALLEL_DO
:
4855 case EXEC_OMP_PARALLEL_SECTIONS
:
4856 omp_workshare_save
= omp_workshare_flag
;
4857 omp_workshare_flag
= 0;
4858 gfc_resolve_omp_parallel_blocks (code
, ns
);
4861 gfc_resolve_omp_do_blocks (code
, ns
);
4863 case EXEC_OMP_WORKSHARE
:
4864 omp_workshare_save
= omp_workshare_flag
;
4865 omp_workshare_flag
= 1;
4868 gfc_resolve_blocks (code
->block
, ns
);
4872 if (omp_workshare_save
!= -1)
4873 omp_workshare_flag
= omp_workshare_save
;
4876 t
= gfc_resolve_expr (code
->expr
);
4877 forall_flag
= forall_save
;
4879 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
4894 /* Keep track of which entry we are up to. */
4895 current_entry_id
= code
->ext
.entry
->id
;
4899 resolve_where (code
, NULL
);
4903 if (code
->expr
!= NULL
)
4905 if (code
->expr
->ts
.type
!= BT_INTEGER
)
4906 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4907 "variable", &code
->expr
->where
);
4908 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
4909 gfc_error ("Variable '%s' has not been assigned a target label "
4910 "at %L", code
->expr
->symtree
->n
.sym
->name
,
4911 &code
->expr
->where
);
4914 resolve_branch (code
->label
, code
);
4918 if (code
->expr
!= NULL
4919 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
4920 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4921 "INTEGER return specifier", &code
->expr
->where
);
4924 case EXEC_INIT_ASSIGN
:
4931 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
4933 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
4935 gfc_error ("Subroutine '%s' called instead of assignment at "
4936 "%L must be PURE", code
->symtree
->n
.sym
->name
,
4943 if (gfc_pure (NULL
))
4945 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
4948 ("Cannot assign to variable '%s' in PURE procedure at %L",
4949 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
4953 if (code
->expr2
->ts
.type
== BT_DERIVED
4954 && derived_pointer (code
->expr2
->ts
.derived
))
4957 ("Right side of assignment at %L is a derived type "
4958 "containing a POINTER in a PURE procedure",
4959 &code
->expr2
->where
);
4964 gfc_check_assign (code
->expr
, code
->expr2
, 1);
4967 case EXEC_LABEL_ASSIGN
:
4968 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
4969 gfc_error ("Label %d referenced at %L is never defined",
4970 code
->label
->value
, &code
->label
->where
);
4972 && (code
->expr
->expr_type
!= EXPR_VARIABLE
4973 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
4974 || code
->expr
->symtree
->n
.sym
->ts
.kind
4975 != gfc_default_integer_kind
4976 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
4977 gfc_error ("ASSIGN statement at %L requires a scalar "
4978 "default INTEGER variable", &code
->expr
->where
);
4981 case EXEC_POINTER_ASSIGN
:
4985 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
4988 case EXEC_ARITHMETIC_IF
:
4990 && code
->expr
->ts
.type
!= BT_INTEGER
4991 && code
->expr
->ts
.type
!= BT_REAL
)
4992 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4993 "expression", &code
->expr
->where
);
4995 resolve_branch (code
->label
, code
);
4996 resolve_branch (code
->label2
, code
);
4997 resolve_branch (code
->label3
, code
);
5001 if (t
== SUCCESS
&& code
->expr
!= NULL
5002 && (code
->expr
->ts
.type
!= BT_LOGICAL
5003 || code
->expr
->rank
!= 0))
5004 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5005 &code
->expr
->where
);
5010 resolve_call (code
);
5014 /* Select is complicated. Also, a SELECT construct could be
5015 a transformed computed GOTO. */
5016 resolve_select (code
);
5020 if (code
->ext
.iterator
!= NULL
)
5022 gfc_iterator
*iter
= code
->ext
.iterator
;
5023 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
5024 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
5029 if (code
->expr
== NULL
)
5030 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5032 && (code
->expr
->rank
!= 0
5033 || code
->expr
->ts
.type
!= BT_LOGICAL
))
5034 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5035 "a scalar LOGICAL expression", &code
->expr
->where
);
5039 if (t
== SUCCESS
&& code
->expr
!= NULL
5040 && code
->expr
->ts
.type
!= BT_INTEGER
)
5041 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5042 "of type INTEGER", &code
->expr
->where
);
5044 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5045 resolve_allocate_expr (a
->expr
, code
);
5049 case EXEC_DEALLOCATE
:
5050 if (t
== SUCCESS
&& code
->expr
!= NULL
5051 && code
->expr
->ts
.type
!= BT_INTEGER
)
5053 ("STAT tag in DEALLOCATE statement at %L must be of type "
5054 "INTEGER", &code
->expr
->where
);
5056 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5057 resolve_deallocate_expr (a
->expr
);
5062 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
5065 resolve_branch (code
->ext
.open
->err
, code
);
5069 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
5072 resolve_branch (code
->ext
.close
->err
, code
);
5075 case EXEC_BACKSPACE
:
5079 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
5082 resolve_branch (code
->ext
.filepos
->err
, code
);
5086 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5089 resolve_branch (code
->ext
.inquire
->err
, code
);
5093 gcc_assert (code
->ext
.inquire
!= NULL
);
5094 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5097 resolve_branch (code
->ext
.inquire
->err
, code
);
5102 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
5105 resolve_branch (code
->ext
.dt
->err
, code
);
5106 resolve_branch (code
->ext
.dt
->end
, code
);
5107 resolve_branch (code
->ext
.dt
->eor
, code
);
5111 resolve_transfer (code
);
5115 resolve_forall_iterators (code
->ext
.forall_iterator
);
5117 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
5119 ("FORALL mask clause at %L requires a LOGICAL expression",
5120 &code
->expr
->where
);
5123 case EXEC_OMP_ATOMIC
:
5124 case EXEC_OMP_BARRIER
:
5125 case EXEC_OMP_CRITICAL
:
5126 case EXEC_OMP_FLUSH
:
5128 case EXEC_OMP_MASTER
:
5129 case EXEC_OMP_ORDERED
:
5130 case EXEC_OMP_SECTIONS
:
5131 case EXEC_OMP_SINGLE
:
5132 case EXEC_OMP_WORKSHARE
:
5133 gfc_resolve_omp_directive (code
, ns
);
5136 case EXEC_OMP_PARALLEL
:
5137 case EXEC_OMP_PARALLEL_DO
:
5138 case EXEC_OMP_PARALLEL_SECTIONS
:
5139 case EXEC_OMP_PARALLEL_WORKSHARE
:
5140 omp_workshare_save
= omp_workshare_flag
;
5141 omp_workshare_flag
= 0;
5142 gfc_resolve_omp_directive (code
, ns
);
5143 omp_workshare_flag
= omp_workshare_save
;
5147 gfc_internal_error ("resolve_code(): Bad statement code");
5151 cs_base
= frame
.prev
;
5155 /* Resolve initial values and make sure they are compatible with
5159 resolve_values (gfc_symbol
* sym
)
5162 if (sym
->value
== NULL
)
5165 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
5168 gfc_check_assign_symbol (sym
, sym
->value
);
5172 /* Resolve an index expression. */
5175 resolve_index_expr (gfc_expr
* e
)
5177 if (gfc_resolve_expr (e
) == FAILURE
)
5180 if (gfc_simplify_expr (e
, 0) == FAILURE
)
5183 if (gfc_specification_expr (e
) == FAILURE
)
5189 /* Resolve a charlen structure. */
5192 resolve_charlen (gfc_charlen
*cl
)
5199 specification_expr
= 1;
5201 if (resolve_index_expr (cl
->length
) == FAILURE
)
5203 specification_expr
= 0;
5211 /* Test for non-constant shape arrays. */
5214 is_non_constant_shape_array (gfc_symbol
*sym
)
5220 not_constant
= false;
5221 if (sym
->as
!= NULL
)
5223 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5224 has not been simplified; parameter array references. Do the
5225 simplification now. */
5226 for (i
= 0; i
< sym
->as
->rank
; i
++)
5228 e
= sym
->as
->lower
[i
];
5229 if (e
&& (resolve_index_expr (e
) == FAILURE
5230 || !gfc_is_constant_expr (e
)))
5231 not_constant
= true;
5233 e
= sym
->as
->upper
[i
];
5234 if (e
&& (resolve_index_expr (e
) == FAILURE
5235 || !gfc_is_constant_expr (e
)))
5236 not_constant
= true;
5239 return not_constant
;
5243 /* Assign the default initializer to a derived type variable or result. */
5246 apply_default_init (gfc_symbol
*sym
)
5249 gfc_expr
*init
= NULL
;
5251 gfc_namespace
*ns
= sym
->ns
;
5253 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
5256 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
5257 init
= gfc_default_initializer (&sym
->ts
);
5262 /* Search for the function namespace if this is a contained
5263 function without an explicit result. */
5264 if (sym
->attr
.function
&& sym
== sym
->result
5265 && sym
->name
!= sym
->ns
->proc_name
->name
)
5268 for (;ns
; ns
= ns
->sibling
)
5269 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
5275 gfc_free_expr (init
);
5279 /* Build an l-value expression for the result. */
5280 lval
= gfc_get_expr ();
5281 lval
->expr_type
= EXPR_VARIABLE
;
5282 lval
->where
= sym
->declared_at
;
5284 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5286 /* It will always be a full array. */
5287 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
5290 lval
->ref
= gfc_get_ref ();
5291 lval
->ref
->type
= REF_ARRAY
;
5292 lval
->ref
->u
.ar
.type
= AR_FULL
;
5293 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
5294 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
5295 lval
->ref
->u
.ar
.as
= sym
->as
;
5298 /* Add the code at scope entry. */
5299 init_st
= gfc_get_code ();
5300 init_st
->next
= ns
->code
;
5303 /* Assign the default initializer to the l-value. */
5304 init_st
->loc
= sym
->declared_at
;
5305 init_st
->op
= EXEC_INIT_ASSIGN
;
5306 init_st
->expr
= lval
;
5307 init_st
->expr2
= init
;
5311 /* Resolution of common features of flavors variable and procedure. */
5314 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
5316 /* Constraints on deferred shape variable. */
5317 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
5319 if (sym
->attr
.allocatable
)
5321 if (sym
->attr
.dimension
)
5322 gfc_error ("Allocatable array '%s' at %L must have "
5323 "a deferred shape", sym
->name
, &sym
->declared_at
);
5325 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5326 sym
->name
, &sym
->declared_at
);
5330 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
5332 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5333 sym
->name
, &sym
->declared_at
);
5340 if (!mp_flag
&& !sym
->attr
.allocatable
5341 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
5343 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5344 sym
->name
, &sym
->declared_at
);
5351 /* Resolve symbols with flavor variable. */
5354 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
5359 gfc_expr
*constructor_expr
;
5360 const char * auto_save_msg
;
5362 auto_save_msg
= "automatic object '%s' at %L cannot have the "
5365 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5368 /* Set this flag to check that variables are parameters of all entries.
5369 This check is effected by the call to gfc_resolve_expr through
5370 is_non_constant_shape_array. */
5371 specification_expr
= 1;
5373 if (!sym
->attr
.use_assoc
5374 && !sym
->attr
.allocatable
5375 && !sym
->attr
.pointer
5376 && is_non_constant_shape_array (sym
))
5378 /* The shape of a main program or module array needs to be constant. */
5379 if (sym
->ns
->proc_name
5380 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5381 || sym
->ns
->proc_name
->attr
.is_main_program
))
5383 gfc_error ("The module or main program array '%s' at %L must "
5384 "have constant shape", sym
->name
, &sym
->declared_at
);
5385 specification_expr
= 0;
5390 if (sym
->ts
.type
== BT_CHARACTER
)
5392 /* Make sure that character string variables with assumed length are
5394 e
= sym
->ts
.cl
->length
;
5395 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
5397 gfc_error ("Entity with assumed character length at %L must be a "
5398 "dummy argument or a PARAMETER", &sym
->declared_at
);
5402 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
5404 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5408 if (!gfc_is_constant_expr (e
)
5409 && !(e
->expr_type
== EXPR_VARIABLE
5410 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
5411 && sym
->ns
->proc_name
5412 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5413 || sym
->ns
->proc_name
->attr
.is_main_program
)
5414 && !sym
->attr
.use_assoc
)
5416 gfc_error ("'%s' at %L must have constant character length "
5417 "in this context", sym
->name
, &sym
->declared_at
);
5422 /* Can the symbol have an initializer? */
5424 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
5425 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
5427 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
5429 /* Don't allow initialization of automatic arrays. */
5430 for (i
= 0; i
< sym
->as
->rank
; i
++)
5432 if (sym
->as
->lower
[i
] == NULL
5433 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5434 || sym
->as
->upper
[i
] == NULL
5435 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
5442 /* Also, they must not have the SAVE attribute. */
5443 if (flag
&& sym
->attr
.save
)
5445 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5450 /* Reject illegal initializers. */
5451 if (sym
->value
&& flag
)
5453 if (sym
->attr
.allocatable
)
5454 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5455 sym
->name
, &sym
->declared_at
);
5456 else if (sym
->attr
.external
)
5457 gfc_error ("External '%s' at %L cannot have an initializer",
5458 sym
->name
, &sym
->declared_at
);
5459 else if (sym
->attr
.dummy
)
5460 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5461 sym
->name
, &sym
->declared_at
);
5462 else if (sym
->attr
.intrinsic
)
5463 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5464 sym
->name
, &sym
->declared_at
);
5465 else if (sym
->attr
.result
)
5466 gfc_error ("Function result '%s' at %L cannot have an initializer",
5467 sym
->name
, &sym
->declared_at
);
5469 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5470 sym
->name
, &sym
->declared_at
);
5474 /* Check to see if a derived type is blocked from being host associated
5475 by the presence of another class I symbol in the same namespace.
5476 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5477 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
)
5480 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
5481 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
5482 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
5484 gfc_error ("The type %s cannot be host associated at %L because "
5485 "it is blocked by an incompatible object of the same "
5486 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
5492 /* 4th constraint in section 11.3: "If an object of a type for which
5493 component-initialization is specified (R429) appears in the
5494 specification-part of a module and does not have the ALLOCATABLE
5495 or POINTER attribute, the object shall have the SAVE attribute." */
5497 constructor_expr
= NULL
;
5498 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
5499 constructor_expr
= gfc_default_initializer (&sym
->ts
);
5501 if (sym
->ns
->proc_name
5502 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5504 && !sym
->ns
->save_all
&& !sym
->attr
.save
5505 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
5507 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5508 sym
->name
, &sym
->declared_at
,
5509 "for default initialization of a component");
5513 /* Assign default initializer. */
5514 if (sym
->ts
.type
== BT_DERIVED
5516 && !sym
->attr
.pointer
5517 && !sym
->attr
.allocatable
5518 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
5519 sym
->value
= gfc_default_initializer (&sym
->ts
);
5525 /* Resolve a procedure. */
5528 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
5530 gfc_formal_arglist
*arg
;
5533 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
5534 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5535 "interfaces", sym
->name
, &sym
->declared_at
);
5537 if (sym
->attr
.function
5538 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5541 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, sym
->name
);
5542 if (st
&& st
->ambiguous
5543 && sym
->attr
.referenced
5544 && !sym
->attr
.generic
)
5546 gfc_error ("Procedure %s at %L is ambiguous",
5547 sym
->name
, &sym
->declared_at
);
5551 if (sym
->ts
.type
== BT_CHARACTER
)
5553 gfc_charlen
*cl
= sym
->ts
.cl
;
5554 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
5556 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5558 gfc_error ("Character-valued statement function '%s' at %L must "
5559 "have constant length", sym
->name
, &sym
->declared_at
);
5563 if (sym
->attr
.external
&& sym
->formal
== NULL
5564 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
5566 gfc_error ("Automatic character length function '%s' at %L must "
5567 "have an explicit interface", sym
->name
, &sym
->declared_at
);
5573 /* Ensure that derived type for are not of a private type. Internal
5574 module procedures are excluded by 2.2.3.3 - ie. they are not
5575 externally accessible and can access all the objects accessible in
5577 if (!(sym
->ns
->parent
5578 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5579 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5581 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
5584 && arg
->sym
->ts
.type
== BT_DERIVED
5585 && !arg
->sym
->ts
.derived
->attr
.use_assoc
5586 && !gfc_check_access(arg
->sym
->ts
.derived
->attr
.access
,
5587 arg
->sym
->ts
.derived
->ns
->default_access
))
5589 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5590 "a dummy argument of '%s', which is "
5591 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
5593 /* Stop this message from recurring. */
5594 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
5600 /* An external symbol may not have an initializer because it is taken to be
5602 if (sym
->attr
.external
&& sym
->value
)
5604 gfc_error ("External object '%s' at %L may not have an initializer",
5605 sym
->name
, &sym
->declared_at
);
5609 /* An elemental function is required to return a scalar 12.7.1 */
5610 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
5612 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5613 "result", sym
->name
, &sym
->declared_at
);
5614 /* Reset so that the error only occurs once. */
5615 sym
->attr
.elemental
= 0;
5619 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5620 char-len-param shall not be array-valued, pointer-valued, recursive
5621 or pure. ....snip... A character value of * may only be used in the
5622 following ways: (i) Dummy arg of procedure - dummy associates with
5623 actual length; (ii) To declare a named constant; or (iii) External
5624 function - but length must be declared in calling scoping unit. */
5625 if (sym
->attr
.function
5626 && sym
->ts
.type
== BT_CHARACTER
5627 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
5629 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
5630 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
5632 if (sym
->as
&& sym
->as
->rank
)
5633 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5634 "array-valued", sym
->name
, &sym
->declared_at
);
5636 if (sym
->attr
.pointer
)
5637 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5638 "pointer-valued", sym
->name
, &sym
->declared_at
);
5641 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5642 "pure", sym
->name
, &sym
->declared_at
);
5644 if (sym
->attr
.recursive
)
5645 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5646 "recursive", sym
->name
, &sym
->declared_at
);
5651 /* Appendix B.2 of the standard. Contained functions give an
5652 error anyway. Fixed-form is likely to be F77/legacy. */
5653 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
5654 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
5655 "'%s' at %L is obsolescent in fortran 95",
5656 sym
->name
, &sym
->declared_at
);
5662 /* Resolve the components of a derived type. */
5665 resolve_fl_derived (gfc_symbol
*sym
)
5668 gfc_dt_list
* dt_list
;
5671 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
5673 if (c
->ts
.type
== BT_CHARACTER
)
5675 if (c
->ts
.cl
->length
== NULL
5676 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
5677 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
5679 gfc_error ("Character length of component '%s' needs to "
5680 "be a constant specification expression at %L",
5682 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
5687 if (c
->ts
.type
== BT_DERIVED
5688 && sym
->component_access
!= ACCESS_PRIVATE
5689 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
)
5690 && !c
->ts
.derived
->attr
.use_assoc
5691 && !gfc_check_access(c
->ts
.derived
->attr
.access
,
5692 c
->ts
.derived
->ns
->default_access
))
5694 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5695 "a component of '%s', which is PUBLIC at %L",
5696 c
->name
, sym
->name
, &sym
->declared_at
);
5700 if (sym
->attr
.sequence
)
5702 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
5704 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5705 "not have the SEQUENCE attribute",
5706 c
->ts
.derived
->name
, &sym
->declared_at
);
5711 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
5712 && c
->ts
.derived
->components
== NULL
)
5714 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5715 "that has not been declared", c
->name
, sym
->name
,
5720 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
5723 for (i
= 0; i
< c
->as
->rank
; i
++)
5725 if (c
->as
->lower
[i
] == NULL
5726 || !gfc_is_constant_expr (c
->as
->lower
[i
])
5727 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
5728 || c
->as
->upper
[i
] == NULL
5729 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
5730 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
5732 gfc_error ("Component '%s' of '%s' at %L must have "
5733 "constant array bounds",
5734 c
->name
, sym
->name
, &c
->loc
);
5740 /* Add derived type to the derived type list. */
5741 for (dt_list
= sym
->ns
->derived_types
; dt_list
; dt_list
= dt_list
->next
)
5742 if (sym
== dt_list
->derived
)
5745 if (dt_list
== NULL
)
5747 dt_list
= gfc_get_dt_list ();
5748 dt_list
->next
= sym
->ns
->derived_types
;
5749 dt_list
->derived
= sym
;
5750 sym
->ns
->derived_types
= dt_list
;
5758 resolve_fl_namelist (gfc_symbol
*sym
)
5763 /* Reject PRIVATE objects in a PUBLIC namelist. */
5764 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5766 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5768 if (!nl
->sym
->attr
.use_assoc
5769 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5770 && !gfc_check_access(nl
->sym
->attr
.access
,
5771 nl
->sym
->ns
->default_access
))
5773 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5774 "PUBLIC namelist at %L", nl
->sym
->name
,
5781 /* Reject namelist arrays that are not constant shape. */
5782 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5784 if (is_non_constant_shape_array (nl
->sym
))
5786 gfc_error ("The array '%s' must have constant shape to be "
5787 "a NAMELIST object at %L", nl
->sym
->name
,
5793 /* Namelist objects cannot have allocatable components. */
5794 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5796 if (nl
->sym
->ts
.type
== BT_DERIVED
5797 && nl
->sym
->ts
.derived
->attr
.alloc_comp
)
5799 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5800 "components", nl
->sym
->name
, &sym
->declared_at
);
5805 /* 14.1.2 A module or internal procedure represent local entities
5806 of the same type as a namelist member and so are not allowed.
5807 Note that this is sometimes caught by check_conflict so the
5808 same message has been used. */
5809 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5811 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
5814 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5815 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5816 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5818 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5819 "attribute in '%s' at %L", nlsym
->name
,
5830 resolve_fl_parameter (gfc_symbol
*sym
)
5832 /* A parameter array's shape needs to be constant. */
5833 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
5835 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5836 "or assumed shape", sym
->name
, &sym
->declared_at
);
5840 /* Make sure a parameter that has been implicitly typed still
5841 matches the implicit type, since PARAMETER statements can precede
5842 IMPLICIT statements. */
5843 if (sym
->attr
.implicit_type
5844 && !gfc_compare_types (&sym
->ts
,
5845 gfc_get_default_type (sym
, sym
->ns
)))
5847 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5848 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
5852 /* Make sure the types of derived parameters are consistent. This
5853 type checking is deferred until resolution because the type may
5854 refer to a derived type from the host. */
5855 if (sym
->ts
.type
== BT_DERIVED
5856 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
5858 gfc_error ("Incompatible derived type in PARAMETER at %L",
5859 &sym
->value
->where
);
5866 /* Do anything necessary to resolve a symbol. Right now, we just
5867 assume that an otherwise unknown symbol is a variable. This sort
5868 of thing commonly happens for symbols in module. */
5871 resolve_symbol (gfc_symbol
* sym
)
5873 /* Zero if we are checking a formal namespace. */
5874 static int formal_ns_flag
= 1;
5875 int formal_ns_save
, check_constant
, mp_flag
;
5876 gfc_symtree
*symtree
;
5877 gfc_symtree
*this_symtree
;
5881 if (sym
->attr
.flavor
== FL_UNKNOWN
)
5884 /* If we find that a flavorless symbol is an interface in one of the
5885 parent namespaces, find its symtree in this namespace, free the
5886 symbol and set the symtree to point to the interface symbol. */
5887 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
5889 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5890 if (symtree
&& symtree
->n
.sym
->generic
)
5892 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
5896 gfc_free_symbol (sym
);
5897 symtree
->n
.sym
->refs
++;
5898 this_symtree
->n
.sym
= symtree
->n
.sym
;
5903 /* Otherwise give it a flavor according to such attributes as
5905 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
5906 sym
->attr
.flavor
= FL_VARIABLE
;
5909 sym
->attr
.flavor
= FL_PROCEDURE
;
5910 if (sym
->attr
.dimension
)
5911 sym
->attr
.function
= 1;
5915 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
5918 /* Symbols that are module procedures with results (functions) have
5919 the types and array specification copied for type checking in
5920 procedures that call them, as well as for saving to a module
5921 file. These symbols can't stand the scrutiny that their results
5923 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
5925 /* Assign default type to symbols that need one and don't have one. */
5926 if (sym
->ts
.type
== BT_UNKNOWN
)
5928 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
5929 gfc_set_default_type (sym
, 1, NULL
);
5931 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
5933 /* The specific case of an external procedure should emit an error
5934 in the case that there is no implicit type. */
5936 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
5939 /* Result may be in another namespace. */
5940 resolve_symbol (sym
->result
);
5942 sym
->ts
= sym
->result
->ts
;
5943 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
5944 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
5945 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
5946 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
5951 /* Assumed size arrays and assumed shape arrays must be dummy
5955 && (sym
->as
->type
== AS_ASSUMED_SIZE
5956 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
5957 && sym
->attr
.dummy
== 0)
5959 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
5960 gfc_error ("Assumed size array at %L must be a dummy argument",
5963 gfc_error ("Assumed shape array at %L must be a dummy argument",
5968 /* Make sure symbols with known intent or optional are really dummy
5969 variable. Because of ENTRY statement, this has to be deferred
5970 until resolution time. */
5972 if (!sym
->attr
.dummy
5973 && (sym
->attr
.optional
5974 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
5976 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
5980 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
5982 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
5983 "it is not a dummy", sym
->name
, &sym
->declared_at
);
5988 /* If a derived type symbol has reached this point, without its
5989 type being declared, we have an error. Notice that most
5990 conditions that produce undefined derived types have already
5991 been dealt with. However, the likes of:
5992 implicit type(t) (t) ..... call foo (t) will get us here if
5993 the type is not declared in the scope of the implicit
5994 statement. Change the type to BT_UNKNOWN, both because it is so
5995 and to prevent an ICE. */
5996 if (sym
->ts
.type
== BT_DERIVED
5997 && sym
->ts
.derived
->components
== NULL
)
5999 gfc_error ("The derived type '%s' at %L is of type '%s', "
6000 "which has not been defined", sym
->name
,
6001 &sym
->declared_at
, sym
->ts
.derived
->name
);
6002 sym
->ts
.type
= BT_UNKNOWN
;
6006 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6007 default initialization is defined (5.1.2.4.4). */
6008 if (sym
->ts
.type
== BT_DERIVED
6010 && sym
->attr
.intent
== INTENT_OUT
6012 && sym
->as
->type
== AS_ASSUMED_SIZE
)
6014 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
6018 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6019 "ASSUMED SIZE and so cannot have a default initializer",
6020 sym
->name
, &sym
->declared_at
);
6026 switch (sym
->attr
.flavor
)
6029 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
6034 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
6039 if (resolve_fl_namelist (sym
) == FAILURE
)
6044 if (resolve_fl_parameter (sym
) == FAILURE
)
6052 /* Make sure that intrinsic exist */
6053 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
6054 && ! gfc_intrinsic_name(sym
->name
, 0)
6055 && ! gfc_intrinsic_name(sym
->name
, 1))
6056 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
6058 /* Resolve array specifier. Check as well some constraints
6059 on COMMON blocks. */
6061 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
6063 /* Set the formal_arg_flag so that check_conflict will not throw
6064 an error for host associated variables in the specification
6065 expression for an array_valued function. */
6066 if (sym
->attr
.function
&& sym
->as
)
6067 formal_arg_flag
= 1;
6069 gfc_resolve_array_spec (sym
->as
, check_constant
);
6071 formal_arg_flag
= 0;
6073 /* Resolve formal namespaces. */
6075 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
6077 formal_ns_save
= formal_ns_flag
;
6079 gfc_resolve (sym
->formal_ns
);
6080 formal_ns_flag
= formal_ns_save
;
6083 /* Check threadprivate restrictions. */
6084 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
6085 && (!sym
->attr
.in_common
6086 && sym
->module
== NULL
6087 && (sym
->ns
->proc_name
== NULL
6088 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
6089 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
6091 /* If we have come this far we can apply default-initializers, as
6092 described in 14.7.5, to those variables that have not already
6093 been assigned one. */
6094 if (sym
->ts
.type
== BT_DERIVED
6095 && sym
->attr
.referenced
6096 && sym
->ns
== gfc_current_ns
6098 && !sym
->attr
.allocatable
6099 && !sym
->attr
.alloc_comp
)
6101 symbol_attribute
*a
= &sym
->attr
;
6103 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
6104 && !a
->in_common
&& !a
->use_assoc
6105 && !(a
->function
&& sym
!= sym
->result
))
6107 (a
->dummy
&& a
->intent
== INTENT_OUT
))
6108 apply_default_init (sym
);
6114 /************* Resolve DATA statements *************/
6118 gfc_data_value
*vnode
;
6124 /* Advance the values structure to point to the next value in the data list. */
6127 next_data_value (void)
6129 while (values
.left
== 0)
6131 if (values
.vnode
->next
== NULL
)
6134 values
.vnode
= values
.vnode
->next
;
6135 values
.left
= values
.vnode
->repeat
;
6143 check_data_variable (gfc_data_variable
* var
, locus
* where
)
6149 ar_type mark
= AR_UNKNOWN
;
6151 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
6155 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
6159 mpz_init_set_si (offset
, 0);
6162 if (e
->expr_type
!= EXPR_VARIABLE
)
6163 gfc_internal_error ("check_data_variable(): Bad expression");
6165 if (e
->symtree
->n
.sym
->ns
->is_block_data
6166 && !e
->symtree
->n
.sym
->attr
.in_common
)
6168 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6169 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
6174 mpz_init_set_ui (size
, 1);
6181 /* Find the array section reference. */
6182 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6184 if (ref
->type
!= REF_ARRAY
)
6186 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6192 /* Set marks according to the reference pattern. */
6193 switch (ref
->u
.ar
.type
)
6201 /* Get the start position of array section. */
6202 gfc_get_section_index (ar
, section_index
, &offset
);
6210 if (gfc_array_size (e
, &size
) == FAILURE
)
6212 gfc_error ("Nonconstant array section at %L in DATA statement",
6221 while (mpz_cmp_ui (size
, 0) > 0)
6223 if (next_data_value () == FAILURE
)
6225 gfc_error ("DATA statement at %L has more variables than values",
6231 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
6235 /* If we have more than one element left in the repeat count,
6236 and we have more than one element left in the target variable,
6237 then create a range assignment. */
6238 /* ??? Only done for full arrays for now, since array sections
6240 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
6241 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
6245 if (mpz_cmp_ui (size
, values
.left
) >= 0)
6247 mpz_init_set_ui (range
, values
.left
);
6248 mpz_sub_ui (size
, size
, values
.left
);
6253 mpz_init_set (range
, size
);
6254 values
.left
-= mpz_get_ui (size
);
6255 mpz_set_ui (size
, 0);
6258 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
6261 mpz_add (offset
, offset
, range
);
6265 /* Assign initial value to symbol. */
6269 mpz_sub_ui (size
, size
, 1);
6271 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
6273 if (mark
== AR_FULL
)
6274 mpz_add_ui (offset
, offset
, 1);
6276 /* Modify the array section indexes and recalculate the offset
6277 for next element. */
6278 else if (mark
== AR_SECTION
)
6279 gfc_advance_section (section_index
, ar
, &offset
);
6283 if (mark
== AR_SECTION
)
6285 for (i
= 0; i
< ar
->dimen
; i
++)
6286 mpz_clear (section_index
[i
]);
6296 static try traverse_data_var (gfc_data_variable
*, locus
*);
6298 /* Iterate over a list of elements in a DATA statement. */
6301 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
6304 iterator_stack frame
;
6307 mpz_init (frame
.value
);
6309 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
6310 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
6311 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
6313 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
6315 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
6317 frame
.prev
= iter_stack
;
6318 frame
.variable
= var
->iter
.var
->symtree
;
6319 iter_stack
= &frame
;
6321 while (mpz_cmp_ui (trip
, 0) > 0)
6323 if (traverse_data_var (var
->list
, where
) == FAILURE
)
6329 e
= gfc_copy_expr (var
->expr
);
6330 if (gfc_simplify_expr (e
, 1) == FAILURE
)
6336 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
6338 mpz_sub_ui (trip
, trip
, 1);
6342 mpz_clear (frame
.value
);
6344 iter_stack
= frame
.prev
;
6349 /* Type resolve variables in the variable list of a DATA statement. */
6352 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
6356 for (; var
; var
= var
->next
)
6358 if (var
->expr
== NULL
)
6359 t
= traverse_data_list (var
, where
);
6361 t
= check_data_variable (var
, where
);
6371 /* Resolve the expressions and iterators associated with a data statement.
6372 This is separate from the assignment checking because data lists should
6373 only be resolved once. */
6376 resolve_data_variables (gfc_data_variable
* d
)
6378 for (; d
; d
= d
->next
)
6380 if (d
->list
== NULL
)
6382 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
6387 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
6390 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
6391 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
6392 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
6393 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6395 if (resolve_data_variables (d
->list
) == FAILURE
)
6404 /* Resolve a single DATA statement. We implement this by storing a pointer to
6405 the value list into static variables, and then recursively traversing the
6406 variables list, expanding iterators and such. */
6409 resolve_data (gfc_data
* d
)
6411 if (resolve_data_variables (d
->var
) == FAILURE
)
6414 values
.vnode
= d
->value
;
6415 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
6417 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
6420 /* At this point, we better not have any values left. */
6422 if (next_data_value () == SUCCESS
)
6423 gfc_error ("DATA statement at %L has more values than variables",
6428 /* Determines if a variable is not 'pure', ie not assignable within a pure
6429 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6433 gfc_impure_variable (gfc_symbol
* sym
)
6435 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
6438 if (sym
->ns
!= gfc_current_ns
)
6439 return !sym
->attr
.function
;
6441 /* TODO: Check storage association through EQUIVALENCE statements */
6447 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6448 symbol of the current procedure. */
6451 gfc_pure (gfc_symbol
* sym
)
6453 symbol_attribute attr
;
6456 sym
= gfc_current_ns
->proc_name
;
6462 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
6466 /* Test whether the current procedure is elemental or not. */
6469 gfc_elemental (gfc_symbol
* sym
)
6471 symbol_attribute attr
;
6474 sym
= gfc_current_ns
->proc_name
;
6479 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
6483 /* Warn about unused labels. */
6486 warn_unused_fortran_label (gfc_st_label
* label
)
6491 warn_unused_fortran_label (label
->left
);
6493 if (label
->defined
== ST_LABEL_UNKNOWN
)
6496 switch (label
->referenced
)
6498 case ST_LABEL_UNKNOWN
:
6499 gfc_warning ("Label %d at %L defined but not used", label
->value
,
6503 case ST_LABEL_BAD_TARGET
:
6504 gfc_warning ("Label %d at %L defined but cannot be used",
6505 label
->value
, &label
->where
);
6512 warn_unused_fortran_label (label
->right
);
6516 /* Returns the sequence type of a symbol or sequence. */
6519 sequence_type (gfc_typespec ts
)
6528 if (ts
.derived
->components
== NULL
)
6529 return SEQ_NONDEFAULT
;
6531 result
= sequence_type (ts
.derived
->components
->ts
);
6532 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
6533 if (sequence_type (c
->ts
) != result
)
6539 if (ts
.kind
!= gfc_default_character_kind
)
6540 return SEQ_NONDEFAULT
;
6542 return SEQ_CHARACTER
;
6545 if (ts
.kind
!= gfc_default_integer_kind
)
6546 return SEQ_NONDEFAULT
;
6551 if (!(ts
.kind
== gfc_default_real_kind
6552 || ts
.kind
== gfc_default_double_kind
))
6553 return SEQ_NONDEFAULT
;
6558 if (ts
.kind
!= gfc_default_complex_kind
)
6559 return SEQ_NONDEFAULT
;
6564 if (ts
.kind
!= gfc_default_logical_kind
)
6565 return SEQ_NONDEFAULT
;
6570 return SEQ_NONDEFAULT
;
6575 /* Resolve derived type EQUIVALENCE object. */
6578 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
6581 gfc_component
*c
= derived
->components
;
6586 /* Shall not be an object of nonsequence derived type. */
6587 if (!derived
->attr
.sequence
)
6589 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6590 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
6594 /* Shall not have allocatable components. */
6595 if (derived
->attr
.alloc_comp
)
6597 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6598 "components to be an EQUIVALENCE object",sym
->name
, &e
->where
);
6602 for (; c
; c
= c
->next
)
6605 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
6608 /* Shall not be an object of sequence derived type containing a pointer
6609 in the structure. */
6612 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6613 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
6619 gfc_error ("Derived type variable '%s' at %L with default initializer "
6620 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
6628 /* Resolve equivalence object.
6629 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6630 an allocatable array, an object of nonsequence derived type, an object of
6631 sequence derived type containing a pointer at any level of component
6632 selection, an automatic object, a function name, an entry name, a result
6633 name, a named constant, a structure component, or a subobject of any of
6634 the preceding objects. A substring shall not have length zero. A
6635 derived type shall not have components with default initialization nor
6636 shall two objects of an equivalence group be initialized.
6637 Either all or none of the objects shall have an protected attribute.
6638 The simple constraints are done in symbol.c(check_conflict) and the rest
6639 are implemented here. */
6642 resolve_equivalence (gfc_equiv
*eq
)
6645 gfc_symbol
*derived
;
6646 gfc_symbol
*first_sym
;
6649 locus
*last_where
= NULL
;
6650 seq_type eq_type
, last_eq_type
;
6651 gfc_typespec
*last_ts
;
6652 int object
, cnt_protected
;
6653 const char *value_name
;
6657 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
6659 first_sym
= eq
->expr
->symtree
->n
.sym
;
6663 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
6667 e
->ts
= e
->symtree
->n
.sym
->ts
;
6668 /* match_varspec might not know yet if it is seeing
6669 array reference or substring reference, as it doesn't
6671 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
6673 gfc_ref
*ref
= e
->ref
;
6674 sym
= e
->symtree
->n
.sym
;
6676 if (sym
->attr
.dimension
)
6678 ref
->u
.ar
.as
= sym
->as
;
6682 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6683 if (e
->ts
.type
== BT_CHARACTER
6685 && ref
->type
== REF_ARRAY
6686 && ref
->u
.ar
.dimen
== 1
6687 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
6688 && ref
->u
.ar
.stride
[0] == NULL
)
6690 gfc_expr
*start
= ref
->u
.ar
.start
[0];
6691 gfc_expr
*end
= ref
->u
.ar
.end
[0];
6694 /* Optimize away the (:) reference. */
6695 if (start
== NULL
&& end
== NULL
)
6700 e
->ref
->next
= ref
->next
;
6705 ref
->type
= REF_SUBSTRING
;
6707 start
= gfc_int_expr (1);
6708 ref
->u
.ss
.start
= start
;
6709 if (end
== NULL
&& e
->ts
.cl
)
6710 end
= gfc_copy_expr (e
->ts
.cl
->length
);
6711 ref
->u
.ss
.end
= end
;
6712 ref
->u
.ss
.length
= e
->ts
.cl
;
6719 /* Any further ref is an error. */
6722 gcc_assert (ref
->type
== REF_ARRAY
);
6723 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6729 if (gfc_resolve_expr (e
) == FAILURE
)
6732 sym
= e
->symtree
->n
.sym
;
6734 if (sym
->attr
.protected)
6736 if (cnt_protected
> 0 && cnt_protected
!= object
)
6738 gfc_error ("Either all or none of the objects in the "
6739 "EQUIVALENCE set at %L shall have the "
6740 "PROTECTED attribute",
6745 /* An equivalence statement cannot have more than one initialized
6749 if (value_name
!= NULL
)
6751 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6752 "be in the EQUIVALENCE statement at %L",
6753 value_name
, sym
->name
, &e
->where
);
6757 value_name
= sym
->name
;
6760 /* Shall not equivalence common block variables in a PURE procedure. */
6761 if (sym
->ns
->proc_name
6762 && sym
->ns
->proc_name
->attr
.pure
6763 && sym
->attr
.in_common
)
6765 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6766 "object in the pure procedure '%s'",
6767 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
6771 /* Shall not be a named constant. */
6772 if (e
->expr_type
== EXPR_CONSTANT
)
6774 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6775 "object", sym
->name
, &e
->where
);
6779 derived
= e
->ts
.derived
;
6780 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
6783 /* Check that the types correspond correctly:
6785 A numeric sequence structure may be equivalenced to another sequence
6786 structure, an object of default integer type, default real type, double
6787 precision real type, default logical type such that components of the
6788 structure ultimately only become associated to objects of the same
6789 kind. A character sequence structure may be equivalenced to an object
6790 of default character kind or another character sequence structure.
6791 Other objects may be equivalenced only to objects of the same type and
6794 /* Identical types are unconditionally OK. */
6795 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
6796 goto identical_types
;
6798 last_eq_type
= sequence_type (*last_ts
);
6799 eq_type
= sequence_type (sym
->ts
);
6801 /* Since the pair of objects is not of the same type, mixed or
6802 non-default sequences can be rejected. */
6804 msg
= "Sequence %s with mixed components in EQUIVALENCE "
6805 "statement at %L with different type objects";
6807 && last_eq_type
== SEQ_MIXED
6808 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
6809 last_where
) == FAILURE
)
6810 || (eq_type
== SEQ_MIXED
6811 && gfc_notify_std (GFC_STD_GNU
, msg
,sym
->name
,
6812 &e
->where
) == FAILURE
))
6815 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
6816 "statement at %L with objects of different type";
6818 && last_eq_type
== SEQ_NONDEFAULT
6819 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
6820 last_where
) == FAILURE
)
6821 || (eq_type
== SEQ_NONDEFAULT
6822 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6823 &e
->where
) == FAILURE
))
6826 msg
="Non-CHARACTER object '%s' in default CHARACTER "
6827 "EQUIVALENCE statement at %L";
6828 if (last_eq_type
== SEQ_CHARACTER
6829 && eq_type
!= SEQ_CHARACTER
6830 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6831 &e
->where
) == FAILURE
)
6834 msg
="Non-NUMERIC object '%s' in default NUMERIC "
6835 "EQUIVALENCE statement at %L";
6836 if (last_eq_type
== SEQ_NUMERIC
6837 && eq_type
!= SEQ_NUMERIC
6838 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6839 &e
->where
) == FAILURE
)
6844 last_where
= &e
->where
;
6849 /* Shall not be an automatic array. */
6850 if (e
->ref
->type
== REF_ARRAY
6851 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
6853 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6854 "an EQUIVALENCE object", sym
->name
, &e
->where
);
6861 /* Shall not be a structure component. */
6862 if (r
->type
== REF_COMPONENT
)
6864 gfc_error ("Structure component '%s' at %L cannot be an "
6865 "EQUIVALENCE object",
6866 r
->u
.c
.component
->name
, &e
->where
);
6870 /* A substring shall not have length zero. */
6871 if (r
->type
== REF_SUBSTRING
)
6873 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
6875 gfc_error ("Substring at %L has length zero",
6876 &r
->u
.ss
.start
->where
);
6886 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6889 resolve_fntype (gfc_namespace
* ns
)
6894 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
6897 /* If there are any entries, ns->proc_name is the entry master
6898 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6900 sym
= ns
->entries
->sym
;
6902 sym
= ns
->proc_name
;
6903 if (sym
->result
== sym
6904 && sym
->ts
.type
== BT_UNKNOWN
6905 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
6906 && !sym
->attr
.untyped
)
6908 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6909 sym
->name
, &sym
->declared_at
);
6910 sym
->attr
.untyped
= 1;
6913 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
6914 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
6915 sym
->ts
.derived
->ns
->default_access
)
6916 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
6918 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6919 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
6922 /* Make sure that the type of a module derived type function is in the
6923 module namespace, by copying it from the namespace's derived type
6924 list, if necessary. */
6925 if (sym
->ts
.type
== BT_DERIVED
6926 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6927 && sym
->ts
.derived
->ns
6928 && sym
->ns
!= sym
->ts
.derived
->ns
)
6930 gfc_dt_list
*dt
= sym
->ns
->derived_types
;
6932 for (; dt
; dt
= dt
->next
)
6933 if (gfc_compare_derived_types (sym
->ts
.derived
, dt
->derived
))
6934 sym
->ts
.derived
= dt
->derived
;
6938 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
6940 if (el
->sym
->result
== el
->sym
6941 && el
->sym
->ts
.type
== BT_UNKNOWN
6942 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
6943 && !el
->sym
->attr
.untyped
)
6945 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6946 el
->sym
->name
, &el
->sym
->declared_at
);
6947 el
->sym
->attr
.untyped
= 1;
6952 /* 12.3.2.1.1 Defined operators. */
6955 gfc_resolve_uops(gfc_symtree
*symtree
)
6959 gfc_formal_arglist
*formal
;
6961 if (symtree
== NULL
)
6964 gfc_resolve_uops (symtree
->left
);
6965 gfc_resolve_uops (symtree
->right
);
6967 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
6970 if (!sym
->attr
.function
)
6971 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6972 sym
->name
, &sym
->declared_at
);
6974 if (sym
->ts
.type
== BT_CHARACTER
6975 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
6976 && !(sym
->result
&& sym
->result
->ts
.cl
&& sym
->result
->ts
.cl
->length
))
6977 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6978 "length", sym
->name
, &sym
->declared_at
);
6980 formal
= sym
->formal
;
6981 if (!formal
|| !formal
->sym
)
6983 gfc_error("User operator procedure '%s' at %L must have at least "
6984 "one argument", sym
->name
, &sym
->declared_at
);
6988 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
6989 gfc_error ("First argument of operator interface at %L must be "
6990 "INTENT(IN)", &sym
->declared_at
);
6992 if (formal
->sym
->attr
.optional
)
6993 gfc_error ("First argument of operator interface at %L cannot be "
6994 "optional", &sym
->declared_at
);
6996 formal
= formal
->next
;
6997 if (!formal
|| !formal
->sym
)
7000 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7001 gfc_error ("Second argument of operator interface at %L must be "
7002 "INTENT(IN)", &sym
->declared_at
);
7004 if (formal
->sym
->attr
.optional
)
7005 gfc_error ("Second argument of operator interface at %L cannot be "
7006 "optional", &sym
->declared_at
);
7009 gfc_error ("Operator interface at %L must have, at most, two "
7010 "arguments", &sym
->declared_at
);
7015 /* Examine all of the expressions associated with a program unit,
7016 assign types to all intermediate expressions, make sure that all
7017 assignments are to compatible types and figure out which names
7018 refer to which functions or subroutines. It doesn't check code
7019 block, which is handled by resolve_code. */
7022 resolve_types (gfc_namespace
* ns
)
7029 gfc_current_ns
= ns
;
7031 resolve_entries (ns
);
7033 resolve_contained_functions (ns
);
7035 gfc_traverse_ns (ns
, resolve_symbol
);
7037 resolve_fntype (ns
);
7039 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7041 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
7042 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7043 "also be PURE", n
->proc_name
->name
,
7044 &n
->proc_name
->declared_at
);
7050 gfc_check_interfaces (ns
);
7052 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
7053 resolve_charlen (cl
);
7055 gfc_traverse_ns (ns
, resolve_values
);
7061 for (d
= ns
->data
; d
; d
= d
->next
)
7065 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
7067 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
7068 resolve_equivalence (eq
);
7070 /* Warn about unused labels. */
7071 if (warn_unused_label
)
7072 warn_unused_fortran_label (ns
->st_labels
);
7074 gfc_resolve_uops (ns
->uop_root
);
7078 /* Call resolve_code recursively. */
7081 resolve_codes (gfc_namespace
* ns
)
7085 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7088 gfc_current_ns
= ns
;
7090 /* Set to an out of range value. */
7091 current_entry_id
= -1;
7092 resolve_code (ns
->code
, ns
);
7096 /* This function is called after a complete program unit has been compiled.
7097 Its purpose is to examine all of the expressions associated with a program
7098 unit, assign types to all intermediate expressions, make sure that all
7099 assignments are to compatible types and figure out which names refer to
7100 which functions or subroutines. */
7103 gfc_resolve (gfc_namespace
* ns
)
7105 gfc_namespace
*old_ns
;
7107 old_ns
= gfc_current_ns
;
7112 gfc_current_ns
= old_ns
;