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 /* TODO: Procedures whose return character length parameter is not constant
93 or assumed must also have explicit interfaces. */
94 if (proc
->result
!= NULL
)
99 if (gfc_elemental (proc
)
100 || sym
->attr
.pointer
|| sym
->attr
.allocatable
101 || (sym
->as
&& sym
->as
->rank
> 0))
102 proc
->attr
.always_explicit
= 1;
106 for (f
= proc
->formal
; f
; f
= f
->next
)
112 /* Alternate return placeholder. */
113 if (gfc_elemental (proc
))
114 gfc_error ("Alternate return specifier in elemental subroutine "
115 "'%s' at %L is not allowed", proc
->name
,
117 if (proc
->attr
.function
)
118 gfc_error ("Alternate return specifier in function "
119 "'%s' at %L is not allowed", proc
->name
,
124 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
125 resolve_formal_arglist (sym
);
127 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
129 if (gfc_pure (proc
) && !gfc_pure (sym
))
132 ("Dummy procedure '%s' of PURE procedure at %L must also "
133 "be PURE", sym
->name
, &sym
->declared_at
);
137 if (gfc_elemental (proc
))
140 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
148 if (sym
->ts
.type
== BT_UNKNOWN
)
150 if (!sym
->attr
.function
|| sym
->result
== sym
)
151 gfc_set_default_type (sym
, 1, sym
->ns
);
154 gfc_resolve_array_spec (sym
->as
, 0);
156 /* We can't tell if an array with dimension (:) is assumed or deferred
157 shape until we know if it has the pointer or allocatable attributes.
159 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
160 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
162 sym
->as
->type
= AS_ASSUMED_SHAPE
;
163 for (i
= 0; i
< sym
->as
->rank
; i
++)
164 sym
->as
->lower
[i
] = gfc_int_expr (1);
167 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
168 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
169 || sym
->attr
.optional
)
170 proc
->attr
.always_explicit
= 1;
172 /* If the flavor is unknown at this point, it has to be a variable.
173 A procedure specification would have already set the type. */
175 if (sym
->attr
.flavor
== FL_UNKNOWN
)
176 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
180 if (proc
->attr
.function
&& !sym
->attr
.pointer
181 && sym
->attr
.flavor
!= FL_PROCEDURE
182 && sym
->attr
.intent
!= INTENT_IN
)
184 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
185 "INTENT(IN)", sym
->name
, proc
->name
,
188 if (proc
->attr
.subroutine
&& !sym
->attr
.pointer
189 && sym
->attr
.intent
== INTENT_UNKNOWN
)
192 ("Argument '%s' of pure subroutine '%s' at %L must have "
193 "its INTENT specified", sym
->name
, proc
->name
,
198 if (gfc_elemental (proc
))
203 ("Argument '%s' of elemental procedure at %L must be scalar",
204 sym
->name
, &sym
->declared_at
);
208 if (sym
->attr
.pointer
)
211 ("Argument '%s' of elemental procedure at %L cannot have "
212 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
217 /* Each dummy shall be specified to be scalar. */
218 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
223 ("Argument '%s' of statement function at %L must be scalar",
224 sym
->name
, &sym
->declared_at
);
228 if (sym
->ts
.type
== BT_CHARACTER
)
230 gfc_charlen
*cl
= sym
->ts
.cl
;
231 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
234 ("Character-valued argument '%s' of statement function at "
235 "%L must has constant length",
236 sym
->name
, &sym
->declared_at
);
246 /* Work function called when searching for symbols that have argument lists
247 associated with them. */
250 find_arglists (gfc_symbol
* sym
)
253 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
256 resolve_formal_arglist (sym
);
260 /* Given a namespace, resolve all formal argument lists within the namespace.
264 resolve_formal_arglists (gfc_namespace
* ns
)
270 gfc_traverse_ns (ns
, find_arglists
);
275 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
279 /* If this namespace is not a function, ignore it. */
281 || !(sym
->attr
.function
282 || sym
->attr
.flavor
== FL_VARIABLE
))
285 /* Try to find out of what the return type is. */
286 if (sym
->result
!= NULL
)
289 if (sym
->ts
.type
== BT_UNKNOWN
)
291 t
= gfc_set_default_type (sym
, 0, ns
);
293 if (t
== FAILURE
&& !sym
->attr
.untyped
)
295 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
296 sym
->name
, &sym
->declared_at
); /* FIXME */
297 sym
->attr
.untyped
= 1;
301 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
302 lists the only ways a character length value of * can be used: dummy arguments
303 of procedures, named constants, and function results in external functions.
304 Internal function results are not on that list; ergo, not permitted. */
306 if (sym
->ts
.type
== BT_CHARACTER
)
308 gfc_charlen
*cl
= sym
->ts
.cl
;
309 if (!cl
|| !cl
->length
)
310 gfc_error ("Character-valued internal function '%s' at %L must "
311 "not be assumed length", sym
->name
, &sym
->declared_at
);
316 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
317 introduce duplicates. */
320 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
322 gfc_formal_arglist
*f
, *new_arglist
;
325 for (; new_args
!= NULL
; new_args
= new_args
->next
)
327 new_sym
= new_args
->sym
;
328 /* See if this arg is already in the formal argument list. */
329 for (f
= proc
->formal
; f
; f
= f
->next
)
331 if (new_sym
== f
->sym
)
338 /* Add a new argument. Argument order is not important. */
339 new_arglist
= gfc_get_formal_arglist ();
340 new_arglist
->sym
= new_sym
;
341 new_arglist
->next
= proc
->formal
;
342 proc
->formal
= new_arglist
;
347 /* Resolve alternate entry points. If a symbol has multiple entry points we
348 create a new master symbol for the main routine, and turn the existing
349 symbol into an entry point. */
352 resolve_entries (gfc_namespace
* ns
)
354 gfc_namespace
*old_ns
;
358 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
359 static int master_count
= 0;
361 if (ns
->proc_name
== NULL
)
364 /* No need to do anything if this procedure doesn't have alternate entry
369 /* We may already have resolved alternate entry points. */
370 if (ns
->proc_name
->attr
.entry_master
)
373 /* If this isn't a procedure something has gone horribly wrong. */
374 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
376 /* Remember the current namespace. */
377 old_ns
= gfc_current_ns
;
381 /* Add the main entry point to the list of entry points. */
382 el
= gfc_get_entry_list ();
383 el
->sym
= ns
->proc_name
;
385 el
->next
= ns
->entries
;
387 ns
->proc_name
->attr
.entry
= 1;
389 /* If it is a module function, it needs to be in the right namespace
390 so that gfc_get_fake_result_decl can gather up the results. The
391 need for this arose in get_proc_name, where these beasts were
392 left in their own namespace, to keep prior references linked to
393 the entry declaration.*/
394 if (ns
->proc_name
->attr
.function
396 && ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
399 /* Add an entry statement for it. */
406 /* Create a new symbol for the master function. */
407 /* Give the internal function a unique name (within this file).
408 Also include the function name so the user has some hope of figuring
409 out what is going on. */
410 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
411 master_count
++, ns
->proc_name
->name
);
412 gfc_get_ha_symbol (name
, &proc
);
413 gcc_assert (proc
!= NULL
);
415 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
416 if (ns
->proc_name
->attr
.subroutine
)
417 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
421 gfc_typespec
*ts
, *fts
;
422 gfc_array_spec
*as
, *fas
;
423 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
425 fas
= ns
->entries
->sym
->as
;
426 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
427 fts
= &ns
->entries
->sym
->result
->ts
;
428 if (fts
->type
== BT_UNKNOWN
)
429 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
430 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
432 ts
= &el
->sym
->result
->ts
;
434 as
= as
? as
: el
->sym
->result
->as
;
435 if (ts
->type
== BT_UNKNOWN
)
436 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
438 if (! gfc_compare_types (ts
, fts
)
439 || (el
->sym
->result
->attr
.dimension
440 != ns
->entries
->sym
->result
->attr
.dimension
)
441 || (el
->sym
->result
->attr
.pointer
442 != ns
->entries
->sym
->result
->attr
.pointer
))
445 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
446 gfc_error ("Procedure %s at %L has entries with mismatched "
447 "array specifications", ns
->entries
->sym
->name
,
448 &ns
->entries
->sym
->declared_at
);
453 sym
= ns
->entries
->sym
->result
;
454 /* All result types the same. */
456 if (sym
->attr
.dimension
)
457 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
458 if (sym
->attr
.pointer
)
459 gfc_add_pointer (&proc
->attr
, NULL
);
463 /* Otherwise the result will be passed through a union by
465 proc
->attr
.mixed_entry_master
= 1;
466 for (el
= ns
->entries
; el
; el
= el
->next
)
468 sym
= el
->sym
->result
;
469 if (sym
->attr
.dimension
)
471 if (el
== ns
->entries
)
473 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
474 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
477 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
478 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
480 else if (sym
->attr
.pointer
)
482 if (el
== ns
->entries
)
484 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
485 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
488 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
489 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
494 if (ts
->type
== BT_UNKNOWN
)
495 ts
= gfc_get_default_type (sym
, NULL
);
499 if (ts
->kind
== gfc_default_integer_kind
)
503 if (ts
->kind
== gfc_default_real_kind
504 || ts
->kind
== gfc_default_double_kind
)
508 if (ts
->kind
== gfc_default_complex_kind
)
512 if (ts
->kind
== gfc_default_logical_kind
)
516 /* We will issue error elsewhere. */
524 if (el
== ns
->entries
)
526 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
527 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
531 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
532 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
539 proc
->attr
.access
= ACCESS_PRIVATE
;
540 proc
->attr
.entry_master
= 1;
542 /* Merge all the entry point arguments. */
543 for (el
= ns
->entries
; el
; el
= el
->next
)
544 merge_argument_lists (proc
, el
->sym
->formal
);
546 /* Use the master function for the function body. */
547 ns
->proc_name
= proc
;
549 /* Finalize the new symbols. */
550 gfc_commit_symbols ();
552 /* Restore the original namespace. */
553 gfc_current_ns
= old_ns
;
557 /* Resolve contained function types. Because contained functions can call one
558 another, they have to be worked out before any of the contained procedures
561 The good news is that if a function doesn't already have a type, the only
562 way it can get one is through an IMPLICIT type or a RESULT variable, because
563 by definition contained functions are contained namespace they're contained
564 in, not in a sibling or parent namespace. */
567 resolve_contained_functions (gfc_namespace
* ns
)
569 gfc_namespace
*child
;
572 resolve_formal_arglists (ns
);
574 for (child
= ns
->contained
; child
; child
= child
->sibling
)
576 /* Resolve alternate entry points first. */
577 resolve_entries (child
);
579 /* Then check function return types. */
580 resolve_contained_fntype (child
->proc_name
, child
);
581 for (el
= child
->entries
; el
; el
= el
->next
)
582 resolve_contained_fntype (el
->sym
, child
);
587 /* Resolve all of the elements of a structure constructor and make sure that
588 the types are correct. */
591 resolve_structure_cons (gfc_expr
* expr
)
593 gfc_constructor
*cons
;
599 cons
= expr
->value
.constructor
;
600 /* A constructor may have references if it is the result of substituting a
601 parameter variable. In this case we just pull out the component we
604 comp
= expr
->ref
->u
.c
.sym
->components
;
606 comp
= expr
->ts
.derived
->components
;
608 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
613 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
619 if (cons
->expr
->expr_type
!= EXPR_NULL
620 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
621 && (comp
->allocatable
|| cons
->expr
->rank
))
623 gfc_error ("The rank of the element in the derived type "
624 "constructor at %L does not match that of the "
625 "component (%d/%d)", &cons
->expr
->where
,
626 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
630 /* If we don't have the right type, try to convert it. */
632 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
635 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
636 gfc_error ("The element in the derived type constructor at %L, "
637 "for pointer component '%s', is %s but should be %s",
638 &cons
->expr
->where
, comp
->name
,
639 gfc_basic_typename (cons
->expr
->ts
.type
),
640 gfc_basic_typename (comp
->ts
.type
));
642 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
645 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
648 a
= gfc_expr_attr (cons
->expr
);
650 if (!a
.pointer
&& !a
.target
)
653 gfc_error ("The element in the derived type constructor at %L, "
654 "for pointer component '%s' should be a POINTER or "
655 "a TARGET", &cons
->expr
->where
, comp
->name
);
664 /****************** Expression name resolution ******************/
666 /* Returns 0 if a symbol was not declared with a type or
667 attribute declaration statement, nonzero otherwise. */
670 was_declared (gfc_symbol
* sym
)
676 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
679 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
680 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
681 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
688 /* Determine if a symbol is generic or not. */
691 generic_sym (gfc_symbol
* sym
)
695 if (sym
->attr
.generic
||
696 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
699 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
702 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
704 return (s
== NULL
) ? 0 : generic_sym (s
);
708 /* Determine if a symbol is specific or not. */
711 specific_sym (gfc_symbol
* sym
)
715 if (sym
->attr
.if_source
== IFSRC_IFBODY
716 || sym
->attr
.proc
== PROC_MODULE
717 || sym
->attr
.proc
== PROC_INTERNAL
718 || sym
->attr
.proc
== PROC_ST_FUNCTION
719 || (sym
->attr
.intrinsic
&&
720 gfc_specific_intrinsic (sym
->name
))
721 || sym
->attr
.external
)
724 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
727 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
729 return (s
== NULL
) ? 0 : specific_sym (s
);
733 /* Figure out if the procedure is specific, generic or unknown. */
736 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
740 procedure_kind (gfc_symbol
* sym
)
743 if (generic_sym (sym
))
744 return PTYPE_GENERIC
;
746 if (specific_sym (sym
))
747 return PTYPE_SPECIFIC
;
749 return PTYPE_UNKNOWN
;
752 /* Check references to assumed size arrays. The flag need_full_assumed_size
753 is nonzero when matching actual arguments. */
755 static int need_full_assumed_size
= 0;
758 check_assumed_size_reference (gfc_symbol
* sym
, gfc_expr
* e
)
764 if (need_full_assumed_size
765 || !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
768 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
769 if (ref
->type
== REF_ARRAY
)
770 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
771 last
= (ref
->u
.ar
.end
[dim
] == NULL
) && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
775 gfc_error ("The upper bound in the last dimension must "
776 "appear in the reference to the assumed size "
777 "array '%s' at %L", sym
->name
, &e
->where
);
784 /* Look for bad assumed size array references in argument expressions
785 of elemental and array valued intrinsic procedures. Since this is
786 called from procedure resolution functions, it only recurses at
790 resolve_assumed_size_actual (gfc_expr
*e
)
795 switch (e
->expr_type
)
799 && check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
804 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
805 || resolve_assumed_size_actual (e
->value
.op
.op2
))
816 /* Resolve an actual argument list. Most of the time, this is just
817 resolving the expressions in the list.
818 The exception is that we sometimes have to decide whether arguments
819 that look like procedure arguments are really simple variable
823 resolve_actual_arglist (gfc_actual_arglist
* arg
)
826 gfc_symtree
*parent_st
;
829 for (; arg
; arg
= arg
->next
)
835 /* Check the label is a valid branching target. */
838 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
840 gfc_error ("Label %d referenced at %L is never defined",
841 arg
->label
->value
, &arg
->label
->where
);
848 if (e
->ts
.type
!= BT_PROCEDURE
)
850 if (gfc_resolve_expr (e
) != SUCCESS
)
855 /* See if the expression node should really be a variable
858 sym
= e
->symtree
->n
.sym
;
860 if (sym
->attr
.flavor
== FL_PROCEDURE
861 || sym
->attr
.intrinsic
862 || sym
->attr
.external
)
866 /* If a procedure is not already determined to be something else
867 check if it is intrinsic. */
868 if (!sym
->attr
.intrinsic
869 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
870 || sym
->attr
.if_source
== IFSRC_IFBODY
)
871 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
872 sym
->attr
.intrinsic
= 1;
874 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
876 gfc_error ("Statement function '%s' at %L is not allowed as an "
877 "actual argument", sym
->name
, &e
->where
);
880 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
, sym
->attr
.subroutine
);
881 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
883 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
884 "actual argument", sym
->name
, &e
->where
);
886 else if (sym
->attr
.intrinsic
&& actual_ok
== 2)
887 /* We need a special case for CHAR, which is the only intrinsic
888 function allowed as actual argument in F2003 and not allowed
890 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: CHAR intrinsic "
891 "as actual argument at %L", &e
->where
);
893 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
894 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
896 gfc_error ("Internal procedure '%s' is not allowed as an "
897 "actual argument at %L", sym
->name
, &e
->where
);
900 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
902 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
903 "allowed as an actual argument at %L", sym
->name
,
907 if (sym
->attr
.generic
)
909 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
910 "allowed as an actual argument at %L", sym
->name
,
914 /* If the symbol is the function that names the current (or
915 parent) scope, then we really have a variable reference. */
917 if (sym
->attr
.function
&& sym
->result
== sym
918 && (sym
->ns
->proc_name
== sym
919 || (sym
->ns
->parent
!= NULL
920 && sym
->ns
->parent
->proc_name
== sym
)))
926 /* See if the name is a module procedure in a parent unit. */
928 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
931 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
933 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
937 if (parent_st
== NULL
)
940 sym
= parent_st
->n
.sym
;
941 e
->symtree
= parent_st
; /* Point to the right thing. */
943 if (sym
->attr
.flavor
== FL_PROCEDURE
944 || sym
->attr
.intrinsic
945 || sym
->attr
.external
)
951 e
->expr_type
= EXPR_VARIABLE
;
955 e
->rank
= sym
->as
->rank
;
956 e
->ref
= gfc_get_ref ();
957 e
->ref
->type
= REF_ARRAY
;
958 e
->ref
->u
.ar
.type
= AR_FULL
;
959 e
->ref
->u
.ar
.as
= sym
->as
;
967 /* Do the checks of the actual argument list that are specific to elemental
968 procedures. If called with c == NULL, we have a function, otherwise if
969 expr == NULL, we have a subroutine. */
971 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
973 gfc_actual_arglist
*arg0
;
974 gfc_actual_arglist
*arg
;
975 gfc_symbol
*esym
= NULL
;
976 gfc_intrinsic_sym
*isym
= NULL
;
978 gfc_intrinsic_arg
*iformal
= NULL
;
979 gfc_formal_arglist
*eformal
= NULL
;
980 bool formal_optional
= false;
981 bool set_by_optional
= false;
985 /* Is this an elemental procedure? */
986 if (expr
&& expr
->value
.function
.actual
!= NULL
)
988 if (expr
->value
.function
.esym
!= NULL
989 && expr
->value
.function
.esym
->attr
.elemental
)
991 arg0
= expr
->value
.function
.actual
;
992 esym
= expr
->value
.function
.esym
;
994 else if (expr
->value
.function
.isym
!= NULL
995 && expr
->value
.function
.isym
->elemental
)
997 arg0
= expr
->value
.function
.actual
;
998 isym
= expr
->value
.function
.isym
;
1003 else if (c
&& c
->ext
.actual
!= NULL
1004 && c
->symtree
->n
.sym
->attr
.elemental
)
1006 arg0
= c
->ext
.actual
;
1007 esym
= c
->symtree
->n
.sym
;
1012 /* The rank of an elemental is the rank of its array argument(s). */
1013 for (arg
= arg0
; arg
; arg
= arg
->next
)
1015 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1017 rank
= arg
->expr
->rank
;
1018 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1019 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1020 set_by_optional
= true;
1022 /* Function specific; set the result rank and shape. */
1026 if (!expr
->shape
&& arg
->expr
->shape
)
1028 expr
->shape
= gfc_get_shape (rank
);
1029 for (i
= 0; i
< rank
; i
++)
1030 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1037 /* If it is an array, it shall not be supplied as an actual argument
1038 to an elemental procedure unless an array of the same rank is supplied
1039 as an actual argument corresponding to a nonoptional dummy argument of
1040 that elemental procedure(12.4.1.5). */
1041 formal_optional
= false;
1043 iformal
= isym
->formal
;
1045 eformal
= esym
->formal
;
1047 for (arg
= arg0
; arg
; arg
= arg
->next
)
1051 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1052 formal_optional
= true;
1053 eformal
= eformal
->next
;
1055 else if (isym
&& iformal
)
1057 if (iformal
->optional
)
1058 formal_optional
= true;
1059 iformal
= iformal
->next
;
1062 formal_optional
= true;
1064 if (pedantic
&& arg
->expr
!= NULL
1065 && arg
->expr
->expr_type
== EXPR_VARIABLE
1066 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1069 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1070 && !(isym
&& isym
->generic_id
== GFC_ISYM_CONVERSION
))
1072 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1073 "MISSING, it cannot be the actual argument of an "
1074 "ELEMENTAL procedure unless there is a non-optional"
1075 "argument with the same rank (12.4.1.5)",
1076 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1081 for (arg
= arg0
; arg
; arg
= arg
->next
)
1083 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1086 /* Being elemental, the last upper bound of an assumed size array
1087 argument must be present. */
1088 if (resolve_assumed_size_actual (arg
->expr
))
1094 /* Elemental subroutine array actual arguments must conform. */
1097 if (gfc_check_conformance ("elemental subroutine", arg
->expr
, e
)
1109 /* Go through each actual argument in ACTUAL and see if it can be
1110 implemented as an inlined, non-copying intrinsic. FNSYM is the
1111 function being called, or NULL if not known. */
1114 find_noncopying_intrinsics (gfc_symbol
* fnsym
, gfc_actual_arglist
* actual
)
1116 gfc_actual_arglist
*ap
;
1119 for (ap
= actual
; ap
; ap
= ap
->next
)
1121 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1122 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1123 ap
->expr
->inline_noncopying_intrinsic
= 1;
1126 /* This function does the checking of references to global procedures
1127 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1128 77 and 95 standards. It checks for a gsymbol for the name, making
1129 one if it does not already exist. If it already exists, then the
1130 reference being resolved must correspond to the type of gsymbol.
1131 Otherwise, the new symbol is equipped with the attributes of the
1132 reference. The corresponding code that is called in creating
1133 global entities is parse.c. */
1136 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1141 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1143 gsym
= gfc_get_gsymbol (sym
->name
);
1145 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1146 global_used (gsym
, where
);
1148 if (gsym
->type
== GSYM_UNKNOWN
)
1151 gsym
->where
= *where
;
1157 /************* Function resolution *************/
1159 /* Resolve a function call known to be generic.
1160 Section 14.1.2.4.1. */
1163 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
1167 if (sym
->attr
.generic
)
1170 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1173 expr
->value
.function
.name
= s
->name
;
1174 expr
->value
.function
.esym
= s
;
1176 if (s
->ts
.type
!= BT_UNKNOWN
)
1178 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1179 expr
->ts
= s
->result
->ts
;
1182 expr
->rank
= s
->as
->rank
;
1183 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1184 expr
->rank
= s
->result
->as
->rank
;
1189 /* TODO: Need to search for elemental references in generic interface */
1192 if (sym
->attr
.intrinsic
)
1193 return gfc_intrinsic_func_interface (expr
, 0);
1200 resolve_generic_f (gfc_expr
* expr
)
1205 sym
= expr
->symtree
->n
.sym
;
1209 m
= resolve_generic_f0 (expr
, sym
);
1212 else if (m
== MATCH_ERROR
)
1216 if (sym
->ns
->parent
== NULL
)
1218 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1222 if (!generic_sym (sym
))
1226 /* Last ditch attempt. */
1228 if (!gfc_generic_intrinsic (expr
->symtree
->n
.sym
->name
))
1230 gfc_error ("There is no specific function for the generic '%s' at %L",
1231 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1235 m
= gfc_intrinsic_func_interface (expr
, 0);
1240 ("Generic function '%s' at %L is not consistent with a specific "
1241 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
1247 /* Resolve a function call known to be specific. */
1250 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
1254 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1256 if (sym
->attr
.dummy
)
1258 sym
->attr
.proc
= PROC_DUMMY
;
1262 sym
->attr
.proc
= PROC_EXTERNAL
;
1266 if (sym
->attr
.proc
== PROC_MODULE
1267 || sym
->attr
.proc
== PROC_ST_FUNCTION
1268 || sym
->attr
.proc
== PROC_INTERNAL
)
1271 if (sym
->attr
.intrinsic
)
1273 m
= gfc_intrinsic_func_interface (expr
, 1);
1278 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1279 "an intrinsic", sym
->name
, &expr
->where
);
1287 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1290 expr
->value
.function
.name
= sym
->name
;
1291 expr
->value
.function
.esym
= sym
;
1292 if (sym
->as
!= NULL
)
1293 expr
->rank
= sym
->as
->rank
;
1300 resolve_specific_f (gfc_expr
* expr
)
1305 sym
= expr
->symtree
->n
.sym
;
1309 m
= resolve_specific_f0 (sym
, expr
);
1312 if (m
== MATCH_ERROR
)
1315 if (sym
->ns
->parent
== NULL
)
1318 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1324 gfc_error ("Unable to resolve the specific function '%s' at %L",
1325 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1331 /* Resolve a procedure call not known to be generic nor specific. */
1334 resolve_unknown_f (gfc_expr
* expr
)
1339 sym
= expr
->symtree
->n
.sym
;
1341 if (sym
->attr
.dummy
)
1343 sym
->attr
.proc
= PROC_DUMMY
;
1344 expr
->value
.function
.name
= sym
->name
;
1348 /* See if we have an intrinsic function reference. */
1350 if (gfc_intrinsic_name (sym
->name
, 0))
1352 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1357 /* The reference is to an external name. */
1359 sym
->attr
.proc
= PROC_EXTERNAL
;
1360 expr
->value
.function
.name
= sym
->name
;
1361 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1363 if (sym
->as
!= NULL
)
1364 expr
->rank
= sym
->as
->rank
;
1366 /* Type of the expression is either the type of the symbol or the
1367 default type of the symbol. */
1370 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1372 if (sym
->ts
.type
!= BT_UNKNOWN
)
1376 ts
= gfc_get_default_type (sym
, sym
->ns
);
1378 if (ts
->type
== BT_UNKNOWN
)
1380 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1381 sym
->name
, &expr
->where
);
1392 /* Figure out if a function reference is pure or not. Also set the name
1393 of the function for a potential error message. Return nonzero if the
1394 function is PURE, zero if not. */
1397 pure_function (gfc_expr
* e
, const char **name
)
1401 if (e
->value
.function
.esym
)
1403 pure
= gfc_pure (e
->value
.function
.esym
);
1404 *name
= e
->value
.function
.esym
->name
;
1406 else if (e
->value
.function
.isym
)
1408 pure
= e
->value
.function
.isym
->pure
1409 || e
->value
.function
.isym
->elemental
;
1410 *name
= e
->value
.function
.isym
->name
;
1414 /* Implicit functions are not pure. */
1416 *name
= e
->value
.function
.name
;
1423 /* Resolve a function call, which means resolving the arguments, then figuring
1424 out which entity the name refers to. */
1425 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1426 to INTENT(OUT) or INTENT(INOUT). */
1429 resolve_function (gfc_expr
* expr
)
1431 gfc_actual_arglist
*arg
;
1439 sym
= expr
->symtree
->n
.sym
;
1441 /* If the procedure is not internal, a statement function or a module
1442 procedure,it must be external and should be checked for usage. */
1443 if (sym
&& !sym
->attr
.dummy
&& !sym
->attr
.contained
1444 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1445 && !sym
->attr
.use_assoc
)
1446 resolve_global_procedure (sym
, &expr
->where
, 0);
1448 /* Switch off assumed size checking and do this again for certain kinds
1449 of procedure, once the procedure itself is resolved. */
1450 need_full_assumed_size
++;
1452 if (resolve_actual_arglist (expr
->value
.function
.actual
) == FAILURE
)
1455 /* Resume assumed_size checking. */
1456 need_full_assumed_size
--;
1458 if (sym
&& sym
->ts
.type
== BT_CHARACTER
1460 && sym
->ts
.cl
->length
== NULL
1462 && expr
->value
.function
.esym
== NULL
1463 && !sym
->attr
.contained
)
1465 /* Internal procedures are taken care of in resolve_contained_fntype. */
1466 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1467 "be used at %L since it is not a dummy argument",
1468 sym
->name
, &expr
->where
);
1472 /* See if function is already resolved. */
1474 if (expr
->value
.function
.name
!= NULL
)
1476 if (expr
->ts
.type
== BT_UNKNOWN
)
1482 /* Apply the rules of section 14.1.2. */
1484 switch (procedure_kind (sym
))
1487 t
= resolve_generic_f (expr
);
1490 case PTYPE_SPECIFIC
:
1491 t
= resolve_specific_f (expr
);
1495 t
= resolve_unknown_f (expr
);
1499 gfc_internal_error ("resolve_function(): bad function type");
1503 /* If the expression is still a function (it might have simplified),
1504 then we check to see if we are calling an elemental function. */
1506 if (expr
->expr_type
!= EXPR_FUNCTION
)
1509 temp
= need_full_assumed_size
;
1510 need_full_assumed_size
= 0;
1512 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
1515 if (omp_workshare_flag
1516 && expr
->value
.function
.esym
1517 && ! gfc_elemental (expr
->value
.function
.esym
))
1519 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1520 " in WORKSHARE construct", expr
->value
.function
.esym
->name
,
1525 else if (expr
->value
.function
.actual
!= NULL
1526 && expr
->value
.function
.isym
!= NULL
1527 && expr
->value
.function
.isym
->generic_id
!= GFC_ISYM_LBOUND
1528 && expr
->value
.function
.isym
->generic_id
!= GFC_ISYM_LOC
1529 && expr
->value
.function
.isym
->generic_id
!= GFC_ISYM_PRESENT
)
1531 /* Array intrinsics must also have the last upper bound of an
1532 assumed size array argument. UBOUND and SIZE have to be
1533 excluded from the check if the second argument is anything
1536 inquiry
= expr
->value
.function
.isym
->generic_id
== GFC_ISYM_UBOUND
1537 || expr
->value
.function
.isym
->generic_id
== GFC_ISYM_SIZE
;
1539 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1541 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
1542 && arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
1545 if (arg
->expr
!= NULL
1546 && arg
->expr
->rank
> 0
1547 && resolve_assumed_size_actual (arg
->expr
))
1552 need_full_assumed_size
= temp
;
1554 if (!pure_function (expr
, &name
) && name
)
1559 ("reference to non-PURE function '%s' at %L inside a "
1560 "FORALL %s", name
, &expr
->where
, forall_flag
== 2 ?
1564 else if (gfc_pure (NULL
))
1566 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1567 "procedure within a PURE procedure", name
, &expr
->where
);
1572 /* Functions without the RECURSIVE attribution are not allowed to
1573 * call themselves. */
1574 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
1576 gfc_symbol
*esym
, *proc
;
1577 esym
= expr
->value
.function
.esym
;
1578 proc
= gfc_current_ns
->proc_name
;
1581 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1582 "RECURSIVE", name
, &expr
->where
);
1586 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
1587 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1589 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1590 "'%s' is not declared as RECURSIVE",
1591 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
1596 /* Character lengths of use associated functions may contains references to
1597 symbols not referenced from the current program unit otherwise. Make sure
1598 those symbols are marked as referenced. */
1600 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
1601 && expr
->value
.function
.esym
->attr
.use_assoc
)
1603 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
1607 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1608 expr
->value
.function
.actual
);
1613 /************* Subroutine resolution *************/
1616 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1623 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1624 sym
->name
, &c
->loc
);
1625 else if (gfc_pure (NULL
))
1626 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1632 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1636 if (sym
->attr
.generic
)
1638 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1641 c
->resolved_sym
= s
;
1642 pure_subroutine (c
, s
);
1646 /* TODO: Need to search for elemental references in generic interface. */
1649 if (sym
->attr
.intrinsic
)
1650 return gfc_intrinsic_sub_interface (c
, 0);
1657 resolve_generic_s (gfc_code
* c
)
1662 sym
= c
->symtree
->n
.sym
;
1666 m
= resolve_generic_s0 (c
, sym
);
1669 else if (m
== MATCH_ERROR
)
1673 if (sym
->ns
->parent
== NULL
)
1675 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1679 if (!generic_sym (sym
))
1683 /* Last ditch attempt. */
1684 sym
= c
->symtree
->n
.sym
;
1685 if (!gfc_generic_intrinsic (sym
->name
))
1688 ("There is no specific subroutine for the generic '%s' at %L",
1689 sym
->name
, &c
->loc
);
1693 m
= gfc_intrinsic_sub_interface (c
, 0);
1697 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1698 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1704 /* Resolve a subroutine call known to be specific. */
1707 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1711 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1713 if (sym
->attr
.dummy
)
1715 sym
->attr
.proc
= PROC_DUMMY
;
1719 sym
->attr
.proc
= PROC_EXTERNAL
;
1723 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1726 if (sym
->attr
.intrinsic
)
1728 m
= gfc_intrinsic_sub_interface (c
, 1);
1732 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1733 "with an intrinsic", sym
->name
, &c
->loc
);
1741 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1743 c
->resolved_sym
= sym
;
1744 pure_subroutine (c
, sym
);
1751 resolve_specific_s (gfc_code
* c
)
1756 sym
= c
->symtree
->n
.sym
;
1760 m
= resolve_specific_s0 (c
, sym
);
1763 if (m
== MATCH_ERROR
)
1766 if (sym
->ns
->parent
== NULL
)
1769 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1775 sym
= c
->symtree
->n
.sym
;
1776 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1777 sym
->name
, &c
->loc
);
1783 /* Resolve a subroutine call not known to be generic nor specific. */
1786 resolve_unknown_s (gfc_code
* c
)
1790 sym
= c
->symtree
->n
.sym
;
1792 if (sym
->attr
.dummy
)
1794 sym
->attr
.proc
= PROC_DUMMY
;
1798 /* See if we have an intrinsic function reference. */
1800 if (gfc_intrinsic_name (sym
->name
, 1))
1802 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1807 /* The reference is to an external name. */
1810 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1812 c
->resolved_sym
= sym
;
1814 pure_subroutine (c
, sym
);
1820 /* Resolve a subroutine call. Although it was tempting to use the same code
1821 for functions, subroutines and functions are stored differently and this
1822 makes things awkward. */
1825 resolve_call (gfc_code
* c
)
1829 if (c
->symtree
&& c
->symtree
->n
.sym
1830 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
1832 gfc_error ("'%s' at %L has a type, which is not consistent with "
1833 "the CALL at %L", c
->symtree
->n
.sym
->name
,
1834 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
1838 /* If the procedure is not internal or module, it must be external and
1839 should be checked for usage. */
1840 if (c
->symtree
&& c
->symtree
->n
.sym
1841 && !c
->symtree
->n
.sym
->attr
.dummy
1842 && !c
->symtree
->n
.sym
->attr
.contained
1843 && !c
->symtree
->n
.sym
->attr
.use_assoc
)
1844 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
1846 /* Subroutines without the RECURSIVE attribution are not allowed to
1847 * call themselves. */
1848 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
1850 gfc_symbol
*csym
, *proc
;
1851 csym
= c
->symtree
->n
.sym
;
1852 proc
= gfc_current_ns
->proc_name
;
1855 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1856 "RECURSIVE", csym
->name
, &c
->loc
);
1860 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
1861 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1863 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1864 "'%s' is not declared as RECURSIVE",
1865 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
1870 /* Switch off assumed size checking and do this again for certain kinds
1871 of procedure, once the procedure itself is resolved. */
1872 need_full_assumed_size
++;
1874 if (resolve_actual_arglist (c
->ext
.actual
) == FAILURE
)
1877 /* Resume assumed_size checking. */
1878 need_full_assumed_size
--;
1882 if (c
->resolved_sym
== NULL
)
1883 switch (procedure_kind (c
->symtree
->n
.sym
))
1886 t
= resolve_generic_s (c
);
1889 case PTYPE_SPECIFIC
:
1890 t
= resolve_specific_s (c
);
1894 t
= resolve_unknown_s (c
);
1898 gfc_internal_error ("resolve_subroutine(): bad function type");
1901 /* Some checks of elemental subroutine actual arguments. */
1902 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
1906 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
1910 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1911 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1912 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1913 if their shapes do not match. If either op1->shape or op2->shape is
1914 NULL, return SUCCESS. */
1917 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
1924 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
1926 for (i
= 0; i
< op1
->rank
; i
++)
1928 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
1930 gfc_error ("Shapes for operands at %L and %L are not conformable",
1931 &op1
->where
, &op2
->where
);
1941 /* Resolve an operator expression node. This can involve replacing the
1942 operation with a user defined function call. */
1945 resolve_operator (gfc_expr
* e
)
1947 gfc_expr
*op1
, *op2
;
1951 /* Resolve all subnodes-- give them types. */
1953 switch (e
->value
.op
.operator)
1956 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
1959 /* Fall through... */
1962 case INTRINSIC_UPLUS
:
1963 case INTRINSIC_UMINUS
:
1964 case INTRINSIC_PARENTHESES
:
1965 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
1970 /* Typecheck the new node. */
1972 op1
= e
->value
.op
.op1
;
1973 op2
= e
->value
.op
.op2
;
1975 switch (e
->value
.op
.operator)
1977 case INTRINSIC_UPLUS
:
1978 case INTRINSIC_UMINUS
:
1979 if (op1
->ts
.type
== BT_INTEGER
1980 || op1
->ts
.type
== BT_REAL
1981 || op1
->ts
.type
== BT_COMPLEX
)
1987 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
1988 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
1991 case INTRINSIC_PLUS
:
1992 case INTRINSIC_MINUS
:
1993 case INTRINSIC_TIMES
:
1994 case INTRINSIC_DIVIDE
:
1995 case INTRINSIC_POWER
:
1996 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
1998 gfc_type_convert_binary (e
);
2003 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2004 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2005 gfc_typename (&op2
->ts
));
2008 case INTRINSIC_CONCAT
:
2009 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2011 e
->ts
.type
= BT_CHARACTER
;
2012 e
->ts
.kind
= op1
->ts
.kind
;
2017 _("Operands of string concatenation operator at %%L are %s/%s"),
2018 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2024 case INTRINSIC_NEQV
:
2025 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2027 e
->ts
.type
= BT_LOGICAL
;
2028 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2029 if (op1
->ts
.kind
< e
->ts
.kind
)
2030 gfc_convert_type (op1
, &e
->ts
, 2);
2031 else if (op2
->ts
.kind
< e
->ts
.kind
)
2032 gfc_convert_type (op2
, &e
->ts
, 2);
2036 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2037 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2038 gfc_typename (&op2
->ts
));
2043 if (op1
->ts
.type
== BT_LOGICAL
)
2045 e
->ts
.type
= BT_LOGICAL
;
2046 e
->ts
.kind
= op1
->ts
.kind
;
2050 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
2051 gfc_typename (&op1
->ts
));
2058 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2060 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2064 /* Fall through... */
2068 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2070 e
->ts
.type
= BT_LOGICAL
;
2071 e
->ts
.kind
= gfc_default_logical_kind
;
2075 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2077 gfc_type_convert_binary (e
);
2079 e
->ts
.type
= BT_LOGICAL
;
2080 e
->ts
.kind
= gfc_default_logical_kind
;
2084 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2086 _("Logicals at %%L must be compared with %s instead of %s"),
2087 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
2088 gfc_op2string (e
->value
.op
.operator));
2091 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2092 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2093 gfc_typename (&op2
->ts
));
2097 case INTRINSIC_USER
:
2099 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2100 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2102 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2103 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2104 gfc_typename (&op2
->ts
));
2108 case INTRINSIC_PARENTHESES
:
2112 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2115 /* Deal with arrayness of an operand through an operator. */
2119 switch (e
->value
.op
.operator)
2121 case INTRINSIC_PLUS
:
2122 case INTRINSIC_MINUS
:
2123 case INTRINSIC_TIMES
:
2124 case INTRINSIC_DIVIDE
:
2125 case INTRINSIC_POWER
:
2126 case INTRINSIC_CONCAT
:
2130 case INTRINSIC_NEQV
:
2138 if (op1
->rank
== 0 && op2
->rank
== 0)
2141 if (op1
->rank
== 0 && op2
->rank
!= 0)
2143 e
->rank
= op2
->rank
;
2145 if (e
->shape
== NULL
)
2146 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2149 if (op1
->rank
!= 0 && op2
->rank
== 0)
2151 e
->rank
= op1
->rank
;
2153 if (e
->shape
== NULL
)
2154 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2157 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2159 if (op1
->rank
== op2
->rank
)
2161 e
->rank
= op1
->rank
;
2162 if (e
->shape
== NULL
)
2164 t
= compare_shapes(op1
, op2
);
2168 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2173 gfc_error ("Inconsistent ranks for operator at %L and %L",
2174 &op1
->where
, &op2
->where
);
2177 /* Allow higher level expressions to work. */
2185 case INTRINSIC_UPLUS
:
2186 case INTRINSIC_UMINUS
:
2187 case INTRINSIC_PARENTHESES
:
2188 e
->rank
= op1
->rank
;
2190 if (e
->shape
== NULL
)
2191 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2193 /* Simply copy arrayness attribute */
2200 /* Attempt to simplify the expression. */
2202 t
= gfc_simplify_expr (e
, 0);
2207 if (gfc_extend_expr (e
) == SUCCESS
)
2210 gfc_error (msg
, &e
->where
);
2216 /************** Array resolution subroutines **************/
2220 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
2223 /* Compare two integer expressions. */
2226 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
2230 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
2231 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
2234 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
2235 gfc_internal_error ("compare_bound(): Bad expression");
2237 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
2247 /* Compare an integer expression with an integer. */
2250 compare_bound_int (gfc_expr
* a
, int b
)
2254 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2257 if (a
->ts
.type
!= BT_INTEGER
)
2258 gfc_internal_error ("compare_bound_int(): Bad expression");
2260 i
= mpz_cmp_si (a
->value
.integer
, b
);
2270 /* Compare an integer expression with a mpz_t. */
2273 compare_bound_mpz_t (gfc_expr
* a
, mpz_t b
)
2277 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2280 if (a
->ts
.type
!= BT_INTEGER
)
2281 gfc_internal_error ("compare_bound_int(): Bad expression");
2283 i
= mpz_cmp (a
->value
.integer
, b
);
2293 /* Compute the last value of a sequence given by a triplet.
2294 Return 0 if it wasn't able to compute the last value, or if the
2295 sequence if empty, and 1 otherwise. */
2298 compute_last_value_for_triplet (gfc_expr
* start
, gfc_expr
* end
,
2299 gfc_expr
* stride
, mpz_t last
)
2303 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
2304 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2305 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
2308 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
2309 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
2312 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
2314 if (compare_bound (start
, end
) == CMP_GT
)
2316 mpz_set (last
, end
->value
.integer
);
2320 if (compare_bound_int (stride
, 0) == CMP_GT
)
2322 /* Stride is positive */
2323 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
2328 /* Stride is negative */
2329 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
2334 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
2335 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
2336 mpz_sub (last
, end
->value
.integer
, rem
);
2343 /* Compare a single dimension of an array reference to the array
2347 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
2351 /* Given start, end and stride values, calculate the minimum and
2352 maximum referenced indexes. */
2360 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2362 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2368 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
2370 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
2374 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2375 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2377 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
2378 && (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
2379 || compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
))
2382 if (((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
2383 || ar
->stride
[i
] == NULL
)
2384 && compare_bound (AR_START
, AR_END
) != CMP_GT
)
2385 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
2386 && compare_bound (AR_START
, AR_END
) != CMP_LT
))
2388 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
2390 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
2394 mpz_init (last_value
);
2395 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
2398 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
2399 || compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
2401 mpz_clear (last_value
);
2405 mpz_clear (last_value
);
2413 gfc_internal_error ("check_dimension(): Bad array reference");
2419 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
2424 /* Compare an array reference with an array specification. */
2427 compare_spec_to_ref (gfc_array_ref
* ar
)
2434 /* TODO: Full array sections are only allowed as actual parameters. */
2435 if (as
->type
== AS_ASSUMED_SIZE
2436 && (/*ar->type == AR_FULL
2437 ||*/ (ar
->type
== AR_SECTION
2438 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
2440 gfc_error ("Rightmost upper bound of assumed size array section"
2441 " not specified at %L", &ar
->where
);
2445 if (ar
->type
== AR_FULL
)
2448 if (as
->rank
!= ar
->dimen
)
2450 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2451 &ar
->where
, ar
->dimen
, as
->rank
);
2455 for (i
= 0; i
< as
->rank
; i
++)
2456 if (check_dimension (i
, ar
, as
) == FAILURE
)
2463 /* Resolve one part of an array index. */
2466 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
2473 if (gfc_resolve_expr (index
) == FAILURE
)
2476 if (check_scalar
&& index
->rank
!= 0)
2478 gfc_error ("Array index at %L must be scalar", &index
->where
);
2482 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
2484 gfc_error ("Array index at %L must be of INTEGER type",
2489 if (index
->ts
.type
== BT_REAL
)
2490 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
2491 &index
->where
) == FAILURE
)
2494 if (index
->ts
.kind
!= gfc_index_integer_kind
2495 || index
->ts
.type
!= BT_INTEGER
)
2498 ts
.type
= BT_INTEGER
;
2499 ts
.kind
= gfc_index_integer_kind
;
2501 gfc_convert_type_warn (index
, &ts
, 2, 0);
2507 /* Resolve a dim argument to an intrinsic function. */
2510 gfc_resolve_dim_arg (gfc_expr
*dim
)
2515 if (gfc_resolve_expr (dim
) == FAILURE
)
2520 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
2524 if (dim
->ts
.type
!= BT_INTEGER
)
2526 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
2529 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
2533 ts
.type
= BT_INTEGER
;
2534 ts
.kind
= gfc_index_integer_kind
;
2536 gfc_convert_type_warn (dim
, &ts
, 2, 0);
2542 /* Given an expression that contains array references, update those array
2543 references to point to the right array specifications. While this is
2544 filled in during matching, this information is difficult to save and load
2545 in a module, so we take care of it here.
2547 The idea here is that the original array reference comes from the
2548 base symbol. We traverse the list of reference structures, setting
2549 the stored reference to references. Component references can
2550 provide an additional array specification. */
2553 find_array_spec (gfc_expr
* e
)
2557 gfc_symbol
*derived
;
2560 as
= e
->symtree
->n
.sym
->as
;
2563 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2568 gfc_internal_error ("find_array_spec(): Missing spec");
2575 if (derived
== NULL
)
2576 derived
= e
->symtree
->n
.sym
->ts
.derived
;
2578 c
= derived
->components
;
2580 for (; c
; c
= c
->next
)
2581 if (c
== ref
->u
.c
.component
)
2583 /* Track the sequence of component references. */
2584 if (c
->ts
.type
== BT_DERIVED
)
2585 derived
= c
->ts
.derived
;
2590 gfc_internal_error ("find_array_spec(): Component not found");
2595 gfc_internal_error ("find_array_spec(): unused as(1)");
2606 gfc_internal_error ("find_array_spec(): unused as(2)");
2610 /* Resolve an array reference. */
2613 resolve_array_ref (gfc_array_ref
* ar
)
2615 int i
, check_scalar
;
2618 for (i
= 0; i
< ar
->dimen
; i
++)
2620 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2622 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2624 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2626 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2631 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2635 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2639 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2640 if (e
->expr_type
== EXPR_VARIABLE
2641 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
2642 ar
->start
[i
] = gfc_get_parentheses (e
);
2646 gfc_error ("Array index at %L is an array of rank %d",
2647 &ar
->c_where
[i
], e
->rank
);
2652 /* If the reference type is unknown, figure out what kind it is. */
2654 if (ar
->type
== AR_UNKNOWN
)
2656 ar
->type
= AR_ELEMENT
;
2657 for (i
= 0; i
< ar
->dimen
; i
++)
2658 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2659 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2661 ar
->type
= AR_SECTION
;
2666 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2674 resolve_substring (gfc_ref
* ref
)
2677 if (ref
->u
.ss
.start
!= NULL
)
2679 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2682 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2684 gfc_error ("Substring start index at %L must be of type INTEGER",
2685 &ref
->u
.ss
.start
->where
);
2689 if (ref
->u
.ss
.start
->rank
!= 0)
2691 gfc_error ("Substring start index at %L must be scalar",
2692 &ref
->u
.ss
.start
->where
);
2696 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
2697 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2698 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2700 gfc_error ("Substring start index at %L is less than one",
2701 &ref
->u
.ss
.start
->where
);
2706 if (ref
->u
.ss
.end
!= NULL
)
2708 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2711 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2713 gfc_error ("Substring end index at %L must be of type INTEGER",
2714 &ref
->u
.ss
.end
->where
);
2718 if (ref
->u
.ss
.end
->rank
!= 0)
2720 gfc_error ("Substring end index at %L must be scalar",
2721 &ref
->u
.ss
.end
->where
);
2725 if (ref
->u
.ss
.length
!= NULL
2726 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
2727 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2728 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2730 gfc_error ("Substring end index at %L exceeds the string length",
2731 &ref
->u
.ss
.start
->where
);
2740 /* Resolve subtype references. */
2743 resolve_ref (gfc_expr
* expr
)
2745 int current_part_dimension
, n_components
, seen_part_dimension
;
2748 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2749 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2751 find_array_spec (expr
);
2755 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2759 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2767 resolve_substring (ref
);
2771 /* Check constraints on part references. */
2773 current_part_dimension
= 0;
2774 seen_part_dimension
= 0;
2777 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2782 switch (ref
->u
.ar
.type
)
2786 current_part_dimension
= 1;
2790 current_part_dimension
= 0;
2794 gfc_internal_error ("resolve_ref(): Bad array reference");
2800 if ((current_part_dimension
|| seen_part_dimension
)
2801 && ref
->u
.c
.component
->pointer
)
2804 ("Component to the right of a part reference with nonzero "
2805 "rank must not have the POINTER attribute at %L",
2817 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2818 || ref
->next
== NULL
)
2819 && current_part_dimension
2820 && seen_part_dimension
)
2823 gfc_error ("Two or more part references with nonzero rank must "
2824 "not be specified at %L", &expr
->where
);
2828 if (ref
->type
== REF_COMPONENT
)
2830 if (current_part_dimension
)
2831 seen_part_dimension
= 1;
2833 /* reset to make sure */
2834 current_part_dimension
= 0;
2842 /* Given an expression, determine its shape. This is easier than it sounds.
2843 Leaves the shape array NULL if it is not possible to determine the shape. */
2846 expression_shape (gfc_expr
* e
)
2848 mpz_t array
[GFC_MAX_DIMENSIONS
];
2851 if (e
->rank
== 0 || e
->shape
!= NULL
)
2854 for (i
= 0; i
< e
->rank
; i
++)
2855 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2858 e
->shape
= gfc_get_shape (e
->rank
);
2860 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
2865 for (i
--; i
>= 0; i
--)
2866 mpz_clear (array
[i
]);
2870 /* Given a variable expression node, compute the rank of the expression by
2871 examining the base symbol and any reference structures it may have. */
2874 expression_rank (gfc_expr
* e
)
2881 if (e
->expr_type
== EXPR_ARRAY
)
2883 /* Constructors can have a rank different from one via RESHAPE(). */
2885 if (e
->symtree
== NULL
)
2891 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
2892 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
2898 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2900 if (ref
->type
!= REF_ARRAY
)
2903 if (ref
->u
.ar
.type
== AR_FULL
)
2905 rank
= ref
->u
.ar
.as
->rank
;
2909 if (ref
->u
.ar
.type
== AR_SECTION
)
2911 /* Figure out the rank of the section. */
2913 gfc_internal_error ("expression_rank(): Two array specs");
2915 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2916 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
2917 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
2927 expression_shape (e
);
2931 /* Resolve a variable expression. */
2934 resolve_variable (gfc_expr
* e
)
2941 if (e
->symtree
== NULL
)
2944 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
2947 sym
= e
->symtree
->n
.sym
;
2948 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
2950 e
->ts
.type
= BT_PROCEDURE
;
2954 if (sym
->ts
.type
!= BT_UNKNOWN
)
2955 gfc_variable_attr (e
, &e
->ts
);
2958 /* Must be a simple variable reference. */
2959 if (gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2964 if (check_assumed_size_reference (sym
, e
))
2967 /* Deal with forward references to entries during resolve_code, to
2968 satisfy, at least partially, 12.5.2.5. */
2969 if (gfc_current_ns
->entries
2970 && current_entry_id
== sym
->entry_id
2973 && cs_base
->current
->op
!= EXEC_ENTRY
)
2975 gfc_entry_list
*entry
;
2976 gfc_formal_arglist
*formal
;
2980 /* If the symbol is a dummy... */
2981 if (sym
->attr
.dummy
)
2983 entry
= gfc_current_ns
->entries
;
2986 /* ...test if the symbol is a parameter of previous entries. */
2987 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
2988 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
2990 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
2994 /* If it has not been seen as a dummy, this is an error. */
2997 if (specification_expr
)
2998 gfc_error ("Variable '%s',used in a specification expression, "
2999 "is referenced at %L before the ENTRY statement "
3000 "in which it is a parameter",
3001 sym
->name
, &cs_base
->current
->loc
);
3003 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3004 "statement in which it is a parameter",
3005 sym
->name
, &cs_base
->current
->loc
);
3010 /* Now do the same check on the specification expressions. */
3011 specification_expr
= 1;
3012 if (sym
->ts
.type
== BT_CHARACTER
3013 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3017 for (n
= 0; n
< sym
->as
->rank
; n
++)
3019 specification_expr
= 1;
3020 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3022 specification_expr
= 1;
3023 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3026 specification_expr
= 0;
3029 /* Update the symbol's entry level. */
3030 sym
->entry_id
= current_entry_id
+ 1;
3037 /* Resolve an expression. That is, make sure that types of operands agree
3038 with their operators, intrinsic operators are converted to function calls
3039 for overloaded types and unresolved function references are resolved. */
3042 gfc_resolve_expr (gfc_expr
* e
)
3049 switch (e
->expr_type
)
3052 t
= resolve_operator (e
);
3056 t
= resolve_function (e
);
3060 t
= resolve_variable (e
);
3062 expression_rank (e
);
3065 case EXPR_SUBSTRING
:
3066 t
= resolve_ref (e
);
3076 if (resolve_ref (e
) == FAILURE
)
3079 t
= gfc_resolve_array_constructor (e
);
3080 /* Also try to expand a constructor. */
3083 expression_rank (e
);
3084 gfc_expand_constructor (e
);
3087 /* This provides the opportunity for the length of constructors with character
3088 valued function elements to propogate the string length to the expression. */
3089 if (e
->ts
.type
== BT_CHARACTER
)
3090 gfc_resolve_character_array_constructor (e
);
3094 case EXPR_STRUCTURE
:
3095 t
= resolve_ref (e
);
3099 t
= resolve_structure_cons (e
);
3103 t
= gfc_simplify_expr (e
, 0);
3107 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3114 /* Resolve an expression from an iterator. They must be scalar and have
3115 INTEGER or (optionally) REAL type. */
3118 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
,
3119 const char * name_msgid
)
3121 if (gfc_resolve_expr (expr
) == FAILURE
)
3124 if (expr
->rank
!= 0)
3126 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
3130 if (!(expr
->ts
.type
== BT_INTEGER
3131 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
3134 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
3137 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
3144 /* Resolve the expressions in an iterator structure. If REAL_OK is
3145 false allow only INTEGER type iterators, otherwise allow REAL types. */
3148 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
3151 if (iter
->var
->ts
.type
== BT_REAL
)
3152 gfc_notify_std (GFC_STD_F95_DEL
,
3153 "Obsolete: REAL DO loop iterator at %L",
3156 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
3160 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
3162 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3167 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
3168 "Start expression in DO loop") == FAILURE
)
3171 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
3172 "End expression in DO loop") == FAILURE
)
3175 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
3176 "Step expression in DO loop") == FAILURE
)
3179 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
3181 if ((iter
->step
->ts
.type
== BT_INTEGER
3182 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
3183 || (iter
->step
->ts
.type
== BT_REAL
3184 && mpfr_sgn (iter
->step
->value
.real
) == 0))
3186 gfc_error ("Step expression in DO loop at %L cannot be zero",
3187 &iter
->step
->where
);
3192 /* Convert start, end, and step to the same type as var. */
3193 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
3194 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
3195 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3197 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
3198 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
3199 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3201 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
3202 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
3203 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
3209 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3210 to be a scalar INTEGER variable. The subscripts and stride are scalar
3211 INTEGERs, and if stride is a constant it must be nonzero. */
3214 resolve_forall_iterators (gfc_forall_iterator
* iter
)
3219 if (gfc_resolve_expr (iter
->var
) == SUCCESS
3220 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
3221 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3224 if (gfc_resolve_expr (iter
->start
) == SUCCESS
3225 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
3226 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3227 &iter
->start
->where
);
3228 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
3229 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3231 if (gfc_resolve_expr (iter
->end
) == SUCCESS
3232 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
3233 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3235 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
3236 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3238 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
3240 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
3241 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3242 &iter
->stride
->where
, "INTEGER");
3244 if (iter
->stride
->expr_type
== EXPR_CONSTANT
3245 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
3246 gfc_error ("FORALL stride expression at %L cannot be zero",
3247 &iter
->stride
->where
);
3249 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
3250 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
3257 /* Given a pointer to a symbol that is a derived type, see if any components
3258 have the POINTER attribute. The search is recursive if necessary.
3259 Returns zero if no pointer components are found, nonzero otherwise. */
3262 derived_pointer (gfc_symbol
* sym
)
3266 for (c
= sym
->components
; c
; c
= c
->next
)
3271 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
3279 /* Given a pointer to a symbol that is a derived type, see if it's
3280 inaccessible, i.e. if it's defined in another module and the components are
3281 PRIVATE. The search is recursive if necessary. Returns zero if no
3282 inaccessible components are found, nonzero otherwise. */
3285 derived_inaccessible (gfc_symbol
*sym
)
3289 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
3292 for (c
= sym
->components
; c
; c
= c
->next
)
3294 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
3302 /* Resolve the argument of a deallocate expression. The expression must be
3303 a pointer or a full array. */
3306 resolve_deallocate_expr (gfc_expr
* e
)
3308 symbol_attribute attr
;
3312 if (gfc_resolve_expr (e
) == FAILURE
)
3315 attr
= gfc_expr_attr (e
);
3319 if (e
->expr_type
!= EXPR_VARIABLE
)
3322 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3323 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3327 if (ref
->u
.ar
.type
!= AR_FULL
)
3332 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3333 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3341 if (allocatable
== 0)
3344 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3345 "ALLOCATABLE or a POINTER", &e
->where
);
3348 if (e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3350 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3351 e
->symtree
->n
.sym
->name
, &e
->where
);
3358 /* Returns true if the expression e contains a reference the symbol sym. */
3360 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
3362 gfc_actual_arglist
*arg
;
3370 switch (e
->expr_type
)
3373 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3374 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
3377 /* If the variable is not the same as the dependent, 'sym', and
3378 it is not marked as being declared and it is in the same
3379 namespace as 'sym', add it to the local declarations. */
3381 if (sym
== e
->symtree
->n
.sym
)
3386 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
3387 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
3396 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3401 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3403 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
3404 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
3405 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
3410 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
3411 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
3415 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3416 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3418 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->ts
.cl
->length
);
3420 if (ref
->u
.c
.component
->as
)
3421 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3423 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->as
->lower
[i
]);
3424 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->as
->upper
[i
]);
3434 /* Given the expression node e for an allocatable/pointer of derived type to be
3435 allocated, get the expression node to be initialized afterwards (needed for
3436 derived types with default initializers, and derived types with allocatable
3437 components that need nullification.) */
3440 expr_to_initialize (gfc_expr
* e
)
3446 result
= gfc_copy_expr (e
);
3448 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3449 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
3450 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3452 ref
->u
.ar
.type
= AR_FULL
;
3454 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3455 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
3457 result
->rank
= ref
->u
.ar
.dimen
;
3465 /* Resolve the expression in an ALLOCATE statement, doing the additional
3466 checks to see whether the expression is OK or not. The expression must
3467 have a trailing array reference that gives the size of the array. */
3470 resolve_allocate_expr (gfc_expr
* e
, gfc_code
* code
)
3472 int i
, pointer
, allocatable
, dimension
;
3473 symbol_attribute attr
;
3474 gfc_ref
*ref
, *ref2
;
3481 if (gfc_resolve_expr (e
) == FAILURE
)
3484 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
3485 sym
= code
->expr
->symtree
->n
.sym
;
3489 /* Make sure the expression is allocatable or a pointer. If it is
3490 pointer, the next-to-last reference must be a pointer. */
3494 if (e
->expr_type
!= EXPR_VARIABLE
)
3498 attr
= gfc_expr_attr (e
);
3499 pointer
= attr
.pointer
;
3500 dimension
= attr
.dimension
;
3505 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3506 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3507 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
3509 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
3511 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3512 "not be allocated in the same statement at %L",
3513 sym
->name
, &e
->where
);
3517 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
3521 if (ref
->next
!= NULL
)
3526 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3527 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3529 pointer
= ref
->u
.c
.component
->pointer
;
3530 dimension
= ref
->u
.c
.component
->dimension
;
3540 if (allocatable
== 0 && pointer
== 0)
3542 gfc_error ("Expression in ALLOCATE statement at %L must be "
3543 "ALLOCATABLE or a POINTER", &e
->where
);
3547 if (e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3549 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3550 e
->symtree
->n
.sym
->name
, &e
->where
);
3554 /* Add default initializer for those derived types that need them. */
3555 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
3557 init_st
= gfc_get_code ();
3558 init_st
->loc
= code
->loc
;
3559 init_st
->op
= EXEC_INIT_ASSIGN
;
3560 init_st
->expr
= expr_to_initialize (e
);
3561 init_st
->expr2
= init_e
;
3562 init_st
->next
= code
->next
;
3563 code
->next
= init_st
;
3566 if (pointer
&& dimension
== 0)
3569 /* Make sure the next-to-last reference node is an array specification. */
3571 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
3573 gfc_error ("Array specification required in ALLOCATE statement "
3574 "at %L", &e
->where
);
3578 /* Make sure that the array section reference makes sense in the
3579 context of an ALLOCATE specification. */
3583 for (i
= 0; i
< ar
->dimen
; i
++)
3585 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
3588 switch (ar
->dimen_type
[i
])
3594 if (ar
->start
[i
] != NULL
3595 && ar
->end
[i
] != NULL
3596 && ar
->stride
[i
] == NULL
)
3599 /* Fall Through... */
3603 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3610 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3612 sym
= a
->expr
->symtree
->n
.sym
;
3614 /* TODO - check derived type components. */
3615 if (sym
->ts
.type
== BT_DERIVED
)
3618 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
3619 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
3621 gfc_error ("'%s' must not appear an the array specification at "
3622 "%L in the same ALLOCATE statement where it is "
3623 "itself allocated", sym
->name
, &ar
->where
);
3633 /************ SELECT CASE resolution subroutines ************/
3635 /* Callback function for our mergesort variant. Determines interval
3636 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3637 op1 > op2. Assumes we're not dealing with the default case.
3638 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3639 There are nine situations to check. */
3642 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
3646 if (op1
->low
== NULL
) /* op1 = (:L) */
3648 /* op2 = (:N), so overlap. */
3650 /* op2 = (M:) or (M:N), L < M */
3651 if (op2
->low
!= NULL
3652 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3655 else if (op1
->high
== NULL
) /* op1 = (K:) */
3657 /* op2 = (M:), so overlap. */
3659 /* op2 = (:N) or (M:N), K > N */
3660 if (op2
->high
!= NULL
3661 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3664 else /* op1 = (K:L) */
3666 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
3667 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
3668 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
3669 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
3670 else /* op2 = (M:N) */
3674 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3677 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3686 /* Merge-sort a double linked case list, detecting overlap in the
3687 process. LIST is the head of the double linked case list before it
3688 is sorted. Returns the head of the sorted list if we don't see any
3689 overlap, or NULL otherwise. */
3692 check_case_overlap (gfc_case
* list
)
3694 gfc_case
*p
, *q
, *e
, *tail
;
3695 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
3697 /* If the passed list was empty, return immediately. */
3704 /* Loop unconditionally. The only exit from this loop is a return
3705 statement, when we've finished sorting the case list. */
3712 /* Count the number of merges we do in this pass. */
3715 /* Loop while there exists a merge to be done. */
3720 /* Count this merge. */
3723 /* Cut the list in two pieces by stepping INSIZE places
3724 forward in the list, starting from P. */
3727 for (i
= 0; i
< insize
; i
++)
3736 /* Now we have two lists. Merge them! */
3737 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
3740 /* See from which the next case to merge comes from. */
3743 /* P is empty so the next case must come from Q. */
3748 else if (qsize
== 0 || q
== NULL
)
3757 cmp
= compare_cases (p
, q
);
3760 /* The whole case range for P is less than the
3768 /* The whole case range for Q is greater than
3769 the case range for P. */
3776 /* The cases overlap, or they are the same
3777 element in the list. Either way, we must
3778 issue an error and get the next case from P. */
3779 /* FIXME: Sort P and Q by line number. */
3780 gfc_error ("CASE label at %L overlaps with CASE "
3781 "label at %L", &p
->where
, &q
->where
);
3789 /* Add the next element to the merged list. */
3798 /* P has now stepped INSIZE places along, and so has Q. So
3799 they're the same. */
3804 /* If we have done only one merge or none at all, we've
3805 finished sorting the cases. */
3814 /* Otherwise repeat, merging lists twice the size. */
3820 /* Check to see if an expression is suitable for use in a CASE statement.
3821 Makes sure that all case expressions are scalar constants of the same
3822 type. Return FAILURE if anything is wrong. */
3825 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
3827 if (e
== NULL
) return SUCCESS
;
3829 if (e
->ts
.type
!= case_expr
->ts
.type
)
3831 gfc_error ("Expression in CASE statement at %L must be of type %s",
3832 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
3836 /* C805 (R808) For a given case-construct, each case-value shall be of
3837 the same type as case-expr. For character type, length differences
3838 are allowed, but the kind type parameters shall be the same. */
3840 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
3842 gfc_error("Expression in CASE statement at %L must be kind %d",
3843 &e
->where
, case_expr
->ts
.kind
);
3847 /* Convert the case value kind to that of case expression kind, if needed.
3848 FIXME: Should a warning be issued? */
3849 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
3850 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
3854 gfc_error ("Expression in CASE statement at %L must be scalar",
3863 /* Given a completely parsed select statement, we:
3865 - Validate all expressions and code within the SELECT.
3866 - Make sure that the selection expression is not of the wrong type.
3867 - Make sure that no case ranges overlap.
3868 - Eliminate unreachable cases and unreachable code resulting from
3869 removing case labels.
3871 The standard does allow unreachable cases, e.g. CASE (5:3). But
3872 they are a hassle for code generation, and to prevent that, we just
3873 cut them out here. This is not necessary for overlapping cases
3874 because they are illegal and we never even try to generate code.
3876 We have the additional caveat that a SELECT construct could have
3877 been a computed GOTO in the source code. Fortunately we can fairly
3878 easily work around that here: The case_expr for a "real" SELECT CASE
3879 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3880 we have to do is make sure that the case_expr is a scalar integer
3884 resolve_select (gfc_code
* code
)
3887 gfc_expr
*case_expr
;
3888 gfc_case
*cp
, *default_case
, *tail
, *head
;
3889 int seen_unreachable
;
3895 if (code
->expr
== NULL
)
3897 /* This was actually a computed GOTO statement. */
3898 case_expr
= code
->expr2
;
3899 if (case_expr
->ts
.type
!= BT_INTEGER
3900 || case_expr
->rank
!= 0)
3901 gfc_error ("Selection expression in computed GOTO statement "
3902 "at %L must be a scalar integer expression",
3905 /* Further checking is not necessary because this SELECT was built
3906 by the compiler, so it should always be OK. Just move the
3907 case_expr from expr2 to expr so that we can handle computed
3908 GOTOs as normal SELECTs from here on. */
3909 code
->expr
= code
->expr2
;
3914 case_expr
= code
->expr
;
3916 type
= case_expr
->ts
.type
;
3917 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
3919 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3920 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
3922 /* Punt. Going on here just produce more garbage error messages. */
3926 if (case_expr
->rank
!= 0)
3928 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3929 "expression", &case_expr
->where
);
3935 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3936 of the SELECT CASE expression and its CASE values. Walk the lists
3937 of case values, and if we find a mismatch, promote case_expr to
3938 the appropriate kind. */
3940 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
3942 for (body
= code
->block
; body
; body
= body
->block
)
3944 /* Walk the case label list. */
3945 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3947 /* Intercept the DEFAULT case. It does not have a kind. */
3948 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3951 /* Unreachable case ranges are discarded, so ignore. */
3952 if (cp
->low
!= NULL
&& cp
->high
!= NULL
3953 && cp
->low
!= cp
->high
3954 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
3957 /* FIXME: Should a warning be issued? */
3959 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
3960 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
3962 if (cp
->high
!= NULL
3963 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
3964 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
3969 /* Assume there is no DEFAULT case. */
3970 default_case
= NULL
;
3975 for (body
= code
->block
; body
; body
= body
->block
)
3977 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3979 seen_unreachable
= 0;
3981 /* Walk the case label list, making sure that all case labels
3983 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
3985 /* Count the number of cases in the whole construct. */
3988 /* Intercept the DEFAULT case. */
3989 if (cp
->low
== NULL
&& cp
->high
== NULL
)
3991 if (default_case
!= NULL
)
3993 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3994 "by a second DEFAULT CASE at %L",
3995 &default_case
->where
, &cp
->where
);
4006 /* Deal with single value cases and case ranges. Errors are
4007 issued from the validation function. */
4008 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
4009 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
4015 if (type
== BT_LOGICAL
4016 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
4017 || cp
->low
!= cp
->high
))
4020 ("Logical range in CASE statement at %L is not allowed",
4026 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
4029 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
4030 if (value
& seen_logical
)
4032 gfc_error ("constant logical value in CASE statement "
4033 "is repeated at %L",
4038 seen_logical
|= value
;
4041 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4042 && cp
->low
!= cp
->high
4043 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4045 if (gfc_option
.warn_surprising
)
4046 gfc_warning ("Range specification at %L can never "
4047 "be matched", &cp
->where
);
4049 cp
->unreachable
= 1;
4050 seen_unreachable
= 1;
4054 /* If the case range can be matched, it can also overlap with
4055 other cases. To make sure it does not, we put it in a
4056 double linked list here. We sort that with a merge sort
4057 later on to detect any overlapping cases. */
4061 head
->right
= head
->left
= NULL
;
4066 tail
->right
->left
= tail
;
4073 /* It there was a failure in the previous case label, give up
4074 for this case label list. Continue with the next block. */
4078 /* See if any case labels that are unreachable have been seen.
4079 If so, we eliminate them. This is a bit of a kludge because
4080 the case lists for a single case statement (label) is a
4081 single forward linked lists. */
4082 if (seen_unreachable
)
4084 /* Advance until the first case in the list is reachable. */
4085 while (body
->ext
.case_list
!= NULL
4086 && body
->ext
.case_list
->unreachable
)
4088 gfc_case
*n
= body
->ext
.case_list
;
4089 body
->ext
.case_list
= body
->ext
.case_list
->next
;
4091 gfc_free_case_list (n
);
4094 /* Strip all other unreachable cases. */
4095 if (body
->ext
.case_list
)
4097 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
4099 if (cp
->next
->unreachable
)
4101 gfc_case
*n
= cp
->next
;
4102 cp
->next
= cp
->next
->next
;
4104 gfc_free_case_list (n
);
4111 /* See if there were overlapping cases. If the check returns NULL,
4112 there was overlap. In that case we don't do anything. If head
4113 is non-NULL, we prepend the DEFAULT case. The sorted list can
4114 then used during code generation for SELECT CASE constructs with
4115 a case expression of a CHARACTER type. */
4118 head
= check_case_overlap (head
);
4120 /* Prepend the default_case if it is there. */
4121 if (head
!= NULL
&& default_case
)
4123 default_case
->left
= NULL
;
4124 default_case
->right
= head
;
4125 head
->left
= default_case
;
4129 /* Eliminate dead blocks that may be the result if we've seen
4130 unreachable case labels for a block. */
4131 for (body
= code
; body
&& body
->block
; body
= body
->block
)
4133 if (body
->block
->ext
.case_list
== NULL
)
4135 /* Cut the unreachable block from the code chain. */
4136 gfc_code
*c
= body
->block
;
4137 body
->block
= c
->block
;
4139 /* Kill the dead block, but not the blocks below it. */
4141 gfc_free_statements (c
);
4145 /* More than two cases is legal but insane for logical selects.
4146 Issue a warning for it. */
4147 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
4149 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4154 /* Resolve a transfer statement. This is making sure that:
4155 -- a derived type being transferred has only non-pointer components
4156 -- a derived type being transferred doesn't have private components, unless
4157 it's being transferred from the module where the type was defined
4158 -- we're not trying to transfer a whole assumed size array. */
4161 resolve_transfer (gfc_code
* code
)
4170 if (exp
->expr_type
!= EXPR_VARIABLE
4171 && exp
->expr_type
!= EXPR_FUNCTION
)
4174 sym
= exp
->symtree
->n
.sym
;
4177 /* Go to actual component transferred. */
4178 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
4179 if (ref
->type
== REF_COMPONENT
)
4180 ts
= &ref
->u
.c
.component
->ts
;
4182 if (ts
->type
== BT_DERIVED
)
4184 /* Check that transferred derived type doesn't contain POINTER
4186 if (derived_pointer (ts
->derived
))
4188 gfc_error ("Data transfer element at %L cannot have "
4189 "POINTER components", &code
->loc
);
4193 if (ts
->derived
->attr
.alloc_comp
)
4195 gfc_error ("Data transfer element at %L cannot have "
4196 "ALLOCATABLE components", &code
->loc
);
4200 if (derived_inaccessible (ts
->derived
))
4202 gfc_error ("Data transfer element at %L cannot have "
4203 "PRIVATE components",&code
->loc
);
4208 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
4209 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
4211 gfc_error ("Data transfer element at %L cannot be a full reference to "
4212 "an assumed-size array", &code
->loc
);
4218 /*********** Toplevel code resolution subroutines ***********/
4220 /* Given a branch to a label and a namespace, if the branch is conforming.
4221 The code node described where the branch is located. */
4224 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
4226 gfc_code
*block
, *found
;
4234 /* Step one: is this a valid branching target? */
4236 if (lp
->defined
== ST_LABEL_UNKNOWN
)
4238 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
4243 if (lp
->defined
!= ST_LABEL_TARGET
)
4245 gfc_error ("Statement at %L is not a valid branch target statement "
4246 "for the branch statement at %L", &lp
->where
, &code
->loc
);
4250 /* Step two: make sure this branch is not a branch to itself ;-) */
4252 if (code
->here
== label
)
4254 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
4258 /* Step three: Try to find the label in the parse tree. To do this,
4259 we traverse the tree block-by-block: first the block that
4260 contains this GOTO, then the block that it is nested in, etc. We
4261 can ignore other blocks because branching into another block is
4266 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4268 for (block
= stack
->head
; block
; block
= block
->next
)
4270 if (block
->here
== label
)
4283 /* The label is not in an enclosing block, so illegal. This was
4284 allowed in Fortran 66, so we allow it as extension. We also
4285 forego further checks if we run into this. */
4286 gfc_notify_std (GFC_STD_LEGACY
,
4287 "Label at %L is not in the same block as the "
4288 "GOTO statement at %L", &lp
->where
, &code
->loc
);
4292 /* Step four: Make sure that the branching target is legal if
4293 the statement is an END {SELECT,DO,IF}. */
4295 if (found
->op
== EXEC_NOP
)
4297 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4298 if (stack
->current
->next
== found
)
4302 gfc_notify_std (GFC_STD_F95_DEL
,
4303 "Obsolete: GOTO at %L jumps to END of construct at %L",
4304 &code
->loc
, &found
->loc
);
4309 /* Check whether EXPR1 has the same shape as EXPR2. */
4312 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
4314 mpz_t shape
[GFC_MAX_DIMENSIONS
];
4315 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
4316 try result
= FAILURE
;
4319 /* Compare the rank. */
4320 if (expr1
->rank
!= expr2
->rank
)
4323 /* Compare the size of each dimension. */
4324 for (i
=0; i
<expr1
->rank
; i
++)
4326 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
4329 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
4332 if (mpz_cmp (shape
[i
], shape2
[i
]))
4336 /* When either of the two expression is an assumed size array, we
4337 ignore the comparison of dimension sizes. */
4342 for (i
--; i
>=0; i
--)
4344 mpz_clear (shape
[i
]);
4345 mpz_clear (shape2
[i
]);
4351 /* Check whether a WHERE assignment target or a WHERE mask expression
4352 has the same shape as the outmost WHERE mask expression. */
4355 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
4361 cblock
= code
->block
;
4363 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4364 In case of nested WHERE, only the outmost one is stored. */
4365 if (mask
== NULL
) /* outmost WHERE */
4367 else /* inner WHERE */
4374 /* Check if the mask-expr has a consistent shape with the
4375 outmost WHERE mask-expr. */
4376 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
4377 gfc_error ("WHERE mask at %L has inconsistent shape",
4378 &cblock
->expr
->where
);
4381 /* the assignment statement of a WHERE statement, or the first
4382 statement in where-body-construct of a WHERE construct */
4383 cnext
= cblock
->next
;
4388 /* WHERE assignment statement */
4391 /* Check shape consistent for WHERE assignment target. */
4392 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
4393 gfc_error ("WHERE assignment target at %L has "
4394 "inconsistent shape", &cnext
->expr
->where
);
4397 /* WHERE or WHERE construct is part of a where-body-construct */
4399 resolve_where (cnext
, e
);
4403 gfc_error ("Unsupported statement inside WHERE at %L",
4406 /* the next statement within the same where-body-construct */
4407 cnext
= cnext
->next
;
4409 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4410 cblock
= cblock
->block
;
4415 /* Check whether the FORALL index appears in the expression or not. */
4418 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4422 gfc_actual_arglist
*args
;
4425 switch (expr
->expr_type
)
4428 gcc_assert (expr
->symtree
->n
.sym
);
4430 /* A scalar assignment */
4433 if (expr
->symtree
->n
.sym
== symbol
)
4439 /* the expr is array ref, substring or struct component. */
4446 /* Check if the symbol appears in the array subscript. */
4448 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4451 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4455 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4459 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4465 if (expr
->symtree
->n
.sym
== symbol
)
4468 /* Check if the symbol appears in the substring section. */
4469 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4471 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4479 gfc_error("expression reference type error at %L", &expr
->where
);
4485 /* If the expression is a function call, then check if the symbol
4486 appears in the actual arglist of the function. */
4488 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4490 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4495 /* It seems not to happen. */
4496 case EXPR_SUBSTRING
:
4500 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4501 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4503 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4508 /* It seems not to happen. */
4509 case EXPR_STRUCTURE
:
4511 gfc_error ("Unsupported statement while finding forall index in "
4516 /* Find the FORALL index in the first operand. */
4517 if (expr
->value
.op
.op1
)
4519 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4523 /* Find the FORALL index in the second operand. */
4524 if (expr
->value
.op
.op2
)
4526 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4539 /* Resolve assignment in FORALL construct.
4540 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4541 FORALL index variables. */
4544 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4548 for (n
= 0; n
< nvar
; n
++)
4550 gfc_symbol
*forall_index
;
4552 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
4554 /* Check whether the assignment target is one of the FORALL index
4556 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
4557 && (code
->expr
->symtree
->n
.sym
== forall_index
))
4558 gfc_error ("Assignment to a FORALL index variable at %L",
4559 &code
->expr
->where
);
4562 /* If one of the FORALL index variables doesn't appear in the
4563 assignment target, then there will be a many-to-one
4565 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4566 gfc_error ("The FORALL with index '%s' cause more than one "
4567 "assignment to this object at %L",
4568 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4574 /* Resolve WHERE statement in FORALL construct. */
4577 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
4581 cblock
= code
->block
;
4584 /* the assignment statement of a WHERE statement, or the first
4585 statement in where-body-construct of a WHERE construct */
4586 cnext
= cblock
->next
;
4591 /* WHERE assignment statement */
4593 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4596 /* WHERE or WHERE construct is part of a where-body-construct */
4598 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4602 gfc_error ("Unsupported statement inside WHERE at %L",
4605 /* the next statement within the same where-body-construct */
4606 cnext
= cnext
->next
;
4608 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4609 cblock
= cblock
->block
;
4614 /* Traverse the FORALL body to check whether the following errors exist:
4615 1. For assignment, check if a many-to-one assignment happens.
4616 2. For WHERE statement, check the WHERE body to see if there is any
4617 many-to-one assignment. */
4620 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4624 c
= code
->block
->next
;
4630 case EXEC_POINTER_ASSIGN
:
4631 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4634 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4635 there is no need to handle it here. */
4639 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4644 /* The next statement in the FORALL body. */
4650 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4651 gfc_resolve_forall_body to resolve the FORALL body. */
4654 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4656 static gfc_expr
**var_expr
;
4657 static int total_var
= 0;
4658 static int nvar
= 0;
4659 gfc_forall_iterator
*fa
;
4660 gfc_symbol
*forall_index
;
4664 /* Start to resolve a FORALL construct */
4665 if (forall_save
== 0)
4667 /* Count the total number of FORALL index in the nested FORALL
4668 construct in order to allocate the VAR_EXPR with proper size. */
4670 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4672 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4674 next
= next
->block
->next
;
4677 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4678 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4681 /* The information about FORALL iterator, including FORALL index start, end
4682 and stride. The FORALL index can not appear in start, end or stride. */
4683 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4685 /* Check if any outer FORALL index name is the same as the current
4687 for (i
= 0; i
< nvar
; i
++)
4689 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4691 gfc_error ("An outer FORALL construct already has an index "
4692 "with this name %L", &fa
->var
->where
);
4696 /* Record the current FORALL index. */
4697 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4699 forall_index
= fa
->var
->symtree
->n
.sym
;
4701 /* Check if the FORALL index appears in start, end or stride. */
4702 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4703 gfc_error ("A FORALL index must not appear in a limit or stride "
4704 "expression in the same FORALL at %L", &fa
->start
->where
);
4705 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4706 gfc_error ("A FORALL index must not appear in a limit or stride "
4707 "expression in the same FORALL at %L", &fa
->end
->where
);
4708 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4709 gfc_error ("A FORALL index must not appear in a limit or stride "
4710 "expression in the same FORALL at %L", &fa
->stride
->where
);
4714 /* Resolve the FORALL body. */
4715 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4717 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4718 gfc_resolve_blocks (code
->block
, ns
);
4720 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4721 for (i
= 0; i
< total_var
; i
++)
4722 gfc_free_expr (var_expr
[i
]);
4724 /* Reset the counters. */
4730 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4733 static void resolve_code (gfc_code
*, gfc_namespace
*);
4736 gfc_resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
4740 for (; b
; b
= b
->block
)
4742 t
= gfc_resolve_expr (b
->expr
);
4743 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4749 if (t
== SUCCESS
&& b
->expr
!= NULL
4750 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4752 ("IF clause at %L requires a scalar LOGICAL expression",
4759 && (b
->expr
->ts
.type
!= BT_LOGICAL
4760 || b
->expr
->rank
== 0))
4762 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4767 resolve_branch (b
->label
, b
);
4779 case EXEC_OMP_ATOMIC
:
4780 case EXEC_OMP_CRITICAL
:
4782 case EXEC_OMP_MASTER
:
4783 case EXEC_OMP_ORDERED
:
4784 case EXEC_OMP_PARALLEL
:
4785 case EXEC_OMP_PARALLEL_DO
:
4786 case EXEC_OMP_PARALLEL_SECTIONS
:
4787 case EXEC_OMP_PARALLEL_WORKSHARE
:
4788 case EXEC_OMP_SECTIONS
:
4789 case EXEC_OMP_SINGLE
:
4790 case EXEC_OMP_WORKSHARE
:
4794 gfc_internal_error ("resolve_block(): Bad block type");
4797 resolve_code (b
->next
, ns
);
4802 /* Given a block of code, recursively resolve everything pointed to by this
4806 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
4808 int omp_workshare_save
;
4814 frame
.prev
= cs_base
;
4818 for (; code
; code
= code
->next
)
4820 frame
.current
= code
;
4821 forall_save
= forall_flag
;
4823 if (code
->op
== EXEC_FORALL
)
4826 gfc_resolve_forall (code
, ns
, forall_save
);
4829 else if (code
->block
)
4831 omp_workshare_save
= -1;
4834 case EXEC_OMP_PARALLEL_WORKSHARE
:
4835 omp_workshare_save
= omp_workshare_flag
;
4836 omp_workshare_flag
= 1;
4837 gfc_resolve_omp_parallel_blocks (code
, ns
);
4839 case EXEC_OMP_PARALLEL
:
4840 case EXEC_OMP_PARALLEL_DO
:
4841 case EXEC_OMP_PARALLEL_SECTIONS
:
4842 omp_workshare_save
= omp_workshare_flag
;
4843 omp_workshare_flag
= 0;
4844 gfc_resolve_omp_parallel_blocks (code
, ns
);
4847 gfc_resolve_omp_do_blocks (code
, ns
);
4849 case EXEC_OMP_WORKSHARE
:
4850 omp_workshare_save
= omp_workshare_flag
;
4851 omp_workshare_flag
= 1;
4854 gfc_resolve_blocks (code
->block
, ns
);
4858 if (omp_workshare_save
!= -1)
4859 omp_workshare_flag
= omp_workshare_save
;
4862 t
= gfc_resolve_expr (code
->expr
);
4863 forall_flag
= forall_save
;
4865 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
4880 /* Keep track of which entry we are up to. */
4881 current_entry_id
= code
->ext
.entry
->id
;
4885 resolve_where (code
, NULL
);
4889 if (code
->expr
!= NULL
)
4891 if (code
->expr
->ts
.type
!= BT_INTEGER
)
4892 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4893 "variable", &code
->expr
->where
);
4894 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
4895 gfc_error ("Variable '%s' has not been assigned a target label "
4896 "at %L", code
->expr
->symtree
->n
.sym
->name
,
4897 &code
->expr
->where
);
4900 resolve_branch (code
->label
, code
);
4904 if (code
->expr
!= NULL
4905 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
4906 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4907 "INTEGER return specifier", &code
->expr
->where
);
4910 case EXEC_INIT_ASSIGN
:
4917 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
4919 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
4921 gfc_error ("Subroutine '%s' called instead of assignment at "
4922 "%L must be PURE", code
->symtree
->n
.sym
->name
,
4929 if (gfc_pure (NULL
))
4931 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
4934 ("Cannot assign to variable '%s' in PURE procedure at %L",
4935 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
4939 if (code
->expr2
->ts
.type
== BT_DERIVED
4940 && derived_pointer (code
->expr2
->ts
.derived
))
4943 ("Right side of assignment at %L is a derived type "
4944 "containing a POINTER in a PURE procedure",
4945 &code
->expr2
->where
);
4950 gfc_check_assign (code
->expr
, code
->expr2
, 1);
4953 case EXEC_LABEL_ASSIGN
:
4954 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
4955 gfc_error ("Label %d referenced at %L is never defined",
4956 code
->label
->value
, &code
->label
->where
);
4958 && (code
->expr
->expr_type
!= EXPR_VARIABLE
4959 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
4960 || code
->expr
->symtree
->n
.sym
->ts
.kind
4961 != gfc_default_integer_kind
4962 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
4963 gfc_error ("ASSIGN statement at %L requires a scalar "
4964 "default INTEGER variable", &code
->expr
->where
);
4967 case EXEC_POINTER_ASSIGN
:
4971 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
4974 case EXEC_ARITHMETIC_IF
:
4976 && code
->expr
->ts
.type
!= BT_INTEGER
4977 && code
->expr
->ts
.type
!= BT_REAL
)
4978 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4979 "expression", &code
->expr
->where
);
4981 resolve_branch (code
->label
, code
);
4982 resolve_branch (code
->label2
, code
);
4983 resolve_branch (code
->label3
, code
);
4987 if (t
== SUCCESS
&& code
->expr
!= NULL
4988 && (code
->expr
->ts
.type
!= BT_LOGICAL
4989 || code
->expr
->rank
!= 0))
4990 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4991 &code
->expr
->where
);
4996 resolve_call (code
);
5000 /* Select is complicated. Also, a SELECT construct could be
5001 a transformed computed GOTO. */
5002 resolve_select (code
);
5006 if (code
->ext
.iterator
!= NULL
)
5008 gfc_iterator
*iter
= code
->ext
.iterator
;
5009 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
5010 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
5015 if (code
->expr
== NULL
)
5016 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5018 && (code
->expr
->rank
!= 0
5019 || code
->expr
->ts
.type
!= BT_LOGICAL
))
5020 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5021 "a scalar LOGICAL expression", &code
->expr
->where
);
5025 if (t
== SUCCESS
&& code
->expr
!= NULL
5026 && code
->expr
->ts
.type
!= BT_INTEGER
)
5027 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5028 "of type INTEGER", &code
->expr
->where
);
5030 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5031 resolve_allocate_expr (a
->expr
, code
);
5035 case EXEC_DEALLOCATE
:
5036 if (t
== SUCCESS
&& code
->expr
!= NULL
5037 && code
->expr
->ts
.type
!= BT_INTEGER
)
5039 ("STAT tag in DEALLOCATE statement at %L must be of type "
5040 "INTEGER", &code
->expr
->where
);
5042 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5043 resolve_deallocate_expr (a
->expr
);
5048 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
5051 resolve_branch (code
->ext
.open
->err
, code
);
5055 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
5058 resolve_branch (code
->ext
.close
->err
, code
);
5061 case EXEC_BACKSPACE
:
5065 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
5068 resolve_branch (code
->ext
.filepos
->err
, code
);
5072 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5075 resolve_branch (code
->ext
.inquire
->err
, code
);
5079 gcc_assert (code
->ext
.inquire
!= NULL
);
5080 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5083 resolve_branch (code
->ext
.inquire
->err
, code
);
5088 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
5091 resolve_branch (code
->ext
.dt
->err
, code
);
5092 resolve_branch (code
->ext
.dt
->end
, code
);
5093 resolve_branch (code
->ext
.dt
->eor
, code
);
5097 resolve_transfer (code
);
5101 resolve_forall_iterators (code
->ext
.forall_iterator
);
5103 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
5105 ("FORALL mask clause at %L requires a LOGICAL expression",
5106 &code
->expr
->where
);
5109 case EXEC_OMP_ATOMIC
:
5110 case EXEC_OMP_BARRIER
:
5111 case EXEC_OMP_CRITICAL
:
5112 case EXEC_OMP_FLUSH
:
5114 case EXEC_OMP_MASTER
:
5115 case EXEC_OMP_ORDERED
:
5116 case EXEC_OMP_SECTIONS
:
5117 case EXEC_OMP_SINGLE
:
5118 case EXEC_OMP_WORKSHARE
:
5119 gfc_resolve_omp_directive (code
, ns
);
5122 case EXEC_OMP_PARALLEL
:
5123 case EXEC_OMP_PARALLEL_DO
:
5124 case EXEC_OMP_PARALLEL_SECTIONS
:
5125 case EXEC_OMP_PARALLEL_WORKSHARE
:
5126 omp_workshare_save
= omp_workshare_flag
;
5127 omp_workshare_flag
= 0;
5128 gfc_resolve_omp_directive (code
, ns
);
5129 omp_workshare_flag
= omp_workshare_save
;
5133 gfc_internal_error ("resolve_code(): Bad statement code");
5137 cs_base
= frame
.prev
;
5141 /* Resolve initial values and make sure they are compatible with
5145 resolve_values (gfc_symbol
* sym
)
5148 if (sym
->value
== NULL
)
5151 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
5154 gfc_check_assign_symbol (sym
, sym
->value
);
5158 /* Resolve an index expression. */
5161 resolve_index_expr (gfc_expr
* e
)
5163 if (gfc_resolve_expr (e
) == FAILURE
)
5166 if (gfc_simplify_expr (e
, 0) == FAILURE
)
5169 if (gfc_specification_expr (e
) == FAILURE
)
5175 /* Resolve a charlen structure. */
5178 resolve_charlen (gfc_charlen
*cl
)
5185 specification_expr
= 1;
5187 if (resolve_index_expr (cl
->length
) == FAILURE
)
5189 specification_expr
= 0;
5197 /* Test for non-constant shape arrays. */
5200 is_non_constant_shape_array (gfc_symbol
*sym
)
5206 not_constant
= false;
5207 if (sym
->as
!= NULL
)
5209 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5210 has not been simplified; parameter array references. Do the
5211 simplification now. */
5212 for (i
= 0; i
< sym
->as
->rank
; i
++)
5214 e
= sym
->as
->lower
[i
];
5215 if (e
&& (resolve_index_expr (e
) == FAILURE
5216 || !gfc_is_constant_expr (e
)))
5217 not_constant
= true;
5219 e
= sym
->as
->upper
[i
];
5220 if (e
&& (resolve_index_expr (e
) == FAILURE
5221 || !gfc_is_constant_expr (e
)))
5222 not_constant
= true;
5225 return not_constant
;
5229 /* Assign the default initializer to a derived type variable or result. */
5232 apply_default_init (gfc_symbol
*sym
)
5235 gfc_expr
*init
= NULL
;
5237 gfc_namespace
*ns
= sym
->ns
;
5239 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
5242 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
5243 init
= gfc_default_initializer (&sym
->ts
);
5248 /* Search for the function namespace if this is a contained
5249 function without an explicit result. */
5250 if (sym
->attr
.function
&& sym
== sym
->result
5251 && sym
->name
!= sym
->ns
->proc_name
->name
)
5254 for (;ns
; ns
= ns
->sibling
)
5255 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
5261 gfc_free_expr (init
);
5265 /* Build an l-value expression for the result. */
5266 lval
= gfc_get_expr ();
5267 lval
->expr_type
= EXPR_VARIABLE
;
5268 lval
->where
= sym
->declared_at
;
5270 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5272 /* It will always be a full array. */
5273 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
5276 lval
->ref
= gfc_get_ref ();
5277 lval
->ref
->type
= REF_ARRAY
;
5278 lval
->ref
->u
.ar
.type
= AR_FULL
;
5279 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
5280 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
5281 lval
->ref
->u
.ar
.as
= sym
->as
;
5284 /* Add the code at scope entry. */
5285 init_st
= gfc_get_code ();
5286 init_st
->next
= ns
->code
;
5289 /* Assign the default initializer to the l-value. */
5290 init_st
->loc
= sym
->declared_at
;
5291 init_st
->op
= EXEC_INIT_ASSIGN
;
5292 init_st
->expr
= lval
;
5293 init_st
->expr2
= init
;
5297 /* Resolution of common features of flavors variable and procedure. */
5300 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
5302 /* Constraints on deferred shape variable. */
5303 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
5305 if (sym
->attr
.allocatable
)
5307 if (sym
->attr
.dimension
)
5308 gfc_error ("Allocatable array '%s' at %L must have "
5309 "a deferred shape", sym
->name
, &sym
->declared_at
);
5311 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5312 sym
->name
, &sym
->declared_at
);
5316 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
5318 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5319 sym
->name
, &sym
->declared_at
);
5326 if (!mp_flag
&& !sym
->attr
.allocatable
5327 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
5329 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5330 sym
->name
, &sym
->declared_at
);
5337 /* Resolve symbols with flavor variable. */
5340 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
5345 gfc_expr
*constructor_expr
;
5346 const char * auto_save_msg
;
5348 auto_save_msg
= "automatic object '%s' at %L cannot have the "
5351 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5354 /* Set this flag to check that variables are parameters of all entries.
5355 This check is effected by the call to gfc_resolve_expr through
5356 is_non_constant_shape_array. */
5357 specification_expr
= 1;
5359 if (!sym
->attr
.use_assoc
5360 && !sym
->attr
.allocatable
5361 && !sym
->attr
.pointer
5362 && is_non_constant_shape_array (sym
))
5364 /* The shape of a main program or module array needs to be constant. */
5365 if (sym
->ns
->proc_name
5366 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5367 || sym
->ns
->proc_name
->attr
.is_main_program
))
5369 gfc_error ("The module or main program array '%s' at %L must "
5370 "have constant shape", sym
->name
, &sym
->declared_at
);
5371 specification_expr
= 0;
5376 if (sym
->ts
.type
== BT_CHARACTER
)
5378 /* Make sure that character string variables with assumed length are
5380 e
= sym
->ts
.cl
->length
;
5381 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
5383 gfc_error ("Entity with assumed character length at %L must be a "
5384 "dummy argument or a PARAMETER", &sym
->declared_at
);
5388 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
5390 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5394 if (!gfc_is_constant_expr (e
)
5395 && !(e
->expr_type
== EXPR_VARIABLE
5396 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
5397 && sym
->ns
->proc_name
5398 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5399 || sym
->ns
->proc_name
->attr
.is_main_program
)
5400 && !sym
->attr
.use_assoc
)
5402 gfc_error ("'%s' at %L must have constant character length "
5403 "in this context", sym
->name
, &sym
->declared_at
);
5408 /* Can the symbol have an initializer? */
5410 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
5411 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
5413 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
5415 /* Don't allow initialization of automatic arrays. */
5416 for (i
= 0; i
< sym
->as
->rank
; i
++)
5418 if (sym
->as
->lower
[i
] == NULL
5419 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5420 || sym
->as
->upper
[i
] == NULL
5421 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
5428 /* Also, they must not have the SAVE attribute. */
5429 if (flag
&& sym
->attr
.save
)
5431 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5436 /* Reject illegal initializers. */
5437 if (sym
->value
&& flag
)
5439 if (sym
->attr
.allocatable
)
5440 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5441 sym
->name
, &sym
->declared_at
);
5442 else if (sym
->attr
.external
)
5443 gfc_error ("External '%s' at %L cannot have an initializer",
5444 sym
->name
, &sym
->declared_at
);
5445 else if (sym
->attr
.dummy
)
5446 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5447 sym
->name
, &sym
->declared_at
);
5448 else if (sym
->attr
.intrinsic
)
5449 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5450 sym
->name
, &sym
->declared_at
);
5451 else if (sym
->attr
.result
)
5452 gfc_error ("Function result '%s' at %L cannot have an initializer",
5453 sym
->name
, &sym
->declared_at
);
5455 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5456 sym
->name
, &sym
->declared_at
);
5460 /* Check to see if a derived type is blocked from being host associated
5461 by the presence of another class I symbol in the same namespace.
5462 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5463 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
)
5466 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
5467 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
5468 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
5470 gfc_error ("The type %s cannot be host associated at %L because "
5471 "it is blocked by an incompatible object of the same "
5472 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
5478 /* 4th constraint in section 11.3: "If an object of a type for which
5479 component-initialization is specified (R429) appears in the
5480 specification-part of a module and does not have the ALLOCATABLE
5481 or POINTER attribute, the object shall have the SAVE attribute." */
5483 constructor_expr
= NULL
;
5484 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
5485 constructor_expr
= gfc_default_initializer (&sym
->ts
);
5487 if (sym
->ns
->proc_name
5488 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5490 && !sym
->ns
->save_all
&& !sym
->attr
.save
5491 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
5493 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5494 sym
->name
, &sym
->declared_at
,
5495 "for default initialization of a component");
5499 /* Assign default initializer. */
5500 if (sym
->ts
.type
== BT_DERIVED
5502 && !sym
->attr
.pointer
5503 && !sym
->attr
.allocatable
5504 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
5505 sym
->value
= gfc_default_initializer (&sym
->ts
);
5511 /* Resolve a procedure. */
5514 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
5516 gfc_formal_arglist
*arg
;
5518 if (sym
->attr
.function
5519 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5522 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5524 if (sym
->ts
.type
== BT_CHARACTER
)
5526 gfc_charlen
*cl
= sym
->ts
.cl
;
5527 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
5529 gfc_error ("Character-valued statement function '%s' at %L must "
5530 "have constant length", sym
->name
, &sym
->declared_at
);
5536 /* Ensure that derived type for are not of a private type. Internal
5537 module procedures are excluded by 2.2.3.3 - ie. they are not
5538 externally accessible and can access all the objects accessible in
5540 if (!(sym
->ns
->parent
5541 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5542 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5544 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
5547 && arg
->sym
->ts
.type
== BT_DERIVED
5548 && !arg
->sym
->ts
.derived
->attr
.use_assoc
5549 && !gfc_check_access(arg
->sym
->ts
.derived
->attr
.access
,
5550 arg
->sym
->ts
.derived
->ns
->default_access
))
5552 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5553 "a dummy argument of '%s', which is "
5554 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
5556 /* Stop this message from recurring. */
5557 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
5563 /* An external symbol may not have an initializer because it is taken to be
5565 if (sym
->attr
.external
&& sym
->value
)
5567 gfc_error ("External object '%s' at %L may not have an initializer",
5568 sym
->name
, &sym
->declared_at
);
5572 /* An elemental function is required to return a scalar 12.7.1 */
5573 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
5575 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5576 "result", sym
->name
, &sym
->declared_at
);
5577 /* Reset so that the error only occurs once. */
5578 sym
->attr
.elemental
= 0;
5582 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5583 char-len-param shall not be array-valued, pointer-valued, recursive
5584 or pure. ....snip... A character value of * may only be used in the
5585 following ways: (i) Dummy arg of procedure - dummy associates with
5586 actual length; (ii) To declare a named constant; or (iii) External
5587 function - but length must be declared in calling scoping unit. */
5588 if (sym
->attr
.function
5589 && sym
->ts
.type
== BT_CHARACTER
5590 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
5592 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
5593 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
5595 if (sym
->as
&& sym
->as
->rank
)
5596 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5597 "array-valued", sym
->name
, &sym
->declared_at
);
5599 if (sym
->attr
.pointer
)
5600 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5601 "pointer-valued", sym
->name
, &sym
->declared_at
);
5604 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5605 "pure", sym
->name
, &sym
->declared_at
);
5607 if (sym
->attr
.recursive
)
5608 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5609 "recursive", sym
->name
, &sym
->declared_at
);
5614 /* Appendix B.2 of the standard. Contained functions give an
5615 error anyway. Fixed-form is likely to be F77/legacy. */
5616 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
5617 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
5618 "'%s' at %L is obsolescent in fortran 95",
5619 sym
->name
, &sym
->declared_at
);
5625 /* Resolve the components of a derived type. */
5628 resolve_fl_derived (gfc_symbol
*sym
)
5631 gfc_dt_list
* dt_list
;
5634 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
5636 if (c
->ts
.type
== BT_CHARACTER
)
5638 if (c
->ts
.cl
->length
== NULL
5639 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
5640 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
5642 gfc_error ("Character length of component '%s' needs to "
5643 "be a constant specification expression at %L",
5645 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
5650 if (c
->ts
.type
== BT_DERIVED
5651 && sym
->component_access
!= ACCESS_PRIVATE
5652 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
)
5653 && !c
->ts
.derived
->attr
.use_assoc
5654 && !gfc_check_access(c
->ts
.derived
->attr
.access
,
5655 c
->ts
.derived
->ns
->default_access
))
5657 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5658 "a component of '%s', which is PUBLIC at %L",
5659 c
->name
, sym
->name
, &sym
->declared_at
);
5663 if (sym
->attr
.sequence
)
5665 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
5667 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5668 "not have the SEQUENCE attribute",
5669 c
->ts
.derived
->name
, &sym
->declared_at
);
5674 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
5675 && c
->ts
.derived
->components
== NULL
)
5677 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5678 "that has not been declared", c
->name
, sym
->name
,
5683 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
5686 for (i
= 0; i
< c
->as
->rank
; i
++)
5688 if (c
->as
->lower
[i
] == NULL
5689 || !gfc_is_constant_expr (c
->as
->lower
[i
])
5690 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
5691 || c
->as
->upper
[i
] == NULL
5692 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
5693 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
5695 gfc_error ("Component '%s' of '%s' at %L must have "
5696 "constant array bounds",
5697 c
->name
, sym
->name
, &c
->loc
);
5703 /* Add derived type to the derived type list. */
5704 for (dt_list
= sym
->ns
->derived_types
; dt_list
; dt_list
= dt_list
->next
)
5705 if (sym
== dt_list
->derived
)
5708 if (dt_list
== NULL
)
5710 dt_list
= gfc_get_dt_list ();
5711 dt_list
->next
= sym
->ns
->derived_types
;
5712 dt_list
->derived
= sym
;
5713 sym
->ns
->derived_types
= dt_list
;
5721 resolve_fl_namelist (gfc_symbol
*sym
)
5726 /* Reject PRIVATE objects in a PUBLIC namelist. */
5727 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5729 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5731 if (!nl
->sym
->attr
.use_assoc
5732 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5733 && !gfc_check_access(nl
->sym
->attr
.access
,
5734 nl
->sym
->ns
->default_access
))
5736 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5737 "PUBLIC namelist at %L", nl
->sym
->name
,
5744 /* Reject namelist arrays that are not constant shape. */
5745 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5747 if (is_non_constant_shape_array (nl
->sym
))
5749 gfc_error ("The array '%s' must have constant shape to be "
5750 "a NAMELIST object at %L", nl
->sym
->name
,
5756 /* Namelist objects cannot have allocatable components. */
5757 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5759 if (nl
->sym
->ts
.type
== BT_DERIVED
5760 && nl
->sym
->ts
.derived
->attr
.alloc_comp
)
5762 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5763 "components", nl
->sym
->name
, &sym
->declared_at
);
5768 /* 14.1.2 A module or internal procedure represent local entities
5769 of the same type as a namelist member and so are not allowed.
5770 Note that this is sometimes caught by check_conflict so the
5771 same message has been used. */
5772 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5774 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
5777 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5778 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5779 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5781 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5782 "attribute in '%s' at %L", nlsym
->name
,
5793 resolve_fl_parameter (gfc_symbol
*sym
)
5795 /* A parameter array's shape needs to be constant. */
5796 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
5798 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5799 "or assumed shape", sym
->name
, &sym
->declared_at
);
5803 /* Make sure a parameter that has been implicitly typed still
5804 matches the implicit type, since PARAMETER statements can precede
5805 IMPLICIT statements. */
5806 if (sym
->attr
.implicit_type
5807 && !gfc_compare_types (&sym
->ts
,
5808 gfc_get_default_type (sym
, sym
->ns
)))
5810 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5811 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
5815 /* Make sure the types of derived parameters are consistent. This
5816 type checking is deferred until resolution because the type may
5817 refer to a derived type from the host. */
5818 if (sym
->ts
.type
== BT_DERIVED
5819 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
5821 gfc_error ("Incompatible derived type in PARAMETER at %L",
5822 &sym
->value
->where
);
5829 /* Do anything necessary to resolve a symbol. Right now, we just
5830 assume that an otherwise unknown symbol is a variable. This sort
5831 of thing commonly happens for symbols in module. */
5834 resolve_symbol (gfc_symbol
* sym
)
5836 /* Zero if we are checking a formal namespace. */
5837 static int formal_ns_flag
= 1;
5838 int formal_ns_save
, check_constant
, mp_flag
;
5839 gfc_symtree
*symtree
;
5840 gfc_symtree
*this_symtree
;
5844 if (sym
->attr
.flavor
== FL_UNKNOWN
)
5847 /* If we find that a flavorless symbol is an interface in one of the
5848 parent namespaces, find its symtree in this namespace, free the
5849 symbol and set the symtree to point to the interface symbol. */
5850 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
5852 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5853 if (symtree
&& symtree
->n
.sym
->generic
)
5855 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
5859 gfc_free_symbol (sym
);
5860 symtree
->n
.sym
->refs
++;
5861 this_symtree
->n
.sym
= symtree
->n
.sym
;
5866 /* Otherwise give it a flavor according to such attributes as
5868 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
5869 sym
->attr
.flavor
= FL_VARIABLE
;
5872 sym
->attr
.flavor
= FL_PROCEDURE
;
5873 if (sym
->attr
.dimension
)
5874 sym
->attr
.function
= 1;
5878 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
5881 /* Symbols that are module procedures with results (functions) have
5882 the types and array specification copied for type checking in
5883 procedures that call them, as well as for saving to a module
5884 file. These symbols can't stand the scrutiny that their results
5886 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
5888 /* Assign default type to symbols that need one and don't have one. */
5889 if (sym
->ts
.type
== BT_UNKNOWN
)
5891 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
5892 gfc_set_default_type (sym
, 1, NULL
);
5894 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
5896 /* The specific case of an external procedure should emit an error
5897 in the case that there is no implicit type. */
5899 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
5902 /* Result may be in another namespace. */
5903 resolve_symbol (sym
->result
);
5905 sym
->ts
= sym
->result
->ts
;
5906 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
5907 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
5908 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
5909 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
5914 /* Assumed size arrays and assumed shape arrays must be dummy
5918 && (sym
->as
->type
== AS_ASSUMED_SIZE
5919 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
5920 && sym
->attr
.dummy
== 0)
5922 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
5923 gfc_error ("Assumed size array at %L must be a dummy argument",
5926 gfc_error ("Assumed shape array at %L must be a dummy argument",
5931 /* Make sure symbols with known intent or optional are really dummy
5932 variable. Because of ENTRY statement, this has to be deferred
5933 until resolution time. */
5935 if (!sym
->attr
.dummy
5936 && (sym
->attr
.optional
5937 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
5939 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
5943 /* If a derived type symbol has reached this point, without its
5944 type being declared, we have an error. Notice that most
5945 conditions that produce undefined derived types have already
5946 been dealt with. However, the likes of:
5947 implicit type(t) (t) ..... call foo (t) will get us here if
5948 the type is not declared in the scope of the implicit
5949 statement. Change the type to BT_UNKNOWN, both because it is so
5950 and to prevent an ICE. */
5951 if (sym
->ts
.type
== BT_DERIVED
5952 && sym
->ts
.derived
->components
== NULL
)
5954 gfc_error ("The derived type '%s' at %L is of type '%s', "
5955 "which has not been defined", sym
->name
,
5956 &sym
->declared_at
, sym
->ts
.derived
->name
);
5957 sym
->ts
.type
= BT_UNKNOWN
;
5961 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
5962 default initialization is defined (5.1.2.4.4). */
5963 if (sym
->ts
.type
== BT_DERIVED
5965 && sym
->attr
.intent
== INTENT_OUT
5967 && sym
->as
->type
== AS_ASSUMED_SIZE
)
5969 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
5973 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
5974 "ASSUMED SIZE and so cannot have a default initializer",
5975 sym
->name
, &sym
->declared_at
);
5981 switch (sym
->attr
.flavor
)
5984 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
5989 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
5994 if (resolve_fl_namelist (sym
) == FAILURE
)
5999 if (resolve_fl_parameter (sym
) == FAILURE
)
6009 /* Make sure that intrinsic exist */
6010 if (sym
->attr
.intrinsic
6011 && ! gfc_intrinsic_name(sym
->name
, 0)
6012 && ! gfc_intrinsic_name(sym
->name
, 1))
6013 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
6015 /* Resolve array specifier. Check as well some constraints
6016 on COMMON blocks. */
6018 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
6019 gfc_resolve_array_spec (sym
->as
, check_constant
);
6021 /* Resolve formal namespaces. */
6023 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
6025 formal_ns_save
= formal_ns_flag
;
6027 gfc_resolve (sym
->formal_ns
);
6028 formal_ns_flag
= formal_ns_save
;
6031 /* Check threadprivate restrictions. */
6032 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
6033 && (!sym
->attr
.in_common
6034 && sym
->module
== NULL
6035 && (sym
->ns
->proc_name
== NULL
6036 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
6037 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
6039 /* If we have come this far we can apply default-initializers, as
6040 described in 14.7.5, to those variables that have not already
6041 been assigned one. */
6042 if (sym
->ts
.type
== BT_DERIVED
6043 && sym
->attr
.referenced
6044 && sym
->ns
== gfc_current_ns
6046 && !sym
->attr
.allocatable
6047 && !sym
->attr
.alloc_comp
)
6049 symbol_attribute
*a
= &sym
->attr
;
6051 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
6052 && !a
->in_common
&& !a
->use_assoc
6053 && !(a
->function
&& sym
!= sym
->result
))
6055 (a
->dummy
&& a
->intent
== INTENT_OUT
))
6056 apply_default_init (sym
);
6062 /************* Resolve DATA statements *************/
6066 gfc_data_value
*vnode
;
6072 /* Advance the values structure to point to the next value in the data list. */
6075 next_data_value (void)
6077 while (values
.left
== 0)
6079 if (values
.vnode
->next
== NULL
)
6082 values
.vnode
= values
.vnode
->next
;
6083 values
.left
= values
.vnode
->repeat
;
6091 check_data_variable (gfc_data_variable
* var
, locus
* where
)
6097 ar_type mark
= AR_UNKNOWN
;
6099 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
6103 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
6107 mpz_init_set_si (offset
, 0);
6110 if (e
->expr_type
!= EXPR_VARIABLE
)
6111 gfc_internal_error ("check_data_variable(): Bad expression");
6113 if (e
->symtree
->n
.sym
->ns
->is_block_data
6114 && !e
->symtree
->n
.sym
->attr
.in_common
)
6116 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6117 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
6122 mpz_init_set_ui (size
, 1);
6129 /* Find the array section reference. */
6130 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6132 if (ref
->type
!= REF_ARRAY
)
6134 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6140 /* Set marks according to the reference pattern. */
6141 switch (ref
->u
.ar
.type
)
6149 /* Get the start position of array section. */
6150 gfc_get_section_index (ar
, section_index
, &offset
);
6158 if (gfc_array_size (e
, &size
) == FAILURE
)
6160 gfc_error ("Nonconstant array section at %L in DATA statement",
6169 while (mpz_cmp_ui (size
, 0) > 0)
6171 if (next_data_value () == FAILURE
)
6173 gfc_error ("DATA statement at %L has more variables than values",
6179 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
6183 /* If we have more than one element left in the repeat count,
6184 and we have more than one element left in the target variable,
6185 then create a range assignment. */
6186 /* ??? Only done for full arrays for now, since array sections
6188 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
6189 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
6193 if (mpz_cmp_ui (size
, values
.left
) >= 0)
6195 mpz_init_set_ui (range
, values
.left
);
6196 mpz_sub_ui (size
, size
, values
.left
);
6201 mpz_init_set (range
, size
);
6202 values
.left
-= mpz_get_ui (size
);
6203 mpz_set_ui (size
, 0);
6206 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
6209 mpz_add (offset
, offset
, range
);
6213 /* Assign initial value to symbol. */
6217 mpz_sub_ui (size
, size
, 1);
6219 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
6221 if (mark
== AR_FULL
)
6222 mpz_add_ui (offset
, offset
, 1);
6224 /* Modify the array section indexes and recalculate the offset
6225 for next element. */
6226 else if (mark
== AR_SECTION
)
6227 gfc_advance_section (section_index
, ar
, &offset
);
6231 if (mark
== AR_SECTION
)
6233 for (i
= 0; i
< ar
->dimen
; i
++)
6234 mpz_clear (section_index
[i
]);
6244 static try traverse_data_var (gfc_data_variable
*, locus
*);
6246 /* Iterate over a list of elements in a DATA statement. */
6249 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
6252 iterator_stack frame
;
6255 mpz_init (frame
.value
);
6257 mpz_init_set (trip
, var
->iter
.end
->value
.integer
);
6258 mpz_sub (trip
, trip
, var
->iter
.start
->value
.integer
);
6259 mpz_add (trip
, trip
, var
->iter
.step
->value
.integer
);
6261 mpz_div (trip
, trip
, var
->iter
.step
->value
.integer
);
6263 mpz_set (frame
.value
, var
->iter
.start
->value
.integer
);
6265 frame
.prev
= iter_stack
;
6266 frame
.variable
= var
->iter
.var
->symtree
;
6267 iter_stack
= &frame
;
6269 while (mpz_cmp_ui (trip
, 0) > 0)
6271 if (traverse_data_var (var
->list
, where
) == FAILURE
)
6277 e
= gfc_copy_expr (var
->expr
);
6278 if (gfc_simplify_expr (e
, 1) == FAILURE
)
6284 mpz_add (frame
.value
, frame
.value
, var
->iter
.step
->value
.integer
);
6286 mpz_sub_ui (trip
, trip
, 1);
6290 mpz_clear (frame
.value
);
6292 iter_stack
= frame
.prev
;
6297 /* Type resolve variables in the variable list of a DATA statement. */
6300 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
6304 for (; var
; var
= var
->next
)
6306 if (var
->expr
== NULL
)
6307 t
= traverse_data_list (var
, where
);
6309 t
= check_data_variable (var
, where
);
6319 /* Resolve the expressions and iterators associated with a data statement.
6320 This is separate from the assignment checking because data lists should
6321 only be resolved once. */
6324 resolve_data_variables (gfc_data_variable
* d
)
6326 for (; d
; d
= d
->next
)
6328 if (d
->list
== NULL
)
6330 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
6335 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
6338 if (d
->iter
.start
->expr_type
!= EXPR_CONSTANT
6339 || d
->iter
.end
->expr_type
!= EXPR_CONSTANT
6340 || d
->iter
.step
->expr_type
!= EXPR_CONSTANT
)
6341 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6343 if (resolve_data_variables (d
->list
) == FAILURE
)
6352 /* Resolve a single DATA statement. We implement this by storing a pointer to
6353 the value list into static variables, and then recursively traversing the
6354 variables list, expanding iterators and such. */
6357 resolve_data (gfc_data
* d
)
6359 if (resolve_data_variables (d
->var
) == FAILURE
)
6362 values
.vnode
= d
->value
;
6363 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
6365 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
6368 /* At this point, we better not have any values left. */
6370 if (next_data_value () == SUCCESS
)
6371 gfc_error ("DATA statement at %L has more values than variables",
6376 /* Determines if a variable is not 'pure', ie not assignable within a pure
6377 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6381 gfc_impure_variable (gfc_symbol
* sym
)
6383 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
6386 if (sym
->ns
!= gfc_current_ns
)
6387 return !sym
->attr
.function
;
6389 /* TODO: Check storage association through EQUIVALENCE statements */
6395 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6396 symbol of the current procedure. */
6399 gfc_pure (gfc_symbol
* sym
)
6401 symbol_attribute attr
;
6404 sym
= gfc_current_ns
->proc_name
;
6410 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
6414 /* Test whether the current procedure is elemental or not. */
6417 gfc_elemental (gfc_symbol
* sym
)
6419 symbol_attribute attr
;
6422 sym
= gfc_current_ns
->proc_name
;
6427 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
6431 /* Warn about unused labels. */
6434 warn_unused_fortran_label (gfc_st_label
* label
)
6439 warn_unused_fortran_label (label
->left
);
6441 if (label
->defined
== ST_LABEL_UNKNOWN
)
6444 switch (label
->referenced
)
6446 case ST_LABEL_UNKNOWN
:
6447 gfc_warning ("Label %d at %L defined but not used", label
->value
,
6451 case ST_LABEL_BAD_TARGET
:
6452 gfc_warning ("Label %d at %L defined but cannot be used",
6453 label
->value
, &label
->where
);
6460 warn_unused_fortran_label (label
->right
);
6464 /* Returns the sequence type of a symbol or sequence. */
6467 sequence_type (gfc_typespec ts
)
6476 if (ts
.derived
->components
== NULL
)
6477 return SEQ_NONDEFAULT
;
6479 result
= sequence_type (ts
.derived
->components
->ts
);
6480 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
6481 if (sequence_type (c
->ts
) != result
)
6487 if (ts
.kind
!= gfc_default_character_kind
)
6488 return SEQ_NONDEFAULT
;
6490 return SEQ_CHARACTER
;
6493 if (ts
.kind
!= gfc_default_integer_kind
)
6494 return SEQ_NONDEFAULT
;
6499 if (!(ts
.kind
== gfc_default_real_kind
6500 || ts
.kind
== gfc_default_double_kind
))
6501 return SEQ_NONDEFAULT
;
6506 if (ts
.kind
!= gfc_default_complex_kind
)
6507 return SEQ_NONDEFAULT
;
6512 if (ts
.kind
!= gfc_default_logical_kind
)
6513 return SEQ_NONDEFAULT
;
6518 return SEQ_NONDEFAULT
;
6523 /* Resolve derived type EQUIVALENCE object. */
6526 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
6529 gfc_component
*c
= derived
->components
;
6534 /* Shall not be an object of nonsequence derived type. */
6535 if (!derived
->attr
.sequence
)
6537 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6538 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
6542 /* Shall not have allocatable components. */
6543 if (derived
->attr
.alloc_comp
)
6545 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6546 "components to be an EQUIVALENCE object",sym
->name
, &e
->where
);
6550 for (; c
; c
= c
->next
)
6553 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
6556 /* Shall not be an object of sequence derived type containing a pointer
6557 in the structure. */
6560 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6561 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
6567 gfc_error ("Derived type variable '%s' at %L with default initializer "
6568 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
6576 /* Resolve equivalence object.
6577 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6578 an allocatable array, an object of nonsequence derived type, an object of
6579 sequence derived type containing a pointer at any level of component
6580 selection, an automatic object, a function name, an entry name, a result
6581 name, a named constant, a structure component, or a subobject of any of
6582 the preceding objects. A substring shall not have length zero. A
6583 derived type shall not have components with default initialization nor
6584 shall two objects of an equivalence group be initialized.
6585 The simple constraints are done in symbol.c(check_conflict) and the rest
6586 are implemented here. */
6589 resolve_equivalence (gfc_equiv
*eq
)
6592 gfc_symbol
*derived
;
6593 gfc_symbol
*first_sym
;
6596 locus
*last_where
= NULL
;
6597 seq_type eq_type
, last_eq_type
;
6598 gfc_typespec
*last_ts
;
6600 const char *value_name
;
6604 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
6606 first_sym
= eq
->expr
->symtree
->n
.sym
;
6608 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
6612 e
->ts
= e
->symtree
->n
.sym
->ts
;
6613 /* match_varspec might not know yet if it is seeing
6614 array reference or substring reference, as it doesn't
6616 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
6618 gfc_ref
*ref
= e
->ref
;
6619 sym
= e
->symtree
->n
.sym
;
6621 if (sym
->attr
.dimension
)
6623 ref
->u
.ar
.as
= sym
->as
;
6627 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6628 if (e
->ts
.type
== BT_CHARACTER
6630 && ref
->type
== REF_ARRAY
6631 && ref
->u
.ar
.dimen
== 1
6632 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
6633 && ref
->u
.ar
.stride
[0] == NULL
)
6635 gfc_expr
*start
= ref
->u
.ar
.start
[0];
6636 gfc_expr
*end
= ref
->u
.ar
.end
[0];
6639 /* Optimize away the (:) reference. */
6640 if (start
== NULL
&& end
== NULL
)
6645 e
->ref
->next
= ref
->next
;
6650 ref
->type
= REF_SUBSTRING
;
6652 start
= gfc_int_expr (1);
6653 ref
->u
.ss
.start
= start
;
6654 if (end
== NULL
&& e
->ts
.cl
)
6655 end
= gfc_copy_expr (e
->ts
.cl
->length
);
6656 ref
->u
.ss
.end
= end
;
6657 ref
->u
.ss
.length
= e
->ts
.cl
;
6664 /* Any further ref is an error. */
6667 gcc_assert (ref
->type
== REF_ARRAY
);
6668 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6674 if (gfc_resolve_expr (e
) == FAILURE
)
6677 sym
= e
->symtree
->n
.sym
;
6679 /* An equivalence statement cannot have more than one initialized
6683 if (value_name
!= NULL
)
6685 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6686 "be in the EQUIVALENCE statement at %L",
6687 value_name
, sym
->name
, &e
->where
);
6691 value_name
= sym
->name
;
6694 /* Shall not equivalence common block variables in a PURE procedure. */
6695 if (sym
->ns
->proc_name
6696 && sym
->ns
->proc_name
->attr
.pure
6697 && sym
->attr
.in_common
)
6699 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6700 "object in the pure procedure '%s'",
6701 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
6705 /* Shall not be a named constant. */
6706 if (e
->expr_type
== EXPR_CONSTANT
)
6708 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6709 "object", sym
->name
, &e
->where
);
6713 derived
= e
->ts
.derived
;
6714 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
6717 /* Check that the types correspond correctly:
6719 A numeric sequence structure may be equivalenced to another sequence
6720 structure, an object of default integer type, default real type, double
6721 precision real type, default logical type such that components of the
6722 structure ultimately only become associated to objects of the same
6723 kind. A character sequence structure may be equivalenced to an object
6724 of default character kind or another character sequence structure.
6725 Other objects may be equivalenced only to objects of the same type and
6728 /* Identical types are unconditionally OK. */
6729 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
6730 goto identical_types
;
6732 last_eq_type
= sequence_type (*last_ts
);
6733 eq_type
= sequence_type (sym
->ts
);
6735 /* Since the pair of objects is not of the same type, mixed or
6736 non-default sequences can be rejected. */
6738 msg
= "Sequence %s with mixed components in EQUIVALENCE "
6739 "statement at %L with different type objects";
6741 && last_eq_type
== SEQ_MIXED
6742 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
6743 last_where
) == FAILURE
)
6744 || (eq_type
== SEQ_MIXED
6745 && gfc_notify_std (GFC_STD_GNU
, msg
,sym
->name
,
6746 &e
->where
) == FAILURE
))
6749 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
6750 "statement at %L with objects of different type";
6752 && last_eq_type
== SEQ_NONDEFAULT
6753 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
6754 last_where
) == FAILURE
)
6755 || (eq_type
== SEQ_NONDEFAULT
6756 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6757 &e
->where
) == FAILURE
))
6760 msg
="Non-CHARACTER object '%s' in default CHARACTER "
6761 "EQUIVALENCE statement at %L";
6762 if (last_eq_type
== SEQ_CHARACTER
6763 && eq_type
!= SEQ_CHARACTER
6764 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6765 &e
->where
) == FAILURE
)
6768 msg
="Non-NUMERIC object '%s' in default NUMERIC "
6769 "EQUIVALENCE statement at %L";
6770 if (last_eq_type
== SEQ_NUMERIC
6771 && eq_type
!= SEQ_NUMERIC
6772 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
6773 &e
->where
) == FAILURE
)
6778 last_where
= &e
->where
;
6783 /* Shall not be an automatic array. */
6784 if (e
->ref
->type
== REF_ARRAY
6785 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
6787 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6788 "an EQUIVALENCE object", sym
->name
, &e
->where
);
6795 /* Shall not be a structure component. */
6796 if (r
->type
== REF_COMPONENT
)
6798 gfc_error ("Structure component '%s' at %L cannot be an "
6799 "EQUIVALENCE object",
6800 r
->u
.c
.component
->name
, &e
->where
);
6804 /* A substring shall not have length zero. */
6805 if (r
->type
== REF_SUBSTRING
)
6807 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
6809 gfc_error ("Substring at %L has length zero",
6810 &r
->u
.ss
.start
->where
);
6820 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6823 resolve_fntype (gfc_namespace
* ns
)
6828 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
6831 /* If there are any entries, ns->proc_name is the entry master
6832 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6834 sym
= ns
->entries
->sym
;
6836 sym
= ns
->proc_name
;
6837 if (sym
->result
== sym
6838 && sym
->ts
.type
== BT_UNKNOWN
6839 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
6840 && !sym
->attr
.untyped
)
6842 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6843 sym
->name
, &sym
->declared_at
);
6844 sym
->attr
.untyped
= 1;
6847 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
6848 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
6849 sym
->ts
.derived
->ns
->default_access
)
6850 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
6852 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6853 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
6856 /* Make sure that the type of a module derived type function is in the
6857 module namespace, by copying it from the namespace's derived type
6858 list, if necessary. */
6859 if (sym
->ts
.type
== BT_DERIVED
6860 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6861 && sym
->ts
.derived
->ns
6862 && sym
->ns
!= sym
->ts
.derived
->ns
)
6864 gfc_dt_list
*dt
= sym
->ns
->derived_types
;
6866 for (; dt
; dt
= dt
->next
)
6867 if (gfc_compare_derived_types (sym
->ts
.derived
, dt
->derived
))
6868 sym
->ts
.derived
= dt
->derived
;
6872 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
6874 if (el
->sym
->result
== el
->sym
6875 && el
->sym
->ts
.type
== BT_UNKNOWN
6876 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
6877 && !el
->sym
->attr
.untyped
)
6879 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6880 el
->sym
->name
, &el
->sym
->declared_at
);
6881 el
->sym
->attr
.untyped
= 1;
6886 /* 12.3.2.1.1 Defined operators. */
6889 gfc_resolve_uops(gfc_symtree
*symtree
)
6893 gfc_formal_arglist
*formal
;
6895 if (symtree
== NULL
)
6898 gfc_resolve_uops (symtree
->left
);
6899 gfc_resolve_uops (symtree
->right
);
6901 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
6904 if (!sym
->attr
.function
)
6905 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6906 sym
->name
, &sym
->declared_at
);
6908 if (sym
->ts
.type
== BT_CHARACTER
6909 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
6910 && !(sym
->result
&& sym
->result
->ts
.cl
&& sym
->result
->ts
.cl
->length
))
6911 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6912 "length", sym
->name
, &sym
->declared_at
);
6914 formal
= sym
->formal
;
6915 if (!formal
|| !formal
->sym
)
6917 gfc_error("User operator procedure '%s' at %L must have at least "
6918 "one argument", sym
->name
, &sym
->declared_at
);
6922 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
6923 gfc_error ("First argument of operator interface at %L must be "
6924 "INTENT(IN)", &sym
->declared_at
);
6926 if (formal
->sym
->attr
.optional
)
6927 gfc_error ("First argument of operator interface at %L cannot be "
6928 "optional", &sym
->declared_at
);
6930 formal
= formal
->next
;
6931 if (!formal
|| !formal
->sym
)
6934 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
6935 gfc_error ("Second argument of operator interface at %L must be "
6936 "INTENT(IN)", &sym
->declared_at
);
6938 if (formal
->sym
->attr
.optional
)
6939 gfc_error ("Second argument of operator interface at %L cannot be "
6940 "optional", &sym
->declared_at
);
6943 gfc_error ("Operator interface at %L must have, at most, two "
6944 "arguments", &sym
->declared_at
);
6949 /* Examine all of the expressions associated with a program unit,
6950 assign types to all intermediate expressions, make sure that all
6951 assignments are to compatible types and figure out which names
6952 refer to which functions or subroutines. It doesn't check code
6953 block, which is handled by resolve_code. */
6956 resolve_types (gfc_namespace
* ns
)
6963 gfc_current_ns
= ns
;
6965 resolve_entries (ns
);
6967 resolve_contained_functions (ns
);
6969 gfc_traverse_ns (ns
, resolve_symbol
);
6971 resolve_fntype (ns
);
6973 for (n
= ns
->contained
; n
; n
= n
->sibling
)
6975 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
6976 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
6977 "also be PURE", n
->proc_name
->name
,
6978 &n
->proc_name
->declared_at
);
6984 gfc_check_interfaces (ns
);
6986 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
6987 resolve_charlen (cl
);
6989 gfc_traverse_ns (ns
, resolve_values
);
6995 for (d
= ns
->data
; d
; d
= d
->next
)
6999 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
7001 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
7002 resolve_equivalence (eq
);
7004 /* Warn about unused labels. */
7005 if (warn_unused_label
)
7006 warn_unused_fortran_label (ns
->st_labels
);
7008 gfc_resolve_uops (ns
->uop_root
);
7012 /* Call resolve_code recursively. */
7015 resolve_codes (gfc_namespace
* ns
)
7019 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7022 gfc_current_ns
= ns
;
7024 /* Set to an out of range value. */
7025 current_entry_id
= -1;
7026 resolve_code (ns
->code
, ns
);
7030 /* This function is called after a complete program unit has been compiled.
7031 Its purpose is to examine all of the expressions associated with a program
7032 unit, assign types to all intermediate expressions, make sure that all
7033 assignments are to compatible types and figure out which names refer to
7034 which functions or subroutines. */
7037 gfc_resolve (gfc_namespace
* ns
)
7039 gfc_namespace
*old_ns
;
7041 old_ns
= gfc_current_ns
;
7046 gfc_current_ns
= old_ns
;