1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 /* Types used in equivalence statements. */
35 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
39 /* Stack to push the current if we descend into a block during
40 resolution. See resolve_branch() and resolve_code(). */
42 typedef struct code_stack
44 struct gfc_code
*head
, *current
;
45 struct code_stack
*prev
;
49 static code_stack
*cs_base
= NULL
;
52 /* Nonzero if we're inside a FORALL block. */
54 static int forall_flag
;
56 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
58 static int omp_workshare_flag
;
60 /* Nonzero if we are processing a formal arglist. The corresponding function
61 resets the flag each time that it is read. */
62 static int formal_arg_flag
= 0;
64 /* True if we are resolving a specification expression. */
65 static int specification_expr
= 0;
67 /* The id of the last entry seen. */
68 static int current_entry_id
;
71 gfc_is_formal_arg (void)
73 return formal_arg_flag
;
76 /* Resolve types of formal argument lists. These have to be done early so that
77 the formal argument lists of module procedures can be copied to the
78 containing module before the individual procedures are resolved
79 individually. We also resolve argument lists of procedures in interface
80 blocks because they are self-contained scoping units.
82 Since a dummy argument cannot be a non-dummy procedure, the only
83 resort left for untyped names are the IMPLICIT types. */
86 resolve_formal_arglist (gfc_symbol
* proc
)
88 gfc_formal_arglist
*f
;
92 if (proc
->result
!= NULL
)
97 if (gfc_elemental (proc
)
98 || sym
->attr
.pointer
|| sym
->attr
.allocatable
99 || (sym
->as
&& sym
->as
->rank
> 0))
100 proc
->attr
.always_explicit
= 1;
104 for (f
= proc
->formal
; f
; f
= f
->next
)
110 /* Alternate return placeholder. */
111 if (gfc_elemental (proc
))
112 gfc_error ("Alternate return specifier in elemental subroutine "
113 "'%s' at %L is not allowed", proc
->name
,
115 if (proc
->attr
.function
)
116 gfc_error ("Alternate return specifier in function "
117 "'%s' at %L is not allowed", proc
->name
,
122 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
123 resolve_formal_arglist (sym
);
125 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
127 if (gfc_pure (proc
) && !gfc_pure (sym
))
130 ("Dummy procedure '%s' of PURE procedure at %L must also "
131 "be PURE", sym
->name
, &sym
->declared_at
);
135 if (gfc_elemental (proc
))
138 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
143 if (sym
->attr
.function
144 && sym
->ts
.type
== BT_UNKNOWN
145 && sym
->attr
.intrinsic
)
147 gfc_intrinsic_sym
*isym
;
148 isym
= gfc_find_function (sym
->name
);
149 if (isym
== NULL
|| !isym
->specific
)
151 gfc_error ("Unable to find a specific INTRINSIC procedure "
152 "for the reference '%s' at %L", sym
->name
,
161 if (sym
->ts
.type
== BT_UNKNOWN
)
163 if (!sym
->attr
.function
|| sym
->result
== sym
)
164 gfc_set_default_type (sym
, 1, sym
->ns
);
167 gfc_resolve_array_spec (sym
->as
, 0);
169 /* We can't tell if an array with dimension (:) is assumed or deferred
170 shape until we know if it has the pointer or allocatable attributes.
172 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
173 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
175 sym
->as
->type
= AS_ASSUMED_SHAPE
;
176 for (i
= 0; i
< sym
->as
->rank
; i
++)
177 sym
->as
->lower
[i
] = gfc_int_expr (1);
180 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
181 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
182 || sym
->attr
.optional
)
183 proc
->attr
.always_explicit
= 1;
185 /* If the flavor is unknown at this point, it has to be a variable.
186 A procedure specification would have already set the type. */
188 if (sym
->attr
.flavor
== FL_UNKNOWN
)
189 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
191 if (gfc_pure (proc
) && !sym
->attr
.pointer
192 && sym
->attr
.flavor
!= FL_PROCEDURE
)
194 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
195 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
196 "INTENT(IN)", sym
->name
, proc
->name
,
199 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
200 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
201 "have its INTENT specified", sym
->name
, proc
->name
,
205 if (gfc_elemental (proc
))
210 ("Argument '%s' of elemental procedure at %L must be scalar",
211 sym
->name
, &sym
->declared_at
);
215 if (sym
->attr
.pointer
)
218 ("Argument '%s' of elemental procedure at %L cannot have "
219 "the POINTER attribute", sym
->name
, &sym
->declared_at
);
224 /* Each dummy shall be specified to be scalar. */
225 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
230 ("Argument '%s' of statement function at %L must be scalar",
231 sym
->name
, &sym
->declared_at
);
235 if (sym
->ts
.type
== BT_CHARACTER
)
237 gfc_charlen
*cl
= sym
->ts
.cl
;
238 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
241 ("Character-valued argument '%s' of statement function at "
242 "%L must have constant length",
243 sym
->name
, &sym
->declared_at
);
253 /* Work function called when searching for symbols that have argument lists
254 associated with them. */
257 find_arglists (gfc_symbol
* sym
)
260 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
263 resolve_formal_arglist (sym
);
267 /* Given a namespace, resolve all formal argument lists within the namespace.
271 resolve_formal_arglists (gfc_namespace
* ns
)
277 gfc_traverse_ns (ns
, find_arglists
);
282 resolve_contained_fntype (gfc_symbol
* sym
, gfc_namespace
* ns
)
286 /* If this namespace is not a function, ignore it. */
288 || !(sym
->attr
.function
289 || sym
->attr
.flavor
== FL_VARIABLE
))
292 /* Try to find out of what the return type is. */
293 if (sym
->result
!= NULL
)
296 if (sym
->ts
.type
== BT_UNKNOWN
)
298 t
= gfc_set_default_type (sym
, 0, ns
);
300 if (t
== FAILURE
&& !sym
->attr
.untyped
)
302 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
303 sym
->name
, &sym
->declared_at
); /* FIXME */
304 sym
->attr
.untyped
= 1;
308 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
309 lists the only ways a character length value of * can be used: dummy arguments
310 of procedures, named constants, and function results in external functions.
311 Internal function results are not on that list; ergo, not permitted. */
313 if (sym
->ts
.type
== BT_CHARACTER
)
315 gfc_charlen
*cl
= sym
->ts
.cl
;
316 if (!cl
|| !cl
->length
)
317 gfc_error ("Character-valued internal function '%s' at %L must "
318 "not be assumed length", sym
->name
, &sym
->declared_at
);
323 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
324 introduce duplicates. */
327 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
329 gfc_formal_arglist
*f
, *new_arglist
;
332 for (; new_args
!= NULL
; new_args
= new_args
->next
)
334 new_sym
= new_args
->sym
;
335 /* See if this arg is already in the formal argument list. */
336 for (f
= proc
->formal
; f
; f
= f
->next
)
338 if (new_sym
== f
->sym
)
345 /* Add a new argument. Argument order is not important. */
346 new_arglist
= gfc_get_formal_arglist ();
347 new_arglist
->sym
= new_sym
;
348 new_arglist
->next
= proc
->formal
;
349 proc
->formal
= new_arglist
;
354 /* Flag the arguments that are not present in all entries. */
357 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
359 gfc_formal_arglist
*f
, *head
;
362 for (f
= proc
->formal
; f
; f
= f
->next
)
367 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
369 if (new_args
->sym
== f
->sym
)
376 f
->sym
->attr
.not_always_present
= 1;
381 /* Resolve alternate entry points. If a symbol has multiple entry points we
382 create a new master symbol for the main routine, and turn the existing
383 symbol into an entry point. */
386 resolve_entries (gfc_namespace
* ns
)
388 gfc_namespace
*old_ns
;
392 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
393 static int master_count
= 0;
395 if (ns
->proc_name
== NULL
)
398 /* No need to do anything if this procedure doesn't have alternate entry
403 /* We may already have resolved alternate entry points. */
404 if (ns
->proc_name
->attr
.entry_master
)
407 /* If this isn't a procedure something has gone horribly wrong. */
408 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
410 /* Remember the current namespace. */
411 old_ns
= gfc_current_ns
;
415 /* Add the main entry point to the list of entry points. */
416 el
= gfc_get_entry_list ();
417 el
->sym
= ns
->proc_name
;
419 el
->next
= ns
->entries
;
421 ns
->proc_name
->attr
.entry
= 1;
423 /* If it is a module function, it needs to be in the right namespace
424 so that gfc_get_fake_result_decl can gather up the results. The
425 need for this arose in get_proc_name, where these beasts were
426 left in their own namespace, to keep prior references linked to
427 the entry declaration.*/
428 if (ns
->proc_name
->attr
.function
430 && ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
433 /* Add an entry statement for it. */
440 /* Create a new symbol for the master function. */
441 /* Give the internal function a unique name (within this file).
442 Also include the function name so the user has some hope of figuring
443 out what is going on. */
444 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
445 master_count
++, ns
->proc_name
->name
);
446 gfc_get_ha_symbol (name
, &proc
);
447 gcc_assert (proc
!= NULL
);
449 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
450 if (ns
->proc_name
->attr
.subroutine
)
451 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
455 gfc_typespec
*ts
, *fts
;
456 gfc_array_spec
*as
, *fas
;
457 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
459 fas
= ns
->entries
->sym
->as
;
460 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
461 fts
= &ns
->entries
->sym
->result
->ts
;
462 if (fts
->type
== BT_UNKNOWN
)
463 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
464 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
466 ts
= &el
->sym
->result
->ts
;
468 as
= as
? as
: el
->sym
->result
->as
;
469 if (ts
->type
== BT_UNKNOWN
)
470 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
472 if (! gfc_compare_types (ts
, fts
)
473 || (el
->sym
->result
->attr
.dimension
474 != ns
->entries
->sym
->result
->attr
.dimension
)
475 || (el
->sym
->result
->attr
.pointer
476 != ns
->entries
->sym
->result
->attr
.pointer
))
479 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
480 gfc_error ("Procedure %s at %L has entries with mismatched "
481 "array specifications", ns
->entries
->sym
->name
,
482 &ns
->entries
->sym
->declared_at
);
487 sym
= ns
->entries
->sym
->result
;
488 /* All result types the same. */
490 if (sym
->attr
.dimension
)
491 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
492 if (sym
->attr
.pointer
)
493 gfc_add_pointer (&proc
->attr
, NULL
);
497 /* Otherwise the result will be passed through a union by
499 proc
->attr
.mixed_entry_master
= 1;
500 for (el
= ns
->entries
; el
; el
= el
->next
)
502 sym
= el
->sym
->result
;
503 if (sym
->attr
.dimension
)
505 if (el
== ns
->entries
)
507 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
508 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
511 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
512 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
514 else if (sym
->attr
.pointer
)
516 if (el
== ns
->entries
)
518 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
519 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
522 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
523 sym
->name
, ns
->entries
->sym
->name
, &sym
->declared_at
);
528 if (ts
->type
== BT_UNKNOWN
)
529 ts
= gfc_get_default_type (sym
, NULL
);
533 if (ts
->kind
== gfc_default_integer_kind
)
537 if (ts
->kind
== gfc_default_real_kind
538 || ts
->kind
== gfc_default_double_kind
)
542 if (ts
->kind
== gfc_default_complex_kind
)
546 if (ts
->kind
== gfc_default_logical_kind
)
550 /* We will issue error elsewhere. */
558 if (el
== ns
->entries
)
560 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
561 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
565 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
566 sym
->name
, gfc_typename (ts
), ns
->entries
->sym
->name
,
573 proc
->attr
.access
= ACCESS_PRIVATE
;
574 proc
->attr
.entry_master
= 1;
576 /* Merge all the entry point arguments. */
577 for (el
= ns
->entries
; el
; el
= el
->next
)
578 merge_argument_lists (proc
, el
->sym
->formal
);
580 /* Check the master formal arguments for any that are not
581 present in all entry points. */
582 for (el
= ns
->entries
; el
; el
= el
->next
)
583 check_argument_lists (proc
, el
->sym
->formal
);
585 /* Use the master function for the function body. */
586 ns
->proc_name
= proc
;
588 /* Finalize the new symbols. */
589 gfc_commit_symbols ();
591 /* Restore the original namespace. */
592 gfc_current_ns
= old_ns
;
596 /* Resolve contained function types. Because contained functions can call one
597 another, they have to be worked out before any of the contained procedures
600 The good news is that if a function doesn't already have a type, the only
601 way it can get one is through an IMPLICIT type or a RESULT variable, because
602 by definition contained functions are contained namespace they're contained
603 in, not in a sibling or parent namespace. */
606 resolve_contained_functions (gfc_namespace
* ns
)
608 gfc_namespace
*child
;
611 resolve_formal_arglists (ns
);
613 for (child
= ns
->contained
; child
; child
= child
->sibling
)
615 /* Resolve alternate entry points first. */
616 resolve_entries (child
);
618 /* Then check function return types. */
619 resolve_contained_fntype (child
->proc_name
, child
);
620 for (el
= child
->entries
; el
; el
= el
->next
)
621 resolve_contained_fntype (el
->sym
, child
);
626 /* Resolve all of the elements of a structure constructor and make sure that
627 the types are correct. */
630 resolve_structure_cons (gfc_expr
* expr
)
632 gfc_constructor
*cons
;
638 cons
= expr
->value
.constructor
;
639 /* A constructor may have references if it is the result of substituting a
640 parameter variable. In this case we just pull out the component we
643 comp
= expr
->ref
->u
.c
.sym
->components
;
645 comp
= expr
->ts
.derived
->components
;
647 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
652 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
658 if (cons
->expr
->expr_type
!= EXPR_NULL
659 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
660 && (comp
->allocatable
|| cons
->expr
->rank
))
662 gfc_error ("The rank of the element in the derived type "
663 "constructor at %L does not match that of the "
664 "component (%d/%d)", &cons
->expr
->where
,
665 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
669 /* If we don't have the right type, try to convert it. */
671 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
674 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
675 gfc_error ("The element in the derived type constructor at %L, "
676 "for pointer component '%s', is %s but should be %s",
677 &cons
->expr
->where
, comp
->name
,
678 gfc_basic_typename (cons
->expr
->ts
.type
),
679 gfc_basic_typename (comp
->ts
.type
));
681 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
684 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
687 a
= gfc_expr_attr (cons
->expr
);
689 if (!a
.pointer
&& !a
.target
)
692 gfc_error ("The element in the derived type constructor at %L, "
693 "for pointer component '%s' should be a POINTER or "
694 "a TARGET", &cons
->expr
->where
, comp
->name
);
703 /****************** Expression name resolution ******************/
705 /* Returns 0 if a symbol was not declared with a type or
706 attribute declaration statement, nonzero otherwise. */
709 was_declared (gfc_symbol
* sym
)
715 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
718 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
719 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
|| a
.value
720 || a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
727 /* Determine if a symbol is generic or not. */
730 generic_sym (gfc_symbol
* sym
)
734 if (sym
->attr
.generic
||
735 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
738 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
741 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
743 return (s
== NULL
) ? 0 : generic_sym (s
);
747 /* Determine if a symbol is specific or not. */
750 specific_sym (gfc_symbol
* sym
)
754 if (sym
->attr
.if_source
== IFSRC_IFBODY
755 || sym
->attr
.proc
== PROC_MODULE
756 || sym
->attr
.proc
== PROC_INTERNAL
757 || sym
->attr
.proc
== PROC_ST_FUNCTION
758 || (sym
->attr
.intrinsic
&&
759 gfc_specific_intrinsic (sym
->name
))
760 || sym
->attr
.external
)
763 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
766 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
768 return (s
== NULL
) ? 0 : specific_sym (s
);
772 /* Figure out if the procedure is specific, generic or unknown. */
775 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
779 procedure_kind (gfc_symbol
* sym
)
782 if (generic_sym (sym
))
783 return PTYPE_GENERIC
;
785 if (specific_sym (sym
))
786 return PTYPE_SPECIFIC
;
788 return PTYPE_UNKNOWN
;
791 /* Check references to assumed size arrays. The flag need_full_assumed_size
792 is nonzero when matching actual arguments. */
794 static int need_full_assumed_size
= 0;
797 check_assumed_size_reference (gfc_symbol
* sym
, gfc_expr
* e
)
803 if (need_full_assumed_size
804 || !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
807 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
808 if (ref
->type
== REF_ARRAY
)
809 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
810 last
= (ref
->u
.ar
.end
[dim
] == NULL
) && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
814 gfc_error ("The upper bound in the last dimension must "
815 "appear in the reference to the assumed size "
816 "array '%s' at %L", sym
->name
, &e
->where
);
823 /* Look for bad assumed size array references in argument expressions
824 of elemental and array valued intrinsic procedures. Since this is
825 called from procedure resolution functions, it only recurses at
829 resolve_assumed_size_actual (gfc_expr
*e
)
834 switch (e
->expr_type
)
838 && check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
843 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
844 || resolve_assumed_size_actual (e
->value
.op
.op2
))
855 /* Resolve an actual argument list. Most of the time, this is just
856 resolving the expressions in the list.
857 The exception is that we sometimes have to decide whether arguments
858 that look like procedure arguments are really simple variable
862 resolve_actual_arglist (gfc_actual_arglist
* arg
, procedure_type ptype
)
865 gfc_symtree
*parent_st
;
868 for (; arg
; arg
= arg
->next
)
873 /* Check the label is a valid branching target. */
876 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
878 gfc_error ("Label %d referenced at %L is never defined",
879 arg
->label
->value
, &arg
->label
->where
);
886 if (e
->ts
.type
!= BT_PROCEDURE
)
888 if (gfc_resolve_expr (e
) != SUCCESS
)
893 /* See if the expression node should really be a variable
896 sym
= e
->symtree
->n
.sym
;
898 if (sym
->attr
.flavor
== FL_PROCEDURE
899 || sym
->attr
.intrinsic
900 || sym
->attr
.external
)
904 /* If a procedure is not already determined to be something else
905 check if it is intrinsic. */
906 if (!sym
->attr
.intrinsic
907 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
908 || sym
->attr
.if_source
== IFSRC_IFBODY
)
909 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
910 sym
->attr
.intrinsic
= 1;
912 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
914 gfc_error ("Statement function '%s' at %L is not allowed as an "
915 "actual argument", sym
->name
, &e
->where
);
918 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
, sym
->attr
.subroutine
);
919 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
921 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
922 "actual argument", sym
->name
, &e
->where
);
925 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
926 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
928 gfc_error ("Internal procedure '%s' is not allowed as an "
929 "actual argument at %L", sym
->name
, &e
->where
);
932 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
934 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
935 "allowed as an actual argument at %L", sym
->name
,
939 if (sym
->attr
.generic
)
941 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
942 "allowed as an actual argument at %L", sym
->name
,
946 /* If the symbol is the function that names the current (or
947 parent) scope, then we really have a variable reference. */
949 if (sym
->attr
.function
&& sym
->result
== sym
950 && (sym
->ns
->proc_name
== sym
951 || (sym
->ns
->parent
!= NULL
952 && sym
->ns
->parent
->proc_name
== sym
)))
955 /* If all else fails, see if we have a specific intrinsic. */
956 if (sym
->attr
.function
957 && sym
->ts
.type
== BT_UNKNOWN
958 && sym
->attr
.intrinsic
)
960 gfc_intrinsic_sym
*isym
;
961 isym
= gfc_find_function (sym
->name
);
962 if (isym
== NULL
|| !isym
->specific
)
964 gfc_error ("Unable to find a specific INTRINSIC procedure "
965 "for the reference '%s' at %L", sym
->name
,
973 /* See if the name is a module procedure in a parent unit. */
975 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
978 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
980 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
984 if (parent_st
== NULL
)
987 sym
= parent_st
->n
.sym
;
988 e
->symtree
= parent_st
; /* Point to the right thing. */
990 if (sym
->attr
.flavor
== FL_PROCEDURE
991 || sym
->attr
.intrinsic
992 || sym
->attr
.external
)
998 e
->expr_type
= EXPR_VARIABLE
;
1000 if (sym
->as
!= NULL
)
1002 e
->rank
= sym
->as
->rank
;
1003 e
->ref
= gfc_get_ref ();
1004 e
->ref
->type
= REF_ARRAY
;
1005 e
->ref
->u
.ar
.type
= AR_FULL
;
1006 e
->ref
->u
.ar
.as
= sym
->as
;
1010 /* Check argument list functions %VAL, %LOC and %REF. There is
1011 nothing to do for %REF. */
1012 if (arg
->name
&& arg
->name
[0] == '%')
1014 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1016 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1018 gfc_error ("By-value argument at %L is not of numeric "
1025 gfc_error ("By-value argument at %L cannot be an array or "
1026 "an array section", &e
->where
);
1030 /* Intrinsics are still PROC_UNKNOWN here. However,
1031 since same file external procedures are not resolvable
1032 in gfortran, it is a good deal easier to leave them to
1034 if (ptype
!= PROC_UNKNOWN
&& ptype
!= PROC_EXTERNAL
)
1036 gfc_error ("By-value argument at %L is not allowed "
1037 "in this context", &e
->where
);
1041 if (((e
->ts
.type
== BT_REAL
|| e
->ts
.type
== BT_COMPLEX
)
1042 && e
->ts
.kind
> gfc_default_real_kind
)
1043 || (e
->ts
.kind
> gfc_default_integer_kind
))
1045 gfc_error ("Kind of by-value argument at %L is larger "
1046 "than default kind", &e
->where
);
1052 /* Statement functions have already been excluded above. */
1053 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1054 && e
->ts
.type
== BT_PROCEDURE
)
1056 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1058 gfc_error ("Passing internal procedure at %L by location "
1059 "not allowed", &e
->where
);
1070 /* Do the checks of the actual argument list that are specific to elemental
1071 procedures. If called with c == NULL, we have a function, otherwise if
1072 expr == NULL, we have a subroutine. */
1074 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1076 gfc_actual_arglist
*arg0
;
1077 gfc_actual_arglist
*arg
;
1078 gfc_symbol
*esym
= NULL
;
1079 gfc_intrinsic_sym
*isym
= NULL
;
1081 gfc_intrinsic_arg
*iformal
= NULL
;
1082 gfc_formal_arglist
*eformal
= NULL
;
1083 bool formal_optional
= false;
1084 bool set_by_optional
= false;
1088 /* Is this an elemental procedure? */
1089 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1091 if (expr
->value
.function
.esym
!= NULL
1092 && expr
->value
.function
.esym
->attr
.elemental
)
1094 arg0
= expr
->value
.function
.actual
;
1095 esym
= expr
->value
.function
.esym
;
1097 else if (expr
->value
.function
.isym
!= NULL
1098 && expr
->value
.function
.isym
->elemental
)
1100 arg0
= expr
->value
.function
.actual
;
1101 isym
= expr
->value
.function
.isym
;
1106 else if (c
&& c
->ext
.actual
!= NULL
1107 && c
->symtree
->n
.sym
->attr
.elemental
)
1109 arg0
= c
->ext
.actual
;
1110 esym
= c
->symtree
->n
.sym
;
1115 /* The rank of an elemental is the rank of its array argument(s). */
1116 for (arg
= arg0
; arg
; arg
= arg
->next
)
1118 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1120 rank
= arg
->expr
->rank
;
1121 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1122 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1123 set_by_optional
= true;
1125 /* Function specific; set the result rank and shape. */
1129 if (!expr
->shape
&& arg
->expr
->shape
)
1131 expr
->shape
= gfc_get_shape (rank
);
1132 for (i
= 0; i
< rank
; i
++)
1133 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1140 /* If it is an array, it shall not be supplied as an actual argument
1141 to an elemental procedure unless an array of the same rank is supplied
1142 as an actual argument corresponding to a nonoptional dummy argument of
1143 that elemental procedure(12.4.1.5). */
1144 formal_optional
= false;
1146 iformal
= isym
->formal
;
1148 eformal
= esym
->formal
;
1150 for (arg
= arg0
; arg
; arg
= arg
->next
)
1154 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1155 formal_optional
= true;
1156 eformal
= eformal
->next
;
1158 else if (isym
&& iformal
)
1160 if (iformal
->optional
)
1161 formal_optional
= true;
1162 iformal
= iformal
->next
;
1165 formal_optional
= true;
1167 if (pedantic
&& arg
->expr
!= NULL
1168 && arg
->expr
->expr_type
== EXPR_VARIABLE
1169 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1172 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1173 && !(isym
&& isym
->generic_id
== GFC_ISYM_CONVERSION
))
1175 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1176 "MISSING, it cannot be the actual argument of an "
1177 "ELEMENTAL procedure unless there is a non-optional"
1178 "argument with the same rank (12.4.1.5)",
1179 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1184 for (arg
= arg0
; arg
; arg
= arg
->next
)
1186 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1189 /* Being elemental, the last upper bound of an assumed size array
1190 argument must be present. */
1191 if (resolve_assumed_size_actual (arg
->expr
))
1197 /* Elemental subroutine array actual arguments must conform. */
1200 if (gfc_check_conformance ("elemental subroutine", arg
->expr
, e
)
1212 /* Go through each actual argument in ACTUAL and see if it can be
1213 implemented as an inlined, non-copying intrinsic. FNSYM is the
1214 function being called, or NULL if not known. */
1217 find_noncopying_intrinsics (gfc_symbol
* fnsym
, gfc_actual_arglist
* actual
)
1219 gfc_actual_arglist
*ap
;
1222 for (ap
= actual
; ap
; ap
= ap
->next
)
1224 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1225 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1226 ap
->expr
->inline_noncopying_intrinsic
= 1;
1229 /* This function does the checking of references to global procedures
1230 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1231 77 and 95 standards. It checks for a gsymbol for the name, making
1232 one if it does not already exist. If it already exists, then the
1233 reference being resolved must correspond to the type of gsymbol.
1234 Otherwise, the new symbol is equipped with the attributes of the
1235 reference. The corresponding code that is called in creating
1236 global entities is parse.c. */
1239 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1244 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1246 gsym
= gfc_get_gsymbol (sym
->name
);
1248 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1249 global_used (gsym
, where
);
1251 if (gsym
->type
== GSYM_UNKNOWN
)
1254 gsym
->where
= *where
;
1260 /************* Function resolution *************/
1262 /* Resolve a function call known to be generic.
1263 Section 14.1.2.4.1. */
1266 resolve_generic_f0 (gfc_expr
* expr
, gfc_symbol
* sym
)
1270 if (sym
->attr
.generic
)
1273 gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1276 expr
->value
.function
.name
= s
->name
;
1277 expr
->value
.function
.esym
= s
;
1279 if (s
->ts
.type
!= BT_UNKNOWN
)
1281 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1282 expr
->ts
= s
->result
->ts
;
1285 expr
->rank
= s
->as
->rank
;
1286 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1287 expr
->rank
= s
->result
->as
->rank
;
1292 /* TODO: Need to search for elemental references in generic interface */
1295 if (sym
->attr
.intrinsic
)
1296 return gfc_intrinsic_func_interface (expr
, 0);
1303 resolve_generic_f (gfc_expr
* expr
)
1308 sym
= expr
->symtree
->n
.sym
;
1312 m
= resolve_generic_f0 (expr
, sym
);
1315 else if (m
== MATCH_ERROR
)
1319 if (sym
->ns
->parent
== NULL
)
1321 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1325 if (!generic_sym (sym
))
1329 /* Last ditch attempt. See if the reference is to an intrinsic
1330 that possesses a matching interface. 14.1.2.4 */
1331 if (!gfc_intrinsic_name (sym
->name
, 0))
1333 gfc_error ("There is no specific function for the generic '%s' at %L",
1334 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1338 m
= gfc_intrinsic_func_interface (expr
, 0);
1343 ("Generic function '%s' at %L is not consistent with a specific "
1344 "intrinsic interface", expr
->symtree
->n
.sym
->name
, &expr
->where
);
1350 /* Resolve a function call known to be specific. */
1353 resolve_specific_f0 (gfc_symbol
* sym
, gfc_expr
* expr
)
1357 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1359 if (sym
->attr
.dummy
)
1361 sym
->attr
.proc
= PROC_DUMMY
;
1365 sym
->attr
.proc
= PROC_EXTERNAL
;
1369 if (sym
->attr
.proc
== PROC_MODULE
1370 || sym
->attr
.proc
== PROC_ST_FUNCTION
1371 || sym
->attr
.proc
== PROC_INTERNAL
)
1374 if (sym
->attr
.intrinsic
)
1376 m
= gfc_intrinsic_func_interface (expr
, 1);
1381 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1382 "an intrinsic", sym
->name
, &expr
->where
);
1390 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1393 expr
->value
.function
.name
= sym
->name
;
1394 expr
->value
.function
.esym
= sym
;
1395 if (sym
->as
!= NULL
)
1396 expr
->rank
= sym
->as
->rank
;
1403 resolve_specific_f (gfc_expr
* expr
)
1408 sym
= expr
->symtree
->n
.sym
;
1412 m
= resolve_specific_f0 (sym
, expr
);
1415 if (m
== MATCH_ERROR
)
1418 if (sym
->ns
->parent
== NULL
)
1421 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1427 gfc_error ("Unable to resolve the specific function '%s' at %L",
1428 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1434 /* Resolve a procedure call not known to be generic nor specific. */
1437 resolve_unknown_f (gfc_expr
* expr
)
1442 sym
= expr
->symtree
->n
.sym
;
1444 if (sym
->attr
.dummy
)
1446 sym
->attr
.proc
= PROC_DUMMY
;
1447 expr
->value
.function
.name
= sym
->name
;
1451 /* See if we have an intrinsic function reference. */
1453 if (gfc_intrinsic_name (sym
->name
, 0))
1455 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1460 /* The reference is to an external name. */
1462 sym
->attr
.proc
= PROC_EXTERNAL
;
1463 expr
->value
.function
.name
= sym
->name
;
1464 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1466 if (sym
->as
!= NULL
)
1467 expr
->rank
= sym
->as
->rank
;
1469 /* Type of the expression is either the type of the symbol or the
1470 default type of the symbol. */
1473 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1475 if (sym
->ts
.type
!= BT_UNKNOWN
)
1479 ts
= gfc_get_default_type (sym
, sym
->ns
);
1481 if (ts
->type
== BT_UNKNOWN
)
1483 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1484 sym
->name
, &expr
->where
);
1495 /* Figure out if a function reference is pure or not. Also set the name
1496 of the function for a potential error message. Return nonzero if the
1497 function is PURE, zero if not. */
1500 pure_function (gfc_expr
* e
, const char **name
)
1504 if (e
->value
.function
.esym
)
1506 pure
= gfc_pure (e
->value
.function
.esym
);
1507 *name
= e
->value
.function
.esym
->name
;
1509 else if (e
->value
.function
.isym
)
1511 pure
= e
->value
.function
.isym
->pure
1512 || e
->value
.function
.isym
->elemental
;
1513 *name
= e
->value
.function
.isym
->name
;
1517 /* Implicit functions are not pure. */
1519 *name
= e
->value
.function
.name
;
1526 /* Resolve a function call, which means resolving the arguments, then figuring
1527 out which entity the name refers to. */
1528 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1529 to INTENT(OUT) or INTENT(INOUT). */
1532 resolve_function (gfc_expr
* expr
)
1534 gfc_actual_arglist
*arg
;
1539 procedure_type p
= PROC_INTRINSIC
;
1543 sym
= expr
->symtree
->n
.sym
;
1545 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
1547 gfc_error ("'%s' at %L is not a function",
1548 sym
->name
, &expr
->where
);
1552 /* If the procedure is not internal, a statement function or a module
1553 procedure,it must be external and should be checked for usage. */
1554 if (sym
&& !sym
->attr
.dummy
&& !sym
->attr
.contained
1555 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1556 && !sym
->attr
.use_assoc
)
1557 resolve_global_procedure (sym
, &expr
->where
, 0);
1559 /* Switch off assumed size checking and do this again for certain kinds
1560 of procedure, once the procedure itself is resolved. */
1561 need_full_assumed_size
++;
1563 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
1564 p
= expr
->symtree
->n
.sym
->attr
.proc
;
1566 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
1569 /* Resume assumed_size checking. */
1570 need_full_assumed_size
--;
1572 if (sym
&& sym
->ts
.type
== BT_CHARACTER
1574 && sym
->ts
.cl
->length
== NULL
1576 && expr
->value
.function
.esym
== NULL
1577 && !sym
->attr
.contained
)
1579 /* Internal procedures are taken care of in resolve_contained_fntype. */
1580 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1581 "be used at %L since it is not a dummy argument",
1582 sym
->name
, &expr
->where
);
1586 /* See if function is already resolved. */
1588 if (expr
->value
.function
.name
!= NULL
)
1590 if (expr
->ts
.type
== BT_UNKNOWN
)
1596 /* Apply the rules of section 14.1.2. */
1598 switch (procedure_kind (sym
))
1601 t
= resolve_generic_f (expr
);
1604 case PTYPE_SPECIFIC
:
1605 t
= resolve_specific_f (expr
);
1609 t
= resolve_unknown_f (expr
);
1613 gfc_internal_error ("resolve_function(): bad function type");
1617 /* If the expression is still a function (it might have simplified),
1618 then we check to see if we are calling an elemental function. */
1620 if (expr
->expr_type
!= EXPR_FUNCTION
)
1623 temp
= need_full_assumed_size
;
1624 need_full_assumed_size
= 0;
1626 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
1629 if (omp_workshare_flag
1630 && expr
->value
.function
.esym
1631 && ! gfc_elemental (expr
->value
.function
.esym
))
1633 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1634 " in WORKSHARE construct", expr
->value
.function
.esym
->name
,
1639 #define GENERIC_ID expr->value.function.isym->generic_id
1640 else if (expr
->value
.function
.actual
!= NULL
1641 && expr
->value
.function
.isym
!= NULL
1642 && GENERIC_ID
!= GFC_ISYM_LBOUND
1643 && GENERIC_ID
!= GFC_ISYM_LEN
1644 && GENERIC_ID
!= GFC_ISYM_LOC
1645 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
1647 /* Array intrinsics must also have the last upper bound of an
1648 assumed size array argument. UBOUND and SIZE have to be
1649 excluded from the check if the second argument is anything
1652 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
1653 || GENERIC_ID
== GFC_ISYM_SIZE
;
1655 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1657 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
1658 && arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
1661 if (arg
->expr
!= NULL
1662 && arg
->expr
->rank
> 0
1663 && resolve_assumed_size_actual (arg
->expr
))
1669 need_full_assumed_size
= temp
;
1671 if (!pure_function (expr
, &name
) && name
)
1676 ("reference to non-PURE function '%s' at %L inside a "
1677 "FORALL %s", name
, &expr
->where
, forall_flag
== 2 ?
1681 else if (gfc_pure (NULL
))
1683 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1684 "procedure within a PURE procedure", name
, &expr
->where
);
1689 /* Functions without the RECURSIVE attribution are not allowed to
1690 * call themselves. */
1691 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
1693 gfc_symbol
*esym
, *proc
;
1694 esym
= expr
->value
.function
.esym
;
1695 proc
= gfc_current_ns
->proc_name
;
1698 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1699 "RECURSIVE", name
, &expr
->where
);
1703 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
1704 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1706 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1707 "'%s' is not declared as RECURSIVE",
1708 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
1713 /* Character lengths of use associated functions may contains references to
1714 symbols not referenced from the current program unit otherwise. Make sure
1715 those symbols are marked as referenced. */
1717 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
1718 && expr
->value
.function
.esym
->attr
.use_assoc
)
1720 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
1724 find_noncopying_intrinsics (expr
->value
.function
.esym
,
1725 expr
->value
.function
.actual
);
1730 /************* Subroutine resolution *************/
1733 pure_subroutine (gfc_code
* c
, gfc_symbol
* sym
)
1740 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1741 sym
->name
, &c
->loc
);
1742 else if (gfc_pure (NULL
))
1743 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
1749 resolve_generic_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1753 if (sym
->attr
.generic
)
1755 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
1758 c
->resolved_sym
= s
;
1759 pure_subroutine (c
, s
);
1763 /* TODO: Need to search for elemental references in generic interface. */
1766 if (sym
->attr
.intrinsic
)
1767 return gfc_intrinsic_sub_interface (c
, 0);
1774 resolve_generic_s (gfc_code
* c
)
1779 sym
= c
->symtree
->n
.sym
;
1783 m
= resolve_generic_s0 (c
, sym
);
1786 else if (m
== MATCH_ERROR
)
1790 if (sym
->ns
->parent
== NULL
)
1792 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1796 if (!generic_sym (sym
))
1800 /* Last ditch attempt. See if the reference is to an intrinsic
1801 that possesses a matching interface. 14.1.2.4 */
1802 sym
= c
->symtree
->n
.sym
;
1804 if (!gfc_intrinsic_name (sym
->name
, 1))
1807 ("There is no specific subroutine for the generic '%s' at %L",
1808 sym
->name
, &c
->loc
);
1812 m
= gfc_intrinsic_sub_interface (c
, 0);
1816 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1817 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
1823 /* Resolve a subroutine call known to be specific. */
1826 resolve_specific_s0 (gfc_code
* c
, gfc_symbol
* sym
)
1830 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1832 if (sym
->attr
.dummy
)
1834 sym
->attr
.proc
= PROC_DUMMY
;
1838 sym
->attr
.proc
= PROC_EXTERNAL
;
1842 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
1845 if (sym
->attr
.intrinsic
)
1847 m
= gfc_intrinsic_sub_interface (c
, 1);
1851 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1852 "with an intrinsic", sym
->name
, &c
->loc
);
1860 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1862 c
->resolved_sym
= sym
;
1863 pure_subroutine (c
, sym
);
1870 resolve_specific_s (gfc_code
* c
)
1875 sym
= c
->symtree
->n
.sym
;
1879 m
= resolve_specific_s0 (c
, sym
);
1882 if (m
== MATCH_ERROR
)
1885 if (sym
->ns
->parent
== NULL
)
1888 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1894 sym
= c
->symtree
->n
.sym
;
1895 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1896 sym
->name
, &c
->loc
);
1902 /* Resolve a subroutine call not known to be generic nor specific. */
1905 resolve_unknown_s (gfc_code
* c
)
1909 sym
= c
->symtree
->n
.sym
;
1911 if (sym
->attr
.dummy
)
1913 sym
->attr
.proc
= PROC_DUMMY
;
1917 /* See if we have an intrinsic function reference. */
1919 if (gfc_intrinsic_name (sym
->name
, 1))
1921 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
1926 /* The reference is to an external name. */
1929 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
1931 c
->resolved_sym
= sym
;
1933 pure_subroutine (c
, sym
);
1939 /* Resolve a subroutine call. Although it was tempting to use the same code
1940 for functions, subroutines and functions are stored differently and this
1941 makes things awkward. */
1944 resolve_call (gfc_code
* c
)
1947 procedure_type ptype
= PROC_INTRINSIC
;
1949 if (c
->symtree
&& c
->symtree
->n
.sym
1950 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
1952 gfc_error ("'%s' at %L has a type, which is not consistent with "
1953 "the CALL at %L", c
->symtree
->n
.sym
->name
,
1954 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
1958 /* If the procedure is not internal or module, it must be external and
1959 should be checked for usage. */
1960 if (c
->symtree
&& c
->symtree
->n
.sym
1961 && !c
->symtree
->n
.sym
->attr
.dummy
1962 && !c
->symtree
->n
.sym
->attr
.contained
1963 && !c
->symtree
->n
.sym
->attr
.use_assoc
)
1964 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
1966 /* Subroutines without the RECURSIVE attribution are not allowed to
1967 * call themselves. */
1968 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
1970 gfc_symbol
*csym
, *proc
;
1971 csym
= c
->symtree
->n
.sym
;
1972 proc
= gfc_current_ns
->proc_name
;
1975 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1976 "RECURSIVE", csym
->name
, &c
->loc
);
1980 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
1981 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
1983 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1984 "'%s' is not declared as RECURSIVE",
1985 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
1990 /* Switch off assumed size checking and do this again for certain kinds
1991 of procedure, once the procedure itself is resolved. */
1992 need_full_assumed_size
++;
1994 if (c
->symtree
&& c
->symtree
->n
.sym
)
1995 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
1997 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
2000 /* Resume assumed_size checking. */
2001 need_full_assumed_size
--;
2005 if (c
->resolved_sym
== NULL
)
2006 switch (procedure_kind (c
->symtree
->n
.sym
))
2009 t
= resolve_generic_s (c
);
2012 case PTYPE_SPECIFIC
:
2013 t
= resolve_specific_s (c
);
2017 t
= resolve_unknown_s (c
);
2021 gfc_internal_error ("resolve_subroutine(): bad function type");
2024 /* Some checks of elemental subroutine actual arguments. */
2025 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2029 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2033 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2034 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2035 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2036 if their shapes do not match. If either op1->shape or op2->shape is
2037 NULL, return SUCCESS. */
2040 compare_shapes (gfc_expr
* op1
, gfc_expr
* op2
)
2047 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2049 for (i
= 0; i
< op1
->rank
; i
++)
2051 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2053 gfc_error ("Shapes for operands at %L and %L are not conformable",
2054 &op1
->where
, &op2
->where
);
2064 /* Resolve an operator expression node. This can involve replacing the
2065 operation with a user defined function call. */
2068 resolve_operator (gfc_expr
* e
)
2070 gfc_expr
*op1
, *op2
;
2074 /* Resolve all subnodes-- give them types. */
2076 switch (e
->value
.op
.operator)
2079 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2082 /* Fall through... */
2085 case INTRINSIC_UPLUS
:
2086 case INTRINSIC_UMINUS
:
2087 case INTRINSIC_PARENTHESES
:
2088 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2093 /* Typecheck the new node. */
2095 op1
= e
->value
.op
.op1
;
2096 op2
= e
->value
.op
.op2
;
2098 switch (e
->value
.op
.operator)
2100 case INTRINSIC_UPLUS
:
2101 case INTRINSIC_UMINUS
:
2102 if (op1
->ts
.type
== BT_INTEGER
2103 || op1
->ts
.type
== BT_REAL
2104 || op1
->ts
.type
== BT_COMPLEX
)
2110 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2111 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2114 case INTRINSIC_PLUS
:
2115 case INTRINSIC_MINUS
:
2116 case INTRINSIC_TIMES
:
2117 case INTRINSIC_DIVIDE
:
2118 case INTRINSIC_POWER
:
2119 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2121 gfc_type_convert_binary (e
);
2126 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2127 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2128 gfc_typename (&op2
->ts
));
2131 case INTRINSIC_CONCAT
:
2132 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2134 e
->ts
.type
= BT_CHARACTER
;
2135 e
->ts
.kind
= op1
->ts
.kind
;
2140 _("Operands of string concatenation operator at %%L are %s/%s"),
2141 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2147 case INTRINSIC_NEQV
:
2148 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2150 e
->ts
.type
= BT_LOGICAL
;
2151 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2152 if (op1
->ts
.kind
< e
->ts
.kind
)
2153 gfc_convert_type (op1
, &e
->ts
, 2);
2154 else if (op2
->ts
.kind
< e
->ts
.kind
)
2155 gfc_convert_type (op2
, &e
->ts
, 2);
2159 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2160 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2161 gfc_typename (&op2
->ts
));
2166 if (op1
->ts
.type
== BT_LOGICAL
)
2168 e
->ts
.type
= BT_LOGICAL
;
2169 e
->ts
.kind
= op1
->ts
.kind
;
2173 sprintf (msg
, _("Operand of .NOT. operator at %%L is %s"),
2174 gfc_typename (&op1
->ts
));
2181 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2183 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2187 /* Fall through... */
2191 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2193 e
->ts
.type
= BT_LOGICAL
;
2194 e
->ts
.kind
= gfc_default_logical_kind
;
2198 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2200 gfc_type_convert_binary (e
);
2202 e
->ts
.type
= BT_LOGICAL
;
2203 e
->ts
.kind
= gfc_default_logical_kind
;
2207 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2209 _("Logicals at %%L must be compared with %s instead of %s"),
2210 e
->value
.op
.operator == INTRINSIC_EQ
? ".EQV." : ".NEQV.",
2211 gfc_op2string (e
->value
.op
.operator));
2214 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2215 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2216 gfc_typename (&op2
->ts
));
2220 case INTRINSIC_USER
:
2222 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2223 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2225 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2226 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2227 gfc_typename (&op2
->ts
));
2231 case INTRINSIC_PARENTHESES
:
2235 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2238 /* Deal with arrayness of an operand through an operator. */
2242 switch (e
->value
.op
.operator)
2244 case INTRINSIC_PLUS
:
2245 case INTRINSIC_MINUS
:
2246 case INTRINSIC_TIMES
:
2247 case INTRINSIC_DIVIDE
:
2248 case INTRINSIC_POWER
:
2249 case INTRINSIC_CONCAT
:
2253 case INTRINSIC_NEQV
:
2261 if (op1
->rank
== 0 && op2
->rank
== 0)
2264 if (op1
->rank
== 0 && op2
->rank
!= 0)
2266 e
->rank
= op2
->rank
;
2268 if (e
->shape
== NULL
)
2269 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2272 if (op1
->rank
!= 0 && op2
->rank
== 0)
2274 e
->rank
= op1
->rank
;
2276 if (e
->shape
== NULL
)
2277 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2280 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2282 if (op1
->rank
== op2
->rank
)
2284 e
->rank
= op1
->rank
;
2285 if (e
->shape
== NULL
)
2287 t
= compare_shapes(op1
, op2
);
2291 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2296 gfc_error ("Inconsistent ranks for operator at %L and %L",
2297 &op1
->where
, &op2
->where
);
2300 /* Allow higher level expressions to work. */
2308 case INTRINSIC_UPLUS
:
2309 case INTRINSIC_UMINUS
:
2310 case INTRINSIC_PARENTHESES
:
2311 e
->rank
= op1
->rank
;
2313 if (e
->shape
== NULL
)
2314 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2316 /* Simply copy arrayness attribute */
2323 /* Attempt to simplify the expression. */
2326 t
= gfc_simplify_expr (e
, 0);
2327 /* Some calls do not succeed in simplification and return FAILURE
2328 even though there is no error; eg. variable references to
2329 PARAMETER arrays. */
2330 if (!gfc_is_constant_expr (e
))
2337 if (gfc_extend_expr (e
) == SUCCESS
)
2340 gfc_error (msg
, &e
->where
);
2346 /************** Array resolution subroutines **************/
2350 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
2353 /* Compare two integer expressions. */
2356 compare_bound (gfc_expr
* a
, gfc_expr
* b
)
2360 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
2361 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
2364 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
2365 gfc_internal_error ("compare_bound(): Bad expression");
2367 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
2377 /* Compare an integer expression with an integer. */
2380 compare_bound_int (gfc_expr
* a
, int b
)
2384 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2387 if (a
->ts
.type
!= BT_INTEGER
)
2388 gfc_internal_error ("compare_bound_int(): Bad expression");
2390 i
= mpz_cmp_si (a
->value
.integer
, b
);
2400 /* Compare an integer expression with a mpz_t. */
2403 compare_bound_mpz_t (gfc_expr
* a
, mpz_t b
)
2407 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
2410 if (a
->ts
.type
!= BT_INTEGER
)
2411 gfc_internal_error ("compare_bound_int(): Bad expression");
2413 i
= mpz_cmp (a
->value
.integer
, b
);
2423 /* Compute the last value of a sequence given by a triplet.
2424 Return 0 if it wasn't able to compute the last value, or if the
2425 sequence if empty, and 1 otherwise. */
2428 compute_last_value_for_triplet (gfc_expr
* start
, gfc_expr
* end
,
2429 gfc_expr
* stride
, mpz_t last
)
2433 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
2434 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
2435 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
2438 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
2439 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
2442 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
2444 if (compare_bound (start
, end
) == CMP_GT
)
2446 mpz_set (last
, end
->value
.integer
);
2450 if (compare_bound_int (stride
, 0) == CMP_GT
)
2452 /* Stride is positive */
2453 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
2458 /* Stride is negative */
2459 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
2464 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
2465 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
2466 mpz_sub (last
, end
->value
.integer
, rem
);
2473 /* Compare a single dimension of an array reference to the array
2477 check_dimension (int i
, gfc_array_ref
* ar
, gfc_array_spec
* as
)
2481 /* Given start, end and stride values, calculate the minimum and
2482 maximum referenced indexes. */
2490 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
2492 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
2498 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
2500 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
2504 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2505 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2507 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
2508 && (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
2509 || compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
))
2512 if (((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
2513 || ar
->stride
[i
] == NULL
)
2514 && compare_bound (AR_START
, AR_END
) != CMP_GT
)
2515 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
2516 && compare_bound (AR_START
, AR_END
) != CMP_LT
))
2518 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
2520 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
2524 mpz_init (last_value
);
2525 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
2528 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
2529 || compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
2531 mpz_clear (last_value
);
2535 mpz_clear (last_value
);
2543 gfc_internal_error ("check_dimension(): Bad array reference");
2549 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
2554 /* Compare an array reference with an array specification. */
2557 compare_spec_to_ref (gfc_array_ref
* ar
)
2564 /* TODO: Full array sections are only allowed as actual parameters. */
2565 if (as
->type
== AS_ASSUMED_SIZE
2566 && (/*ar->type == AR_FULL
2567 ||*/ (ar
->type
== AR_SECTION
2568 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
2570 gfc_error ("Rightmost upper bound of assumed size array section"
2571 " not specified at %L", &ar
->where
);
2575 if (ar
->type
== AR_FULL
)
2578 if (as
->rank
!= ar
->dimen
)
2580 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2581 &ar
->where
, ar
->dimen
, as
->rank
);
2585 for (i
= 0; i
< as
->rank
; i
++)
2586 if (check_dimension (i
, ar
, as
) == FAILURE
)
2593 /* Resolve one part of an array index. */
2596 gfc_resolve_index (gfc_expr
* index
, int check_scalar
)
2603 if (gfc_resolve_expr (index
) == FAILURE
)
2606 if (check_scalar
&& index
->rank
!= 0)
2608 gfc_error ("Array index at %L must be scalar", &index
->where
);
2612 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
2614 gfc_error ("Array index at %L must be of INTEGER type",
2619 if (index
->ts
.type
== BT_REAL
)
2620 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
2621 &index
->where
) == FAILURE
)
2624 if (index
->ts
.kind
!= gfc_index_integer_kind
2625 || index
->ts
.type
!= BT_INTEGER
)
2628 ts
.type
= BT_INTEGER
;
2629 ts
.kind
= gfc_index_integer_kind
;
2631 gfc_convert_type_warn (index
, &ts
, 2, 0);
2637 /* Resolve a dim argument to an intrinsic function. */
2640 gfc_resolve_dim_arg (gfc_expr
*dim
)
2645 if (gfc_resolve_expr (dim
) == FAILURE
)
2650 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
2654 if (dim
->ts
.type
!= BT_INTEGER
)
2656 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
2659 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
2663 ts
.type
= BT_INTEGER
;
2664 ts
.kind
= gfc_index_integer_kind
;
2666 gfc_convert_type_warn (dim
, &ts
, 2, 0);
2672 /* Given an expression that contains array references, update those array
2673 references to point to the right array specifications. While this is
2674 filled in during matching, this information is difficult to save and load
2675 in a module, so we take care of it here.
2677 The idea here is that the original array reference comes from the
2678 base symbol. We traverse the list of reference structures, setting
2679 the stored reference to references. Component references can
2680 provide an additional array specification. */
2683 find_array_spec (gfc_expr
* e
)
2687 gfc_symbol
*derived
;
2690 as
= e
->symtree
->n
.sym
->as
;
2693 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2698 gfc_internal_error ("find_array_spec(): Missing spec");
2705 if (derived
== NULL
)
2706 derived
= e
->symtree
->n
.sym
->ts
.derived
;
2708 c
= derived
->components
;
2710 for (; c
; c
= c
->next
)
2711 if (c
== ref
->u
.c
.component
)
2713 /* Track the sequence of component references. */
2714 if (c
->ts
.type
== BT_DERIVED
)
2715 derived
= c
->ts
.derived
;
2720 gfc_internal_error ("find_array_spec(): Component not found");
2725 gfc_internal_error ("find_array_spec(): unused as(1)");
2736 gfc_internal_error ("find_array_spec(): unused as(2)");
2740 /* Resolve an array reference. */
2743 resolve_array_ref (gfc_array_ref
* ar
)
2745 int i
, check_scalar
;
2748 for (i
= 0; i
< ar
->dimen
; i
++)
2750 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
2752 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
2754 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
2756 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
2761 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
2765 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2769 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
2770 if (e
->expr_type
== EXPR_VARIABLE
2771 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
2772 ar
->start
[i
] = gfc_get_parentheses (e
);
2776 gfc_error ("Array index at %L is an array of rank %d",
2777 &ar
->c_where
[i
], e
->rank
);
2782 /* If the reference type is unknown, figure out what kind it is. */
2784 if (ar
->type
== AR_UNKNOWN
)
2786 ar
->type
= AR_ELEMENT
;
2787 for (i
= 0; i
< ar
->dimen
; i
++)
2788 if (ar
->dimen_type
[i
] == DIMEN_RANGE
2789 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2791 ar
->type
= AR_SECTION
;
2796 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
2804 resolve_substring (gfc_ref
* ref
)
2807 if (ref
->u
.ss
.start
!= NULL
)
2809 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
2812 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
2814 gfc_error ("Substring start index at %L must be of type INTEGER",
2815 &ref
->u
.ss
.start
->where
);
2819 if (ref
->u
.ss
.start
->rank
!= 0)
2821 gfc_error ("Substring start index at %L must be scalar",
2822 &ref
->u
.ss
.start
->where
);
2826 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
2827 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2828 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2830 gfc_error ("Substring start index at %L is less than one",
2831 &ref
->u
.ss
.start
->where
);
2836 if (ref
->u
.ss
.end
!= NULL
)
2838 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
2841 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
2843 gfc_error ("Substring end index at %L must be of type INTEGER",
2844 &ref
->u
.ss
.end
->where
);
2848 if (ref
->u
.ss
.end
->rank
!= 0)
2850 gfc_error ("Substring end index at %L must be scalar",
2851 &ref
->u
.ss
.end
->where
);
2855 if (ref
->u
.ss
.length
!= NULL
2856 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
2857 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
2858 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
2860 gfc_error ("Substring end index at %L exceeds the string length",
2861 &ref
->u
.ss
.start
->where
);
2870 /* Resolve subtype references. */
2873 resolve_ref (gfc_expr
* expr
)
2875 int current_part_dimension
, n_components
, seen_part_dimension
;
2878 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2879 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
2881 find_array_spec (expr
);
2885 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2889 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
2897 resolve_substring (ref
);
2901 /* Check constraints on part references. */
2903 current_part_dimension
= 0;
2904 seen_part_dimension
= 0;
2907 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2912 switch (ref
->u
.ar
.type
)
2916 current_part_dimension
= 1;
2920 current_part_dimension
= 0;
2924 gfc_internal_error ("resolve_ref(): Bad array reference");
2930 if (current_part_dimension
|| seen_part_dimension
)
2932 if (ref
->u
.c
.component
->pointer
)
2935 ("Component to the right of a part reference with nonzero "
2936 "rank must not have the POINTER attribute at %L",
2940 else if (ref
->u
.c
.component
->allocatable
)
2943 ("Component to the right of a part reference with nonzero "
2944 "rank must not have the ALLOCATABLE attribute at %L",
2957 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
2958 || ref
->next
== NULL
)
2959 && current_part_dimension
2960 && seen_part_dimension
)
2963 gfc_error ("Two or more part references with nonzero rank must "
2964 "not be specified at %L", &expr
->where
);
2968 if (ref
->type
== REF_COMPONENT
)
2970 if (current_part_dimension
)
2971 seen_part_dimension
= 1;
2973 /* reset to make sure */
2974 current_part_dimension
= 0;
2982 /* Given an expression, determine its shape. This is easier than it sounds.
2983 Leaves the shape array NULL if it is not possible to determine the shape. */
2986 expression_shape (gfc_expr
* e
)
2988 mpz_t array
[GFC_MAX_DIMENSIONS
];
2991 if (e
->rank
== 0 || e
->shape
!= NULL
)
2994 for (i
= 0; i
< e
->rank
; i
++)
2995 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
2998 e
->shape
= gfc_get_shape (e
->rank
);
3000 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3005 for (i
--; i
>= 0; i
--)
3006 mpz_clear (array
[i
]);
3010 /* Given a variable expression node, compute the rank of the expression by
3011 examining the base symbol and any reference structures it may have. */
3014 expression_rank (gfc_expr
* e
)
3021 if (e
->expr_type
== EXPR_ARRAY
)
3023 /* Constructors can have a rank different from one via RESHAPE(). */
3025 if (e
->symtree
== NULL
)
3031 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3032 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3038 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3040 if (ref
->type
!= REF_ARRAY
)
3043 if (ref
->u
.ar
.type
== AR_FULL
)
3045 rank
= ref
->u
.ar
.as
->rank
;
3049 if (ref
->u
.ar
.type
== AR_SECTION
)
3051 /* Figure out the rank of the section. */
3053 gfc_internal_error ("expression_rank(): Two array specs");
3055 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3056 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
3057 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
3067 expression_shape (e
);
3071 /* Resolve a variable expression. */
3074 resolve_variable (gfc_expr
* e
)
3081 if (e
->symtree
== NULL
)
3084 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
3087 sym
= e
->symtree
->n
.sym
;
3088 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
3090 e
->ts
.type
= BT_PROCEDURE
;
3094 if (sym
->ts
.type
!= BT_UNKNOWN
)
3095 gfc_variable_attr (e
, &e
->ts
);
3098 /* Must be a simple variable reference. */
3099 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
3104 if (check_assumed_size_reference (sym
, e
))
3107 /* Deal with forward references to entries during resolve_code, to
3108 satisfy, at least partially, 12.5.2.5. */
3109 if (gfc_current_ns
->entries
3110 && current_entry_id
== sym
->entry_id
3113 && cs_base
->current
->op
!= EXEC_ENTRY
)
3115 gfc_entry_list
*entry
;
3116 gfc_formal_arglist
*formal
;
3120 /* If the symbol is a dummy... */
3121 if (sym
->attr
.dummy
)
3123 entry
= gfc_current_ns
->entries
;
3126 /* ...test if the symbol is a parameter of previous entries. */
3127 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
3128 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
3130 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
3134 /* If it has not been seen as a dummy, this is an error. */
3137 if (specification_expr
)
3138 gfc_error ("Variable '%s',used in a specification expression, "
3139 "is referenced at %L before the ENTRY statement "
3140 "in which it is a parameter",
3141 sym
->name
, &cs_base
->current
->loc
);
3143 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3144 "statement in which it is a parameter",
3145 sym
->name
, &cs_base
->current
->loc
);
3150 /* Now do the same check on the specification expressions. */
3151 specification_expr
= 1;
3152 if (sym
->ts
.type
== BT_CHARACTER
3153 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3157 for (n
= 0; n
< sym
->as
->rank
; n
++)
3159 specification_expr
= 1;
3160 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3162 specification_expr
= 1;
3163 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3166 specification_expr
= 0;
3169 /* Update the symbol's entry level. */
3170 sym
->entry_id
= current_entry_id
+ 1;
3177 /* Resolve an expression. That is, make sure that types of operands agree
3178 with their operators, intrinsic operators are converted to function calls
3179 for overloaded types and unresolved function references are resolved. */
3182 gfc_resolve_expr (gfc_expr
* e
)
3189 switch (e
->expr_type
)
3192 t
= resolve_operator (e
);
3196 t
= resolve_function (e
);
3200 t
= resolve_variable (e
);
3202 expression_rank (e
);
3205 case EXPR_SUBSTRING
:
3206 t
= resolve_ref (e
);
3216 if (resolve_ref (e
) == FAILURE
)
3219 t
= gfc_resolve_array_constructor (e
);
3220 /* Also try to expand a constructor. */
3223 expression_rank (e
);
3224 gfc_expand_constructor (e
);
3227 /* This provides the opportunity for the length of constructors with character
3228 valued function elements to propogate the string length to the expression. */
3229 if (e
->ts
.type
== BT_CHARACTER
)
3230 gfc_resolve_character_array_constructor (e
);
3234 case EXPR_STRUCTURE
:
3235 t
= resolve_ref (e
);
3239 t
= resolve_structure_cons (e
);
3243 t
= gfc_simplify_expr (e
, 0);
3247 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3254 /* Resolve an expression from an iterator. They must be scalar and have
3255 INTEGER or (optionally) REAL type. */
3258 gfc_resolve_iterator_expr (gfc_expr
* expr
, bool real_ok
,
3259 const char * name_msgid
)
3261 if (gfc_resolve_expr (expr
) == FAILURE
)
3264 if (expr
->rank
!= 0)
3266 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
3270 if (!(expr
->ts
.type
== BT_INTEGER
3271 || (expr
->ts
.type
== BT_REAL
&& real_ok
)))
3274 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid
),
3277 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
3284 /* Resolve the expressions in an iterator structure. If REAL_OK is
3285 false allow only INTEGER type iterators, otherwise allow REAL types. */
3288 gfc_resolve_iterator (gfc_iterator
* iter
, bool real_ok
)
3291 if (iter
->var
->ts
.type
== BT_REAL
)
3292 gfc_notify_std (GFC_STD_F95_DEL
,
3293 "Obsolete: REAL DO loop iterator at %L",
3296 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
3300 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
3302 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3307 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
3308 "Start expression in DO loop") == FAILURE
)
3311 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
3312 "End expression in DO loop") == FAILURE
)
3315 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
3316 "Step expression in DO loop") == FAILURE
)
3319 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
3321 if ((iter
->step
->ts
.type
== BT_INTEGER
3322 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
3323 || (iter
->step
->ts
.type
== BT_REAL
3324 && mpfr_sgn (iter
->step
->value
.real
) == 0))
3326 gfc_error ("Step expression in DO loop at %L cannot be zero",
3327 &iter
->step
->where
);
3332 /* Convert start, end, and step to the same type as var. */
3333 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
3334 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
3335 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3337 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
3338 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
3339 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3341 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
3342 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
3343 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
3349 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3350 to be a scalar INTEGER variable. The subscripts and stride are scalar
3351 INTEGERs, and if stride is a constant it must be nonzero. */
3354 resolve_forall_iterators (gfc_forall_iterator
* iter
)
3359 if (gfc_resolve_expr (iter
->var
) == SUCCESS
3360 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
3361 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3364 if (gfc_resolve_expr (iter
->start
) == SUCCESS
3365 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
3366 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3367 &iter
->start
->where
);
3368 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
3369 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
3371 if (gfc_resolve_expr (iter
->end
) == SUCCESS
3372 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
3373 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3375 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
3376 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
3378 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
3380 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
3381 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3382 &iter
->stride
->where
, "INTEGER");
3384 if (iter
->stride
->expr_type
== EXPR_CONSTANT
3385 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
3386 gfc_error ("FORALL stride expression at %L cannot be zero",
3387 &iter
->stride
->where
);
3389 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
3390 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
3397 /* Given a pointer to a symbol that is a derived type, see if any components
3398 have the POINTER attribute. The search is recursive if necessary.
3399 Returns zero if no pointer components are found, nonzero otherwise. */
3402 derived_pointer (gfc_symbol
* sym
)
3406 for (c
= sym
->components
; c
; c
= c
->next
)
3411 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
3419 /* Given a pointer to a symbol that is a derived type, see if it's
3420 inaccessible, i.e. if it's defined in another module and the components are
3421 PRIVATE. The search is recursive if necessary. Returns zero if no
3422 inaccessible components are found, nonzero otherwise. */
3425 derived_inaccessible (gfc_symbol
*sym
)
3429 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
3432 for (c
= sym
->components
; c
; c
= c
->next
)
3434 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
3442 /* Resolve the argument of a deallocate expression. The expression must be
3443 a pointer or a full array. */
3446 resolve_deallocate_expr (gfc_expr
* e
)
3448 symbol_attribute attr
;
3449 int allocatable
, pointer
, check_intent_in
;
3452 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3453 check_intent_in
= 1;
3455 if (gfc_resolve_expr (e
) == FAILURE
)
3458 if (e
->expr_type
!= EXPR_VARIABLE
)
3461 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3462 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3463 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3466 check_intent_in
= 0;
3471 if (ref
->u
.ar
.type
!= AR_FULL
)
3476 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3477 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3478 pointer
= ref
->u
.c
.component
->pointer
;
3487 attr
= gfc_expr_attr (e
);
3489 if (allocatable
== 0 && attr
.pointer
== 0)
3492 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3493 "ALLOCATABLE or a POINTER", &e
->where
);
3497 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3499 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
3500 e
->symtree
->n
.sym
->name
, &e
->where
);
3507 /* Returns true if the expression e contains a reference the symbol sym. */
3509 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
3511 gfc_actual_arglist
*arg
;
3519 switch (e
->expr_type
)
3522 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3523 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
3526 /* If the variable is not the same as the dependent, 'sym', and
3527 it is not marked as being declared and it is in the same
3528 namespace as 'sym', add it to the local declarations. */
3530 if (sym
== e
->symtree
->n
.sym
)
3535 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
3536 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
3545 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3550 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3552 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
3553 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
3554 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
3559 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
3560 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
3564 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3565 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3567 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->ts
.cl
->length
);
3569 if (ref
->u
.c
.component
->as
)
3570 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3572 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->as
->lower
[i
]);
3573 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.c
.component
->as
->upper
[i
]);
3583 /* Given the expression node e for an allocatable/pointer of derived type to be
3584 allocated, get the expression node to be initialized afterwards (needed for
3585 derived types with default initializers, and derived types with allocatable
3586 components that need nullification.) */
3589 expr_to_initialize (gfc_expr
* e
)
3595 result
= gfc_copy_expr (e
);
3597 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3598 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
3599 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3601 ref
->u
.ar
.type
= AR_FULL
;
3603 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3604 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
3606 result
->rank
= ref
->u
.ar
.dimen
;
3614 /* Resolve the expression in an ALLOCATE statement, doing the additional
3615 checks to see whether the expression is OK or not. The expression must
3616 have a trailing array reference that gives the size of the array. */
3619 resolve_allocate_expr (gfc_expr
* e
, gfc_code
* code
)
3621 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
3622 symbol_attribute attr
;
3623 gfc_ref
*ref
, *ref2
;
3630 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
3631 check_intent_in
= 1;
3633 if (gfc_resolve_expr (e
) == FAILURE
)
3636 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
3637 sym
= code
->expr
->symtree
->n
.sym
;
3641 /* Make sure the expression is allocatable or a pointer. If it is
3642 pointer, the next-to-last reference must be a pointer. */
3646 if (e
->expr_type
!= EXPR_VARIABLE
)
3650 attr
= gfc_expr_attr (e
);
3651 pointer
= attr
.pointer
;
3652 dimension
= attr
.dimension
;
3657 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
3658 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
3659 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
3661 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
3663 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3664 "not be allocated in the same statement at %L",
3665 sym
->name
, &e
->where
);
3669 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
3672 check_intent_in
= 0;
3677 if (ref
->next
!= NULL
)
3682 allocatable
= (ref
->u
.c
.component
->as
!= NULL
3683 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
3685 pointer
= ref
->u
.c
.component
->pointer
;
3686 dimension
= ref
->u
.c
.component
->dimension
;
3697 if (allocatable
== 0 && pointer
== 0)
3699 gfc_error ("Expression in ALLOCATE statement at %L must be "
3700 "ALLOCATABLE or a POINTER", &e
->where
);
3705 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3707 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
3708 e
->symtree
->n
.sym
->name
, &e
->where
);
3712 /* Add default initializer for those derived types that need them. */
3713 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
3715 init_st
= gfc_get_code ();
3716 init_st
->loc
= code
->loc
;
3717 init_st
->op
= EXEC_INIT_ASSIGN
;
3718 init_st
->expr
= expr_to_initialize (e
);
3719 init_st
->expr2
= init_e
;
3720 init_st
->next
= code
->next
;
3721 code
->next
= init_st
;
3724 if (pointer
&& dimension
== 0)
3727 /* Make sure the next-to-last reference node is an array specification. */
3729 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
3731 gfc_error ("Array specification required in ALLOCATE statement "
3732 "at %L", &e
->where
);
3736 /* Make sure that the array section reference makes sense in the
3737 context of an ALLOCATE specification. */
3741 for (i
= 0; i
< ar
->dimen
; i
++)
3743 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
3746 switch (ar
->dimen_type
[i
])
3752 if (ar
->start
[i
] != NULL
3753 && ar
->end
[i
] != NULL
3754 && ar
->stride
[i
] == NULL
)
3757 /* Fall Through... */
3761 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3768 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
3770 sym
= a
->expr
->symtree
->n
.sym
;
3772 /* TODO - check derived type components. */
3773 if (sym
->ts
.type
== BT_DERIVED
)
3776 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
3777 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
3779 gfc_error ("'%s' must not appear an the array specification at "
3780 "%L in the same ALLOCATE statement where it is "
3781 "itself allocated", sym
->name
, &ar
->where
);
3791 /************ SELECT CASE resolution subroutines ************/
3793 /* Callback function for our mergesort variant. Determines interval
3794 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3795 op1 > op2. Assumes we're not dealing with the default case.
3796 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3797 There are nine situations to check. */
3800 compare_cases (const gfc_case
* op1
, const gfc_case
* op2
)
3804 if (op1
->low
== NULL
) /* op1 = (:L) */
3806 /* op2 = (:N), so overlap. */
3808 /* op2 = (M:) or (M:N), L < M */
3809 if (op2
->low
!= NULL
3810 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3813 else if (op1
->high
== NULL
) /* op1 = (K:) */
3815 /* op2 = (M:), so overlap. */
3817 /* op2 = (:N) or (M:N), K > N */
3818 if (op2
->high
!= NULL
3819 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3822 else /* op1 = (K:L) */
3824 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
3825 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
3826 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
3827 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
3828 else /* op2 = (M:N) */
3832 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
3835 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
3844 /* Merge-sort a double linked case list, detecting overlap in the
3845 process. LIST is the head of the double linked case list before it
3846 is sorted. Returns the head of the sorted list if we don't see any
3847 overlap, or NULL otherwise. */
3850 check_case_overlap (gfc_case
* list
)
3852 gfc_case
*p
, *q
, *e
, *tail
;
3853 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
3855 /* If the passed list was empty, return immediately. */
3862 /* Loop unconditionally. The only exit from this loop is a return
3863 statement, when we've finished sorting the case list. */
3870 /* Count the number of merges we do in this pass. */
3873 /* Loop while there exists a merge to be done. */
3878 /* Count this merge. */
3881 /* Cut the list in two pieces by stepping INSIZE places
3882 forward in the list, starting from P. */
3885 for (i
= 0; i
< insize
; i
++)
3894 /* Now we have two lists. Merge them! */
3895 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
3898 /* See from which the next case to merge comes from. */
3901 /* P is empty so the next case must come from Q. */
3906 else if (qsize
== 0 || q
== NULL
)
3915 cmp
= compare_cases (p
, q
);
3918 /* The whole case range for P is less than the
3926 /* The whole case range for Q is greater than
3927 the case range for P. */
3934 /* The cases overlap, or they are the same
3935 element in the list. Either way, we must
3936 issue an error and get the next case from P. */
3937 /* FIXME: Sort P and Q by line number. */
3938 gfc_error ("CASE label at %L overlaps with CASE "
3939 "label at %L", &p
->where
, &q
->where
);
3947 /* Add the next element to the merged list. */
3956 /* P has now stepped INSIZE places along, and so has Q. So
3957 they're the same. */
3962 /* If we have done only one merge or none at all, we've
3963 finished sorting the cases. */
3972 /* Otherwise repeat, merging lists twice the size. */
3978 /* Check to see if an expression is suitable for use in a CASE statement.
3979 Makes sure that all case expressions are scalar constants of the same
3980 type. Return FAILURE if anything is wrong. */
3983 validate_case_label_expr (gfc_expr
* e
, gfc_expr
* case_expr
)
3985 if (e
== NULL
) return SUCCESS
;
3987 if (e
->ts
.type
!= case_expr
->ts
.type
)
3989 gfc_error ("Expression in CASE statement at %L must be of type %s",
3990 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
3994 /* C805 (R808) For a given case-construct, each case-value shall be of
3995 the same type as case-expr. For character type, length differences
3996 are allowed, but the kind type parameters shall be the same. */
3998 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
4000 gfc_error("Expression in CASE statement at %L must be kind %d",
4001 &e
->where
, case_expr
->ts
.kind
);
4005 /* Convert the case value kind to that of case expression kind, if needed.
4006 FIXME: Should a warning be issued? */
4007 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
4008 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
4012 gfc_error ("Expression in CASE statement at %L must be scalar",
4021 /* Given a completely parsed select statement, we:
4023 - Validate all expressions and code within the SELECT.
4024 - Make sure that the selection expression is not of the wrong type.
4025 - Make sure that no case ranges overlap.
4026 - Eliminate unreachable cases and unreachable code resulting from
4027 removing case labels.
4029 The standard does allow unreachable cases, e.g. CASE (5:3). But
4030 they are a hassle for code generation, and to prevent that, we just
4031 cut them out here. This is not necessary for overlapping cases
4032 because they are illegal and we never even try to generate code.
4034 We have the additional caveat that a SELECT construct could have
4035 been a computed GOTO in the source code. Fortunately we can fairly
4036 easily work around that here: The case_expr for a "real" SELECT CASE
4037 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4038 we have to do is make sure that the case_expr is a scalar integer
4042 resolve_select (gfc_code
* code
)
4045 gfc_expr
*case_expr
;
4046 gfc_case
*cp
, *default_case
, *tail
, *head
;
4047 int seen_unreachable
;
4053 if (code
->expr
== NULL
)
4055 /* This was actually a computed GOTO statement. */
4056 case_expr
= code
->expr2
;
4057 if (case_expr
->ts
.type
!= BT_INTEGER
4058 || case_expr
->rank
!= 0)
4059 gfc_error ("Selection expression in computed GOTO statement "
4060 "at %L must be a scalar integer expression",
4063 /* Further checking is not necessary because this SELECT was built
4064 by the compiler, so it should always be OK. Just move the
4065 case_expr from expr2 to expr so that we can handle computed
4066 GOTOs as normal SELECTs from here on. */
4067 code
->expr
= code
->expr2
;
4072 case_expr
= code
->expr
;
4074 type
= case_expr
->ts
.type
;
4075 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
4077 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4078 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
4080 /* Punt. Going on here just produce more garbage error messages. */
4084 if (case_expr
->rank
!= 0)
4086 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4087 "expression", &case_expr
->where
);
4093 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4094 of the SELECT CASE expression and its CASE values. Walk the lists
4095 of case values, and if we find a mismatch, promote case_expr to
4096 the appropriate kind. */
4098 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
4100 for (body
= code
->block
; body
; body
= body
->block
)
4102 /* Walk the case label list. */
4103 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4105 /* Intercept the DEFAULT case. It does not have a kind. */
4106 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4109 /* Unreachable case ranges are discarded, so ignore. */
4110 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4111 && cp
->low
!= cp
->high
4112 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4115 /* FIXME: Should a warning be issued? */
4117 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
4118 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
4120 if (cp
->high
!= NULL
4121 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
4122 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
4127 /* Assume there is no DEFAULT case. */
4128 default_case
= NULL
;
4133 for (body
= code
->block
; body
; body
= body
->block
)
4135 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4137 seen_unreachable
= 0;
4139 /* Walk the case label list, making sure that all case labels
4141 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4143 /* Count the number of cases in the whole construct. */
4146 /* Intercept the DEFAULT case. */
4147 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4149 if (default_case
!= NULL
)
4151 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4152 "by a second DEFAULT CASE at %L",
4153 &default_case
->where
, &cp
->where
);
4164 /* Deal with single value cases and case ranges. Errors are
4165 issued from the validation function. */
4166 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
4167 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
4173 if (type
== BT_LOGICAL
4174 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
4175 || cp
->low
!= cp
->high
))
4178 ("Logical range in CASE statement at %L is not allowed",
4184 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
4187 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
4188 if (value
& seen_logical
)
4190 gfc_error ("constant logical value in CASE statement "
4191 "is repeated at %L",
4196 seen_logical
|= value
;
4199 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4200 && cp
->low
!= cp
->high
4201 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4203 if (gfc_option
.warn_surprising
)
4204 gfc_warning ("Range specification at %L can never "
4205 "be matched", &cp
->where
);
4207 cp
->unreachable
= 1;
4208 seen_unreachable
= 1;
4212 /* If the case range can be matched, it can also overlap with
4213 other cases. To make sure it does not, we put it in a
4214 double linked list here. We sort that with a merge sort
4215 later on to detect any overlapping cases. */
4219 head
->right
= head
->left
= NULL
;
4224 tail
->right
->left
= tail
;
4231 /* It there was a failure in the previous case label, give up
4232 for this case label list. Continue with the next block. */
4236 /* See if any case labels that are unreachable have been seen.
4237 If so, we eliminate them. This is a bit of a kludge because
4238 the case lists for a single case statement (label) is a
4239 single forward linked lists. */
4240 if (seen_unreachable
)
4242 /* Advance until the first case in the list is reachable. */
4243 while (body
->ext
.case_list
!= NULL
4244 && body
->ext
.case_list
->unreachable
)
4246 gfc_case
*n
= body
->ext
.case_list
;
4247 body
->ext
.case_list
= body
->ext
.case_list
->next
;
4249 gfc_free_case_list (n
);
4252 /* Strip all other unreachable cases. */
4253 if (body
->ext
.case_list
)
4255 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
4257 if (cp
->next
->unreachable
)
4259 gfc_case
*n
= cp
->next
;
4260 cp
->next
= cp
->next
->next
;
4262 gfc_free_case_list (n
);
4269 /* See if there were overlapping cases. If the check returns NULL,
4270 there was overlap. In that case we don't do anything. If head
4271 is non-NULL, we prepend the DEFAULT case. The sorted list can
4272 then used during code generation for SELECT CASE constructs with
4273 a case expression of a CHARACTER type. */
4276 head
= check_case_overlap (head
);
4278 /* Prepend the default_case if it is there. */
4279 if (head
!= NULL
&& default_case
)
4281 default_case
->left
= NULL
;
4282 default_case
->right
= head
;
4283 head
->left
= default_case
;
4287 /* Eliminate dead blocks that may be the result if we've seen
4288 unreachable case labels for a block. */
4289 for (body
= code
; body
&& body
->block
; body
= body
->block
)
4291 if (body
->block
->ext
.case_list
== NULL
)
4293 /* Cut the unreachable block from the code chain. */
4294 gfc_code
*c
= body
->block
;
4295 body
->block
= c
->block
;
4297 /* Kill the dead block, but not the blocks below it. */
4299 gfc_free_statements (c
);
4303 /* More than two cases is legal but insane for logical selects.
4304 Issue a warning for it. */
4305 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
4307 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4312 /* Resolve a transfer statement. This is making sure that:
4313 -- a derived type being transferred has only non-pointer components
4314 -- a derived type being transferred doesn't have private components, unless
4315 it's being transferred from the module where the type was defined
4316 -- we're not trying to transfer a whole assumed size array. */
4319 resolve_transfer (gfc_code
* code
)
4328 if (exp
->expr_type
!= EXPR_VARIABLE
4329 && exp
->expr_type
!= EXPR_FUNCTION
)
4332 sym
= exp
->symtree
->n
.sym
;
4335 /* Go to actual component transferred. */
4336 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
4337 if (ref
->type
== REF_COMPONENT
)
4338 ts
= &ref
->u
.c
.component
->ts
;
4340 if (ts
->type
== BT_DERIVED
)
4342 /* Check that transferred derived type doesn't contain POINTER
4344 if (derived_pointer (ts
->derived
))
4346 gfc_error ("Data transfer element at %L cannot have "
4347 "POINTER components", &code
->loc
);
4351 if (ts
->derived
->attr
.alloc_comp
)
4353 gfc_error ("Data transfer element at %L cannot have "
4354 "ALLOCATABLE components", &code
->loc
);
4358 if (derived_inaccessible (ts
->derived
))
4360 gfc_error ("Data transfer element at %L cannot have "
4361 "PRIVATE components",&code
->loc
);
4366 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
4367 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
4369 gfc_error ("Data transfer element at %L cannot be a full reference to "
4370 "an assumed-size array", &code
->loc
);
4376 /*********** Toplevel code resolution subroutines ***********/
4378 /* Given a branch to a label and a namespace, if the branch is conforming.
4379 The code node described where the branch is located. */
4382 resolve_branch (gfc_st_label
* label
, gfc_code
* code
)
4384 gfc_code
*block
, *found
;
4392 /* Step one: is this a valid branching target? */
4394 if (lp
->defined
== ST_LABEL_UNKNOWN
)
4396 gfc_error ("Label %d referenced at %L is never defined", lp
->value
,
4401 if (lp
->defined
!= ST_LABEL_TARGET
)
4403 gfc_error ("Statement at %L is not a valid branch target statement "
4404 "for the branch statement at %L", &lp
->where
, &code
->loc
);
4408 /* Step two: make sure this branch is not a branch to itself ;-) */
4410 if (code
->here
== label
)
4412 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
4416 /* Step three: Try to find the label in the parse tree. To do this,
4417 we traverse the tree block-by-block: first the block that
4418 contains this GOTO, then the block that it is nested in, etc. We
4419 can ignore other blocks because branching into another block is
4424 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4426 for (block
= stack
->head
; block
; block
= block
->next
)
4428 if (block
->here
== label
)
4441 /* The label is not in an enclosing block, so illegal. This was
4442 allowed in Fortran 66, so we allow it as extension. We also
4443 forego further checks if we run into this. */
4444 gfc_notify_std (GFC_STD_LEGACY
,
4445 "Label at %L is not in the same block as the "
4446 "GOTO statement at %L", &lp
->where
, &code
->loc
);
4450 /* Step four: Make sure that the branching target is legal if
4451 the statement is an END {SELECT,DO,IF}. */
4453 if (found
->op
== EXEC_NOP
)
4455 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
4456 if (stack
->current
->next
== found
)
4460 gfc_notify_std (GFC_STD_F95_DEL
,
4461 "Obsolete: GOTO at %L jumps to END of construct at %L",
4462 &code
->loc
, &found
->loc
);
4467 /* Check whether EXPR1 has the same shape as EXPR2. */
4470 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
4472 mpz_t shape
[GFC_MAX_DIMENSIONS
];
4473 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
4474 try result
= FAILURE
;
4477 /* Compare the rank. */
4478 if (expr1
->rank
!= expr2
->rank
)
4481 /* Compare the size of each dimension. */
4482 for (i
=0; i
<expr1
->rank
; i
++)
4484 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
4487 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
4490 if (mpz_cmp (shape
[i
], shape2
[i
]))
4494 /* When either of the two expression is an assumed size array, we
4495 ignore the comparison of dimension sizes. */
4500 for (i
--; i
>=0; i
--)
4502 mpz_clear (shape
[i
]);
4503 mpz_clear (shape2
[i
]);
4509 /* Check whether a WHERE assignment target or a WHERE mask expression
4510 has the same shape as the outmost WHERE mask expression. */
4513 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
4519 cblock
= code
->block
;
4521 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4522 In case of nested WHERE, only the outmost one is stored. */
4523 if (mask
== NULL
) /* outmost WHERE */
4525 else /* inner WHERE */
4532 /* Check if the mask-expr has a consistent shape with the
4533 outmost WHERE mask-expr. */
4534 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
4535 gfc_error ("WHERE mask at %L has inconsistent shape",
4536 &cblock
->expr
->where
);
4539 /* the assignment statement of a WHERE statement, or the first
4540 statement in where-body-construct of a WHERE construct */
4541 cnext
= cblock
->next
;
4546 /* WHERE assignment statement */
4549 /* Check shape consistent for WHERE assignment target. */
4550 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
4551 gfc_error ("WHERE assignment target at %L has "
4552 "inconsistent shape", &cnext
->expr
->where
);
4555 /* WHERE or WHERE construct is part of a where-body-construct */
4557 resolve_where (cnext
, e
);
4561 gfc_error ("Unsupported statement inside WHERE at %L",
4564 /* the next statement within the same where-body-construct */
4565 cnext
= cnext
->next
;
4567 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4568 cblock
= cblock
->block
;
4573 /* Check whether the FORALL index appears in the expression or not. */
4576 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
4580 gfc_actual_arglist
*args
;
4583 switch (expr
->expr_type
)
4586 gcc_assert (expr
->symtree
->n
.sym
);
4588 /* A scalar assignment */
4591 if (expr
->symtree
->n
.sym
== symbol
)
4597 /* the expr is array ref, substring or struct component. */
4604 /* Check if the symbol appears in the array subscript. */
4606 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4609 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
4613 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
4617 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
4623 if (expr
->symtree
->n
.sym
== symbol
)
4626 /* Check if the symbol appears in the substring section. */
4627 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4629 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4637 gfc_error("expression reference type error at %L", &expr
->where
);
4643 /* If the expression is a function call, then check if the symbol
4644 appears in the actual arglist of the function. */
4646 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4648 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
4653 /* It seems not to happen. */
4654 case EXPR_SUBSTRING
:
4658 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
4659 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
4661 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
4666 /* It seems not to happen. */
4667 case EXPR_STRUCTURE
:
4669 gfc_error ("Unsupported statement while finding forall index in "
4674 /* Find the FORALL index in the first operand. */
4675 if (expr
->value
.op
.op1
)
4677 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
4681 /* Find the FORALL index in the second operand. */
4682 if (expr
->value
.op
.op2
)
4684 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
4697 /* Resolve assignment in FORALL construct.
4698 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4699 FORALL index variables. */
4702 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4706 for (n
= 0; n
< nvar
; n
++)
4708 gfc_symbol
*forall_index
;
4710 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
4712 /* Check whether the assignment target is one of the FORALL index
4714 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
4715 && (code
->expr
->symtree
->n
.sym
== forall_index
))
4716 gfc_error ("Assignment to a FORALL index variable at %L",
4717 &code
->expr
->where
);
4720 /* If one of the FORALL index variables doesn't appear in the
4721 assignment target, then there will be a many-to-one
4723 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
4724 gfc_error ("The FORALL with index '%s' cause more than one "
4725 "assignment to this object at %L",
4726 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
4732 /* Resolve WHERE statement in FORALL construct. */
4735 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
){
4739 cblock
= code
->block
;
4742 /* the assignment statement of a WHERE statement, or the first
4743 statement in where-body-construct of a WHERE construct */
4744 cnext
= cblock
->next
;
4749 /* WHERE assignment statement */
4751 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
4754 /* WHERE or WHERE construct is part of a where-body-construct */
4756 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
4760 gfc_error ("Unsupported statement inside WHERE at %L",
4763 /* the next statement within the same where-body-construct */
4764 cnext
= cnext
->next
;
4766 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4767 cblock
= cblock
->block
;
4772 /* Traverse the FORALL body to check whether the following errors exist:
4773 1. For assignment, check if a many-to-one assignment happens.
4774 2. For WHERE statement, check the WHERE body to see if there is any
4775 many-to-one assignment. */
4778 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
4782 c
= code
->block
->next
;
4788 case EXEC_POINTER_ASSIGN
:
4789 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
4792 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4793 there is no need to handle it here. */
4797 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
4802 /* The next statement in the FORALL body. */
4808 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4809 gfc_resolve_forall_body to resolve the FORALL body. */
4812 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
4814 static gfc_expr
**var_expr
;
4815 static int total_var
= 0;
4816 static int nvar
= 0;
4817 gfc_forall_iterator
*fa
;
4818 gfc_symbol
*forall_index
;
4822 /* Start to resolve a FORALL construct */
4823 if (forall_save
== 0)
4825 /* Count the total number of FORALL index in the nested FORALL
4826 construct in order to allocate the VAR_EXPR with proper size. */
4828 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
4830 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4832 next
= next
->block
->next
;
4835 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4836 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
4839 /* The information about FORALL iterator, including FORALL index start, end
4840 and stride. The FORALL index can not appear in start, end or stride. */
4841 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4843 /* Check if any outer FORALL index name is the same as the current
4845 for (i
= 0; i
< nvar
; i
++)
4847 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
4849 gfc_error ("An outer FORALL construct already has an index "
4850 "with this name %L", &fa
->var
->where
);
4854 /* Record the current FORALL index. */
4855 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
4857 forall_index
= fa
->var
->symtree
->n
.sym
;
4859 /* Check if the FORALL index appears in start, end or stride. */
4860 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
4861 gfc_error ("A FORALL index must not appear in a limit or stride "
4862 "expression in the same FORALL at %L", &fa
->start
->where
);
4863 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
4864 gfc_error ("A FORALL index must not appear in a limit or stride "
4865 "expression in the same FORALL at %L", &fa
->end
->where
);
4866 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
4867 gfc_error ("A FORALL index must not appear in a limit or stride "
4868 "expression in the same FORALL at %L", &fa
->stride
->where
);
4872 /* Resolve the FORALL body. */
4873 gfc_resolve_forall_body (code
, nvar
, var_expr
);
4875 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4876 gfc_resolve_blocks (code
->block
, ns
);
4878 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4879 for (i
= 0; i
< total_var
; i
++)
4880 gfc_free_expr (var_expr
[i
]);
4882 /* Reset the counters. */
4888 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4891 static void resolve_code (gfc_code
*, gfc_namespace
*);
4894 gfc_resolve_blocks (gfc_code
* b
, gfc_namespace
* ns
)
4898 for (; b
; b
= b
->block
)
4900 t
= gfc_resolve_expr (b
->expr
);
4901 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
4907 if (t
== SUCCESS
&& b
->expr
!= NULL
4908 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
4910 ("IF clause at %L requires a scalar LOGICAL expression",
4917 && (b
->expr
->ts
.type
!= BT_LOGICAL
4918 || b
->expr
->rank
== 0))
4920 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4925 resolve_branch (b
->label
, b
);
4937 case EXEC_OMP_ATOMIC
:
4938 case EXEC_OMP_CRITICAL
:
4940 case EXEC_OMP_MASTER
:
4941 case EXEC_OMP_ORDERED
:
4942 case EXEC_OMP_PARALLEL
:
4943 case EXEC_OMP_PARALLEL_DO
:
4944 case EXEC_OMP_PARALLEL_SECTIONS
:
4945 case EXEC_OMP_PARALLEL_WORKSHARE
:
4946 case EXEC_OMP_SECTIONS
:
4947 case EXEC_OMP_SINGLE
:
4948 case EXEC_OMP_WORKSHARE
:
4952 gfc_internal_error ("resolve_block(): Bad block type");
4955 resolve_code (b
->next
, ns
);
4960 /* Given a block of code, recursively resolve everything pointed to by this
4964 resolve_code (gfc_code
* code
, gfc_namespace
* ns
)
4966 int omp_workshare_save
;
4972 frame
.prev
= cs_base
;
4976 for (; code
; code
= code
->next
)
4978 frame
.current
= code
;
4979 forall_save
= forall_flag
;
4981 if (code
->op
== EXEC_FORALL
)
4984 gfc_resolve_forall (code
, ns
, forall_save
);
4987 else if (code
->block
)
4989 omp_workshare_save
= -1;
4992 case EXEC_OMP_PARALLEL_WORKSHARE
:
4993 omp_workshare_save
= omp_workshare_flag
;
4994 omp_workshare_flag
= 1;
4995 gfc_resolve_omp_parallel_blocks (code
, ns
);
4997 case EXEC_OMP_PARALLEL
:
4998 case EXEC_OMP_PARALLEL_DO
:
4999 case EXEC_OMP_PARALLEL_SECTIONS
:
5000 omp_workshare_save
= omp_workshare_flag
;
5001 omp_workshare_flag
= 0;
5002 gfc_resolve_omp_parallel_blocks (code
, ns
);
5005 gfc_resolve_omp_do_blocks (code
, ns
);
5007 case EXEC_OMP_WORKSHARE
:
5008 omp_workshare_save
= omp_workshare_flag
;
5009 omp_workshare_flag
= 1;
5012 gfc_resolve_blocks (code
->block
, ns
);
5016 if (omp_workshare_save
!= -1)
5017 omp_workshare_flag
= omp_workshare_save
;
5020 t
= gfc_resolve_expr (code
->expr
);
5021 forall_flag
= forall_save
;
5023 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
5038 /* Keep track of which entry we are up to. */
5039 current_entry_id
= code
->ext
.entry
->id
;
5043 resolve_where (code
, NULL
);
5047 if (code
->expr
!= NULL
)
5049 if (code
->expr
->ts
.type
!= BT_INTEGER
)
5050 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
5051 "variable", &code
->expr
->where
);
5052 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
5053 gfc_error ("Variable '%s' has not been assigned a target label "
5054 "at %L", code
->expr
->symtree
->n
.sym
->name
,
5055 &code
->expr
->where
);
5058 resolve_branch (code
->label
, code
);
5062 if (code
->expr
!= NULL
5063 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
5064 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5065 "INTEGER return specifier", &code
->expr
->where
);
5068 case EXEC_INIT_ASSIGN
:
5075 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5077 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5079 gfc_error ("Subroutine '%s' called instead of assignment at "
5080 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5087 if (code
->expr
->ts
.type
== BT_CHARACTER
5088 && gfc_option
.warn_character_truncation
)
5090 int llen
= 0, rlen
= 0;
5092 if (code
->expr
->ts
.cl
!= NULL
5093 && code
->expr
->ts
.cl
->length
!= NULL
5094 && code
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5095 llen
= mpz_get_si (code
->expr
->ts
.cl
->length
->value
.integer
);
5097 if (code
->expr2
->expr_type
== EXPR_CONSTANT
)
5098 rlen
= code
->expr2
->value
.character
.length
;
5100 else if (code
->expr2
->ts
.cl
!= NULL
5101 && code
->expr2
->ts
.cl
->length
!= NULL
5102 && code
->expr2
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5103 rlen
= mpz_get_si (code
->expr2
->ts
.cl
->length
->value
.integer
);
5105 if (rlen
&& llen
&& rlen
> llen
)
5106 gfc_warning_now ("rhs of CHARACTER assignment at %L will "
5107 "be truncated (%d/%d)", &code
->loc
, rlen
, llen
);
5110 if (gfc_pure (NULL
))
5112 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
5115 ("Cannot assign to variable '%s' in PURE procedure at %L",
5116 code
->expr
->symtree
->n
.sym
->name
, &code
->expr
->where
);
5120 if (code
->expr2
->ts
.type
== BT_DERIVED
5121 && derived_pointer (code
->expr2
->ts
.derived
))
5124 ("Right side of assignment at %L is a derived type "
5125 "containing a POINTER in a PURE procedure",
5126 &code
->expr2
->where
);
5131 gfc_check_assign (code
->expr
, code
->expr2
, 1);
5134 case EXEC_LABEL_ASSIGN
:
5135 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
5136 gfc_error ("Label %d referenced at %L is never defined",
5137 code
->label
->value
, &code
->label
->where
);
5139 && (code
->expr
->expr_type
!= EXPR_VARIABLE
5140 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
5141 || code
->expr
->symtree
->n
.sym
->ts
.kind
5142 != gfc_default_integer_kind
5143 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
5144 gfc_error ("ASSIGN statement at %L requires a scalar "
5145 "default INTEGER variable", &code
->expr
->where
);
5148 case EXEC_POINTER_ASSIGN
:
5152 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
5155 case EXEC_ARITHMETIC_IF
:
5157 && code
->expr
->ts
.type
!= BT_INTEGER
5158 && code
->expr
->ts
.type
!= BT_REAL
)
5159 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5160 "expression", &code
->expr
->where
);
5162 resolve_branch (code
->label
, code
);
5163 resolve_branch (code
->label2
, code
);
5164 resolve_branch (code
->label3
, code
);
5168 if (t
== SUCCESS
&& code
->expr
!= NULL
5169 && (code
->expr
->ts
.type
!= BT_LOGICAL
5170 || code
->expr
->rank
!= 0))
5171 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5172 &code
->expr
->where
);
5177 resolve_call (code
);
5181 /* Select is complicated. Also, a SELECT construct could be
5182 a transformed computed GOTO. */
5183 resolve_select (code
);
5187 if (code
->ext
.iterator
!= NULL
)
5189 gfc_iterator
*iter
= code
->ext
.iterator
;
5190 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
5191 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
5196 if (code
->expr
== NULL
)
5197 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5199 && (code
->expr
->rank
!= 0
5200 || code
->expr
->ts
.type
!= BT_LOGICAL
))
5201 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5202 "a scalar LOGICAL expression", &code
->expr
->where
);
5206 if (t
== SUCCESS
&& code
->expr
!= NULL
5207 && code
->expr
->ts
.type
!= BT_INTEGER
)
5208 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5209 "of type INTEGER", &code
->expr
->where
);
5211 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5212 resolve_allocate_expr (a
->expr
, code
);
5216 case EXEC_DEALLOCATE
:
5217 if (t
== SUCCESS
&& code
->expr
!= NULL
5218 && code
->expr
->ts
.type
!= BT_INTEGER
)
5220 ("STAT tag in DEALLOCATE statement at %L must be of type "
5221 "INTEGER", &code
->expr
->where
);
5223 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5224 resolve_deallocate_expr (a
->expr
);
5229 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
5232 resolve_branch (code
->ext
.open
->err
, code
);
5236 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
5239 resolve_branch (code
->ext
.close
->err
, code
);
5242 case EXEC_BACKSPACE
:
5246 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
5249 resolve_branch (code
->ext
.filepos
->err
, code
);
5253 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5256 resolve_branch (code
->ext
.inquire
->err
, code
);
5260 gcc_assert (code
->ext
.inquire
!= NULL
);
5261 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
5264 resolve_branch (code
->ext
.inquire
->err
, code
);
5269 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
5272 resolve_branch (code
->ext
.dt
->err
, code
);
5273 resolve_branch (code
->ext
.dt
->end
, code
);
5274 resolve_branch (code
->ext
.dt
->eor
, code
);
5278 resolve_transfer (code
);
5282 resolve_forall_iterators (code
->ext
.forall_iterator
);
5284 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
5286 ("FORALL mask clause at %L requires a LOGICAL expression",
5287 &code
->expr
->where
);
5290 case EXEC_OMP_ATOMIC
:
5291 case EXEC_OMP_BARRIER
:
5292 case EXEC_OMP_CRITICAL
:
5293 case EXEC_OMP_FLUSH
:
5295 case EXEC_OMP_MASTER
:
5296 case EXEC_OMP_ORDERED
:
5297 case EXEC_OMP_SECTIONS
:
5298 case EXEC_OMP_SINGLE
:
5299 case EXEC_OMP_WORKSHARE
:
5300 gfc_resolve_omp_directive (code
, ns
);
5303 case EXEC_OMP_PARALLEL
:
5304 case EXEC_OMP_PARALLEL_DO
:
5305 case EXEC_OMP_PARALLEL_SECTIONS
:
5306 case EXEC_OMP_PARALLEL_WORKSHARE
:
5307 omp_workshare_save
= omp_workshare_flag
;
5308 omp_workshare_flag
= 0;
5309 gfc_resolve_omp_directive (code
, ns
);
5310 omp_workshare_flag
= omp_workshare_save
;
5314 gfc_internal_error ("resolve_code(): Bad statement code");
5318 cs_base
= frame
.prev
;
5322 /* Resolve initial values and make sure they are compatible with
5326 resolve_values (gfc_symbol
* sym
)
5329 if (sym
->value
== NULL
)
5332 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
5335 gfc_check_assign_symbol (sym
, sym
->value
);
5339 /* Resolve an index expression. */
5342 resolve_index_expr (gfc_expr
* e
)
5344 if (gfc_resolve_expr (e
) == FAILURE
)
5347 if (gfc_simplify_expr (e
, 0) == FAILURE
)
5350 if (gfc_specification_expr (e
) == FAILURE
)
5356 /* Resolve a charlen structure. */
5359 resolve_charlen (gfc_charlen
*cl
)
5366 specification_expr
= 1;
5368 if (resolve_index_expr (cl
->length
) == FAILURE
)
5370 specification_expr
= 0;
5378 /* Test for non-constant shape arrays. */
5381 is_non_constant_shape_array (gfc_symbol
*sym
)
5387 not_constant
= false;
5388 if (sym
->as
!= NULL
)
5390 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5391 has not been simplified; parameter array references. Do the
5392 simplification now. */
5393 for (i
= 0; i
< sym
->as
->rank
; i
++)
5395 e
= sym
->as
->lower
[i
];
5396 if (e
&& (resolve_index_expr (e
) == FAILURE
5397 || !gfc_is_constant_expr (e
)))
5398 not_constant
= true;
5400 e
= sym
->as
->upper
[i
];
5401 if (e
&& (resolve_index_expr (e
) == FAILURE
5402 || !gfc_is_constant_expr (e
)))
5403 not_constant
= true;
5406 return not_constant
;
5410 /* Assign the default initializer to a derived type variable or result. */
5413 apply_default_init (gfc_symbol
*sym
)
5416 gfc_expr
*init
= NULL
;
5418 gfc_namespace
*ns
= sym
->ns
;
5420 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
5423 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
5424 init
= gfc_default_initializer (&sym
->ts
);
5429 /* Search for the function namespace if this is a contained
5430 function without an explicit result. */
5431 if (sym
->attr
.function
&& sym
== sym
->result
5432 && sym
->name
!= sym
->ns
->proc_name
->name
)
5435 for (;ns
; ns
= ns
->sibling
)
5436 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
5442 gfc_free_expr (init
);
5446 /* Build an l-value expression for the result. */
5447 lval
= gfc_get_expr ();
5448 lval
->expr_type
= EXPR_VARIABLE
;
5449 lval
->where
= sym
->declared_at
;
5451 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5453 /* It will always be a full array. */
5454 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
5457 lval
->ref
= gfc_get_ref ();
5458 lval
->ref
->type
= REF_ARRAY
;
5459 lval
->ref
->u
.ar
.type
= AR_FULL
;
5460 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
5461 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
5462 lval
->ref
->u
.ar
.as
= sym
->as
;
5465 /* Add the code at scope entry. */
5466 init_st
= gfc_get_code ();
5467 init_st
->next
= ns
->code
;
5470 /* Assign the default initializer to the l-value. */
5471 init_st
->loc
= sym
->declared_at
;
5472 init_st
->op
= EXEC_INIT_ASSIGN
;
5473 init_st
->expr
= lval
;
5474 init_st
->expr2
= init
;
5478 /* Resolution of common features of flavors variable and procedure. */
5481 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
5483 /* Constraints on deferred shape variable. */
5484 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
5486 if (sym
->attr
.allocatable
)
5488 if (sym
->attr
.dimension
)
5489 gfc_error ("Allocatable array '%s' at %L must have "
5490 "a deferred shape", sym
->name
, &sym
->declared_at
);
5492 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5493 sym
->name
, &sym
->declared_at
);
5497 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
5499 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5500 sym
->name
, &sym
->declared_at
);
5507 if (!mp_flag
&& !sym
->attr
.allocatable
5508 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
5510 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5511 sym
->name
, &sym
->declared_at
);
5518 /* Resolve symbols with flavor variable. */
5521 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
5526 gfc_expr
*constructor_expr
;
5527 const char * auto_save_msg
;
5529 auto_save_msg
= "automatic object '%s' at %L cannot have the "
5532 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5535 /* Set this flag to check that variables are parameters of all entries.
5536 This check is effected by the call to gfc_resolve_expr through
5537 is_non_constant_shape_array. */
5538 specification_expr
= 1;
5540 if (!sym
->attr
.use_assoc
5541 && !sym
->attr
.allocatable
5542 && !sym
->attr
.pointer
5543 && is_non_constant_shape_array (sym
))
5545 /* The shape of a main program or module array needs to be constant. */
5546 if (sym
->ns
->proc_name
5547 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5548 || sym
->ns
->proc_name
->attr
.is_main_program
))
5550 gfc_error ("The module or main program array '%s' at %L must "
5551 "have constant shape", sym
->name
, &sym
->declared_at
);
5552 specification_expr
= 0;
5557 if (sym
->ts
.type
== BT_CHARACTER
)
5559 /* Make sure that character string variables with assumed length are
5561 e
= sym
->ts
.cl
->length
;
5562 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
5564 gfc_error ("Entity with assumed character length at %L must be a "
5565 "dummy argument or a PARAMETER", &sym
->declared_at
);
5569 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
5571 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5575 if (!gfc_is_constant_expr (e
)
5576 && !(e
->expr_type
== EXPR_VARIABLE
5577 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
5578 && sym
->ns
->proc_name
5579 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5580 || sym
->ns
->proc_name
->attr
.is_main_program
)
5581 && !sym
->attr
.use_assoc
)
5583 gfc_error ("'%s' at %L must have constant character length "
5584 "in this context", sym
->name
, &sym
->declared_at
);
5589 /* Can the symbol have an initializer? */
5591 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
5592 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
5594 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
5596 /* Don't allow initialization of automatic arrays. */
5597 for (i
= 0; i
< sym
->as
->rank
; i
++)
5599 if (sym
->as
->lower
[i
] == NULL
5600 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5601 || sym
->as
->upper
[i
] == NULL
5602 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
5609 /* Also, they must not have the SAVE attribute. */
5610 if (flag
&& sym
->attr
.save
)
5612 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
5617 /* Reject illegal initializers. */
5618 if (sym
->value
&& flag
)
5620 if (sym
->attr
.allocatable
)
5621 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5622 sym
->name
, &sym
->declared_at
);
5623 else if (sym
->attr
.external
)
5624 gfc_error ("External '%s' at %L cannot have an initializer",
5625 sym
->name
, &sym
->declared_at
);
5626 else if (sym
->attr
.dummy
)
5627 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5628 sym
->name
, &sym
->declared_at
);
5629 else if (sym
->attr
.intrinsic
)
5630 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5631 sym
->name
, &sym
->declared_at
);
5632 else if (sym
->attr
.result
)
5633 gfc_error ("Function result '%s' at %L cannot have an initializer",
5634 sym
->name
, &sym
->declared_at
);
5636 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5637 sym
->name
, &sym
->declared_at
);
5641 /* Check to see if a derived type is blocked from being host associated
5642 by the presence of another class I symbol in the same namespace.
5643 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5644 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
)
5647 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
5648 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
5649 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
5651 gfc_error ("The type %s cannot be host associated at %L because "
5652 "it is blocked by an incompatible object of the same "
5653 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
5659 /* 4th constraint in section 11.3: "If an object of a type for which
5660 component-initialization is specified (R429) appears in the
5661 specification-part of a module and does not have the ALLOCATABLE
5662 or POINTER attribute, the object shall have the SAVE attribute." */
5664 constructor_expr
= NULL
;
5665 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
5666 constructor_expr
= gfc_default_initializer (&sym
->ts
);
5668 if (sym
->ns
->proc_name
5669 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5671 && !sym
->ns
->save_all
&& !sym
->attr
.save
5672 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
5674 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5675 sym
->name
, &sym
->declared_at
,
5676 "for default initialization of a component");
5680 /* Assign default initializer. */
5681 if (sym
->ts
.type
== BT_DERIVED
5683 && !sym
->attr
.pointer
5684 && !sym
->attr
.allocatable
5685 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
5686 sym
->value
= gfc_default_initializer (&sym
->ts
);
5692 /* Resolve a procedure. */
5695 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
5697 gfc_formal_arglist
*arg
;
5699 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
5700 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5701 "interfaces", sym
->name
, &sym
->declared_at
);
5703 if (sym
->attr
.function
5704 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
5707 if (sym
->ts
.type
== BT_CHARACTER
)
5709 gfc_charlen
*cl
= sym
->ts
.cl
;
5710 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
5712 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5714 gfc_error ("Character-valued statement function '%s' at %L must "
5715 "have constant length", sym
->name
, &sym
->declared_at
);
5719 if (sym
->attr
.external
&& sym
->formal
== NULL
5720 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
5722 gfc_error ("Automatic character length function '%s' at %L must "
5723 "have an explicit interface", sym
->name
, &sym
->declared_at
);
5729 /* Ensure that derived type for are not of a private type. Internal
5730 module procedures are excluded by 2.2.3.3 - ie. they are not
5731 externally accessible and can access all the objects accessible in
5733 if (!(sym
->ns
->parent
5734 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5735 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5737 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
5740 && arg
->sym
->ts
.type
== BT_DERIVED
5741 && !arg
->sym
->ts
.derived
->attr
.use_assoc
5742 && !gfc_check_access(arg
->sym
->ts
.derived
->attr
.access
,
5743 arg
->sym
->ts
.derived
->ns
->default_access
))
5745 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5746 "a dummy argument of '%s', which is "
5747 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
5749 /* Stop this message from recurring. */
5750 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
5756 /* An external symbol may not have an initializer because it is taken to be
5758 if (sym
->attr
.external
&& sym
->value
)
5760 gfc_error ("External object '%s' at %L may not have an initializer",
5761 sym
->name
, &sym
->declared_at
);
5765 /* An elemental function is required to return a scalar 12.7.1 */
5766 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
5768 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5769 "result", sym
->name
, &sym
->declared_at
);
5770 /* Reset so that the error only occurs once. */
5771 sym
->attr
.elemental
= 0;
5775 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5776 char-len-param shall not be array-valued, pointer-valued, recursive
5777 or pure. ....snip... A character value of * may only be used in the
5778 following ways: (i) Dummy arg of procedure - dummy associates with
5779 actual length; (ii) To declare a named constant; or (iii) External
5780 function - but length must be declared in calling scoping unit. */
5781 if (sym
->attr
.function
5782 && sym
->ts
.type
== BT_CHARACTER
5783 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
5785 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
5786 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
5788 if (sym
->as
&& sym
->as
->rank
)
5789 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5790 "array-valued", sym
->name
, &sym
->declared_at
);
5792 if (sym
->attr
.pointer
)
5793 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5794 "pointer-valued", sym
->name
, &sym
->declared_at
);
5797 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5798 "pure", sym
->name
, &sym
->declared_at
);
5800 if (sym
->attr
.recursive
)
5801 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5802 "recursive", sym
->name
, &sym
->declared_at
);
5807 /* Appendix B.2 of the standard. Contained functions give an
5808 error anyway. Fixed-form is likely to be F77/legacy. */
5809 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
5810 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
5811 "'%s' at %L is obsolescent in fortran 95",
5812 sym
->name
, &sym
->declared_at
);
5818 /* Resolve the components of a derived type. */
5821 resolve_fl_derived (gfc_symbol
*sym
)
5824 gfc_dt_list
* dt_list
;
5827 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
5829 if (c
->ts
.type
== BT_CHARACTER
)
5831 if (c
->ts
.cl
->length
== NULL
5832 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
5833 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
5835 gfc_error ("Character length of component '%s' needs to "
5836 "be a constant specification expression at %L",
5838 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
5843 if (c
->ts
.type
== BT_DERIVED
5844 && sym
->component_access
!= ACCESS_PRIVATE
5845 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
)
5846 && !c
->ts
.derived
->attr
.use_assoc
5847 && !gfc_check_access(c
->ts
.derived
->attr
.access
,
5848 c
->ts
.derived
->ns
->default_access
))
5850 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5851 "a component of '%s', which is PUBLIC at %L",
5852 c
->name
, sym
->name
, &sym
->declared_at
);
5856 if (sym
->attr
.sequence
)
5858 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
5860 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5861 "not have the SEQUENCE attribute",
5862 c
->ts
.derived
->name
, &sym
->declared_at
);
5867 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
5868 && c
->ts
.derived
->components
== NULL
)
5870 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5871 "that has not been declared", c
->name
, sym
->name
,
5876 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
5879 for (i
= 0; i
< c
->as
->rank
; i
++)
5881 if (c
->as
->lower
[i
] == NULL
5882 || !gfc_is_constant_expr (c
->as
->lower
[i
])
5883 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
5884 || c
->as
->upper
[i
] == NULL
5885 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
5886 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
5888 gfc_error ("Component '%s' of '%s' at %L must have "
5889 "constant array bounds",
5890 c
->name
, sym
->name
, &c
->loc
);
5896 /* Add derived type to the derived type list. */
5897 for (dt_list
= sym
->ns
->derived_types
; dt_list
; dt_list
= dt_list
->next
)
5898 if (sym
== dt_list
->derived
)
5901 if (dt_list
== NULL
)
5903 dt_list
= gfc_get_dt_list ();
5904 dt_list
->next
= sym
->ns
->derived_types
;
5905 dt_list
->derived
= sym
;
5906 sym
->ns
->derived_types
= dt_list
;
5914 resolve_fl_namelist (gfc_symbol
*sym
)
5919 /* Reject PRIVATE objects in a PUBLIC namelist. */
5920 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
5922 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5924 if (!nl
->sym
->attr
.use_assoc
5925 && !(sym
->ns
->parent
== nl
->sym
->ns
)
5926 && !gfc_check_access(nl
->sym
->attr
.access
,
5927 nl
->sym
->ns
->default_access
))
5929 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5930 "PUBLIC namelist at %L", nl
->sym
->name
,
5937 /* Reject namelist arrays that are not constant shape. */
5938 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5940 if (is_non_constant_shape_array (nl
->sym
))
5942 gfc_error ("The array '%s' must have constant shape to be "
5943 "a NAMELIST object at %L", nl
->sym
->name
,
5949 /* Namelist objects cannot have allocatable components. */
5950 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5952 if (nl
->sym
->ts
.type
== BT_DERIVED
5953 && nl
->sym
->ts
.derived
->attr
.alloc_comp
)
5955 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5956 "components", nl
->sym
->name
, &sym
->declared_at
);
5961 /* 14.1.2 A module or internal procedure represent local entities
5962 of the same type as a namelist member and so are not allowed.
5963 Note that this is sometimes caught by check_conflict so the
5964 same message has been used. */
5965 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
5967 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
5970 if (sym
->ns
->parent
&& nl
->sym
&& nl
->sym
->name
)
5971 gfc_find_symbol (nl
->sym
->name
, sym
->ns
->parent
, 0, &nlsym
);
5972 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
5974 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5975 "attribute in '%s' at %L", nlsym
->name
,
5986 resolve_fl_parameter (gfc_symbol
*sym
)
5988 /* A parameter array's shape needs to be constant. */
5989 if (sym
->as
!= NULL
&& !gfc_is_compile_time_shape (sym
->as
))
5991 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5992 "or assumed shape", sym
->name
, &sym
->declared_at
);
5996 /* Make sure a parameter that has been implicitly typed still
5997 matches the implicit type, since PARAMETER statements can precede
5998 IMPLICIT statements. */
5999 if (sym
->attr
.implicit_type
6000 && !gfc_compare_types (&sym
->ts
,
6001 gfc_get_default_type (sym
, sym
->ns
)))
6003 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
6004 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
6008 /* Make sure the types of derived parameters are consistent. This
6009 type checking is deferred until resolution because the type may
6010 refer to a derived type from the host. */
6011 if (sym
->ts
.type
== BT_DERIVED
6012 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
6014 gfc_error ("Incompatible derived type in PARAMETER at %L",
6015 &sym
->value
->where
);
6022 /* Do anything necessary to resolve a symbol. Right now, we just
6023 assume that an otherwise unknown symbol is a variable. This sort
6024 of thing commonly happens for symbols in module. */
6027 resolve_symbol (gfc_symbol
* sym
)
6029 /* Zero if we are checking a formal namespace. */
6030 static int formal_ns_flag
= 1;
6031 int formal_ns_save
, check_constant
, mp_flag
;
6032 gfc_symtree
*symtree
;
6033 gfc_symtree
*this_symtree
;
6037 if (sym
->attr
.flavor
== FL_UNKNOWN
)
6040 /* If we find that a flavorless symbol is an interface in one of the
6041 parent namespaces, find its symtree in this namespace, free the
6042 symbol and set the symtree to point to the interface symbol. */
6043 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
6045 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6046 if (symtree
&& symtree
->n
.sym
->generic
)
6048 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
6052 gfc_free_symbol (sym
);
6053 symtree
->n
.sym
->refs
++;
6054 this_symtree
->n
.sym
= symtree
->n
.sym
;
6059 /* Otherwise give it a flavor according to such attributes as
6061 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
6062 sym
->attr
.flavor
= FL_VARIABLE
;
6065 sym
->attr
.flavor
= FL_PROCEDURE
;
6066 if (sym
->attr
.dimension
)
6067 sym
->attr
.function
= 1;
6071 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
6074 /* Symbols that are module procedures with results (functions) have
6075 the types and array specification copied for type checking in
6076 procedures that call them, as well as for saving to a module
6077 file. These symbols can't stand the scrutiny that their results
6079 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
6081 /* Assign default type to symbols that need one and don't have one. */
6082 if (sym
->ts
.type
== BT_UNKNOWN
)
6084 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
6085 gfc_set_default_type (sym
, 1, NULL
);
6087 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
6089 /* The specific case of an external procedure should emit an error
6090 in the case that there is no implicit type. */
6092 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
6095 /* Result may be in another namespace. */
6096 resolve_symbol (sym
->result
);
6098 sym
->ts
= sym
->result
->ts
;
6099 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
6100 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
6101 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
6102 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
6107 /* Assumed size arrays and assumed shape arrays must be dummy
6111 && (sym
->as
->type
== AS_ASSUMED_SIZE
6112 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
6113 && sym
->attr
.dummy
== 0)
6115 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
6116 gfc_error ("Assumed size array at %L must be a dummy argument",
6119 gfc_error ("Assumed shape array at %L must be a dummy argument",
6124 /* Make sure symbols with known intent or optional are really dummy
6125 variable. Because of ENTRY statement, this has to be deferred
6126 until resolution time. */
6128 if (!sym
->attr
.dummy
6129 && (sym
->attr
.optional
6130 || sym
->attr
.intent
!= INTENT_UNKNOWN
))
6132 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
6136 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
6138 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
6139 "it is not a dummy", sym
->name
, &sym
->declared_at
);
6144 /* If a derived type symbol has reached this point, without its
6145 type being declared, we have an error. Notice that most
6146 conditions that produce undefined derived types have already
6147 been dealt with. However, the likes of:
6148 implicit type(t) (t) ..... call foo (t) will get us here if
6149 the type is not declared in the scope of the implicit
6150 statement. Change the type to BT_UNKNOWN, both because it is so
6151 and to prevent an ICE. */
6152 if (sym
->ts
.type
== BT_DERIVED
6153 && sym
->ts
.derived
->components
== NULL
)
6155 gfc_error ("The derived type '%s' at %L is of type '%s', "
6156 "which has not been defined", sym
->name
,
6157 &sym
->declared_at
, sym
->ts
.derived
->name
);
6158 sym
->ts
.type
= BT_UNKNOWN
;
6162 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6163 default initialization is defined (5.1.2.4.4). */
6164 if (sym
->ts
.type
== BT_DERIVED
6166 && sym
->attr
.intent
== INTENT_OUT
6168 && sym
->as
->type
== AS_ASSUMED_SIZE
)
6170 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
6174 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6175 "ASSUMED SIZE and so cannot have a default initializer",
6176 sym
->name
, &sym
->declared_at
);
6182 switch (sym
->attr
.flavor
)
6185 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
6190 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
6195 if (resolve_fl_namelist (sym
) == FAILURE
)
6200 if (resolve_fl_parameter (sym
) == FAILURE
)
6208 /* Make sure that intrinsic exist */
6209 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
6210 && ! gfc_intrinsic_name(sym
->name
, 0)
6211 && ! gfc_intrinsic_name(sym
->name
, 1))
6212 gfc_error("Intrinsic at %L does not exist", &sym
->declared_at
);
6214 /* Resolve array specifier. Check as well some constraints
6215 on COMMON blocks. */
6217 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
6219 /* Set the formal_arg_flag so that check_conflict will not throw
6220 an error for host associated variables in the specification
6221 expression for an array_valued function. */
6222 if (sym
->attr
.function
&& sym
->as
)
6223 formal_arg_flag
= 1;
6225 gfc_resolve_array_spec (sym
->as
, check_constant
);
6227 formal_arg_flag
= 0;
6229 /* Resolve formal namespaces. */
6231 if (formal_ns_flag
&& sym
!= NULL
&& sym
->formal_ns
!= NULL
)
6233 formal_ns_save
= formal_ns_flag
;
6235 gfc_resolve (sym
->formal_ns
);
6236 formal_ns_flag
= formal_ns_save
;
6239 /* Check threadprivate restrictions. */
6240 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
6241 && (!sym
->attr
.in_common
6242 && sym
->module
== NULL
6243 && (sym
->ns
->proc_name
== NULL
6244 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
6245 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
6247 /* If we have come this far we can apply default-initializers, as
6248 described in 14.7.5, to those variables that have not already
6249 been assigned one. */
6250 if (sym
->ts
.type
== BT_DERIVED
6251 && sym
->attr
.referenced
6252 && sym
->ns
== gfc_current_ns
6254 && !sym
->attr
.allocatable
6255 && !sym
->attr
.alloc_comp
)
6257 symbol_attribute
*a
= &sym
->attr
;
6259 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
6260 && !a
->in_common
&& !a
->use_assoc
6261 && !(a
->function
&& sym
!= sym
->result
))
6263 (a
->dummy
&& a
->intent
== INTENT_OUT
))
6264 apply_default_init (sym
);
6270 /************* Resolve DATA statements *************/
6274 gfc_data_value
*vnode
;
6280 /* Advance the values structure to point to the next value in the data list. */
6283 next_data_value (void)
6285 while (values
.left
== 0)
6287 if (values
.vnode
->next
== NULL
)
6290 values
.vnode
= values
.vnode
->next
;
6291 values
.left
= values
.vnode
->repeat
;
6299 check_data_variable (gfc_data_variable
* var
, locus
* where
)
6305 ar_type mark
= AR_UNKNOWN
;
6307 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
6311 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
6315 mpz_init_set_si (offset
, 0);
6318 if (e
->expr_type
!= EXPR_VARIABLE
)
6319 gfc_internal_error ("check_data_variable(): Bad expression");
6321 if (e
->symtree
->n
.sym
->ns
->is_block_data
6322 && !e
->symtree
->n
.sym
->attr
.in_common
)
6324 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6325 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
6330 mpz_init_set_ui (size
, 1);
6337 /* Find the array section reference. */
6338 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6340 if (ref
->type
!= REF_ARRAY
)
6342 if (ref
->u
.ar
.type
== AR_ELEMENT
)
6348 /* Set marks according to the reference pattern. */
6349 switch (ref
->u
.ar
.type
)
6357 /* Get the start position of array section. */
6358 gfc_get_section_index (ar
, section_index
, &offset
);
6366 if (gfc_array_size (e
, &size
) == FAILURE
)
6368 gfc_error ("Nonconstant array section at %L in DATA statement",
6377 while (mpz_cmp_ui (size
, 0) > 0)
6379 if (next_data_value () == FAILURE
)
6381 gfc_error ("DATA statement at %L has more variables than values",
6387 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
6391 /* If we have more than one element left in the repeat count,
6392 and we have more than one element left in the target variable,
6393 then create a range assignment. */
6394 /* ??? Only done for full arrays for now, since array sections
6396 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
6397 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
6401 if (mpz_cmp_ui (size
, values
.left
) >= 0)
6403 mpz_init_set_ui (range
, values
.left
);
6404 mpz_sub_ui (size
, size
, values
.left
);
6409 mpz_init_set (range
, size
);
6410 values
.left
-= mpz_get_ui (size
);
6411 mpz_set_ui (size
, 0);
6414 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
6417 mpz_add (offset
, offset
, range
);
6421 /* Assign initial value to symbol. */
6425 mpz_sub_ui (size
, size
, 1);
6427 gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
6429 if (mark
== AR_FULL
)
6430 mpz_add_ui (offset
, offset
, 1);
6432 /* Modify the array section indexes and recalculate the offset
6433 for next element. */
6434 else if (mark
== AR_SECTION
)
6435 gfc_advance_section (section_index
, ar
, &offset
);
6439 if (mark
== AR_SECTION
)
6441 for (i
= 0; i
< ar
->dimen
; i
++)
6442 mpz_clear (section_index
[i
]);
6452 static try traverse_data_var (gfc_data_variable
*, locus
*);
6454 /* Iterate over a list of elements in a DATA statement. */
6457 traverse_data_list (gfc_data_variable
* var
, locus
* where
)
6460 iterator_stack frame
;
6461 gfc_expr
*e
, *start
, *end
, *step
;
6462 try retval
= SUCCESS
;
6464 mpz_init (frame
.value
);
6466 start
= gfc_copy_expr (var
->iter
.start
);
6467 end
= gfc_copy_expr (var
->iter
.end
);
6468 step
= gfc_copy_expr (var
->iter
.step
);
6470 if (gfc_simplify_expr (start
, 1) == FAILURE
6471 || start
->expr_type
!= EXPR_CONSTANT
)
6473 gfc_error ("iterator start at %L does not simplify",
6478 if (gfc_simplify_expr (end
, 1) == FAILURE
6479 || end
->expr_type
!= EXPR_CONSTANT
)
6481 gfc_error ("iterator end at %L does not simplify",
6486 if (gfc_simplify_expr (step
, 1) == FAILURE
6487 || step
->expr_type
!= EXPR_CONSTANT
)
6489 gfc_error ("iterator step at %L does not simplify",
6495 mpz_init_set (trip
, end
->value
.integer
);
6496 mpz_sub (trip
, trip
, start
->value
.integer
);
6497 mpz_add (trip
, trip
, step
->value
.integer
);
6499 mpz_div (trip
, trip
, step
->value
.integer
);
6501 mpz_set (frame
.value
, start
->value
.integer
);
6503 frame
.prev
= iter_stack
;
6504 frame
.variable
= var
->iter
.var
->symtree
;
6505 iter_stack
= &frame
;
6507 while (mpz_cmp_ui (trip
, 0) > 0)
6509 if (traverse_data_var (var
->list
, where
) == FAILURE
)
6516 e
= gfc_copy_expr (var
->expr
);
6517 if (gfc_simplify_expr (e
, 1) == FAILURE
)
6525 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
6527 mpz_sub_ui (trip
, trip
, 1);
6532 mpz_clear (frame
.value
);
6534 gfc_free_expr (start
);
6535 gfc_free_expr (end
);
6536 gfc_free_expr (step
);
6538 iter_stack
= frame
.prev
;
6543 /* Type resolve variables in the variable list of a DATA statement. */
6546 traverse_data_var (gfc_data_variable
* var
, locus
* where
)
6550 for (; var
; var
= var
->next
)
6552 if (var
->expr
== NULL
)
6553 t
= traverse_data_list (var
, where
);
6555 t
= check_data_variable (var
, where
);
6565 /* Resolve the expressions and iterators associated with a data statement.
6566 This is separate from the assignment checking because data lists should
6567 only be resolved once. */
6570 resolve_data_variables (gfc_data_variable
* d
)
6572 for (; d
; d
= d
->next
)
6574 if (d
->list
== NULL
)
6576 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
6581 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
6584 if (resolve_data_variables (d
->list
) == FAILURE
)
6593 /* Resolve a single DATA statement. We implement this by storing a pointer to
6594 the value list into static variables, and then recursively traversing the
6595 variables list, expanding iterators and such. */
6598 resolve_data (gfc_data
* d
)
6600 if (resolve_data_variables (d
->var
) == FAILURE
)
6603 values
.vnode
= d
->value
;
6604 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
6606 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
6609 /* At this point, we better not have any values left. */
6611 if (next_data_value () == SUCCESS
)
6612 gfc_error ("DATA statement at %L has more values than variables",
6617 /* Determines if a variable is not 'pure', ie not assignable within a pure
6618 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6622 gfc_impure_variable (gfc_symbol
* sym
)
6624 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
6627 if (sym
->ns
!= gfc_current_ns
)
6628 return !sym
->attr
.function
;
6630 /* TODO: Check storage association through EQUIVALENCE statements */
6636 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6637 symbol of the current procedure. */
6640 gfc_pure (gfc_symbol
* sym
)
6642 symbol_attribute attr
;
6645 sym
= gfc_current_ns
->proc_name
;
6651 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
6655 /* Test whether the current procedure is elemental or not. */
6658 gfc_elemental (gfc_symbol
* sym
)
6660 symbol_attribute attr
;
6663 sym
= gfc_current_ns
->proc_name
;
6668 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
6672 /* Warn about unused labels. */
6675 warn_unused_fortran_label (gfc_st_label
* label
)
6680 warn_unused_fortran_label (label
->left
);
6682 if (label
->defined
== ST_LABEL_UNKNOWN
)
6685 switch (label
->referenced
)
6687 case ST_LABEL_UNKNOWN
:
6688 gfc_warning ("Label %d at %L defined but not used", label
->value
,
6692 case ST_LABEL_BAD_TARGET
:
6693 gfc_warning ("Label %d at %L defined but cannot be used",
6694 label
->value
, &label
->where
);
6701 warn_unused_fortran_label (label
->right
);
6705 /* Returns the sequence type of a symbol or sequence. */
6708 sequence_type (gfc_typespec ts
)
6717 if (ts
.derived
->components
== NULL
)
6718 return SEQ_NONDEFAULT
;
6720 result
= sequence_type (ts
.derived
->components
->ts
);
6721 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
6722 if (sequence_type (c
->ts
) != result
)
6728 if (ts
.kind
!= gfc_default_character_kind
)
6729 return SEQ_NONDEFAULT
;
6731 return SEQ_CHARACTER
;
6734 if (ts
.kind
!= gfc_default_integer_kind
)
6735 return SEQ_NONDEFAULT
;
6740 if (!(ts
.kind
== gfc_default_real_kind
6741 || ts
.kind
== gfc_default_double_kind
))
6742 return SEQ_NONDEFAULT
;
6747 if (ts
.kind
!= gfc_default_complex_kind
)
6748 return SEQ_NONDEFAULT
;
6753 if (ts
.kind
!= gfc_default_logical_kind
)
6754 return SEQ_NONDEFAULT
;
6759 return SEQ_NONDEFAULT
;
6764 /* Resolve derived type EQUIVALENCE object. */
6767 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
6770 gfc_component
*c
= derived
->components
;
6775 /* Shall not be an object of nonsequence derived type. */
6776 if (!derived
->attr
.sequence
)
6778 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6779 "attribute to be an EQUIVALENCE object", sym
->name
, &e
->where
);
6783 /* Shall not have allocatable components. */
6784 if (derived
->attr
.alloc_comp
)
6786 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6787 "components to be an EQUIVALENCE object",sym
->name
, &e
->where
);
6791 for (; c
; c
= c
->next
)
6794 if (d
&& (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
6797 /* Shall not be an object of sequence derived type containing a pointer
6798 in the structure. */
6801 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6802 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
6808 gfc_error ("Derived type variable '%s' at %L with default initializer "
6809 "cannot be an EQUIVALENCE object", sym
->name
, &e
->where
);
6817 /* Resolve equivalence object.
6818 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6819 an allocatable array, an object of nonsequence derived type, an object of
6820 sequence derived type containing a pointer at any level of component
6821 selection, an automatic object, a function name, an entry name, a result
6822 name, a named constant, a structure component, or a subobject of any of
6823 the preceding objects. A substring shall not have length zero. A
6824 derived type shall not have components with default initialization nor
6825 shall two objects of an equivalence group be initialized.
6826 Either all or none of the objects shall have an protected attribute.
6827 The simple constraints are done in symbol.c(check_conflict) and the rest
6828 are implemented here. */
6831 resolve_equivalence (gfc_equiv
*eq
)
6834 gfc_symbol
*derived
;
6835 gfc_symbol
*first_sym
;
6838 locus
*last_where
= NULL
;
6839 seq_type eq_type
, last_eq_type
;
6840 gfc_typespec
*last_ts
;
6841 int object
, cnt_protected
;
6842 const char *value_name
;
6846 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
6848 first_sym
= eq
->expr
->symtree
->n
.sym
;
6852 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
6856 e
->ts
= e
->symtree
->n
.sym
->ts
;
6857 /* match_varspec might not know yet if it is seeing
6858 array reference or substring reference, as it doesn't
6860 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
6862 gfc_ref
*ref
= e
->ref
;
6863 sym
= e
->symtree
->n
.sym
;
6865 if (sym
->attr
.dimension
)
6867 ref
->u
.ar
.as
= sym
->as
;
6871 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6872 if (e
->ts
.type
== BT_CHARACTER
6874 && ref
->type
== REF_ARRAY
6875 && ref
->u
.ar
.dimen
== 1
6876 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
6877 && ref
->u
.ar
.stride
[0] == NULL
)
6879 gfc_expr
*start
= ref
->u
.ar
.start
[0];
6880 gfc_expr
*end
= ref
->u
.ar
.end
[0];
6883 /* Optimize away the (:) reference. */
6884 if (start
== NULL
&& end
== NULL
)
6889 e
->ref
->next
= ref
->next
;
6894 ref
->type
= REF_SUBSTRING
;
6896 start
= gfc_int_expr (1);
6897 ref
->u
.ss
.start
= start
;
6898 if (end
== NULL
&& e
->ts
.cl
)
6899 end
= gfc_copy_expr (e
->ts
.cl
->length
);
6900 ref
->u
.ss
.end
= end
;
6901 ref
->u
.ss
.length
= e
->ts
.cl
;
6908 /* Any further ref is an error. */
6911 gcc_assert (ref
->type
== REF_ARRAY
);
6912 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6918 if (gfc_resolve_expr (e
) == FAILURE
)
6921 sym
= e
->symtree
->n
.sym
;
6923 if (sym
->attr
.protected)
6925 if (cnt_protected
> 0 && cnt_protected
!= object
)
6927 gfc_error ("Either all or none of the objects in the "
6928 "EQUIVALENCE set at %L shall have the "
6929 "PROTECTED attribute",
6934 /* An equivalence statement cannot have more than one initialized
6938 if (value_name
!= NULL
)
6940 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6941 "be in the EQUIVALENCE statement at %L",
6942 value_name
, sym
->name
, &e
->where
);
6946 value_name
= sym
->name
;
6949 /* Shall not equivalence common block variables in a PURE procedure. */
6950 if (sym
->ns
->proc_name
6951 && sym
->ns
->proc_name
->attr
.pure
6952 && sym
->attr
.in_common
)
6954 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6955 "object in the pure procedure '%s'",
6956 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
6960 /* Shall not be a named constant. */
6961 if (e
->expr_type
== EXPR_CONSTANT
)
6963 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6964 "object", sym
->name
, &e
->where
);
6968 derived
= e
->ts
.derived
;
6969 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
6972 /* Check that the types correspond correctly:
6974 A numeric sequence structure may be equivalenced to another sequence
6975 structure, an object of default integer type, default real type, double
6976 precision real type, default logical type such that components of the
6977 structure ultimately only become associated to objects of the same
6978 kind. A character sequence structure may be equivalenced to an object
6979 of default character kind or another character sequence structure.
6980 Other objects may be equivalenced only to objects of the same type and
6983 /* Identical types are unconditionally OK. */
6984 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
6985 goto identical_types
;
6987 last_eq_type
= sequence_type (*last_ts
);
6988 eq_type
= sequence_type (sym
->ts
);
6990 /* Since the pair of objects is not of the same type, mixed or
6991 non-default sequences can be rejected. */
6993 msg
= "Sequence %s with mixed components in EQUIVALENCE "
6994 "statement at %L with different type objects";
6996 && last_eq_type
== SEQ_MIXED
6997 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
6998 last_where
) == FAILURE
)
6999 || (eq_type
== SEQ_MIXED
7000 && gfc_notify_std (GFC_STD_GNU
, msg
,sym
->name
,
7001 &e
->where
) == FAILURE
))
7004 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
7005 "statement at %L with objects of different type";
7007 && last_eq_type
== SEQ_NONDEFAULT
7008 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
7009 last_where
) == FAILURE
)
7010 || (eq_type
== SEQ_NONDEFAULT
7011 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7012 &e
->where
) == FAILURE
))
7015 msg
="Non-CHARACTER object '%s' in default CHARACTER "
7016 "EQUIVALENCE statement at %L";
7017 if (last_eq_type
== SEQ_CHARACTER
7018 && eq_type
!= SEQ_CHARACTER
7019 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7020 &e
->where
) == FAILURE
)
7023 msg
="Non-NUMERIC object '%s' in default NUMERIC "
7024 "EQUIVALENCE statement at %L";
7025 if (last_eq_type
== SEQ_NUMERIC
7026 && eq_type
!= SEQ_NUMERIC
7027 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
7028 &e
->where
) == FAILURE
)
7033 last_where
= &e
->where
;
7038 /* Shall not be an automatic array. */
7039 if (e
->ref
->type
== REF_ARRAY
7040 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
7042 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
7043 "an EQUIVALENCE object", sym
->name
, &e
->where
);
7050 /* Shall not be a structure component. */
7051 if (r
->type
== REF_COMPONENT
)
7053 gfc_error ("Structure component '%s' at %L cannot be an "
7054 "EQUIVALENCE object",
7055 r
->u
.c
.component
->name
, &e
->where
);
7059 /* A substring shall not have length zero. */
7060 if (r
->type
== REF_SUBSTRING
)
7062 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
7064 gfc_error ("Substring at %L has length zero",
7065 &r
->u
.ss
.start
->where
);
7075 /* Resolve function and ENTRY types, issue diagnostics if needed. */
7078 resolve_fntype (gfc_namespace
* ns
)
7083 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
7086 /* If there are any entries, ns->proc_name is the entry master
7087 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
7089 sym
= ns
->entries
->sym
;
7091 sym
= ns
->proc_name
;
7092 if (sym
->result
== sym
7093 && sym
->ts
.type
== BT_UNKNOWN
7094 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
7095 && !sym
->attr
.untyped
)
7097 gfc_error ("Function '%s' at %L has no IMPLICIT type",
7098 sym
->name
, &sym
->declared_at
);
7099 sym
->attr
.untyped
= 1;
7102 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
7103 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7104 sym
->ts
.derived
->ns
->default_access
)
7105 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
7107 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
7108 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
7111 /* Make sure that the type of a module derived type function is in the
7112 module namespace, by copying it from the namespace's derived type
7113 list, if necessary. */
7114 if (sym
->ts
.type
== BT_DERIVED
7115 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7116 && sym
->ts
.derived
->ns
7117 && sym
->ns
!= sym
->ts
.derived
->ns
)
7119 gfc_dt_list
*dt
= sym
->ns
->derived_types
;
7121 for (; dt
; dt
= dt
->next
)
7122 if (gfc_compare_derived_types (sym
->ts
.derived
, dt
->derived
))
7123 sym
->ts
.derived
= dt
->derived
;
7127 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
7129 if (el
->sym
->result
== el
->sym
7130 && el
->sym
->ts
.type
== BT_UNKNOWN
7131 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
7132 && !el
->sym
->attr
.untyped
)
7134 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
7135 el
->sym
->name
, &el
->sym
->declared_at
);
7136 el
->sym
->attr
.untyped
= 1;
7141 /* 12.3.2.1.1 Defined operators. */
7144 gfc_resolve_uops(gfc_symtree
*symtree
)
7148 gfc_formal_arglist
*formal
;
7150 if (symtree
== NULL
)
7153 gfc_resolve_uops (symtree
->left
);
7154 gfc_resolve_uops (symtree
->right
);
7156 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
7159 if (!sym
->attr
.function
)
7160 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
7161 sym
->name
, &sym
->declared_at
);
7163 if (sym
->ts
.type
== BT_CHARACTER
7164 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
7165 && !(sym
->result
&& sym
->result
->ts
.cl
&& sym
->result
->ts
.cl
->length
))
7166 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
7167 "length", sym
->name
, &sym
->declared_at
);
7169 formal
= sym
->formal
;
7170 if (!formal
|| !formal
->sym
)
7172 gfc_error("User operator procedure '%s' at %L must have at least "
7173 "one argument", sym
->name
, &sym
->declared_at
);
7177 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7178 gfc_error ("First argument of operator interface at %L must be "
7179 "INTENT(IN)", &sym
->declared_at
);
7181 if (formal
->sym
->attr
.optional
)
7182 gfc_error ("First argument of operator interface at %L cannot be "
7183 "optional", &sym
->declared_at
);
7185 formal
= formal
->next
;
7186 if (!formal
|| !formal
->sym
)
7189 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
7190 gfc_error ("Second argument of operator interface at %L must be "
7191 "INTENT(IN)", &sym
->declared_at
);
7193 if (formal
->sym
->attr
.optional
)
7194 gfc_error ("Second argument of operator interface at %L cannot be "
7195 "optional", &sym
->declared_at
);
7198 gfc_error ("Operator interface at %L must have, at most, two "
7199 "arguments", &sym
->declared_at
);
7204 /* Examine all of the expressions associated with a program unit,
7205 assign types to all intermediate expressions, make sure that all
7206 assignments are to compatible types and figure out which names
7207 refer to which functions or subroutines. It doesn't check code
7208 block, which is handled by resolve_code. */
7211 resolve_types (gfc_namespace
* ns
)
7218 gfc_current_ns
= ns
;
7220 resolve_entries (ns
);
7222 resolve_contained_functions (ns
);
7224 gfc_traverse_ns (ns
, resolve_symbol
);
7226 resolve_fntype (ns
);
7228 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7230 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
7231 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7232 "also be PURE", n
->proc_name
->name
,
7233 &n
->proc_name
->declared_at
);
7239 gfc_check_interfaces (ns
);
7241 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
7242 resolve_charlen (cl
);
7244 gfc_traverse_ns (ns
, resolve_values
);
7250 for (d
= ns
->data
; d
; d
= d
->next
)
7254 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
7256 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
7257 resolve_equivalence (eq
);
7259 /* Warn about unused labels. */
7260 if (warn_unused_label
)
7261 warn_unused_fortran_label (ns
->st_labels
);
7263 gfc_resolve_uops (ns
->uop_root
);
7267 /* Call resolve_code recursively. */
7270 resolve_codes (gfc_namespace
* ns
)
7274 for (n
= ns
->contained
; n
; n
= n
->sibling
)
7277 gfc_current_ns
= ns
;
7279 /* Set to an out of range value. */
7280 current_entry_id
= -1;
7281 resolve_code (ns
->code
, ns
);
7285 /* This function is called after a complete program unit has been compiled.
7286 Its purpose is to examine all of the expressions associated with a program
7287 unit, assign types to all intermediate expressions, make sure that all
7288 assignments are to compatible types and figure out which names refer to
7289 which functions or subroutines. */
7292 gfc_resolve (gfc_namespace
* ns
)
7294 gfc_namespace
*old_ns
;
7296 old_ns
= gfc_current_ns
;
7301 gfc_current_ns
= old_ns
;