1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 /* Types used in equivalence statements. */
36 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
40 /* Stack to keep track of the nesting of blocks as we move through the
41 code. See resolve_branch() and resolve_code(). */
43 typedef struct code_stack
45 struct gfc_code
*head
, *current
, *tail
;
46 struct code_stack
*prev
;
48 /* This bitmap keeps track of the targets valid for a branch from
50 bitmap reachable_labels
;
54 static code_stack
*cs_base
= NULL
;
57 /* Nonzero if we're inside a FORALL block. */
59 static int forall_flag
;
61 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
63 static int omp_workshare_flag
;
65 /* Nonzero if we are processing a formal arglist. The corresponding function
66 resets the flag each time that it is read. */
67 static int formal_arg_flag
= 0;
69 /* True if we are resolving a specification expression. */
70 static int specification_expr
= 0;
72 /* The id of the last entry seen. */
73 static int current_entry_id
;
75 /* We use bitmaps to determine if a branch target is valid. */
76 static bitmap_obstack labels_obstack
;
79 gfc_is_formal_arg (void)
81 return formal_arg_flag
;
84 /* Resolve types of formal argument lists. These have to be done early so that
85 the formal argument lists of module procedures can be copied to the
86 containing module before the individual procedures are resolved
87 individually. We also resolve argument lists of procedures in interface
88 blocks because they are self-contained scoping units.
90 Since a dummy argument cannot be a non-dummy procedure, the only
91 resort left for untyped names are the IMPLICIT types. */
94 resolve_formal_arglist (gfc_symbol
*proc
)
96 gfc_formal_arglist
*f
;
100 if (proc
->result
!= NULL
)
105 if (gfc_elemental (proc
)
106 || sym
->attr
.pointer
|| sym
->attr
.allocatable
107 || (sym
->as
&& sym
->as
->rank
> 0))
108 proc
->attr
.always_explicit
= 1;
112 for (f
= proc
->formal
; f
; f
= f
->next
)
118 /* Alternate return placeholder. */
119 if (gfc_elemental (proc
))
120 gfc_error ("Alternate return specifier in elemental subroutine "
121 "'%s' at %L is not allowed", proc
->name
,
123 if (proc
->attr
.function
)
124 gfc_error ("Alternate return specifier in function "
125 "'%s' at %L is not allowed", proc
->name
,
130 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
131 resolve_formal_arglist (sym
);
133 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
135 if (gfc_pure (proc
) && !gfc_pure (sym
))
137 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
138 "also be PURE", sym
->name
, &sym
->declared_at
);
142 if (gfc_elemental (proc
))
144 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
145 "procedure", &sym
->declared_at
);
149 if (sym
->attr
.function
150 && sym
->ts
.type
== BT_UNKNOWN
151 && sym
->attr
.intrinsic
)
153 gfc_intrinsic_sym
*isym
;
154 isym
= gfc_find_function (sym
->name
);
155 if (isym
== NULL
|| !isym
->specific
)
157 gfc_error ("Unable to find a specific INTRINSIC procedure "
158 "for the reference '%s' at %L", sym
->name
,
167 if (sym
->ts
.type
== BT_UNKNOWN
)
169 if (!sym
->attr
.function
|| sym
->result
== sym
)
170 gfc_set_default_type (sym
, 1, sym
->ns
);
173 gfc_resolve_array_spec (sym
->as
, 0);
175 /* We can't tell if an array with dimension (:) is assumed or deferred
176 shape until we know if it has the pointer or allocatable attributes.
178 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
179 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
181 sym
->as
->type
= AS_ASSUMED_SHAPE
;
182 for (i
= 0; i
< sym
->as
->rank
; i
++)
183 sym
->as
->lower
[i
] = gfc_int_expr (1);
186 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
187 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
188 || sym
->attr
.optional
)
189 proc
->attr
.always_explicit
= 1;
191 /* If the flavor is unknown at this point, it has to be a variable.
192 A procedure specification would have already set the type. */
194 if (sym
->attr
.flavor
== FL_UNKNOWN
)
195 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
197 if (gfc_pure (proc
) && !sym
->attr
.pointer
198 && sym
->attr
.flavor
!= FL_PROCEDURE
)
200 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
201 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
202 "INTENT(IN)", sym
->name
, proc
->name
,
205 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
206 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
207 "have its INTENT specified", sym
->name
, proc
->name
,
211 if (gfc_elemental (proc
))
215 gfc_error ("Argument '%s' of elemental procedure at %L must "
216 "be scalar", sym
->name
, &sym
->declared_at
);
220 if (sym
->attr
.pointer
)
222 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
223 "have the POINTER attribute", sym
->name
,
229 /* Each dummy shall be specified to be scalar. */
230 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
234 gfc_error ("Argument '%s' of statement function at %L must "
235 "be scalar", sym
->name
, &sym
->declared_at
);
239 if (sym
->ts
.type
== BT_CHARACTER
)
241 gfc_charlen
*cl
= sym
->ts
.cl
;
242 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
244 gfc_error ("Character-valued argument '%s' of statement "
245 "function at %L must have constant length",
246 sym
->name
, &sym
->declared_at
);
256 /* Work function called when searching for symbols that have argument lists
257 associated with them. */
260 find_arglists (gfc_symbol
*sym
)
262 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
265 resolve_formal_arglist (sym
);
269 /* Given a namespace, resolve all formal argument lists within the namespace.
273 resolve_formal_arglists (gfc_namespace
*ns
)
278 gfc_traverse_ns (ns
, find_arglists
);
283 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
287 /* If this namespace is not a function, ignore it. */
288 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
))
291 /* Try to find out of what the return type is. */
292 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
294 t
= gfc_set_default_type (sym
->result
, 0, ns
);
296 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
298 if (sym
->result
== sym
)
299 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
300 sym
->name
, &sym
->declared_at
);
302 gfc_error ("Result '%s' of contained function '%s' at %L has "
303 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
304 &sym
->result
->declared_at
);
305 sym
->result
->attr
.untyped
= 1;
309 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
310 type, lists the only ways a character length value of * can be used:
311 dummy arguments of procedures, named constants, and function results
312 in external functions. Internal function results are not on that list;
313 ergo, not permitted. */
315 if (sym
->result
->ts
.type
== BT_CHARACTER
)
317 gfc_charlen
*cl
= sym
->result
->ts
.cl
;
318 if (!cl
|| !cl
->length
)
319 gfc_error ("Character-valued internal function '%s' at %L must "
320 "not be assumed length", sym
->name
, &sym
->declared_at
);
325 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
326 introduce duplicates. */
329 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
331 gfc_formal_arglist
*f
, *new_arglist
;
334 for (; new_args
!= NULL
; new_args
= new_args
->next
)
336 new_sym
= new_args
->sym
;
337 /* See if this arg is already in the formal argument list. */
338 for (f
= proc
->formal
; f
; f
= f
->next
)
340 if (new_sym
== f
->sym
)
347 /* Add a new argument. Argument order is not important. */
348 new_arglist
= gfc_get_formal_arglist ();
349 new_arglist
->sym
= new_sym
;
350 new_arglist
->next
= proc
->formal
;
351 proc
->formal
= new_arglist
;
356 /* Flag the arguments that are not present in all entries. */
359 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
361 gfc_formal_arglist
*f
, *head
;
364 for (f
= proc
->formal
; f
; f
= f
->next
)
369 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
371 if (new_args
->sym
== f
->sym
)
378 f
->sym
->attr
.not_always_present
= 1;
383 /* Resolve alternate entry points. If a symbol has multiple entry points we
384 create a new master symbol for the main routine, and turn the existing
385 symbol into an entry point. */
388 resolve_entries (gfc_namespace
*ns
)
390 gfc_namespace
*old_ns
;
394 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
395 static int master_count
= 0;
397 if (ns
->proc_name
== NULL
)
400 /* No need to do anything if this procedure doesn't have alternate entry
405 /* We may already have resolved alternate entry points. */
406 if (ns
->proc_name
->attr
.entry_master
)
409 /* If this isn't a procedure something has gone horribly wrong. */
410 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
412 /* Remember the current namespace. */
413 old_ns
= gfc_current_ns
;
417 /* Add the main entry point to the list of entry points. */
418 el
= gfc_get_entry_list ();
419 el
->sym
= ns
->proc_name
;
421 el
->next
= ns
->entries
;
423 ns
->proc_name
->attr
.entry
= 1;
425 /* If it is a module function, it needs to be in the right namespace
426 so that gfc_get_fake_result_decl can gather up the results. The
427 need for this arose in get_proc_name, where these beasts were
428 left in their own namespace, to keep prior references linked to
429 the entry declaration.*/
430 if (ns
->proc_name
->attr
.function
431 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
434 /* Do the same for entries where the master is not a module
435 procedure. These are retained in the module namespace because
436 of the module procedure declaration. */
437 for (el
= el
->next
; el
; el
= el
->next
)
438 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
439 && el
->sym
->attr
.mod_proc
)
443 /* Add an entry statement for it. */
450 /* Create a new symbol for the master function. */
451 /* Give the internal function a unique name (within this file).
452 Also include the function name so the user has some hope of figuring
453 out what is going on. */
454 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
455 master_count
++, ns
->proc_name
->name
);
456 gfc_get_ha_symbol (name
, &proc
);
457 gcc_assert (proc
!= NULL
);
459 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
460 if (ns
->proc_name
->attr
.subroutine
)
461 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
465 gfc_typespec
*ts
, *fts
;
466 gfc_array_spec
*as
, *fas
;
467 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
469 fas
= ns
->entries
->sym
->as
;
470 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
471 fts
= &ns
->entries
->sym
->result
->ts
;
472 if (fts
->type
== BT_UNKNOWN
)
473 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
474 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
476 ts
= &el
->sym
->result
->ts
;
478 as
= as
? as
: el
->sym
->result
->as
;
479 if (ts
->type
== BT_UNKNOWN
)
480 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
482 if (! gfc_compare_types (ts
, fts
)
483 || (el
->sym
->result
->attr
.dimension
484 != ns
->entries
->sym
->result
->attr
.dimension
)
485 || (el
->sym
->result
->attr
.pointer
486 != ns
->entries
->sym
->result
->attr
.pointer
))
489 else if (as
&& fas
&& gfc_compare_array_spec (as
, fas
) == 0)
490 gfc_error ("Procedure %s at %L has entries with mismatched "
491 "array specifications", ns
->entries
->sym
->name
,
492 &ns
->entries
->sym
->declared_at
);
497 sym
= ns
->entries
->sym
->result
;
498 /* All result types the same. */
500 if (sym
->attr
.dimension
)
501 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
502 if (sym
->attr
.pointer
)
503 gfc_add_pointer (&proc
->attr
, NULL
);
507 /* Otherwise the result will be passed through a union by
509 proc
->attr
.mixed_entry_master
= 1;
510 for (el
= ns
->entries
; el
; el
= el
->next
)
512 sym
= el
->sym
->result
;
513 if (sym
->attr
.dimension
)
515 if (el
== ns
->entries
)
516 gfc_error ("FUNCTION result %s can't be an array in "
517 "FUNCTION %s at %L", sym
->name
,
518 ns
->entries
->sym
->name
, &sym
->declared_at
);
520 gfc_error ("ENTRY result %s can't be an array in "
521 "FUNCTION %s at %L", sym
->name
,
522 ns
->entries
->sym
->name
, &sym
->declared_at
);
524 else if (sym
->attr
.pointer
)
526 if (el
== ns
->entries
)
527 gfc_error ("FUNCTION result %s can't be a POINTER in "
528 "FUNCTION %s at %L", sym
->name
,
529 ns
->entries
->sym
->name
, &sym
->declared_at
);
531 gfc_error ("ENTRY result %s can't be a POINTER in "
532 "FUNCTION %s at %L", sym
->name
,
533 ns
->entries
->sym
->name
, &sym
->declared_at
);
538 if (ts
->type
== BT_UNKNOWN
)
539 ts
= gfc_get_default_type (sym
, NULL
);
543 if (ts
->kind
== gfc_default_integer_kind
)
547 if (ts
->kind
== gfc_default_real_kind
548 || ts
->kind
== gfc_default_double_kind
)
552 if (ts
->kind
== gfc_default_complex_kind
)
556 if (ts
->kind
== gfc_default_logical_kind
)
560 /* We will issue error elsewhere. */
568 if (el
== ns
->entries
)
569 gfc_error ("FUNCTION result %s can't be of type %s "
570 "in FUNCTION %s at %L", sym
->name
,
571 gfc_typename (ts
), ns
->entries
->sym
->name
,
574 gfc_error ("ENTRY result %s can't be of type %s "
575 "in FUNCTION %s at %L", sym
->name
,
576 gfc_typename (ts
), ns
->entries
->sym
->name
,
583 proc
->attr
.access
= ACCESS_PRIVATE
;
584 proc
->attr
.entry_master
= 1;
586 /* Merge all the entry point arguments. */
587 for (el
= ns
->entries
; el
; el
= el
->next
)
588 merge_argument_lists (proc
, el
->sym
->formal
);
590 /* Check the master formal arguments for any that are not
591 present in all entry points. */
592 for (el
= ns
->entries
; el
; el
= el
->next
)
593 check_argument_lists (proc
, el
->sym
->formal
);
595 /* Use the master function for the function body. */
596 ns
->proc_name
= proc
;
598 /* Finalize the new symbols. */
599 gfc_commit_symbols ();
601 /* Restore the original namespace. */
602 gfc_current_ns
= old_ns
;
606 /* Resolve common blocks. */
608 resolve_common_blocks (gfc_symtree
*common_root
)
610 gfc_symtree
*symtree
;
613 if (common_root
== NULL
)
616 for (symtree
= common_root
; symtree
->left
; symtree
= symtree
->left
);
618 for (; symtree
; symtree
= symtree
->right
)
620 gfc_find_symbol (symtree
->name
, gfc_current_ns
, 0, &sym
);
624 if (sym
->attr
.flavor
== FL_PARAMETER
)
626 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
627 sym
->name
, &symtree
->n
.common
->where
,
631 if (sym
->attr
.intrinsic
)
633 gfc_error ("COMMON block '%s' at %L is also an intrinsic "
634 "procedure", sym
->name
,
635 &symtree
->n
.common
->where
);
637 else if (sym
->attr
.result
638 ||(sym
->attr
.function
&& gfc_current_ns
->proc_name
== sym
))
640 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' "
641 "at %L that is also a function result", sym
->name
,
642 &symtree
->n
.common
->where
);
644 else if (sym
->attr
.flavor
== FL_PROCEDURE
645 && sym
->attr
.proc
!= PROC_INTERNAL
646 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
648 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' "
649 "at %L that is also a global procedure", sym
->name
,
650 &symtree
->n
.common
->where
);
656 /* Resolve contained function types. Because contained functions can call one
657 another, they have to be worked out before any of the contained procedures
660 The good news is that if a function doesn't already have a type, the only
661 way it can get one is through an IMPLICIT type or a RESULT variable, because
662 by definition contained functions are contained namespace they're contained
663 in, not in a sibling or parent namespace. */
666 resolve_contained_functions (gfc_namespace
*ns
)
668 gfc_namespace
*child
;
671 resolve_formal_arglists (ns
);
673 for (child
= ns
->contained
; child
; child
= child
->sibling
)
675 /* Resolve alternate entry points first. */
676 resolve_entries (child
);
678 /* Then check function return types. */
679 resolve_contained_fntype (child
->proc_name
, child
);
680 for (el
= child
->entries
; el
; el
= el
->next
)
681 resolve_contained_fntype (el
->sym
, child
);
686 /* Resolve all of the elements of a structure constructor and make sure that
687 the types are correct. */
690 resolve_structure_cons (gfc_expr
*expr
)
692 gfc_constructor
*cons
;
698 cons
= expr
->value
.constructor
;
699 /* A constructor may have references if it is the result of substituting a
700 parameter variable. In this case we just pull out the component we
703 comp
= expr
->ref
->u
.c
.sym
->components
;
705 comp
= expr
->ts
.derived
->components
;
707 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
712 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
718 if (cons
->expr
->expr_type
!= EXPR_NULL
719 && comp
->as
&& comp
->as
->rank
!= cons
->expr
->rank
720 && (comp
->allocatable
|| cons
->expr
->rank
))
722 gfc_error ("The rank of the element in the derived type "
723 "constructor at %L does not match that of the "
724 "component (%d/%d)", &cons
->expr
->where
,
725 cons
->expr
->rank
, comp
->as
? comp
->as
->rank
: 0);
729 /* If we don't have the right type, try to convert it. */
731 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
734 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
735 gfc_error ("The element in the derived type constructor at %L, "
736 "for pointer component '%s', is %s but should be %s",
737 &cons
->expr
->where
, comp
->name
,
738 gfc_basic_typename (cons
->expr
->ts
.type
),
739 gfc_basic_typename (comp
->ts
.type
));
741 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
744 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
747 a
= gfc_expr_attr (cons
->expr
);
749 if (!a
.pointer
&& !a
.target
)
752 gfc_error ("The element in the derived type constructor at %L, "
753 "for pointer component '%s' should be a POINTER or "
754 "a TARGET", &cons
->expr
->where
, comp
->name
);
762 /****************** Expression name resolution ******************/
764 /* Returns 0 if a symbol was not declared with a type or
765 attribute declaration statement, nonzero otherwise. */
768 was_declared (gfc_symbol
*sym
)
774 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
777 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
778 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
779 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
786 /* Determine if a symbol is generic or not. */
789 generic_sym (gfc_symbol
*sym
)
793 if (sym
->attr
.generic
||
794 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
797 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
800 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
807 return generic_sym (s
);
814 /* Determine if a symbol is specific or not. */
817 specific_sym (gfc_symbol
*sym
)
821 if (sym
->attr
.if_source
== IFSRC_IFBODY
822 || sym
->attr
.proc
== PROC_MODULE
823 || sym
->attr
.proc
== PROC_INTERNAL
824 || sym
->attr
.proc
== PROC_ST_FUNCTION
825 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
826 || sym
->attr
.external
)
829 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
832 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
834 return (s
== NULL
) ? 0 : specific_sym (s
);
838 /* Figure out if the procedure is specific, generic or unknown. */
841 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
845 procedure_kind (gfc_symbol
*sym
)
847 if (generic_sym (sym
))
848 return PTYPE_GENERIC
;
850 if (specific_sym (sym
))
851 return PTYPE_SPECIFIC
;
853 return PTYPE_UNKNOWN
;
856 /* Check references to assumed size arrays. The flag need_full_assumed_size
857 is nonzero when matching actual arguments. */
859 static int need_full_assumed_size
= 0;
862 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
868 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
871 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
872 if (ref
->type
== REF_ARRAY
)
873 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
874 last
= (ref
->u
.ar
.end
[dim
] == NULL
)
875 && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
879 gfc_error ("The upper bound in the last dimension must "
880 "appear in the reference to the assumed size "
881 "array '%s' at %L", sym
->name
, &e
->where
);
888 /* Look for bad assumed size array references in argument expressions
889 of elemental and array valued intrinsic procedures. Since this is
890 called from procedure resolution functions, it only recurses at
894 resolve_assumed_size_actual (gfc_expr
*e
)
899 switch (e
->expr_type
)
902 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
907 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
908 || resolve_assumed_size_actual (e
->value
.op
.op2
))
919 /* Resolve an actual argument list. Most of the time, this is just
920 resolving the expressions in the list.
921 The exception is that we sometimes have to decide whether arguments
922 that look like procedure arguments are really simple variable
926 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
)
929 gfc_symtree
*parent_st
;
932 for (; arg
; arg
= arg
->next
)
937 /* Check the label is a valid branching target. */
940 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
942 gfc_error ("Label %d referenced at %L is never defined",
943 arg
->label
->value
, &arg
->label
->where
);
950 if (e
->ts
.type
!= BT_PROCEDURE
)
952 if (gfc_resolve_expr (e
) != SUCCESS
)
957 /* See if the expression node should really be a variable reference. */
959 sym
= e
->symtree
->n
.sym
;
961 if (sym
->attr
.flavor
== FL_PROCEDURE
962 || sym
->attr
.intrinsic
963 || sym
->attr
.external
)
967 /* If a procedure is not already determined to be something else
968 check if it is intrinsic. */
969 if (!sym
->attr
.intrinsic
970 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
971 || sym
->attr
.if_source
== IFSRC_IFBODY
)
972 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
973 sym
->attr
.intrinsic
= 1;
975 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
977 gfc_error ("Statement function '%s' at %L is not allowed as an "
978 "actual argument", sym
->name
, &e
->where
);
981 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
982 sym
->attr
.subroutine
);
983 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
985 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
986 "actual argument", sym
->name
, &e
->where
);
989 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
990 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
992 gfc_error ("Internal procedure '%s' is not allowed as an "
993 "actual argument at %L", sym
->name
, &e
->where
);
996 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
998 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
999 "allowed as an actual argument at %L", sym
->name
,
1003 /* Check if a generic interface has a specific procedure
1004 with the same name before emitting an error. */
1005 if (sym
->attr
.generic
)
1008 for (p
= sym
->generic
; p
; p
= p
->next
)
1009 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1011 e
->symtree
= gfc_find_symtree
1012 (p
->sym
->ns
->sym_root
, sym
->name
);
1017 if (p
== NULL
|| e
->symtree
== NULL
)
1018 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
1019 "allowed as an actual argument at %L", sym
->name
,
1023 /* If the symbol is the function that names the current (or
1024 parent) scope, then we really have a variable reference. */
1026 if (sym
->attr
.function
&& sym
->result
== sym
1027 && (sym
->ns
->proc_name
== sym
1028 || (sym
->ns
->parent
!= NULL
1029 && sym
->ns
->parent
->proc_name
== sym
)))
1032 /* If all else fails, see if we have a specific intrinsic. */
1033 if (sym
->attr
.function
1034 && sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1036 gfc_intrinsic_sym
*isym
;
1037 isym
= gfc_find_function (sym
->name
);
1038 if (isym
== NULL
|| !isym
->specific
)
1040 gfc_error ("Unable to find a specific INTRINSIC procedure "
1041 "for the reference '%s' at %L", sym
->name
,
1049 /* See if the name is a module procedure in a parent unit. */
1051 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1054 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1056 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1060 if (parent_st
== NULL
)
1063 sym
= parent_st
->n
.sym
;
1064 e
->symtree
= parent_st
; /* Point to the right thing. */
1066 if (sym
->attr
.flavor
== FL_PROCEDURE
1067 || sym
->attr
.intrinsic
1068 || sym
->attr
.external
)
1074 e
->expr_type
= EXPR_VARIABLE
;
1076 if (sym
->as
!= NULL
)
1078 e
->rank
= sym
->as
->rank
;
1079 e
->ref
= gfc_get_ref ();
1080 e
->ref
->type
= REF_ARRAY
;
1081 e
->ref
->u
.ar
.type
= AR_FULL
;
1082 e
->ref
->u
.ar
.as
= sym
->as
;
1085 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1086 primary.c (match_actual_arg). If above code determines that it
1087 is a variable instead, it needs to be resolved as it was not
1088 done at the beginning of this function. */
1089 if (gfc_resolve_expr (e
) != SUCCESS
)
1093 /* Check argument list functions %VAL, %LOC and %REF. There is
1094 nothing to do for %REF. */
1095 if (arg
->name
&& arg
->name
[0] == '%')
1097 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1099 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1101 gfc_error ("By-value argument at %L is not of numeric "
1108 gfc_error ("By-value argument at %L cannot be an array or "
1109 "an array section", &e
->where
);
1113 /* Intrinsics are still PROC_UNKNOWN here. However,
1114 since same file external procedures are not resolvable
1115 in gfortran, it is a good deal easier to leave them to
1117 if (ptype
!= PROC_UNKNOWN
1118 && ptype
!= PROC_DUMMY
1119 && ptype
!= PROC_EXTERNAL
1120 && ptype
!= PROC_MODULE
)
1122 gfc_error ("By-value argument at %L is not allowed "
1123 "in this context", &e
->where
);
1128 /* Statement functions have already been excluded above. */
1129 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1130 && e
->ts
.type
== BT_PROCEDURE
)
1132 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1134 gfc_error ("Passing internal procedure at %L by location "
1135 "not allowed", &e
->where
);
1146 /* Do the checks of the actual argument list that are specific to elemental
1147 procedures. If called with c == NULL, we have a function, otherwise if
1148 expr == NULL, we have a subroutine. */
1151 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1153 gfc_actual_arglist
*arg0
;
1154 gfc_actual_arglist
*arg
;
1155 gfc_symbol
*esym
= NULL
;
1156 gfc_intrinsic_sym
*isym
= NULL
;
1158 gfc_intrinsic_arg
*iformal
= NULL
;
1159 gfc_formal_arglist
*eformal
= NULL
;
1160 bool formal_optional
= false;
1161 bool set_by_optional
= false;
1165 /* Is this an elemental procedure? */
1166 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1168 if (expr
->value
.function
.esym
!= NULL
1169 && expr
->value
.function
.esym
->attr
.elemental
)
1171 arg0
= expr
->value
.function
.actual
;
1172 esym
= expr
->value
.function
.esym
;
1174 else if (expr
->value
.function
.isym
!= NULL
1175 && expr
->value
.function
.isym
->elemental
)
1177 arg0
= expr
->value
.function
.actual
;
1178 isym
= expr
->value
.function
.isym
;
1183 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1185 arg0
= c
->ext
.actual
;
1186 esym
= c
->symtree
->n
.sym
;
1191 /* The rank of an elemental is the rank of its array argument(s). */
1192 for (arg
= arg0
; arg
; arg
= arg
->next
)
1194 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1196 rank
= arg
->expr
->rank
;
1197 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1198 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1199 set_by_optional
= true;
1201 /* Function specific; set the result rank and shape. */
1205 if (!expr
->shape
&& arg
->expr
->shape
)
1207 expr
->shape
= gfc_get_shape (rank
);
1208 for (i
= 0; i
< rank
; i
++)
1209 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1216 /* If it is an array, it shall not be supplied as an actual argument
1217 to an elemental procedure unless an array of the same rank is supplied
1218 as an actual argument corresponding to a nonoptional dummy argument of
1219 that elemental procedure(12.4.1.5). */
1220 formal_optional
= false;
1222 iformal
= isym
->formal
;
1224 eformal
= esym
->formal
;
1226 for (arg
= arg0
; arg
; arg
= arg
->next
)
1230 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1231 formal_optional
= true;
1232 eformal
= eformal
->next
;
1234 else if (isym
&& iformal
)
1236 if (iformal
->optional
)
1237 formal_optional
= true;
1238 iformal
= iformal
->next
;
1241 formal_optional
= true;
1243 if (pedantic
&& arg
->expr
!= NULL
1244 && arg
->expr
->expr_type
== EXPR_VARIABLE
1245 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1248 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1249 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1251 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1252 "MISSING, it cannot be the actual argument of an "
1253 "ELEMENTAL procedure unless there is a non-optional "
1254 "argument with the same rank (12.4.1.5)",
1255 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1260 for (arg
= arg0
; arg
; arg
= arg
->next
)
1262 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1265 /* Being elemental, the last upper bound of an assumed size array
1266 argument must be present. */
1267 if (resolve_assumed_size_actual (arg
->expr
))
1273 /* Elemental subroutine array actual arguments must conform. */
1276 if (gfc_check_conformance ("elemental subroutine", arg
->expr
, e
)
1288 /* Go through each actual argument in ACTUAL and see if it can be
1289 implemented as an inlined, non-copying intrinsic. FNSYM is the
1290 function being called, or NULL if not known. */
1293 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1295 gfc_actual_arglist
*ap
;
1298 for (ap
= actual
; ap
; ap
= ap
->next
)
1300 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1301 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1302 ap
->expr
->inline_noncopying_intrinsic
= 1;
1306 /* This function does the checking of references to global procedures
1307 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1308 77 and 95 standards. It checks for a gsymbol for the name, making
1309 one if it does not already exist. If it already exists, then the
1310 reference being resolved must correspond to the type of gsymbol.
1311 Otherwise, the new symbol is equipped with the attributes of the
1312 reference. The corresponding code that is called in creating
1313 global entities is parse.c. */
1316 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1321 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1323 gsym
= gfc_get_gsymbol (sym
->name
);
1325 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1326 global_used (gsym
, where
);
1328 if (gsym
->type
== GSYM_UNKNOWN
)
1331 gsym
->where
= *where
;
1338 /************* Function resolution *************/
1340 /* Resolve a function call known to be generic.
1341 Section 14.1.2.4.1. */
1344 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1348 if (sym
->attr
.generic
)
1350 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1353 expr
->value
.function
.name
= s
->name
;
1354 expr
->value
.function
.esym
= s
;
1356 if (s
->ts
.type
!= BT_UNKNOWN
)
1358 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1359 expr
->ts
= s
->result
->ts
;
1362 expr
->rank
= s
->as
->rank
;
1363 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1364 expr
->rank
= s
->result
->as
->rank
;
1369 /* TODO: Need to search for elemental references in generic
1373 if (sym
->attr
.intrinsic
)
1374 return gfc_intrinsic_func_interface (expr
, 0);
1381 resolve_generic_f (gfc_expr
*expr
)
1386 sym
= expr
->symtree
->n
.sym
;
1390 m
= resolve_generic_f0 (expr
, sym
);
1393 else if (m
== MATCH_ERROR
)
1397 if (sym
->ns
->parent
== NULL
)
1399 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1403 if (!generic_sym (sym
))
1407 /* Last ditch attempt. See if the reference is to an intrinsic
1408 that possesses a matching interface. 14.1.2.4 */
1409 if (sym
&& !gfc_intrinsic_name (sym
->name
, 0))
1411 gfc_error ("There is no specific function for the generic '%s' at %L",
1412 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1416 m
= gfc_intrinsic_func_interface (expr
, 0);
1420 gfc_error ("Generic function '%s' at %L is not consistent with a "
1421 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1428 /* Resolve a function call known to be specific. */
1431 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1435 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1437 if (sym
->attr
.dummy
)
1439 sym
->attr
.proc
= PROC_DUMMY
;
1443 sym
->attr
.proc
= PROC_EXTERNAL
;
1447 if (sym
->attr
.proc
== PROC_MODULE
1448 || sym
->attr
.proc
== PROC_ST_FUNCTION
1449 || sym
->attr
.proc
== PROC_INTERNAL
)
1452 if (sym
->attr
.intrinsic
)
1454 m
= gfc_intrinsic_func_interface (expr
, 1);
1458 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1459 "with an intrinsic", sym
->name
, &expr
->where
);
1467 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1470 expr
->value
.function
.name
= sym
->name
;
1471 expr
->value
.function
.esym
= sym
;
1472 if (sym
->as
!= NULL
)
1473 expr
->rank
= sym
->as
->rank
;
1480 resolve_specific_f (gfc_expr
*expr
)
1485 sym
= expr
->symtree
->n
.sym
;
1489 m
= resolve_specific_f0 (sym
, expr
);
1492 if (m
== MATCH_ERROR
)
1495 if (sym
->ns
->parent
== NULL
)
1498 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1504 gfc_error ("Unable to resolve the specific function '%s' at %L",
1505 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1511 /* Resolve a procedure call not known to be generic nor specific. */
1514 resolve_unknown_f (gfc_expr
*expr
)
1519 sym
= expr
->symtree
->n
.sym
;
1521 if (sym
->attr
.dummy
)
1523 sym
->attr
.proc
= PROC_DUMMY
;
1524 expr
->value
.function
.name
= sym
->name
;
1528 /* See if we have an intrinsic function reference. */
1530 if (gfc_intrinsic_name (sym
->name
, 0))
1532 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1537 /* The reference is to an external name. */
1539 sym
->attr
.proc
= PROC_EXTERNAL
;
1540 expr
->value
.function
.name
= sym
->name
;
1541 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1543 if (sym
->as
!= NULL
)
1544 expr
->rank
= sym
->as
->rank
;
1546 /* Type of the expression is either the type of the symbol or the
1547 default type of the symbol. */
1550 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1552 if (sym
->ts
.type
!= BT_UNKNOWN
)
1556 ts
= gfc_get_default_type (sym
, sym
->ns
);
1558 if (ts
->type
== BT_UNKNOWN
)
1560 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1561 sym
->name
, &expr
->where
);
1572 /* Return true, if the symbol is an external procedure. */
1574 is_external_proc (gfc_symbol
*sym
)
1576 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1577 && !(sym
->attr
.intrinsic
1578 || gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1579 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1580 && !sym
->attr
.use_assoc
1588 /* Figure out if a function reference is pure or not. Also set the name
1589 of the function for a potential error message. Return nonzero if the
1590 function is PURE, zero if not. */
1593 pure_function (gfc_expr
*e
, const char **name
)
1599 if (e
->symtree
!= NULL
1600 && e
->symtree
->n
.sym
!= NULL
1601 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1604 if (e
->value
.function
.esym
)
1606 pure
= gfc_pure (e
->value
.function
.esym
);
1607 *name
= e
->value
.function
.esym
->name
;
1609 else if (e
->value
.function
.isym
)
1611 pure
= e
->value
.function
.isym
->pure
1612 || e
->value
.function
.isym
->elemental
;
1613 *name
= e
->value
.function
.isym
->name
;
1617 /* Implicit functions are not pure. */
1619 *name
= e
->value
.function
.name
;
1627 is_scalar_expr_ptr (gfc_expr
*expr
)
1629 try retval
= SUCCESS
;
1634 /* See if we have a gfc_ref, which means we have a substring, array
1635 reference, or a component. */
1636 if (expr
->ref
!= NULL
)
1639 while (ref
->next
!= NULL
)
1645 if (ref
->u
.ss
.length
!= NULL
1646 && ref
->u
.ss
.length
->length
!= NULL
1648 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1650 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1652 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1653 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1654 if (end
- start
+ 1 != 1)
1661 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1663 else if (ref
->u
.ar
.type
== AR_FULL
)
1665 /* The user can give a full array if the array is of size 1. */
1666 if (ref
->u
.ar
.as
!= NULL
1667 && ref
->u
.ar
.as
->rank
== 1
1668 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1669 && ref
->u
.ar
.as
->lower
[0] != NULL
1670 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1671 && ref
->u
.ar
.as
->upper
[0] != NULL
1672 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1674 /* If we have a character string, we need to check if
1675 its length is one. */
1676 if (expr
->ts
.type
== BT_CHARACTER
)
1678 if (expr
->ts
.cl
== NULL
1679 || expr
->ts
.cl
->length
== NULL
1680 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
1686 /* We have constant lower and upper bounds. If the
1687 difference between is 1, it can be considered a
1689 start
= (int) mpz_get_si
1690 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
1691 end
= (int) mpz_get_si
1692 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
1693 if (end
- start
+ 1 != 1)
1708 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
1710 /* Character string. Make sure it's of length 1. */
1711 if (expr
->ts
.cl
== NULL
1712 || expr
->ts
.cl
->length
== NULL
1713 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
1716 else if (expr
->rank
!= 0)
1723 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1724 and, in the case of c_associated, set the binding label based on
1728 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
1729 gfc_symbol
**new_sym
)
1731 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1732 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
1733 int optional_arg
= 0;
1734 try retval
= SUCCESS
;
1735 gfc_symbol
*args_sym
;
1737 if (args
->expr
->expr_type
== EXPR_CONSTANT
1738 || args
->expr
->expr_type
== EXPR_OP
1739 || args
->expr
->expr_type
== EXPR_NULL
)
1741 gfc_error ("Argument to '%s' at %L is not a variable",
1742 sym
->name
, &(args
->expr
->where
));
1746 args_sym
= args
->expr
->symtree
->n
.sym
;
1748 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
1750 /* If the user gave two args then they are providing something for
1751 the optional arg (the second cptr). Therefore, set the name and
1752 binding label to the c_associated for two cptrs. Otherwise,
1753 set c_associated to expect one cptr. */
1757 sprintf (name
, "%s_2", sym
->name
);
1758 sprintf (binding_label
, "%s_2", sym
->binding_label
);
1764 sprintf (name
, "%s_1", sym
->name
);
1765 sprintf (binding_label
, "%s_1", sym
->binding_label
);
1769 /* Get a new symbol for the version of c_associated that
1771 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
1773 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
1774 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
1776 sprintf (name
, "%s", sym
->name
);
1777 sprintf (binding_label
, "%s", sym
->binding_label
);
1779 /* Error check the call. */
1780 if (args
->next
!= NULL
)
1782 gfc_error_now ("More actual than formal arguments in '%s' "
1783 "call at %L", name
, &(args
->expr
->where
));
1786 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
1788 /* Make sure we have either the target or pointer attribute. */
1789 if (!(args
->expr
->symtree
->n
.sym
->attr
.target
)
1790 && !(args
->expr
->symtree
->n
.sym
->attr
.pointer
))
1792 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1793 "a TARGET or an associated pointer",
1794 args
->expr
->symtree
->n
.sym
->name
,
1795 sym
->name
, &(args
->expr
->where
));
1799 /* See if we have interoperable type and type param. */
1800 if (verify_c_interop (&(args
->expr
->symtree
->n
.sym
->ts
),
1801 args
->expr
->symtree
->n
.sym
->name
,
1802 &(args
->expr
->where
)) == SUCCESS
1803 || gfc_check_any_c_kind (&(args_sym
->ts
)) == SUCCESS
)
1805 if (args_sym
->attr
.target
== 1)
1807 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
1808 has the target attribute and is interoperable. */
1809 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
1810 allocatable variable that has the TARGET attribute and
1811 is not an array of zero size. */
1812 if (args_sym
->attr
.allocatable
== 1)
1814 if (args_sym
->attr
.dimension
!= 0
1815 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
1817 gfc_error_now ("Allocatable variable '%s' used as a "
1818 "parameter to '%s' at %L must not be "
1819 "an array of zero size",
1820 args_sym
->name
, sym
->name
,
1821 &(args
->expr
->where
));
1827 /* A non-allocatable target variable with C
1828 interoperable type and type parameters must be
1830 if (args_sym
&& args_sym
->attr
.dimension
)
1832 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
1834 gfc_error ("Assumed-shape array '%s' at %L "
1835 "cannot be an argument to the "
1836 "procedure '%s' because "
1837 "it is not C interoperable",
1839 &(args
->expr
->where
), sym
->name
);
1842 else if (args_sym
->as
->type
== AS_DEFERRED
)
1844 gfc_error ("Deferred-shape array '%s' at %L "
1845 "cannot be an argument to the "
1846 "procedure '%s' because "
1847 "it is not C interoperable",
1849 &(args
->expr
->where
), sym
->name
);
1854 /* Make sure it's not a character string. Arrays of
1855 any type should be ok if the variable is of a C
1856 interoperable type. */
1857 if (args_sym
->ts
.type
== BT_CHARACTER
)
1858 if (args_sym
->ts
.cl
!= NULL
1859 && (args_sym
->ts
.cl
->length
== NULL
1860 || args_sym
->ts
.cl
->length
->expr_type
1863 (args_sym
->ts
.cl
->length
->value
.integer
, 1)
1865 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1867 gfc_error_now ("CHARACTER argument '%s' to '%s' "
1868 "at %L must have a length of 1",
1869 args_sym
->name
, sym
->name
,
1870 &(args
->expr
->where
));
1875 else if (args_sym
->attr
.pointer
== 1
1876 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1878 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
1880 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
1881 "associated scalar POINTER", args_sym
->name
,
1882 sym
->name
, &(args
->expr
->where
));
1888 /* The parameter is not required to be C interoperable. If it
1889 is not C interoperable, it must be a nonpolymorphic scalar
1890 with no length type parameters. It still must have either
1891 the pointer or target attribute, and it can be
1892 allocatable (but must be allocated when c_loc is called). */
1893 if (args_sym
->attr
.dimension
!= 0
1894 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1896 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1897 "scalar", args_sym
->name
, sym
->name
,
1898 &(args
->expr
->where
));
1901 else if (args_sym
->ts
.type
== BT_CHARACTER
1902 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
1904 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
1905 "%L must have a length of 1",
1906 args_sym
->name
, sym
->name
,
1907 &(args
->expr
->where
));
1912 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
1914 if (args
->expr
->symtree
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
)
1916 /* TODO: Update this error message to allow for procedure
1917 pointers once they are implemented. */
1918 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
1920 args
->expr
->symtree
->n
.sym
->name
, sym
->name
,
1921 &(args
->expr
->where
));
1924 else if (args
->expr
->symtree
->n
.sym
->attr
.is_bind_c
!= 1)
1926 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
1928 args
->expr
->symtree
->n
.sym
->name
, sym
->name
,
1929 &(args
->expr
->where
));
1934 /* for c_loc/c_funloc, the new symbol is the same as the old one */
1939 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
1940 "iso_c_binding function: '%s'!\n", sym
->name
);
1947 /* Resolve a function call, which means resolving the arguments, then figuring
1948 out which entity the name refers to. */
1949 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1950 to INTENT(OUT) or INTENT(INOUT). */
1953 resolve_function (gfc_expr
*expr
)
1955 gfc_actual_arglist
*arg
;
1960 procedure_type p
= PROC_INTRINSIC
;
1964 sym
= expr
->symtree
->n
.sym
;
1966 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
1968 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
1972 /* If the procedure is external, check for usage. */
1973 if (sym
&& is_external_proc (sym
))
1974 resolve_global_procedure (sym
, &expr
->where
, 0);
1976 /* Switch off assumed size checking and do this again for certain kinds
1977 of procedure, once the procedure itself is resolved. */
1978 need_full_assumed_size
++;
1980 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
1981 p
= expr
->symtree
->n
.sym
->attr
.proc
;
1983 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
1986 /* Need to setup the call to the correct c_associated, depending on
1987 the number of cptrs to user gives to compare. */
1988 if (sym
&& sym
->attr
.is_iso_c
== 1)
1990 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
1994 /* Get the symtree for the new symbol (resolved func).
1995 the old one will be freed later, when it's no longer used. */
1996 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
1999 /* Resume assumed_size checking. */
2000 need_full_assumed_size
--;
2002 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2004 && sym
->ts
.cl
->length
== NULL
2006 && expr
->value
.function
.esym
== NULL
2007 && !sym
->attr
.contained
)
2009 /* Internal procedures are taken care of in resolve_contained_fntype. */
2010 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2011 "be used at %L since it is not a dummy argument",
2012 sym
->name
, &expr
->where
);
2016 /* See if function is already resolved. */
2018 if (expr
->value
.function
.name
!= NULL
)
2020 if (expr
->ts
.type
== BT_UNKNOWN
)
2026 /* Apply the rules of section 14.1.2. */
2028 switch (procedure_kind (sym
))
2031 t
= resolve_generic_f (expr
);
2034 case PTYPE_SPECIFIC
:
2035 t
= resolve_specific_f (expr
);
2039 t
= resolve_unknown_f (expr
);
2043 gfc_internal_error ("resolve_function(): bad function type");
2047 /* If the expression is still a function (it might have simplified),
2048 then we check to see if we are calling an elemental function. */
2050 if (expr
->expr_type
!= EXPR_FUNCTION
)
2053 temp
= need_full_assumed_size
;
2054 need_full_assumed_size
= 0;
2056 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2059 if (omp_workshare_flag
2060 && expr
->value
.function
.esym
2061 && ! gfc_elemental (expr
->value
.function
.esym
))
2063 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2064 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2069 #define GENERIC_ID expr->value.function.isym->id
2070 else if (expr
->value
.function
.actual
!= NULL
2071 && expr
->value
.function
.isym
!= NULL
2072 && GENERIC_ID
!= GFC_ISYM_LBOUND
2073 && GENERIC_ID
!= GFC_ISYM_LEN
2074 && GENERIC_ID
!= GFC_ISYM_LOC
2075 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2077 /* Array intrinsics must also have the last upper bound of an
2078 assumed size array argument. UBOUND and SIZE have to be
2079 excluded from the check if the second argument is anything
2082 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
2083 || GENERIC_ID
== GFC_ISYM_SIZE
;
2085 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2087 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
)
2089 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2092 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2097 if (arg
->expr
!= NULL
2098 && arg
->expr
->rank
> 0
2099 && resolve_assumed_size_actual (arg
->expr
))
2105 need_full_assumed_size
= temp
;
2108 if (!pure_function (expr
, &name
) && name
)
2112 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2113 "FORALL %s", name
, &expr
->where
,
2114 forall_flag
== 2 ? "mask" : "block");
2117 else if (gfc_pure (NULL
))
2119 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2120 "procedure within a PURE procedure", name
, &expr
->where
);
2125 /* Functions without the RECURSIVE attribution are not allowed to
2126 * call themselves. */
2127 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2129 gfc_symbol
*esym
, *proc
;
2130 esym
= expr
->value
.function
.esym
;
2131 proc
= gfc_current_ns
->proc_name
;
2134 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2135 "RECURSIVE", name
, &expr
->where
);
2139 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
2140 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2142 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2143 "'%s' is not declared as RECURSIVE",
2144 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2149 /* Character lengths of use associated functions may contains references to
2150 symbols not referenced from the current program unit otherwise. Make sure
2151 those symbols are marked as referenced. */
2153 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2154 && expr
->value
.function
.esym
->attr
.use_assoc
)
2156 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2160 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2161 expr
->value
.function
.actual
);
2163 /* Make sure that the expression has a typespec that works. */
2164 if (expr
->ts
.type
== BT_UNKNOWN
)
2166 if (expr
->symtree
->n
.sym
->result
2167 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2168 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2175 /************* Subroutine resolution *************/
2178 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2184 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2185 sym
->name
, &c
->loc
);
2186 else if (gfc_pure (NULL
))
2187 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2193 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2197 if (sym
->attr
.generic
)
2199 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2202 c
->resolved_sym
= s
;
2203 pure_subroutine (c
, s
);
2207 /* TODO: Need to search for elemental references in generic interface. */
2210 if (sym
->attr
.intrinsic
)
2211 return gfc_intrinsic_sub_interface (c
, 0);
2218 resolve_generic_s (gfc_code
*c
)
2223 sym
= c
->symtree
->n
.sym
;
2227 m
= resolve_generic_s0 (c
, sym
);
2230 else if (m
== MATCH_ERROR
)
2234 if (sym
->ns
->parent
== NULL
)
2236 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2240 if (!generic_sym (sym
))
2244 /* Last ditch attempt. See if the reference is to an intrinsic
2245 that possesses a matching interface. 14.1.2.4 */
2246 sym
= c
->symtree
->n
.sym
;
2248 if (!gfc_intrinsic_name (sym
->name
, 1))
2250 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2251 sym
->name
, &c
->loc
);
2255 m
= gfc_intrinsic_sub_interface (c
, 0);
2259 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2260 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2266 /* Set the name and binding label of the subroutine symbol in the call
2267 expression represented by 'c' to include the type and kind of the
2268 second parameter. This function is for resolving the appropriate
2269 version of c_f_pointer() and c_f_procpointer(). For example, a
2270 call to c_f_pointer() for a default integer pointer could have a
2271 name of c_f_pointer_i4. If no second arg exists, which is an error
2272 for these two functions, it defaults to the generic symbol's name
2273 and binding label. */
2276 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2277 char *name
, char *binding_label
)
2279 gfc_expr
*arg
= NULL
;
2283 /* The second arg of c_f_pointer and c_f_procpointer determines
2284 the type and kind for the procedure name. */
2285 arg
= c
->ext
.actual
->next
->expr
;
2289 /* Set up the name to have the given symbol's name,
2290 plus the type and kind. */
2291 /* a derived type is marked with the type letter 'u' */
2292 if (arg
->ts
.type
== BT_DERIVED
)
2295 kind
= 0; /* set the kind as 0 for now */
2299 type
= gfc_type_letter (arg
->ts
.type
);
2300 kind
= arg
->ts
.kind
;
2303 if (arg
->ts
.type
== BT_CHARACTER
)
2304 /* Kind info for character strings not needed. */
2307 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2308 /* Set up the binding label as the given symbol's label plus
2309 the type and kind. */
2310 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2314 /* If the second arg is missing, set the name and label as
2315 was, cause it should at least be found, and the missing
2316 arg error will be caught by compare_parameters(). */
2317 sprintf (name
, "%s", sym
->name
);
2318 sprintf (binding_label
, "%s", sym
->binding_label
);
2325 /* Resolve a generic version of the iso_c_binding procedure given
2326 (sym) to the specific one based on the type and kind of the
2327 argument(s). Currently, this function resolves c_f_pointer() and
2328 c_f_procpointer based on the type and kind of the second argument
2329 (FPTR). Other iso_c_binding procedures aren't specially handled.
2330 Upon successfully exiting, c->resolved_sym will hold the resolved
2331 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2335 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2337 gfc_symbol
*new_sym
;
2338 /* this is fine, since we know the names won't use the max */
2339 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2340 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2341 /* default to success; will override if find error */
2342 match m
= MATCH_YES
;
2344 /* Make sure the actual arguments are in the necessary order (based on the
2345 formal args) before resolving. */
2346 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2348 /* Give the optional SHAPE formal arg a type now that we've done our
2349 initial checking against the actual. */
2350 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2351 sym
->formal
->next
->next
->sym
->ts
.type
= BT_INTEGER
;
2353 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2354 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2356 set_name_and_label (c
, sym
, name
, binding_label
);
2358 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2360 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2362 /* Make sure we got a third arg if the second arg has non-zero
2363 rank. We must also check that the type and rank are
2364 correct since we short-circuit this check in
2365 gfc_procedure_use() (called above to sort actual args). */
2366 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2368 if(c
->ext
.actual
->next
->next
== NULL
2369 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2372 gfc_error ("Missing SHAPE parameter for call to %s "
2373 "at %L", sym
->name
, &(c
->loc
));
2375 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2377 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2380 gfc_error ("SHAPE parameter for call to %s at %L must "
2381 "be a rank 1 INTEGER array", sym
->name
,
2388 if (m
!= MATCH_ERROR
)
2390 /* the 1 means to add the optional arg to formal list */
2391 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2393 /* Set the kind for the SHAPE array to that of the actual
2395 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
2396 && c
->ext
.actual
->next
->expr
->rank
!= 0)
2397 new_sym
->formal
->next
->next
->sym
->ts
.kind
=
2398 c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
2400 /* for error reporting, say it's declared where the original was */
2401 new_sym
->declared_at
= sym
->declared_at
;
2404 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2406 /* TODO: Figure out if this is even reachable; this part of the
2407 conditional may not be necessary. */
2409 if (c
->ext
.actual
->next
== NULL
)
2411 /* The user did not give two args, so resolve to the version
2412 of c_associated expecting one arg. */
2414 /* get rid of the second arg */
2415 /* TODO!! Should free up the memory here! */
2416 sym
->formal
->next
= NULL
;
2424 sprintf (name
, "%s_%d", sym
->name
, num_args
);
2425 sprintf (binding_label
, "%s_%d", sym
->binding_label
, num_args
);
2426 sym
->name
= gfc_get_string (name
);
2427 strcpy (sym
->binding_label
, binding_label
);
2431 /* no differences for c_loc or c_funloc */
2435 /* set the resolved symbol */
2436 if (m
!= MATCH_ERROR
)
2437 c
->resolved_sym
= new_sym
;
2439 c
->resolved_sym
= sym
;
2445 /* Resolve a subroutine call known to be specific. */
2448 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2452 if(sym
->attr
.is_iso_c
)
2454 m
= gfc_iso_c_sub_interface (c
,sym
);
2458 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2460 if (sym
->attr
.dummy
)
2462 sym
->attr
.proc
= PROC_DUMMY
;
2466 sym
->attr
.proc
= PROC_EXTERNAL
;
2470 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2473 if (sym
->attr
.intrinsic
)
2475 m
= gfc_intrinsic_sub_interface (c
, 1);
2479 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2480 "with an intrinsic", sym
->name
, &c
->loc
);
2488 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2490 c
->resolved_sym
= sym
;
2491 pure_subroutine (c
, sym
);
2498 resolve_specific_s (gfc_code
*c
)
2503 sym
= c
->symtree
->n
.sym
;
2507 m
= resolve_specific_s0 (c
, sym
);
2510 if (m
== MATCH_ERROR
)
2513 if (sym
->ns
->parent
== NULL
)
2516 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2522 sym
= c
->symtree
->n
.sym
;
2523 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2524 sym
->name
, &c
->loc
);
2530 /* Resolve a subroutine call not known to be generic nor specific. */
2533 resolve_unknown_s (gfc_code
*c
)
2537 sym
= c
->symtree
->n
.sym
;
2539 if (sym
->attr
.dummy
)
2541 sym
->attr
.proc
= PROC_DUMMY
;
2545 /* See if we have an intrinsic function reference. */
2547 if (gfc_intrinsic_name (sym
->name
, 1))
2549 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2554 /* The reference is to an external name. */
2557 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2559 c
->resolved_sym
= sym
;
2561 pure_subroutine (c
, sym
);
2567 /* Resolve a subroutine call. Although it was tempting to use the same code
2568 for functions, subroutines and functions are stored differently and this
2569 makes things awkward. */
2572 resolve_call (gfc_code
*c
)
2575 procedure_type ptype
= PROC_INTRINSIC
;
2577 if (c
->symtree
&& c
->symtree
->n
.sym
2578 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
2580 gfc_error ("'%s' at %L has a type, which is not consistent with "
2581 "the CALL at %L", c
->symtree
->n
.sym
->name
,
2582 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
2586 /* If external, check for usage. */
2587 if (c
->symtree
&& is_external_proc (c
->symtree
->n
.sym
))
2588 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
2590 /* Subroutines without the RECURSIVE attribution are not allowed to
2591 * call themselves. */
2592 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
2594 gfc_symbol
*csym
, *proc
;
2595 csym
= c
->symtree
->n
.sym
;
2596 proc
= gfc_current_ns
->proc_name
;
2599 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2600 "RECURSIVE", csym
->name
, &c
->loc
);
2604 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
2605 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2607 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2608 "'%s' is not declared as RECURSIVE",
2609 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2614 /* Switch off assumed size checking and do this again for certain kinds
2615 of procedure, once the procedure itself is resolved. */
2616 need_full_assumed_size
++;
2618 if (c
->symtree
&& c
->symtree
->n
.sym
)
2619 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
2621 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
2624 /* Resume assumed_size checking. */
2625 need_full_assumed_size
--;
2628 if (c
->resolved_sym
== NULL
)
2629 switch (procedure_kind (c
->symtree
->n
.sym
))
2632 t
= resolve_generic_s (c
);
2635 case PTYPE_SPECIFIC
:
2636 t
= resolve_specific_s (c
);
2640 t
= resolve_unknown_s (c
);
2644 gfc_internal_error ("resolve_subroutine(): bad function type");
2647 /* Some checks of elemental subroutine actual arguments. */
2648 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2652 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2657 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2658 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2659 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2660 if their shapes do not match. If either op1->shape or op2->shape is
2661 NULL, return SUCCESS. */
2664 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2671 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2673 for (i
= 0; i
< op1
->rank
; i
++)
2675 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2677 gfc_error ("Shapes for operands at %L and %L are not conformable",
2678 &op1
->where
, &op2
->where
);
2689 /* Resolve an operator expression node. This can involve replacing the
2690 operation with a user defined function call. */
2693 resolve_operator (gfc_expr
*e
)
2695 gfc_expr
*op1
, *op2
;
2697 bool dual_locus_error
;
2700 /* Resolve all subnodes-- give them types. */
2702 switch (e
->value
.op
.operator)
2705 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2708 /* Fall through... */
2711 case INTRINSIC_UPLUS
:
2712 case INTRINSIC_UMINUS
:
2713 case INTRINSIC_PARENTHESES
:
2714 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2719 /* Typecheck the new node. */
2721 op1
= e
->value
.op
.op1
;
2722 op2
= e
->value
.op
.op2
;
2723 dual_locus_error
= false;
2725 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
2726 || (op2
&& op2
->expr_type
== EXPR_NULL
))
2728 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
2732 switch (e
->value
.op
.operator)
2734 case INTRINSIC_UPLUS
:
2735 case INTRINSIC_UMINUS
:
2736 if (op1
->ts
.type
== BT_INTEGER
2737 || op1
->ts
.type
== BT_REAL
2738 || op1
->ts
.type
== BT_COMPLEX
)
2744 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2745 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2748 case INTRINSIC_PLUS
:
2749 case INTRINSIC_MINUS
:
2750 case INTRINSIC_TIMES
:
2751 case INTRINSIC_DIVIDE
:
2752 case INTRINSIC_POWER
:
2753 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2755 gfc_type_convert_binary (e
);
2760 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2761 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2762 gfc_typename (&op2
->ts
));
2765 case INTRINSIC_CONCAT
:
2766 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2768 e
->ts
.type
= BT_CHARACTER
;
2769 e
->ts
.kind
= op1
->ts
.kind
;
2774 _("Operands of string concatenation operator at %%L are %s/%s"),
2775 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2781 case INTRINSIC_NEQV
:
2782 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2784 e
->ts
.type
= BT_LOGICAL
;
2785 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2786 if (op1
->ts
.kind
< e
->ts
.kind
)
2787 gfc_convert_type (op1
, &e
->ts
, 2);
2788 else if (op2
->ts
.kind
< e
->ts
.kind
)
2789 gfc_convert_type (op2
, &e
->ts
, 2);
2793 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2794 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2795 gfc_typename (&op2
->ts
));
2800 if (op1
->ts
.type
== BT_LOGICAL
)
2802 e
->ts
.type
= BT_LOGICAL
;
2803 e
->ts
.kind
= op1
->ts
.kind
;
2807 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
2808 gfc_typename (&op1
->ts
));
2812 case INTRINSIC_GT_OS
:
2814 case INTRINSIC_GE_OS
:
2816 case INTRINSIC_LT_OS
:
2818 case INTRINSIC_LE_OS
:
2819 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
2821 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
2825 /* Fall through... */
2828 case INTRINSIC_EQ_OS
:
2830 case INTRINSIC_NE_OS
:
2831 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2833 e
->ts
.type
= BT_LOGICAL
;
2834 e
->ts
.kind
= gfc_default_logical_kind
;
2838 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2840 gfc_type_convert_binary (e
);
2842 e
->ts
.type
= BT_LOGICAL
;
2843 e
->ts
.kind
= gfc_default_logical_kind
;
2847 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2849 _("Logicals at %%L must be compared with %s instead of %s"),
2850 (e
->value
.op
.operator == INTRINSIC_EQ
2851 || e
->value
.op
.operator == INTRINSIC_EQ_OS
)
2852 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.operator));
2855 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2856 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2857 gfc_typename (&op2
->ts
));
2861 case INTRINSIC_USER
:
2862 if (e
->value
.op
.uop
->operator == NULL
)
2863 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
2864 else if (op2
== NULL
)
2865 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
2866 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
2868 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
2869 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
2870 gfc_typename (&op2
->ts
));
2874 case INTRINSIC_PARENTHESES
:
2878 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2881 /* Deal with arrayness of an operand through an operator. */
2885 switch (e
->value
.op
.operator)
2887 case INTRINSIC_PLUS
:
2888 case INTRINSIC_MINUS
:
2889 case INTRINSIC_TIMES
:
2890 case INTRINSIC_DIVIDE
:
2891 case INTRINSIC_POWER
:
2892 case INTRINSIC_CONCAT
:
2896 case INTRINSIC_NEQV
:
2898 case INTRINSIC_EQ_OS
:
2900 case INTRINSIC_NE_OS
:
2902 case INTRINSIC_GT_OS
:
2904 case INTRINSIC_GE_OS
:
2906 case INTRINSIC_LT_OS
:
2908 case INTRINSIC_LE_OS
:
2910 if (op1
->rank
== 0 && op2
->rank
== 0)
2913 if (op1
->rank
== 0 && op2
->rank
!= 0)
2915 e
->rank
= op2
->rank
;
2917 if (e
->shape
== NULL
)
2918 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
2921 if (op1
->rank
!= 0 && op2
->rank
== 0)
2923 e
->rank
= op1
->rank
;
2925 if (e
->shape
== NULL
)
2926 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2929 if (op1
->rank
!= 0 && op2
->rank
!= 0)
2931 if (op1
->rank
== op2
->rank
)
2933 e
->rank
= op1
->rank
;
2934 if (e
->shape
== NULL
)
2936 t
= compare_shapes(op1
, op2
);
2940 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2945 /* Allow higher level expressions to work. */
2948 /* Try user-defined operators, and otherwise throw an error. */
2949 dual_locus_error
= true;
2951 _("Inconsistent ranks for operator at %%L and %%L"));
2958 case INTRINSIC_PARENTHESES
:
2960 /* This is always correct and sometimes necessary! */
2961 if (e
->ts
.type
== BT_UNKNOWN
)
2964 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.cl
)
2965 e
->ts
.cl
= op1
->ts
.cl
;
2968 case INTRINSIC_UPLUS
:
2969 case INTRINSIC_UMINUS
:
2970 /* Simply copy arrayness attribute */
2971 e
->rank
= op1
->rank
;
2973 if (e
->shape
== NULL
)
2974 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
2982 /* Attempt to simplify the expression. */
2985 t
= gfc_simplify_expr (e
, 0);
2986 /* Some calls do not succeed in simplification and return FAILURE
2987 even though there is no error; eg. variable references to
2988 PARAMETER arrays. */
2989 if (!gfc_is_constant_expr (e
))
2996 if (gfc_extend_expr (e
) == SUCCESS
)
2999 if (dual_locus_error
)
3000 gfc_error (msg
, &op1
->where
, &op2
->where
);
3002 gfc_error (msg
, &e
->where
);
3008 /************** Array resolution subroutines **************/
3011 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3014 /* Compare two integer expressions. */
3017 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3021 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3022 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3025 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3026 gfc_internal_error ("compare_bound(): Bad expression");
3028 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3038 /* Compare an integer expression with an integer. */
3041 compare_bound_int (gfc_expr
*a
, int b
)
3045 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3048 if (a
->ts
.type
!= BT_INTEGER
)
3049 gfc_internal_error ("compare_bound_int(): Bad expression");
3051 i
= mpz_cmp_si (a
->value
.integer
, b
);
3061 /* Compare an integer expression with a mpz_t. */
3064 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3068 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3071 if (a
->ts
.type
!= BT_INTEGER
)
3072 gfc_internal_error ("compare_bound_int(): Bad expression");
3074 i
= mpz_cmp (a
->value
.integer
, b
);
3084 /* Compute the last value of a sequence given by a triplet.
3085 Return 0 if it wasn't able to compute the last value, or if the
3086 sequence if empty, and 1 otherwise. */
3089 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3090 gfc_expr
*stride
, mpz_t last
)
3094 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3095 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3096 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3099 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3100 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3103 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3105 if (compare_bound (start
, end
) == CMP_GT
)
3107 mpz_set (last
, end
->value
.integer
);
3111 if (compare_bound_int (stride
, 0) == CMP_GT
)
3113 /* Stride is positive */
3114 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3119 /* Stride is negative */
3120 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3125 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3126 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3127 mpz_sub (last
, end
->value
.integer
, rem
);
3134 /* Compare a single dimension of an array reference to the array
3138 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3142 /* Given start, end and stride values, calculate the minimum and
3143 maximum referenced indexes. */
3151 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3153 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3160 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3161 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3163 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3165 /* Check for zero stride, which is not allowed. */
3166 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3168 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3172 /* if start == len || (stride > 0 && start < len)
3173 || (stride < 0 && start > len),
3174 then the array section contains at least one element. In this
3175 case, there is an out-of-bounds access if
3176 (start < lower || start > upper). */
3177 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3178 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3179 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3180 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3181 && comp_start_end
== CMP_GT
))
3183 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
3184 || compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3188 /* If we can compute the highest index of the array section,
3189 then it also has to be between lower and upper. */
3190 mpz_init (last_value
);
3191 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3194 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
3195 || compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3197 mpz_clear (last_value
);
3201 mpz_clear (last_value
);
3209 gfc_internal_error ("check_dimension(): Bad array reference");
3215 gfc_warning ("Array reference at %L is out of bounds", &ar
->c_where
[i
]);
3220 /* Compare an array reference with an array specification. */
3223 compare_spec_to_ref (gfc_array_ref
*ar
)
3230 /* TODO: Full array sections are only allowed as actual parameters. */
3231 if (as
->type
== AS_ASSUMED_SIZE
3232 && (/*ar->type == AR_FULL
3233 ||*/ (ar
->type
== AR_SECTION
3234 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3236 gfc_error ("Rightmost upper bound of assumed size array section "
3237 "not specified at %L", &ar
->where
);
3241 if (ar
->type
== AR_FULL
)
3244 if (as
->rank
!= ar
->dimen
)
3246 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3247 &ar
->where
, ar
->dimen
, as
->rank
);
3251 for (i
= 0; i
< as
->rank
; i
++)
3252 if (check_dimension (i
, ar
, as
) == FAILURE
)
3259 /* Resolve one part of an array index. */
3262 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3269 if (gfc_resolve_expr (index
) == FAILURE
)
3272 if (check_scalar
&& index
->rank
!= 0)
3274 gfc_error ("Array index at %L must be scalar", &index
->where
);
3278 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3280 gfc_error ("Array index at %L must be of INTEGER type",
3285 if (index
->ts
.type
== BT_REAL
)
3286 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3287 &index
->where
) == FAILURE
)
3290 if (index
->ts
.kind
!= gfc_index_integer_kind
3291 || index
->ts
.type
!= BT_INTEGER
)
3294 ts
.type
= BT_INTEGER
;
3295 ts
.kind
= gfc_index_integer_kind
;
3297 gfc_convert_type_warn (index
, &ts
, 2, 0);
3303 /* Resolve a dim argument to an intrinsic function. */
3306 gfc_resolve_dim_arg (gfc_expr
*dim
)
3311 if (gfc_resolve_expr (dim
) == FAILURE
)
3316 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3320 if (dim
->ts
.type
!= BT_INTEGER
)
3322 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3325 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3329 ts
.type
= BT_INTEGER
;
3330 ts
.kind
= gfc_index_integer_kind
;
3332 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3338 /* Given an expression that contains array references, update those array
3339 references to point to the right array specifications. While this is
3340 filled in during matching, this information is difficult to save and load
3341 in a module, so we take care of it here.
3343 The idea here is that the original array reference comes from the
3344 base symbol. We traverse the list of reference structures, setting
3345 the stored reference to references. Component references can
3346 provide an additional array specification. */
3349 find_array_spec (gfc_expr
*e
)
3353 gfc_symbol
*derived
;
3356 as
= e
->symtree
->n
.sym
->as
;
3359 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3364 gfc_internal_error ("find_array_spec(): Missing spec");
3371 if (derived
== NULL
)
3372 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3374 c
= derived
->components
;
3376 for (; c
; c
= c
->next
)
3377 if (c
== ref
->u
.c
.component
)
3379 /* Track the sequence of component references. */
3380 if (c
->ts
.type
== BT_DERIVED
)
3381 derived
= c
->ts
.derived
;
3386 gfc_internal_error ("find_array_spec(): Component not found");
3391 gfc_internal_error ("find_array_spec(): unused as(1)");
3402 gfc_internal_error ("find_array_spec(): unused as(2)");
3406 /* Resolve an array reference. */
3409 resolve_array_ref (gfc_array_ref
*ar
)
3411 int i
, check_scalar
;
3414 for (i
= 0; i
< ar
->dimen
; i
++)
3416 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3418 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3420 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3422 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3427 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3431 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3435 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3436 if (e
->expr_type
== EXPR_VARIABLE
3437 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3438 ar
->start
[i
] = gfc_get_parentheses (e
);
3442 gfc_error ("Array index at %L is an array of rank %d",
3443 &ar
->c_where
[i
], e
->rank
);
3448 /* If the reference type is unknown, figure out what kind it is. */
3450 if (ar
->type
== AR_UNKNOWN
)
3452 ar
->type
= AR_ELEMENT
;
3453 for (i
= 0; i
< ar
->dimen
; i
++)
3454 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3455 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3457 ar
->type
= AR_SECTION
;
3462 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3470 resolve_substring (gfc_ref
*ref
)
3472 if (ref
->u
.ss
.start
!= NULL
)
3474 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3477 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3479 gfc_error ("Substring start index at %L must be of type INTEGER",
3480 &ref
->u
.ss
.start
->where
);
3484 if (ref
->u
.ss
.start
->rank
!= 0)
3486 gfc_error ("Substring start index at %L must be scalar",
3487 &ref
->u
.ss
.start
->where
);
3491 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3492 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3493 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3495 gfc_error ("Substring start index at %L is less than one",
3496 &ref
->u
.ss
.start
->where
);
3501 if (ref
->u
.ss
.end
!= NULL
)
3503 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3506 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3508 gfc_error ("Substring end index at %L must be of type INTEGER",
3509 &ref
->u
.ss
.end
->where
);
3513 if (ref
->u
.ss
.end
->rank
!= 0)
3515 gfc_error ("Substring end index at %L must be scalar",
3516 &ref
->u
.ss
.end
->where
);
3520 if (ref
->u
.ss
.length
!= NULL
3521 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3522 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3523 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3525 gfc_error ("Substring end index at %L exceeds the string length",
3526 &ref
->u
.ss
.start
->where
);
3535 /* Resolve subtype references. */
3538 resolve_ref (gfc_expr
*expr
)
3540 int current_part_dimension
, n_components
, seen_part_dimension
;
3543 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3544 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3546 find_array_spec (expr
);
3550 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3554 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
3562 resolve_substring (ref
);
3566 /* Check constraints on part references. */
3568 current_part_dimension
= 0;
3569 seen_part_dimension
= 0;
3572 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3577 switch (ref
->u
.ar
.type
)
3581 current_part_dimension
= 1;
3585 current_part_dimension
= 0;
3589 gfc_internal_error ("resolve_ref(): Bad array reference");
3595 if (current_part_dimension
|| seen_part_dimension
)
3597 if (ref
->u
.c
.component
->pointer
)
3599 gfc_error ("Component to the right of a part reference "
3600 "with nonzero rank must not have the POINTER "
3601 "attribute at %L", &expr
->where
);
3604 else if (ref
->u
.c
.component
->allocatable
)
3606 gfc_error ("Component to the right of a part reference "
3607 "with nonzero rank must not have the ALLOCATABLE "
3608 "attribute at %L", &expr
->where
);
3620 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
3621 || ref
->next
== NULL
)
3622 && current_part_dimension
3623 && seen_part_dimension
)
3625 gfc_error ("Two or more part references with nonzero rank must "
3626 "not be specified at %L", &expr
->where
);
3630 if (ref
->type
== REF_COMPONENT
)
3632 if (current_part_dimension
)
3633 seen_part_dimension
= 1;
3635 /* reset to make sure */
3636 current_part_dimension
= 0;
3644 /* Given an expression, determine its shape. This is easier than it sounds.
3645 Leaves the shape array NULL if it is not possible to determine the shape. */
3648 expression_shape (gfc_expr
*e
)
3650 mpz_t array
[GFC_MAX_DIMENSIONS
];
3653 if (e
->rank
== 0 || e
->shape
!= NULL
)
3656 for (i
= 0; i
< e
->rank
; i
++)
3657 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
3660 e
->shape
= gfc_get_shape (e
->rank
);
3662 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3667 for (i
--; i
>= 0; i
--)
3668 mpz_clear (array
[i
]);
3672 /* Given a variable expression node, compute the rank of the expression by
3673 examining the base symbol and any reference structures it may have. */
3676 expression_rank (gfc_expr
*e
)
3683 if (e
->expr_type
== EXPR_ARRAY
)
3685 /* Constructors can have a rank different from one via RESHAPE(). */
3687 if (e
->symtree
== NULL
)
3693 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3694 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3700 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3702 if (ref
->type
!= REF_ARRAY
)
3705 if (ref
->u
.ar
.type
== AR_FULL
)
3707 rank
= ref
->u
.ar
.as
->rank
;
3711 if (ref
->u
.ar
.type
== AR_SECTION
)
3713 /* Figure out the rank of the section. */
3715 gfc_internal_error ("expression_rank(): Two array specs");
3717 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3718 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
3719 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
3729 expression_shape (e
);
3733 /* Resolve a variable expression. */
3736 resolve_variable (gfc_expr
*e
)
3743 if (e
->symtree
== NULL
)
3746 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
3749 sym
= e
->symtree
->n
.sym
;
3750 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
3752 e
->ts
.type
= BT_PROCEDURE
;
3756 if (sym
->ts
.type
!= BT_UNKNOWN
)
3757 gfc_variable_attr (e
, &e
->ts
);
3760 /* Must be a simple variable reference. */
3761 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
3766 if (check_assumed_size_reference (sym
, e
))
3769 /* Deal with forward references to entries during resolve_code, to
3770 satisfy, at least partially, 12.5.2.5. */
3771 if (gfc_current_ns
->entries
3772 && current_entry_id
== sym
->entry_id
3775 && cs_base
->current
->op
!= EXEC_ENTRY
)
3777 gfc_entry_list
*entry
;
3778 gfc_formal_arglist
*formal
;
3782 /* If the symbol is a dummy... */
3783 if (sym
->attr
.dummy
)
3785 entry
= gfc_current_ns
->entries
;
3788 /* ...test if the symbol is a parameter of previous entries. */
3789 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
3790 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
3792 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
3796 /* If it has not been seen as a dummy, this is an error. */
3799 if (specification_expr
)
3800 gfc_error ("Variable '%s',used in a specification expression, "
3801 "is referenced at %L before the ENTRY statement "
3802 "in which it is a parameter",
3803 sym
->name
, &cs_base
->current
->loc
);
3805 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3806 "statement in which it is a parameter",
3807 sym
->name
, &cs_base
->current
->loc
);
3812 /* Now do the same check on the specification expressions. */
3813 specification_expr
= 1;
3814 if (sym
->ts
.type
== BT_CHARACTER
3815 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
3819 for (n
= 0; n
< sym
->as
->rank
; n
++)
3821 specification_expr
= 1;
3822 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
3824 specification_expr
= 1;
3825 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
3828 specification_expr
= 0;
3831 /* Update the symbol's entry level. */
3832 sym
->entry_id
= current_entry_id
+ 1;
3839 /* Checks to see that the correct symbol has been host associated.
3840 The only situation where this arises is that in which a twice
3841 contained function is parsed after the host association is made.
3842 Therefore, on detecting this, the line is rematched, having got
3843 rid of the existing references and actual_arg_list. */
3845 check_host_association (gfc_expr
*e
)
3847 gfc_symbol
*sym
, *old_sym
;
3851 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
3853 if (e
->symtree
== NULL
|| e
->symtree
->n
.sym
== NULL
)
3856 old_sym
= e
->symtree
->n
.sym
;
3858 if (old_sym
->attr
.use_assoc
)
3861 if (gfc_current_ns
->parent
3862 && gfc_current_ns
->parent
->parent
3863 && old_sym
->ns
!= gfc_current_ns
)
3865 gfc_find_symbol (old_sym
->name
, gfc_current_ns
->parent
, 1, &sym
);
3866 if (sym
&& old_sym
!= sym
&& sym
->attr
.flavor
== FL_PROCEDURE
)
3868 temp_locus
= gfc_current_locus
;
3869 gfc_current_locus
= e
->where
;
3871 gfc_buffer_error (1);
3873 gfc_free_ref_list (e
->ref
);
3878 gfc_free_actual_arglist (e
->value
.function
.actual
);
3879 e
->value
.function
.actual
= NULL
;
3882 if (e
->shape
!= NULL
)
3884 for (n
= 0; n
< e
->rank
; n
++)
3885 mpz_clear (e
->shape
[n
]);
3887 gfc_free (e
->shape
);
3890 gfc_match_rvalue (&expr
);
3892 gfc_buffer_error (0);
3894 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
3900 gfc_current_locus
= temp_locus
;
3903 /* This might have changed! */
3904 return e
->expr_type
== EXPR_FUNCTION
;
3908 /* Resolve an expression. That is, make sure that types of operands agree
3909 with their operators, intrinsic operators are converted to function calls
3910 for overloaded types and unresolved function references are resolved. */
3913 gfc_resolve_expr (gfc_expr
*e
)
3920 switch (e
->expr_type
)
3923 t
= resolve_operator (e
);
3929 if (check_host_association (e
))
3930 t
= resolve_function (e
);
3933 t
= resolve_variable (e
);
3935 expression_rank (e
);
3939 case EXPR_SUBSTRING
:
3940 t
= resolve_ref (e
);
3950 if (resolve_ref (e
) == FAILURE
)
3953 t
= gfc_resolve_array_constructor (e
);
3954 /* Also try to expand a constructor. */
3957 expression_rank (e
);
3958 gfc_expand_constructor (e
);
3961 /* This provides the opportunity for the length of constructors with
3962 character valued function elements to propagate the string length
3963 to the expression. */
3964 if (e
->ts
.type
== BT_CHARACTER
)
3965 gfc_resolve_character_array_constructor (e
);
3969 case EXPR_STRUCTURE
:
3970 t
= resolve_ref (e
);
3974 t
= resolve_structure_cons (e
);
3978 t
= gfc_simplify_expr (e
, 0);
3982 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3989 /* Resolve an expression from an iterator. They must be scalar and have
3990 INTEGER or (optionally) REAL type. */
3993 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
3994 const char *name_msgid
)
3996 if (gfc_resolve_expr (expr
) == FAILURE
)
3999 if (expr
->rank
!= 0)
4001 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4005 if (expr
->ts
.type
!= BT_INTEGER
)
4007 if (expr
->ts
.type
== BT_REAL
)
4010 return gfc_notify_std (GFC_STD_F95_DEL
,
4011 "Deleted feature: %s at %L must be integer",
4012 _(name_msgid
), &expr
->where
);
4015 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4022 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4030 /* Resolve the expressions in an iterator structure. If REAL_OK is
4031 false allow only INTEGER type iterators, otherwise allow REAL types. */
4034 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4036 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4040 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4042 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4047 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4048 "Start expression in DO loop") == FAILURE
)
4051 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4052 "End expression in DO loop") == FAILURE
)
4055 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4056 "Step expression in DO loop") == FAILURE
)
4059 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4061 if ((iter
->step
->ts
.type
== BT_INTEGER
4062 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4063 || (iter
->step
->ts
.type
== BT_REAL
4064 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4066 gfc_error ("Step expression in DO loop at %L cannot be zero",
4067 &iter
->step
->where
);
4072 /* Convert start, end, and step to the same type as var. */
4073 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4074 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4075 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4077 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4078 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4079 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4081 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4082 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4083 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4089 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4090 to be a scalar INTEGER variable. The subscripts and stride are scalar
4091 INTEGERs, and if stride is a constant it must be nonzero. */
4094 resolve_forall_iterators (gfc_forall_iterator
*iter
)
4098 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4099 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4100 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4103 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4104 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4105 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4106 &iter
->start
->where
);
4107 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4108 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4110 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4111 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4112 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4114 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4115 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4117 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4119 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4120 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4121 &iter
->stride
->where
, "INTEGER");
4123 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4124 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4125 gfc_error ("FORALL stride expression at %L cannot be zero",
4126 &iter
->stride
->where
);
4128 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4129 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4136 /* Given a pointer to a symbol that is a derived type, see if any components
4137 have the POINTER attribute. The search is recursive if necessary.
4138 Returns zero if no pointer components are found, nonzero otherwise. */
4141 derived_pointer (gfc_symbol
*sym
)
4145 for (c
= sym
->components
; c
; c
= c
->next
)
4150 if (c
->ts
.type
== BT_DERIVED
&& derived_pointer (c
->ts
.derived
))
4158 /* Given a pointer to a symbol that is a derived type, see if it's
4159 inaccessible, i.e. if it's defined in another module and the components are
4160 PRIVATE. The search is recursive if necessary. Returns zero if no
4161 inaccessible components are found, nonzero otherwise. */
4164 derived_inaccessible (gfc_symbol
*sym
)
4168 if (sym
->attr
.use_assoc
&& sym
->component_access
== ACCESS_PRIVATE
)
4171 for (c
= sym
->components
; c
; c
= c
->next
)
4173 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
4181 /* Resolve the argument of a deallocate expression. The expression must be
4182 a pointer or a full array. */
4185 resolve_deallocate_expr (gfc_expr
*e
)
4187 symbol_attribute attr
;
4188 int allocatable
, pointer
, check_intent_in
;
4191 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4192 check_intent_in
= 1;
4194 if (gfc_resolve_expr (e
) == FAILURE
)
4197 if (e
->expr_type
!= EXPR_VARIABLE
)
4200 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4201 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4202 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4205 check_intent_in
= 0;
4210 if (ref
->u
.ar
.type
!= AR_FULL
)
4215 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4216 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4217 pointer
= ref
->u
.c
.component
->pointer
;
4226 attr
= gfc_expr_attr (e
);
4228 if (allocatable
== 0 && attr
.pointer
== 0)
4231 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4232 "ALLOCATABLE or a POINTER", &e
->where
);
4236 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4238 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4239 e
->symtree
->n
.sym
->name
, &e
->where
);
4247 /* Returns true if the expression e contains a reference the symbol sym. */
4249 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
4251 gfc_actual_arglist
*arg
;
4259 switch (e
->expr_type
)
4262 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
4263 rv
= rv
|| find_sym_in_expr (sym
, arg
->expr
);
4266 /* If the variable is not the same as the dependent, 'sym', and
4267 it is not marked as being declared and it is in the same
4268 namespace as 'sym', add it to the local declarations. */
4270 if (sym
== e
->symtree
->n
.sym
)
4275 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op1
);
4276 rv
= rv
|| find_sym_in_expr (sym
, e
->value
.op
.op2
);
4285 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4290 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4292 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.start
[i
]);
4293 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.end
[i
]);
4294 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ar
.stride
[i
]);
4299 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.start
);
4300 rv
= rv
|| find_sym_in_expr (sym
, ref
->u
.ss
.end
);
4304 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4305 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
4308 || find_sym_in_expr (sym
,
4309 ref
->u
.c
.component
->ts
.cl
->length
);
4311 if (ref
->u
.c
.component
->as
)
4312 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
4315 || find_sym_in_expr (sym
,
4316 ref
->u
.c
.component
->as
->lower
[i
]);
4318 || find_sym_in_expr (sym
,
4319 ref
->u
.c
.component
->as
->upper
[i
]);
4329 /* Given the expression node e for an allocatable/pointer of derived type to be
4330 allocated, get the expression node to be initialized afterwards (needed for
4331 derived types with default initializers, and derived types with allocatable
4332 components that need nullification.) */
4335 expr_to_initialize (gfc_expr
*e
)
4341 result
= gfc_copy_expr (e
);
4343 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4344 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
4345 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
4347 ref
->u
.ar
.type
= AR_FULL
;
4349 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4350 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
4352 result
->rank
= ref
->u
.ar
.dimen
;
4360 /* Resolve the expression in an ALLOCATE statement, doing the additional
4361 checks to see whether the expression is OK or not. The expression must
4362 have a trailing array reference that gives the size of the array. */
4365 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
4367 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
4368 symbol_attribute attr
;
4369 gfc_ref
*ref
, *ref2
;
4376 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4377 check_intent_in
= 1;
4379 if (gfc_resolve_expr (e
) == FAILURE
)
4382 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
4383 sym
= code
->expr
->symtree
->n
.sym
;
4387 /* Make sure the expression is allocatable or a pointer. If it is
4388 pointer, the next-to-last reference must be a pointer. */
4392 if (e
->expr_type
!= EXPR_VARIABLE
)
4395 attr
= gfc_expr_attr (e
);
4396 pointer
= attr
.pointer
;
4397 dimension
= attr
.dimension
;
4401 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4402 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4403 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
4405 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
4407 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4408 "not be allocated in the same statement at %L",
4409 sym
->name
, &e
->where
);
4413 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
4416 check_intent_in
= 0;
4421 if (ref
->next
!= NULL
)
4426 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4427 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4429 pointer
= ref
->u
.c
.component
->pointer
;
4430 dimension
= ref
->u
.c
.component
->dimension
;
4441 if (allocatable
== 0 && pointer
== 0)
4443 gfc_error ("Expression in ALLOCATE statement at %L must be "
4444 "ALLOCATABLE or a POINTER", &e
->where
);
4449 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4451 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4452 e
->symtree
->n
.sym
->name
, &e
->where
);
4456 /* Add default initializer for those derived types that need them. */
4457 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
4459 init_st
= gfc_get_code ();
4460 init_st
->loc
= code
->loc
;
4461 init_st
->op
= EXEC_INIT_ASSIGN
;
4462 init_st
->expr
= expr_to_initialize (e
);
4463 init_st
->expr2
= init_e
;
4464 init_st
->next
= code
->next
;
4465 code
->next
= init_st
;
4468 if (pointer
&& dimension
== 0)
4471 /* Make sure the next-to-last reference node is an array specification. */
4473 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
4475 gfc_error ("Array specification required in ALLOCATE statement "
4476 "at %L", &e
->where
);
4480 /* Make sure that the array section reference makes sense in the
4481 context of an ALLOCATE specification. */
4485 for (i
= 0; i
< ar
->dimen
; i
++)
4487 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
4490 switch (ar
->dimen_type
[i
])
4496 if (ar
->start
[i
] != NULL
4497 && ar
->end
[i
] != NULL
4498 && ar
->stride
[i
] == NULL
)
4501 /* Fall Through... */
4505 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4512 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4514 sym
= a
->expr
->symtree
->n
.sym
;
4516 /* TODO - check derived type components. */
4517 if (sym
->ts
.type
== BT_DERIVED
)
4520 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
4521 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
4523 gfc_error ("'%s' must not appear an the array specification at "
4524 "%L in the same ALLOCATE statement where it is "
4525 "itself allocated", sym
->name
, &ar
->where
);
4535 /************ SELECT CASE resolution subroutines ************/
4537 /* Callback function for our mergesort variant. Determines interval
4538 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4539 op1 > op2. Assumes we're not dealing with the default case.
4540 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4541 There are nine situations to check. */
4544 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
4548 if (op1
->low
== NULL
) /* op1 = (:L) */
4550 /* op2 = (:N), so overlap. */
4552 /* op2 = (M:) or (M:N), L < M */
4553 if (op2
->low
!= NULL
4554 && gfc_compare_expr (op1
->high
, op2
->low
) < 0)
4557 else if (op1
->high
== NULL
) /* op1 = (K:) */
4559 /* op2 = (M:), so overlap. */
4561 /* op2 = (:N) or (M:N), K > N */
4562 if (op2
->high
!= NULL
4563 && gfc_compare_expr (op1
->low
, op2
->high
) > 0)
4566 else /* op1 = (K:L) */
4568 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
4569 retval
= (gfc_compare_expr (op1
->low
, op2
->high
) > 0) ? 1 : 0;
4570 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
4571 retval
= (gfc_compare_expr (op1
->high
, op2
->low
) < 0) ? -1 : 0;
4572 else /* op2 = (M:N) */
4576 if (gfc_compare_expr (op1
->high
, op2
->low
) < 0)
4579 else if (gfc_compare_expr (op1
->low
, op2
->high
) > 0)
4588 /* Merge-sort a double linked case list, detecting overlap in the
4589 process. LIST is the head of the double linked case list before it
4590 is sorted. Returns the head of the sorted list if we don't see any
4591 overlap, or NULL otherwise. */
4594 check_case_overlap (gfc_case
*list
)
4596 gfc_case
*p
, *q
, *e
, *tail
;
4597 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
4599 /* If the passed list was empty, return immediately. */
4606 /* Loop unconditionally. The only exit from this loop is a return
4607 statement, when we've finished sorting the case list. */
4614 /* Count the number of merges we do in this pass. */
4617 /* Loop while there exists a merge to be done. */
4622 /* Count this merge. */
4625 /* Cut the list in two pieces by stepping INSIZE places
4626 forward in the list, starting from P. */
4629 for (i
= 0; i
< insize
; i
++)
4638 /* Now we have two lists. Merge them! */
4639 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
4641 /* See from which the next case to merge comes from. */
4644 /* P is empty so the next case must come from Q. */
4649 else if (qsize
== 0 || q
== NULL
)
4658 cmp
= compare_cases (p
, q
);
4661 /* The whole case range for P is less than the
4669 /* The whole case range for Q is greater than
4670 the case range for P. */
4677 /* The cases overlap, or they are the same
4678 element in the list. Either way, we must
4679 issue an error and get the next case from P. */
4680 /* FIXME: Sort P and Q by line number. */
4681 gfc_error ("CASE label at %L overlaps with CASE "
4682 "label at %L", &p
->where
, &q
->where
);
4690 /* Add the next element to the merged list. */
4699 /* P has now stepped INSIZE places along, and so has Q. So
4700 they're the same. */
4705 /* If we have done only one merge or none at all, we've
4706 finished sorting the cases. */
4715 /* Otherwise repeat, merging lists twice the size. */
4721 /* Check to see if an expression is suitable for use in a CASE statement.
4722 Makes sure that all case expressions are scalar constants of the same
4723 type. Return FAILURE if anything is wrong. */
4726 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
4728 if (e
== NULL
) return SUCCESS
;
4730 if (e
->ts
.type
!= case_expr
->ts
.type
)
4732 gfc_error ("Expression in CASE statement at %L must be of type %s",
4733 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
4737 /* C805 (R808) For a given case-construct, each case-value shall be of
4738 the same type as case-expr. For character type, length differences
4739 are allowed, but the kind type parameters shall be the same. */
4741 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
4743 gfc_error("Expression in CASE statement at %L must be kind %d",
4744 &e
->where
, case_expr
->ts
.kind
);
4748 /* Convert the case value kind to that of case expression kind, if needed.
4749 FIXME: Should a warning be issued? */
4750 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
4751 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
4755 gfc_error ("Expression in CASE statement at %L must be scalar",
4764 /* Given a completely parsed select statement, we:
4766 - Validate all expressions and code within the SELECT.
4767 - Make sure that the selection expression is not of the wrong type.
4768 - Make sure that no case ranges overlap.
4769 - Eliminate unreachable cases and unreachable code resulting from
4770 removing case labels.
4772 The standard does allow unreachable cases, e.g. CASE (5:3). But
4773 they are a hassle for code generation, and to prevent that, we just
4774 cut them out here. This is not necessary for overlapping cases
4775 because they are illegal and we never even try to generate code.
4777 We have the additional caveat that a SELECT construct could have
4778 been a computed GOTO in the source code. Fortunately we can fairly
4779 easily work around that here: The case_expr for a "real" SELECT CASE
4780 is in code->expr1, but for a computed GOTO it is in code->expr2. All
4781 we have to do is make sure that the case_expr is a scalar integer
4785 resolve_select (gfc_code
*code
)
4788 gfc_expr
*case_expr
;
4789 gfc_case
*cp
, *default_case
, *tail
, *head
;
4790 int seen_unreachable
;
4796 if (code
->expr
== NULL
)
4798 /* This was actually a computed GOTO statement. */
4799 case_expr
= code
->expr2
;
4800 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
4801 gfc_error ("Selection expression in computed GOTO statement "
4802 "at %L must be a scalar integer expression",
4805 /* Further checking is not necessary because this SELECT was built
4806 by the compiler, so it should always be OK. Just move the
4807 case_expr from expr2 to expr so that we can handle computed
4808 GOTOs as normal SELECTs from here on. */
4809 code
->expr
= code
->expr2
;
4814 case_expr
= code
->expr
;
4816 type
= case_expr
->ts
.type
;
4817 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
4819 gfc_error ("Argument of SELECT statement at %L cannot be %s",
4820 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
4822 /* Punt. Going on here just produce more garbage error messages. */
4826 if (case_expr
->rank
!= 0)
4828 gfc_error ("Argument of SELECT statement at %L must be a scalar "
4829 "expression", &case_expr
->where
);
4835 /* PR 19168 has a long discussion concerning a mismatch of the kinds
4836 of the SELECT CASE expression and its CASE values. Walk the lists
4837 of case values, and if we find a mismatch, promote case_expr to
4838 the appropriate kind. */
4840 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
4842 for (body
= code
->block
; body
; body
= body
->block
)
4844 /* Walk the case label list. */
4845 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4847 /* Intercept the DEFAULT case. It does not have a kind. */
4848 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4851 /* Unreachable case ranges are discarded, so ignore. */
4852 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4853 && cp
->low
!= cp
->high
4854 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4857 /* FIXME: Should a warning be issued? */
4859 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
4860 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
4862 if (cp
->high
!= NULL
4863 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
4864 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
4869 /* Assume there is no DEFAULT case. */
4870 default_case
= NULL
;
4875 for (body
= code
->block
; body
; body
= body
->block
)
4877 /* Assume the CASE list is OK, and all CASE labels can be matched. */
4879 seen_unreachable
= 0;
4881 /* Walk the case label list, making sure that all case labels
4883 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
4885 /* Count the number of cases in the whole construct. */
4888 /* Intercept the DEFAULT case. */
4889 if (cp
->low
== NULL
&& cp
->high
== NULL
)
4891 if (default_case
!= NULL
)
4893 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4894 "by a second DEFAULT CASE at %L",
4895 &default_case
->where
, &cp
->where
);
4906 /* Deal with single value cases and case ranges. Errors are
4907 issued from the validation function. */
4908 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
4909 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
4915 if (type
== BT_LOGICAL
4916 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
4917 || cp
->low
!= cp
->high
))
4919 gfc_error ("Logical range in CASE statement at %L is not "
4920 "allowed", &cp
->low
->where
);
4925 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
4928 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
4929 if (value
& seen_logical
)
4931 gfc_error ("constant logical value in CASE statement "
4932 "is repeated at %L",
4937 seen_logical
|= value
;
4940 if (cp
->low
!= NULL
&& cp
->high
!= NULL
4941 && cp
->low
!= cp
->high
4942 && gfc_compare_expr (cp
->low
, cp
->high
) > 0)
4944 if (gfc_option
.warn_surprising
)
4945 gfc_warning ("Range specification at %L can never "
4946 "be matched", &cp
->where
);
4948 cp
->unreachable
= 1;
4949 seen_unreachable
= 1;
4953 /* If the case range can be matched, it can also overlap with
4954 other cases. To make sure it does not, we put it in a
4955 double linked list here. We sort that with a merge sort
4956 later on to detect any overlapping cases. */
4960 head
->right
= head
->left
= NULL
;
4965 tail
->right
->left
= tail
;
4972 /* It there was a failure in the previous case label, give up
4973 for this case label list. Continue with the next block. */
4977 /* See if any case labels that are unreachable have been seen.
4978 If so, we eliminate them. This is a bit of a kludge because
4979 the case lists for a single case statement (label) is a
4980 single forward linked lists. */
4981 if (seen_unreachable
)
4983 /* Advance until the first case in the list is reachable. */
4984 while (body
->ext
.case_list
!= NULL
4985 && body
->ext
.case_list
->unreachable
)
4987 gfc_case
*n
= body
->ext
.case_list
;
4988 body
->ext
.case_list
= body
->ext
.case_list
->next
;
4990 gfc_free_case_list (n
);
4993 /* Strip all other unreachable cases. */
4994 if (body
->ext
.case_list
)
4996 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
4998 if (cp
->next
->unreachable
)
5000 gfc_case
*n
= cp
->next
;
5001 cp
->next
= cp
->next
->next
;
5003 gfc_free_case_list (n
);
5010 /* See if there were overlapping cases. If the check returns NULL,
5011 there was overlap. In that case we don't do anything. If head
5012 is non-NULL, we prepend the DEFAULT case. The sorted list can
5013 then used during code generation for SELECT CASE constructs with
5014 a case expression of a CHARACTER type. */
5017 head
= check_case_overlap (head
);
5019 /* Prepend the default_case if it is there. */
5020 if (head
!= NULL
&& default_case
)
5022 default_case
->left
= NULL
;
5023 default_case
->right
= head
;
5024 head
->left
= default_case
;
5028 /* Eliminate dead blocks that may be the result if we've seen
5029 unreachable case labels for a block. */
5030 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5032 if (body
->block
->ext
.case_list
== NULL
)
5034 /* Cut the unreachable block from the code chain. */
5035 gfc_code
*c
= body
->block
;
5036 body
->block
= c
->block
;
5038 /* Kill the dead block, but not the blocks below it. */
5040 gfc_free_statements (c
);
5044 /* More than two cases is legal but insane for logical selects.
5045 Issue a warning for it. */
5046 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5048 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5053 /* Resolve a transfer statement. This is making sure that:
5054 -- a derived type being transferred has only non-pointer components
5055 -- a derived type being transferred doesn't have private components, unless
5056 it's being transferred from the module where the type was defined
5057 -- we're not trying to transfer a whole assumed size array. */
5060 resolve_transfer (gfc_code
*code
)
5069 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5072 sym
= exp
->symtree
->n
.sym
;
5075 /* Go to actual component transferred. */
5076 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5077 if (ref
->type
== REF_COMPONENT
)
5078 ts
= &ref
->u
.c
.component
->ts
;
5080 if (ts
->type
== BT_DERIVED
)
5082 /* Check that transferred derived type doesn't contain POINTER
5084 if (derived_pointer (ts
->derived
))
5086 gfc_error ("Data transfer element at %L cannot have "
5087 "POINTER components", &code
->loc
);
5091 if (ts
->derived
->attr
.alloc_comp
)
5093 gfc_error ("Data transfer element at %L cannot have "
5094 "ALLOCATABLE components", &code
->loc
);
5098 if (derived_inaccessible (ts
->derived
))
5100 gfc_error ("Data transfer element at %L cannot have "
5101 "PRIVATE components",&code
->loc
);
5106 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5107 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5109 gfc_error ("Data transfer element at %L cannot be a full reference to "
5110 "an assumed-size array", &code
->loc
);
5116 /*********** Toplevel code resolution subroutines ***********/
5118 /* Find the set of labels that are reachable from this block. We also
5119 record the last statement in each block so that we don't have to do
5120 a linear search to find the END DO statements of the blocks. */
5123 reachable_labels (gfc_code
*block
)
5130 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5132 /* Collect labels in this block. */
5133 for (c
= block
; c
; c
= c
->next
)
5136 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5138 if (!c
->next
&& cs_base
->prev
)
5139 cs_base
->prev
->tail
= c
;
5142 /* Merge with labels from parent block. */
5145 gcc_assert (cs_base
->prev
->reachable_labels
);
5146 bitmap_ior_into (cs_base
->reachable_labels
,
5147 cs_base
->prev
->reachable_labels
);
5151 /* Given a branch to a label and a namespace, if the branch is conforming.
5152 The code node describes where the branch is located. */
5155 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5162 /* Step one: is this a valid branching target? */
5164 if (label
->defined
== ST_LABEL_UNKNOWN
)
5166 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5171 if (label
->defined
!= ST_LABEL_TARGET
)
5173 gfc_error ("Statement at %L is not a valid branch target statement "
5174 "for the branch statement at %L", &label
->where
, &code
->loc
);
5178 /* Step two: make sure this branch is not a branch to itself ;-) */
5180 if (code
->here
== label
)
5182 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
5186 /* Step three: See if the label is in the same block as the
5187 branching statement. The hard work has been done by setting up
5188 the bitmap reachable_labels. */
5190 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
5192 /* The label is not in an enclosing block, so illegal. This was
5193 allowed in Fortran 66, so we allow it as extension. No
5194 further checks are necessary in this case. */
5195 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
5196 "as the GOTO statement at %L", &label
->where
,
5201 /* Step four: Make sure that the branching target is legal if
5202 the statement is an END {SELECT,IF}. */
5204 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5205 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
5208 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
5210 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
5211 "END of construct at %L", &code
->loc
,
5212 &stack
->current
->next
->loc
);
5213 return; /* We know this is not an END DO. */
5216 /* Step five: Make sure that we're not jumping to the end of a DO
5217 loop from within the loop. */
5219 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5220 if ((stack
->current
->op
== EXEC_DO
5221 || stack
->current
->op
== EXEC_DO_WHILE
)
5222 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
5224 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
5225 "to END of construct at %L", &code
->loc
,
5233 /* Check whether EXPR1 has the same shape as EXPR2. */
5236 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
5238 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5239 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
5240 try result
= FAILURE
;
5243 /* Compare the rank. */
5244 if (expr1
->rank
!= expr2
->rank
)
5247 /* Compare the size of each dimension. */
5248 for (i
=0; i
<expr1
->rank
; i
++)
5250 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
5253 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
5256 if (mpz_cmp (shape
[i
], shape2
[i
]))
5260 /* When either of the two expression is an assumed size array, we
5261 ignore the comparison of dimension sizes. */
5266 for (i
--; i
>= 0; i
--)
5268 mpz_clear (shape
[i
]);
5269 mpz_clear (shape2
[i
]);
5275 /* Check whether a WHERE assignment target or a WHERE mask expression
5276 has the same shape as the outmost WHERE mask expression. */
5279 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
5285 cblock
= code
->block
;
5287 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5288 In case of nested WHERE, only the outmost one is stored. */
5289 if (mask
== NULL
) /* outmost WHERE */
5291 else /* inner WHERE */
5298 /* Check if the mask-expr has a consistent shape with the
5299 outmost WHERE mask-expr. */
5300 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
5301 gfc_error ("WHERE mask at %L has inconsistent shape",
5302 &cblock
->expr
->where
);
5305 /* the assignment statement of a WHERE statement, or the first
5306 statement in where-body-construct of a WHERE construct */
5307 cnext
= cblock
->next
;
5312 /* WHERE assignment statement */
5315 /* Check shape consistent for WHERE assignment target. */
5316 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
5317 gfc_error ("WHERE assignment target at %L has "
5318 "inconsistent shape", &cnext
->expr
->where
);
5322 case EXEC_ASSIGN_CALL
:
5323 resolve_call (cnext
);
5326 /* WHERE or WHERE construct is part of a where-body-construct */
5328 resolve_where (cnext
, e
);
5332 gfc_error ("Unsupported statement inside WHERE at %L",
5335 /* the next statement within the same where-body-construct */
5336 cnext
= cnext
->next
;
5338 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5339 cblock
= cblock
->block
;
5344 /* Check whether the FORALL index appears in the expression or not. */
5347 gfc_find_forall_index (gfc_expr
*expr
, gfc_symbol
*symbol
)
5351 gfc_actual_arglist
*args
;
5354 switch (expr
->expr_type
)
5357 gcc_assert (expr
->symtree
->n
.sym
);
5359 /* A scalar assignment */
5362 if (expr
->symtree
->n
.sym
== symbol
)
5368 /* the expr is array ref, substring or struct component. */
5375 /* Check if the symbol appears in the array subscript. */
5377 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5380 if (gfc_find_forall_index (ar
.start
[i
], symbol
) == SUCCESS
)
5384 if (gfc_find_forall_index (ar
.end
[i
], symbol
) == SUCCESS
)
5388 if (gfc_find_forall_index (ar
.stride
[i
], symbol
) == SUCCESS
)
5394 if (expr
->symtree
->n
.sym
== symbol
)
5397 /* Check if the symbol appears in the substring section. */
5398 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
5400 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
5408 gfc_error("expression reference type error at %L", &expr
->where
);
5414 /* If the expression is a function call, then check if the symbol
5415 appears in the actual arglist of the function. */
5417 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5419 if (gfc_find_forall_index(args
->expr
,symbol
) == SUCCESS
)
5424 /* It seems not to happen. */
5425 case EXPR_SUBSTRING
:
5429 gcc_assert (expr
->ref
->type
== REF_SUBSTRING
);
5430 if (gfc_find_forall_index (tmp
->u
.ss
.start
, symbol
) == SUCCESS
)
5432 if (gfc_find_forall_index (tmp
->u
.ss
.end
, symbol
) == SUCCESS
)
5437 /* It seems not to happen. */
5438 case EXPR_STRUCTURE
:
5440 gfc_error ("Unsupported statement while finding forall index in "
5445 /* Find the FORALL index in the first operand. */
5446 if (expr
->value
.op
.op1
)
5448 if (gfc_find_forall_index (expr
->value
.op
.op1
, symbol
) == SUCCESS
)
5452 /* Find the FORALL index in the second operand. */
5453 if (expr
->value
.op
.op2
)
5455 if (gfc_find_forall_index (expr
->value
.op
.op2
, symbol
) == SUCCESS
)
5468 /* Resolve assignment in FORALL construct.
5469 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5470 FORALL index variables. */
5473 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5477 for (n
= 0; n
< nvar
; n
++)
5479 gfc_symbol
*forall_index
;
5481 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
5483 /* Check whether the assignment target is one of the FORALL index
5485 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
5486 && (code
->expr
->symtree
->n
.sym
== forall_index
))
5487 gfc_error ("Assignment to a FORALL index variable at %L",
5488 &code
->expr
->where
);
5491 /* If one of the FORALL index variables doesn't appear in the
5492 assignment target, then there will be a many-to-one
5494 if (gfc_find_forall_index (code
->expr
, forall_index
) == FAILURE
)
5495 gfc_error ("The FORALL with index '%s' cause more than one "
5496 "assignment to this object at %L",
5497 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
5503 /* Resolve WHERE statement in FORALL construct. */
5506 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
5507 gfc_expr
**var_expr
)
5512 cblock
= code
->block
;
5515 /* the assignment statement of a WHERE statement, or the first
5516 statement in where-body-construct of a WHERE construct */
5517 cnext
= cblock
->next
;
5522 /* WHERE assignment statement */
5524 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
5527 /* WHERE operator assignment statement */
5528 case EXEC_ASSIGN_CALL
:
5529 resolve_call (cnext
);
5532 /* WHERE or WHERE construct is part of a where-body-construct */
5534 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
5538 gfc_error ("Unsupported statement inside WHERE at %L",
5541 /* the next statement within the same where-body-construct */
5542 cnext
= cnext
->next
;
5544 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5545 cblock
= cblock
->block
;
5550 /* Traverse the FORALL body to check whether the following errors exist:
5551 1. For assignment, check if a many-to-one assignment happens.
5552 2. For WHERE statement, check the WHERE body to see if there is any
5553 many-to-one assignment. */
5556 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5560 c
= code
->block
->next
;
5566 case EXEC_POINTER_ASSIGN
:
5567 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
5570 case EXEC_ASSIGN_CALL
:
5574 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5575 there is no need to handle it here. */
5579 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
5584 /* The next statement in the FORALL body. */
5590 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5591 gfc_resolve_forall_body to resolve the FORALL body. */
5594 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
5596 static gfc_expr
**var_expr
;
5597 static int total_var
= 0;
5598 static int nvar
= 0;
5599 gfc_forall_iterator
*fa
;
5600 gfc_symbol
*forall_index
;
5604 /* Start to resolve a FORALL construct */
5605 if (forall_save
== 0)
5607 /* Count the total number of FORALL index in the nested FORALL
5608 construct in order to allocate the VAR_EXPR with proper size. */
5610 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
5612 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5614 next
= next
->block
->next
;
5617 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5618 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
5621 /* The information about FORALL iterator, including FORALL index start, end
5622 and stride. The FORALL index can not appear in start, end or stride. */
5623 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5625 /* Check if any outer FORALL index name is the same as the current
5627 for (i
= 0; i
< nvar
; i
++)
5629 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
5631 gfc_error ("An outer FORALL construct already has an index "
5632 "with this name %L", &fa
->var
->where
);
5636 /* Record the current FORALL index. */
5637 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
5639 forall_index
= fa
->var
->symtree
->n
.sym
;
5641 /* Check if the FORALL index appears in start, end or stride. */
5642 if (gfc_find_forall_index (fa
->start
, forall_index
) == SUCCESS
)
5643 gfc_error ("A FORALL index must not appear in a limit or stride "
5644 "expression in the same FORALL at %L", &fa
->start
->where
);
5645 if (gfc_find_forall_index (fa
->end
, forall_index
) == SUCCESS
)
5646 gfc_error ("A FORALL index must not appear in a limit or stride "
5647 "expression in the same FORALL at %L", &fa
->end
->where
);
5648 if (gfc_find_forall_index (fa
->stride
, forall_index
) == SUCCESS
)
5649 gfc_error ("A FORALL index must not appear in a limit or stride "
5650 "expression in the same FORALL at %L", &fa
->stride
->where
);
5654 /* Resolve the FORALL body. */
5655 gfc_resolve_forall_body (code
, nvar
, var_expr
);
5657 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5658 gfc_resolve_blocks (code
->block
, ns
);
5660 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5661 for (i
= 0; i
< total_var
; i
++)
5662 gfc_free_expr (var_expr
[i
]);
5664 /* Reset the counters. */
5670 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5673 static void resolve_code (gfc_code
*, gfc_namespace
*);
5676 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
5680 for (; b
; b
= b
->block
)
5682 t
= gfc_resolve_expr (b
->expr
);
5683 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
5689 if (t
== SUCCESS
&& b
->expr
!= NULL
5690 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
5691 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5698 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
5699 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5704 resolve_branch (b
->label
, b
);
5716 case EXEC_OMP_ATOMIC
:
5717 case EXEC_OMP_CRITICAL
:
5719 case EXEC_OMP_MASTER
:
5720 case EXEC_OMP_ORDERED
:
5721 case EXEC_OMP_PARALLEL
:
5722 case EXEC_OMP_PARALLEL_DO
:
5723 case EXEC_OMP_PARALLEL_SECTIONS
:
5724 case EXEC_OMP_PARALLEL_WORKSHARE
:
5725 case EXEC_OMP_SECTIONS
:
5726 case EXEC_OMP_SINGLE
:
5727 case EXEC_OMP_WORKSHARE
:
5731 gfc_internal_error ("resolve_block(): Bad block type");
5734 resolve_code (b
->next
, ns
);
5739 static gfc_component
*
5740 has_default_initializer (gfc_symbol
*der
)
5743 for (c
= der
->components
; c
; c
= c
->next
)
5744 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
5745 || (c
->ts
.type
== BT_DERIVED
5747 && has_default_initializer (c
->ts
.derived
)))
5754 /* Given a block of code, recursively resolve everything pointed to by this
5758 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
5760 int omp_workshare_save
;
5766 frame
.prev
= cs_base
;
5770 reachable_labels (code
);
5772 for (; code
; code
= code
->next
)
5774 frame
.current
= code
;
5775 forall_save
= forall_flag
;
5777 if (code
->op
== EXEC_FORALL
)
5780 gfc_resolve_forall (code
, ns
, forall_save
);
5783 else if (code
->block
)
5785 omp_workshare_save
= -1;
5788 case EXEC_OMP_PARALLEL_WORKSHARE
:
5789 omp_workshare_save
= omp_workshare_flag
;
5790 omp_workshare_flag
= 1;
5791 gfc_resolve_omp_parallel_blocks (code
, ns
);
5793 case EXEC_OMP_PARALLEL
:
5794 case EXEC_OMP_PARALLEL_DO
:
5795 case EXEC_OMP_PARALLEL_SECTIONS
:
5796 omp_workshare_save
= omp_workshare_flag
;
5797 omp_workshare_flag
= 0;
5798 gfc_resolve_omp_parallel_blocks (code
, ns
);
5801 gfc_resolve_omp_do_blocks (code
, ns
);
5803 case EXEC_OMP_WORKSHARE
:
5804 omp_workshare_save
= omp_workshare_flag
;
5805 omp_workshare_flag
= 1;
5808 gfc_resolve_blocks (code
->block
, ns
);
5812 if (omp_workshare_save
!= -1)
5813 omp_workshare_flag
= omp_workshare_save
;
5816 t
= gfc_resolve_expr (code
->expr
);
5817 forall_flag
= forall_save
;
5819 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
5834 /* Keep track of which entry we are up to. */
5835 current_entry_id
= code
->ext
.entry
->id
;
5839 resolve_where (code
, NULL
);
5843 if (code
->expr
!= NULL
)
5845 if (code
->expr
->ts
.type
!= BT_INTEGER
)
5846 gfc_error ("ASSIGNED GOTO statement at %L requires an "
5847 "INTEGER variable", &code
->expr
->where
);
5848 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
5849 gfc_error ("Variable '%s' has not been assigned a target "
5850 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
5851 &code
->expr
->where
);
5854 resolve_branch (code
->label
, code
);
5858 if (code
->expr
!= NULL
5859 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
5860 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
5861 "INTEGER return specifier", &code
->expr
->where
);
5864 case EXEC_INIT_ASSIGN
:
5871 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5873 gfc_expr
*lhs
= code
->ext
.actual
->expr
;
5874 gfc_expr
*rhs
= code
->ext
.actual
->next
->expr
;
5876 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5878 gfc_error ("Subroutine '%s' called instead of assignment at "
5879 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5884 /* Make a temporary rhs when there is a default initializer
5885 and rhs is the same symbol as the lhs. */
5886 if (rhs
->expr_type
== EXPR_VARIABLE
5887 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
5888 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
5889 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
5890 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
5895 if (code
->expr
->ts
.type
== BT_CHARACTER
5896 && gfc_option
.warn_character_truncation
)
5898 int llen
= 0, rlen
= 0;
5900 if (code
->expr
->ts
.cl
!= NULL
5901 && code
->expr
->ts
.cl
->length
!= NULL
5902 && code
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5903 llen
= mpz_get_si (code
->expr
->ts
.cl
->length
->value
.integer
);
5905 if (code
->expr2
->expr_type
== EXPR_CONSTANT
)
5906 rlen
= code
->expr2
->value
.character
.length
;
5908 else if (code
->expr2
->ts
.cl
!= NULL
5909 && code
->expr2
->ts
.cl
->length
!= NULL
5910 && code
->expr2
->ts
.cl
->length
->expr_type
5912 rlen
= mpz_get_si (code
->expr2
->ts
.cl
->length
->value
.integer
);
5914 if (rlen
&& llen
&& rlen
> llen
)
5915 gfc_warning_now ("CHARACTER expression will be truncated "
5916 "in assignment (%d/%d) at %L",
5917 llen
, rlen
, &code
->loc
);
5920 if (gfc_pure (NULL
))
5922 if (gfc_impure_variable (code
->expr
->symtree
->n
.sym
))
5924 gfc_error ("Cannot assign to variable '%s' in PURE "
5926 code
->expr
->symtree
->n
.sym
->name
,
5927 &code
->expr
->where
);
5931 if (code
->expr
->ts
.type
== BT_DERIVED
5932 && code
->expr
->expr_type
== EXPR_VARIABLE
5933 && derived_pointer (code
->expr
->ts
.derived
)
5934 && gfc_impure_variable (code
->expr2
->symtree
->n
.sym
))
5936 gfc_error ("The impure variable at %L is assigned to "
5937 "a derived type variable with a POINTER "
5938 "component in a PURE procedure (12.6)",
5939 &code
->expr2
->where
);
5944 gfc_check_assign (code
->expr
, code
->expr2
, 1);
5947 case EXEC_LABEL_ASSIGN
:
5948 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
5949 gfc_error ("Label %d referenced at %L is never defined",
5950 code
->label
->value
, &code
->label
->where
);
5952 && (code
->expr
->expr_type
!= EXPR_VARIABLE
5953 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
5954 || code
->expr
->symtree
->n
.sym
->ts
.kind
5955 != gfc_default_integer_kind
5956 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
5957 gfc_error ("ASSIGN statement at %L requires a scalar "
5958 "default INTEGER variable", &code
->expr
->where
);
5961 case EXEC_POINTER_ASSIGN
:
5965 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
5968 case EXEC_ARITHMETIC_IF
:
5970 && code
->expr
->ts
.type
!= BT_INTEGER
5971 && code
->expr
->ts
.type
!= BT_REAL
)
5972 gfc_error ("Arithmetic IF statement at %L requires a numeric "
5973 "expression", &code
->expr
->where
);
5975 resolve_branch (code
->label
, code
);
5976 resolve_branch (code
->label2
, code
);
5977 resolve_branch (code
->label3
, code
);
5981 if (t
== SUCCESS
&& code
->expr
!= NULL
5982 && (code
->expr
->ts
.type
!= BT_LOGICAL
5983 || code
->expr
->rank
!= 0))
5984 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5985 &code
->expr
->where
);
5990 resolve_call (code
);
5994 /* Select is complicated. Also, a SELECT construct could be
5995 a transformed computed GOTO. */
5996 resolve_select (code
);
6000 if (code
->ext
.iterator
!= NULL
)
6002 gfc_iterator
*iter
= code
->ext
.iterator
;
6003 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6004 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6009 if (code
->expr
== NULL
)
6010 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6012 && (code
->expr
->rank
!= 0
6013 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6014 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6015 "a scalar LOGICAL expression", &code
->expr
->where
);
6019 if (t
== SUCCESS
&& code
->expr
!= NULL
6020 && code
->expr
->ts
.type
!= BT_INTEGER
)
6021 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6022 "of type INTEGER", &code
->expr
->where
);
6024 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6025 resolve_allocate_expr (a
->expr
, code
);
6029 case EXEC_DEALLOCATE
:
6030 if (t
== SUCCESS
&& code
->expr
!= NULL
6031 && code
->expr
->ts
.type
!= BT_INTEGER
)
6033 ("STAT tag in DEALLOCATE statement at %L must be of type "
6034 "INTEGER", &code
->expr
->where
);
6036 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6037 resolve_deallocate_expr (a
->expr
);
6042 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6045 resolve_branch (code
->ext
.open
->err
, code
);
6049 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6052 resolve_branch (code
->ext
.close
->err
, code
);
6055 case EXEC_BACKSPACE
:
6059 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6062 resolve_branch (code
->ext
.filepos
->err
, code
);
6066 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6069 resolve_branch (code
->ext
.inquire
->err
, code
);
6073 gcc_assert (code
->ext
.inquire
!= NULL
);
6074 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6077 resolve_branch (code
->ext
.inquire
->err
, code
);
6082 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6085 resolve_branch (code
->ext
.dt
->err
, code
);
6086 resolve_branch (code
->ext
.dt
->end
, code
);
6087 resolve_branch (code
->ext
.dt
->eor
, code
);
6091 resolve_transfer (code
);
6095 resolve_forall_iterators (code
->ext
.forall_iterator
);
6097 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6098 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6099 "expression", &code
->expr
->where
);
6102 case EXEC_OMP_ATOMIC
:
6103 case EXEC_OMP_BARRIER
:
6104 case EXEC_OMP_CRITICAL
:
6105 case EXEC_OMP_FLUSH
:
6107 case EXEC_OMP_MASTER
:
6108 case EXEC_OMP_ORDERED
:
6109 case EXEC_OMP_SECTIONS
:
6110 case EXEC_OMP_SINGLE
:
6111 case EXEC_OMP_WORKSHARE
:
6112 gfc_resolve_omp_directive (code
, ns
);
6115 case EXEC_OMP_PARALLEL
:
6116 case EXEC_OMP_PARALLEL_DO
:
6117 case EXEC_OMP_PARALLEL_SECTIONS
:
6118 case EXEC_OMP_PARALLEL_WORKSHARE
:
6119 omp_workshare_save
= omp_workshare_flag
;
6120 omp_workshare_flag
= 0;
6121 gfc_resolve_omp_directive (code
, ns
);
6122 omp_workshare_flag
= omp_workshare_save
;
6126 gfc_internal_error ("resolve_code(): Bad statement code");
6130 cs_base
= frame
.prev
;
6134 /* Resolve initial values and make sure they are compatible with
6138 resolve_values (gfc_symbol
*sym
)
6140 if (sym
->value
== NULL
)
6143 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6146 gfc_check_assign_symbol (sym
, sym
->value
);
6150 /* Verify the binding labels for common blocks that are BIND(C). The label
6151 for a BIND(C) common block must be identical in all scoping units in which
6152 the common block is declared. Further, the binding label can not collide
6153 with any other global entity in the program. */
6156 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6158 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6160 gfc_gsymbol
*binding_label_gsym
;
6161 gfc_gsymbol
*comm_name_gsym
;
6163 /* See if a global symbol exists by the common block's name. It may
6164 be NULL if the common block is use-associated. */
6165 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6166 comm_block_tree
->n
.common
->name
);
6167 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6168 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6169 "with the global entity '%s' at %L",
6170 comm_block_tree
->n
.common
->binding_label
,
6171 comm_block_tree
->n
.common
->name
,
6172 &(comm_block_tree
->n
.common
->where
),
6173 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6174 else if (comm_name_gsym
!= NULL
6175 && strcmp (comm_name_gsym
->name
,
6176 comm_block_tree
->n
.common
->name
) == 0)
6178 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6180 if (comm_name_gsym
->binding_label
== NULL
)
6181 /* No binding label for common block stored yet; save this one. */
6182 comm_name_gsym
->binding_label
=
6183 comm_block_tree
->n
.common
->binding_label
;
6185 if (strcmp (comm_name_gsym
->binding_label
,
6186 comm_block_tree
->n
.common
->binding_label
) != 0)
6188 /* Common block names match but binding labels do not. */
6189 gfc_error ("Binding label '%s' for common block '%s' at %L "
6190 "does not match the binding label '%s' for common "
6192 comm_block_tree
->n
.common
->binding_label
,
6193 comm_block_tree
->n
.common
->name
,
6194 &(comm_block_tree
->n
.common
->where
),
6195 comm_name_gsym
->binding_label
,
6196 comm_name_gsym
->name
,
6197 &(comm_name_gsym
->where
));
6202 /* There is no binding label (NAME="") so we have nothing further to
6203 check and nothing to add as a global symbol for the label. */
6204 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6207 binding_label_gsym
=
6208 gfc_find_gsymbol (gfc_gsym_root
,
6209 comm_block_tree
->n
.common
->binding_label
);
6210 if (binding_label_gsym
== NULL
)
6212 /* Need to make a global symbol for the binding label to prevent
6213 it from colliding with another. */
6214 binding_label_gsym
=
6215 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
6216 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
6217 binding_label_gsym
->type
= GSYM_COMMON
;
6221 /* If comm_name_gsym is NULL, the name common block is use
6222 associated and the name could be colliding. */
6223 if (binding_label_gsym
->type
!= GSYM_COMMON
)
6224 gfc_error ("Binding label '%s' for common block '%s' at %L "
6225 "collides with the global entity '%s' at %L",
6226 comm_block_tree
->n
.common
->binding_label
,
6227 comm_block_tree
->n
.common
->name
,
6228 &(comm_block_tree
->n
.common
->where
),
6229 binding_label_gsym
->name
,
6230 &(binding_label_gsym
->where
));
6231 else if (comm_name_gsym
!= NULL
6232 && (strcmp (binding_label_gsym
->name
,
6233 comm_name_gsym
->binding_label
) != 0)
6234 && (strcmp (binding_label_gsym
->sym_name
,
6235 comm_name_gsym
->name
) != 0))
6236 gfc_error ("Binding label '%s' for common block '%s' at %L "
6237 "collides with global entity '%s' at %L",
6238 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
6239 &(comm_block_tree
->n
.common
->where
),
6240 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6248 /* Verify any BIND(C) derived types in the namespace so we can report errors
6249 for them once, rather than for each variable declared of that type. */
6252 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
6254 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
6255 && derived_sym
->attr
.is_bind_c
== 1)
6256 verify_bind_c_derived_type (derived_sym
);
6262 /* Verify that any binding labels used in a given namespace do not collide
6263 with the names or binding labels of any global symbols. */
6266 gfc_verify_binding_labels (gfc_symbol
*sym
)
6270 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
6271 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
6273 gfc_gsymbol
*bind_c_sym
;
6275 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
6276 if (bind_c_sym
!= NULL
6277 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
6279 if (sym
->attr
.if_source
== IFSRC_DECL
6280 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
6281 && bind_c_sym
->type
!= GSYM_FUNCTION
)
6282 && ((sym
->attr
.contained
== 1
6283 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
6284 || (sym
->attr
.use_assoc
== 1
6285 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
6287 /* Make sure global procedures don't collide with anything. */
6288 gfc_error ("Binding label '%s' at %L collides with the global "
6289 "entity '%s' at %L", sym
->binding_label
,
6290 &(sym
->declared_at
), bind_c_sym
->name
,
6291 &(bind_c_sym
->where
));
6294 else if (sym
->attr
.contained
== 0
6295 && (sym
->attr
.if_source
== IFSRC_IFBODY
6296 && sym
->attr
.flavor
== FL_PROCEDURE
)
6297 && (bind_c_sym
->sym_name
!= NULL
6298 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
6300 /* Make sure procedures in interface bodies don't collide. */
6301 gfc_error ("Binding label '%s' in interface body at %L collides "
6302 "with the global entity '%s' at %L",
6304 &(sym
->declared_at
), bind_c_sym
->name
,
6305 &(bind_c_sym
->where
));
6308 else if (sym
->attr
.contained
== 0
6309 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
))
6310 if ((sym
->attr
.use_assoc
6311 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))
6312 || sym
->attr
.use_assoc
== 0)
6314 gfc_error ("Binding label '%s' at %L collides with global "
6315 "entity '%s' at %L", sym
->binding_label
,
6316 &(sym
->declared_at
), bind_c_sym
->name
,
6317 &(bind_c_sym
->where
));
6322 /* Clear the binding label to prevent checking multiple times. */
6323 sym
->binding_label
[0] = '\0';
6325 else if (bind_c_sym
== NULL
)
6327 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
6328 bind_c_sym
->where
= sym
->declared_at
;
6329 bind_c_sym
->sym_name
= sym
->name
;
6331 if (sym
->attr
.use_assoc
== 1)
6332 bind_c_sym
->mod_name
= sym
->module
;
6334 if (sym
->ns
->proc_name
!= NULL
)
6335 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
6337 if (sym
->attr
.contained
== 0)
6339 if (sym
->attr
.subroutine
)
6340 bind_c_sym
->type
= GSYM_SUBROUTINE
;
6341 else if (sym
->attr
.function
)
6342 bind_c_sym
->type
= GSYM_FUNCTION
;
6350 /* Resolve an index expression. */
6353 resolve_index_expr (gfc_expr
*e
)
6355 if (gfc_resolve_expr (e
) == FAILURE
)
6358 if (gfc_simplify_expr (e
, 0) == FAILURE
)
6361 if (gfc_specification_expr (e
) == FAILURE
)
6367 /* Resolve a charlen structure. */
6370 resolve_charlen (gfc_charlen
*cl
)
6379 specification_expr
= 1;
6381 if (resolve_index_expr (cl
->length
) == FAILURE
)
6383 specification_expr
= 0;
6387 /* "If the character length parameter value evaluates to a negative
6388 value, the length of character entities declared is zero." */
6389 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
<= 0)
6391 gfc_warning_now ("CHARACTER variable has zero length at %L",
6392 &cl
->length
->where
);
6393 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
6400 /* Test for non-constant shape arrays. */
6403 is_non_constant_shape_array (gfc_symbol
*sym
)
6409 not_constant
= false;
6410 if (sym
->as
!= NULL
)
6412 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6413 has not been simplified; parameter array references. Do the
6414 simplification now. */
6415 for (i
= 0; i
< sym
->as
->rank
; i
++)
6417 e
= sym
->as
->lower
[i
];
6418 if (e
&& (resolve_index_expr (e
) == FAILURE
6419 || !gfc_is_constant_expr (e
)))
6420 not_constant
= true;
6422 e
= sym
->as
->upper
[i
];
6423 if (e
&& (resolve_index_expr (e
) == FAILURE
6424 || !gfc_is_constant_expr (e
)))
6425 not_constant
= true;
6428 return not_constant
;
6432 /* Assign the default initializer to a derived type variable or result. */
6435 apply_default_init (gfc_symbol
*sym
)
6438 gfc_expr
*init
= NULL
;
6440 gfc_namespace
*ns
= sym
->ns
;
6442 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6445 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
6446 init
= gfc_default_initializer (&sym
->ts
);
6451 /* Search for the function namespace if this is a contained
6452 function without an explicit result. */
6453 if (sym
->attr
.function
&& sym
== sym
->result
6454 && sym
->name
!= sym
->ns
->proc_name
->name
)
6457 for (;ns
; ns
= ns
->sibling
)
6458 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
6464 gfc_free_expr (init
);
6468 /* Build an l-value expression for the result. */
6469 lval
= gfc_lval_expr_from_sym (sym
);
6471 /* Add the code at scope entry. */
6472 init_st
= gfc_get_code ();
6473 init_st
->next
= ns
->code
;
6476 /* Assign the default initializer to the l-value. */
6477 init_st
->loc
= sym
->declared_at
;
6478 init_st
->op
= EXEC_INIT_ASSIGN
;
6479 init_st
->expr
= lval
;
6480 init_st
->expr2
= init
;
6484 /* Resolution of common features of flavors variable and procedure. */
6487 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
6489 /* Constraints on deferred shape variable. */
6490 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
6492 if (sym
->attr
.allocatable
)
6494 if (sym
->attr
.dimension
)
6495 gfc_error ("Allocatable array '%s' at %L must have "
6496 "a deferred shape", sym
->name
, &sym
->declared_at
);
6498 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6499 sym
->name
, &sym
->declared_at
);
6503 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
6505 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6506 sym
->name
, &sym
->declared_at
);
6513 if (!mp_flag
&& !sym
->attr
.allocatable
6514 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
6516 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6517 sym
->name
, &sym
->declared_at
);
6525 /* Resolve symbols with flavor variable. */
6528 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
6534 const char *auto_save_msg
;
6536 auto_save_msg
= "automatic object '%s' at %L cannot have the "
6539 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
6542 /* Set this flag to check that variables are parameters of all entries.
6543 This check is effected by the call to gfc_resolve_expr through
6544 is_non_constant_shape_array. */
6545 specification_expr
= 1;
6547 if (!sym
->attr
.use_assoc
6548 && !sym
->attr
.allocatable
6549 && !sym
->attr
.pointer
6550 && is_non_constant_shape_array (sym
))
6552 /* The shape of a main program or module array needs to be
6554 if (sym
->ns
->proc_name
6555 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6556 || sym
->ns
->proc_name
->attr
.is_main_program
))
6558 gfc_error ("The module or main program array '%s' at %L must "
6559 "have constant shape", sym
->name
, &sym
->declared_at
);
6560 specification_expr
= 0;
6565 if (sym
->ts
.type
== BT_CHARACTER
)
6567 /* Make sure that character string variables with assumed length are
6569 e
= sym
->ts
.cl
->length
;
6570 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
6572 gfc_error ("Entity with assumed character length at %L must be a "
6573 "dummy argument or a PARAMETER", &sym
->declared_at
);
6577 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
6579 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
6583 if (!gfc_is_constant_expr (e
)
6584 && !(e
->expr_type
== EXPR_VARIABLE
6585 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
6586 && sym
->ns
->proc_name
6587 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6588 || sym
->ns
->proc_name
->attr
.is_main_program
)
6589 && !sym
->attr
.use_assoc
)
6591 gfc_error ("'%s' at %L must have constant character length "
6592 "in this context", sym
->name
, &sym
->declared_at
);
6597 /* Can the symbol have an initializer? */
6599 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
6600 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
6602 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
)
6604 /* Don't allow initialization of automatic arrays. */
6605 for (i
= 0; i
< sym
->as
->rank
; i
++)
6607 if (sym
->as
->lower
[i
] == NULL
6608 || sym
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
6609 || sym
->as
->upper
[i
] == NULL
6610 || sym
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
)
6617 /* Also, they must not have the SAVE attribute.
6618 SAVE_IMPLICIT is checked below. */
6619 if (flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
6621 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
6626 /* Reject illegal initializers. */
6627 if (!sym
->mark
&& sym
->value
&& flag
)
6629 if (sym
->attr
.allocatable
)
6630 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
6631 sym
->name
, &sym
->declared_at
);
6632 else if (sym
->attr
.external
)
6633 gfc_error ("External '%s' at %L cannot have an initializer",
6634 sym
->name
, &sym
->declared_at
);
6635 else if (sym
->attr
.dummy
6636 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
6637 gfc_error ("Dummy '%s' at %L cannot have an initializer",
6638 sym
->name
, &sym
->declared_at
);
6639 else if (sym
->attr
.intrinsic
)
6640 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
6641 sym
->name
, &sym
->declared_at
);
6642 else if (sym
->attr
.result
)
6643 gfc_error ("Function result '%s' at %L cannot have an initializer",
6644 sym
->name
, &sym
->declared_at
);
6646 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
6647 sym
->name
, &sym
->declared_at
);
6654 /* Check to see if a derived type is blocked from being host associated
6655 by the presence of another class I symbol in the same namespace.
6656 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
6657 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ns
!= sym
->ts
.derived
->ns
6658 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
6661 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
6662 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
6663 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
6665 gfc_error ("The type %s cannot be host associated at %L because "
6666 "it is blocked by an incompatible object of the same "
6667 "name at %L", sym
->ts
.derived
->name
, &sym
->declared_at
,
6673 /* Do not use gfc_default_initializer to test for a default initializer
6674 in the fortran because it generates a hidden default for allocatable
6677 if (sym
->ts
.type
== BT_DERIVED
&& !(sym
->value
|| flag
))
6678 c
= has_default_initializer (sym
->ts
.derived
);
6680 /* 4th constraint in section 11.3: "If an object of a type for which
6681 component-initialization is specified (R429) appears in the
6682 specification-part of a module and does not have the ALLOCATABLE
6683 or POINTER attribute, the object shall have the SAVE attribute." */
6684 if (c
&& sym
->ns
->proc_name
6685 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
6686 && !sym
->ns
->save_all
&& !sym
->attr
.save
6687 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
6689 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
6690 sym
->name
, &sym
->declared_at
,
6691 "for default initialization of a component");
6695 /* Assign default initializer. */
6696 if (sym
->ts
.type
== BT_DERIVED
6698 && !sym
->attr
.pointer
6699 && !sym
->attr
.allocatable
6700 && (!flag
|| sym
->attr
.intent
== INTENT_OUT
))
6701 sym
->value
= gfc_default_initializer (&sym
->ts
);
6707 /* Resolve a procedure. */
6710 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
6712 gfc_formal_arglist
*arg
;
6714 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
6715 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
6716 "interfaces", sym
->name
, &sym
->declared_at
);
6718 if (sym
->attr
.function
6719 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
6722 if (sym
->ts
.type
== BT_CHARACTER
)
6724 gfc_charlen
*cl
= sym
->ts
.cl
;
6726 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
6727 && resolve_charlen (cl
) == FAILURE
)
6730 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
6732 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6734 gfc_error ("Character-valued statement function '%s' at %L must "
6735 "have constant length", sym
->name
, &sym
->declared_at
);
6739 if (sym
->attr
.external
&& sym
->formal
== NULL
6740 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
6742 gfc_error ("Automatic character length function '%s' at %L must "
6743 "have an explicit interface", sym
->name
,
6750 /* Ensure that derived type for are not of a private type. Internal
6751 module procedures are excluded by 2.2.3.3 - ie. they are not
6752 externally accessible and can access all the objects accessible in
6754 if (!(sym
->ns
->parent
6755 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
6756 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
6758 gfc_interface
*iface
;
6760 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
6763 && arg
->sym
->ts
.type
== BT_DERIVED
6764 && !arg
->sym
->ts
.derived
->attr
.use_assoc
6765 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
6766 arg
->sym
->ts
.derived
->ns
->default_access
))
6768 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
6769 "a dummy argument of '%s', which is "
6770 "PUBLIC at %L", arg
->sym
->name
, sym
->name
,
6772 /* Stop this message from recurring. */
6773 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
6778 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6779 PRIVATE to the containing module. */
6780 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
6782 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
6785 && arg
->sym
->ts
.type
== BT_DERIVED
6786 && !arg
->sym
->ts
.derived
->attr
.use_assoc
6787 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
6788 arg
->sym
->ts
.derived
->ns
->default_access
))
6790 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6791 "dummy arguments of '%s' which is PRIVATE",
6792 iface
->sym
->name
, sym
->name
, &iface
->sym
->declared_at
,
6793 gfc_typename(&arg
->sym
->ts
));
6794 /* Stop this message from recurring. */
6795 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
6801 /* PUBLIC interfaces may expose PRIVATE procedures that take types
6802 PRIVATE to the containing module. */
6803 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
6805 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
6808 && arg
->sym
->ts
.type
== BT_DERIVED
6809 && !arg
->sym
->ts
.derived
->attr
.use_assoc
6810 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
6811 arg
->sym
->ts
.derived
->ns
->default_access
))
6813 gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
6814 "dummy arguments of '%s' which is PRIVATE",
6815 iface
->sym
->name
, sym
->name
, &iface
->sym
->declared_at
,
6816 gfc_typename(&arg
->sym
->ts
));
6817 /* Stop this message from recurring. */
6818 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
6825 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
)
6827 gfc_error ("Function '%s' at %L cannot have an initializer",
6828 sym
->name
, &sym
->declared_at
);
6832 /* An external symbol may not have an initializer because it is taken to be
6834 if (sym
->attr
.external
&& sym
->value
)
6836 gfc_error ("External object '%s' at %L may not have an initializer",
6837 sym
->name
, &sym
->declared_at
);
6841 /* An elemental function is required to return a scalar 12.7.1 */
6842 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
6844 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
6845 "result", sym
->name
, &sym
->declared_at
);
6846 /* Reset so that the error only occurs once. */
6847 sym
->attr
.elemental
= 0;
6851 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
6852 char-len-param shall not be array-valued, pointer-valued, recursive
6853 or pure. ....snip... A character value of * may only be used in the
6854 following ways: (i) Dummy arg of procedure - dummy associates with
6855 actual length; (ii) To declare a named constant; or (iii) External
6856 function - but length must be declared in calling scoping unit. */
6857 if (sym
->attr
.function
6858 && sym
->ts
.type
== BT_CHARACTER
6859 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
6861 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
6862 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
6864 if (sym
->as
&& sym
->as
->rank
)
6865 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6866 "array-valued", sym
->name
, &sym
->declared_at
);
6868 if (sym
->attr
.pointer
)
6869 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6870 "pointer-valued", sym
->name
, &sym
->declared_at
);
6873 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6874 "pure", sym
->name
, &sym
->declared_at
);
6876 if (sym
->attr
.recursive
)
6877 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
6878 "recursive", sym
->name
, &sym
->declared_at
);
6883 /* Appendix B.2 of the standard. Contained functions give an
6884 error anyway. Fixed-form is likely to be F77/legacy. */
6885 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
6886 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
6887 "'%s' at %L is obsolescent in fortran 95",
6888 sym
->name
, &sym
->declared_at
);
6891 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
6893 gfc_formal_arglist
*curr_arg
;
6894 int has_non_interop_arg
= 0;
6896 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
6897 sym
->common_block
) == FAILURE
)
6899 /* Clear these to prevent looking at them again if there was an
6901 sym
->attr
.is_bind_c
= 0;
6902 sym
->attr
.is_c_interop
= 0;
6903 sym
->ts
.is_c_interop
= 0;
6907 /* So far, no errors have been found. */
6908 sym
->attr
.is_c_interop
= 1;
6909 sym
->ts
.is_c_interop
= 1;
6912 curr_arg
= sym
->formal
;
6913 while (curr_arg
!= NULL
)
6915 /* Skip implicitly typed dummy args here. */
6916 if (curr_arg
->sym
->attr
.implicit_type
== 0)
6917 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
6918 /* If something is found to fail, record the fact so we
6919 can mark the symbol for the procedure as not being
6920 BIND(C) to try and prevent multiple errors being
6922 has_non_interop_arg
= 1;
6924 curr_arg
= curr_arg
->next
;
6927 /* See if any of the arguments were not interoperable and if so, clear
6928 the procedure symbol to prevent duplicate error messages. */
6929 if (has_non_interop_arg
!= 0)
6931 sym
->attr
.is_c_interop
= 0;
6932 sym
->ts
.is_c_interop
= 0;
6933 sym
->attr
.is_bind_c
= 0;
6941 /* Resolve the components of a derived type. */
6944 resolve_fl_derived (gfc_symbol
*sym
)
6947 gfc_dt_list
* dt_list
;
6950 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
6952 if (c
->ts
.type
== BT_CHARACTER
)
6954 if (c
->ts
.cl
->length
== NULL
6955 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
6956 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
6958 gfc_error ("Character length of component '%s' needs to "
6959 "be a constant specification expression at %L",
6961 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
6966 if (c
->ts
.type
== BT_DERIVED
6967 && sym
->component_access
!= ACCESS_PRIVATE
6968 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
6969 && !c
->ts
.derived
->attr
.use_assoc
6970 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
6971 c
->ts
.derived
->ns
->default_access
))
6973 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
6974 "a component of '%s', which is PUBLIC at %L",
6975 c
->name
, sym
->name
, &sym
->declared_at
);
6979 if (sym
->attr
.sequence
)
6981 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
6983 gfc_error ("Component %s of SEQUENCE type declared at %L does "
6984 "not have the SEQUENCE attribute",
6985 c
->ts
.derived
->name
, &sym
->declared_at
);
6990 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
6991 && c
->ts
.derived
->components
== NULL
)
6993 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
6994 "that has not been declared", c
->name
, sym
->name
,
6999 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
7002 for (i
= 0; i
< c
->as
->rank
; i
++)
7004 if (c
->as
->lower
[i
] == NULL
7005 || !gfc_is_constant_expr (c
->as
->lower
[i
])
7006 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
7007 || c
->as
->upper
[i
] == NULL
7008 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
7009 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
7011 gfc_error ("Component '%s' of '%s' at %L must have "
7012 "constant array bounds",
7013 c
->name
, sym
->name
, &c
->loc
);
7019 /* Add derived type to the derived type list. */
7020 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
7021 if (sym
== dt_list
->derived
)
7024 if (dt_list
== NULL
)
7026 dt_list
= gfc_get_dt_list ();
7027 dt_list
->next
= gfc_derived_types
;
7028 dt_list
->derived
= sym
;
7029 gfc_derived_types
= dt_list
;
7037 resolve_fl_namelist (gfc_symbol
*sym
)
7042 /* Reject PRIVATE objects in a PUBLIC namelist. */
7043 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7045 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7047 if (nl
->sym
->attr
.use_assoc
7048 || (sym
->ns
->parent
== nl
->sym
->ns
)
7050 && sym
->ns
->parent
->parent
== nl
->sym
->ns
))
7053 if (!gfc_check_access(nl
->sym
->attr
.access
,
7054 nl
->sym
->ns
->default_access
))
7056 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7057 "cannot be member of PUBLIC namelist '%s' at %L",
7058 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7062 if (nl
->sym
->ts
.type
== BT_DERIVED
7063 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
7064 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
7065 nl
->sym
->ns
->default_access
))
7067 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7068 "cannot be a member of PUBLIC namelist '%s' at %L",
7069 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7075 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7077 /* Reject namelist arrays of assumed shape. */
7078 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
7079 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
7080 "must not have assumed shape in namelist "
7081 "'%s' at %L", nl
->sym
->name
, sym
->name
,
7082 &sym
->declared_at
) == FAILURE
)
7085 /* Reject namelist arrays that are not constant shape. */
7086 if (is_non_constant_shape_array (nl
->sym
))
7088 gfc_error ("NAMELIST array object '%s' must have constant "
7089 "shape in namelist '%s' at %L", nl
->sym
->name
,
7090 sym
->name
, &sym
->declared_at
);
7094 /* Namelist objects cannot have allocatable or pointer components. */
7095 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
7098 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
7100 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7101 "have ALLOCATABLE components",
7102 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7106 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
7108 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7109 "have POINTER components",
7110 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7116 /* 14.1.2 A module or internal procedure represent local entities
7117 of the same type as a namelist member and so are not allowed. */
7118 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7120 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
7123 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
7124 if ((nl
->sym
== sym
->ns
->proc_name
)
7126 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
7130 if (nl
->sym
&& nl
->sym
->name
)
7131 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
7132 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
7134 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7135 "attribute in '%s' at %L", nlsym
->name
,
7146 resolve_fl_parameter (gfc_symbol
*sym
)
7148 /* A parameter array's shape needs to be constant. */
7150 && (sym
->as
->type
== AS_DEFERRED
7151 || is_non_constant_shape_array (sym
)))
7153 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7154 "or of deferred shape", sym
->name
, &sym
->declared_at
);
7158 /* Make sure a parameter that has been implicitly typed still
7159 matches the implicit type, since PARAMETER statements can precede
7160 IMPLICIT statements. */
7161 if (sym
->attr
.implicit_type
7162 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
7164 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7165 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
7169 /* Make sure the types of derived parameters are consistent. This
7170 type checking is deferred until resolution because the type may
7171 refer to a derived type from the host. */
7172 if (sym
->ts
.type
== BT_DERIVED
7173 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
7175 gfc_error ("Incompatible derived type in PARAMETER at %L",
7176 &sym
->value
->where
);
7183 /* Do anything necessary to resolve a symbol. Right now, we just
7184 assume that an otherwise unknown symbol is a variable. This sort
7185 of thing commonly happens for symbols in module. */
7188 resolve_symbol (gfc_symbol
*sym
)
7190 int check_constant
, mp_flag
;
7191 gfc_symtree
*symtree
;
7192 gfc_symtree
*this_symtree
;
7196 if (sym
->attr
.flavor
== FL_UNKNOWN
)
7199 /* If we find that a flavorless symbol is an interface in one of the
7200 parent namespaces, find its symtree in this namespace, free the
7201 symbol and set the symtree to point to the interface symbol. */
7202 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
7204 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
7205 if (symtree
&& symtree
->n
.sym
->generic
)
7207 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
7211 gfc_free_symbol (sym
);
7212 symtree
->n
.sym
->refs
++;
7213 this_symtree
->n
.sym
= symtree
->n
.sym
;
7218 /* Otherwise give it a flavor according to such attributes as
7220 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
7221 sym
->attr
.flavor
= FL_VARIABLE
;
7224 sym
->attr
.flavor
= FL_PROCEDURE
;
7225 if (sym
->attr
.dimension
)
7226 sym
->attr
.function
= 1;
7230 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
7233 /* Symbols that are module procedures with results (functions) have
7234 the types and array specification copied for type checking in
7235 procedures that call them, as well as for saving to a module
7236 file. These symbols can't stand the scrutiny that their results
7238 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
7241 /* Make sure that the intrinsic is consistent with its internal
7242 representation. This needs to be done before assigning a default
7243 type to avoid spurious warnings. */
7244 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
7246 if (gfc_intrinsic_name (sym
->name
, 0))
7248 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
7249 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7250 sym
->name
, &sym
->declared_at
);
7252 else if (gfc_intrinsic_name (sym
->name
, 1))
7254 if (sym
->ts
.type
!= BT_UNKNOWN
)
7256 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7257 sym
->name
, &sym
->declared_at
);
7263 gfc_error ("Intrinsic '%s' at %L does not exist", sym
->name
, &sym
->declared_at
);
7268 /* Assign default type to symbols that need one and don't have one. */
7269 if (sym
->ts
.type
== BT_UNKNOWN
)
7271 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
7272 gfc_set_default_type (sym
, 1, NULL
);
7274 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
7276 /* The specific case of an external procedure should emit an error
7277 in the case that there is no implicit type. */
7279 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
7282 /* Result may be in another namespace. */
7283 resolve_symbol (sym
->result
);
7285 sym
->ts
= sym
->result
->ts
;
7286 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
7287 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
7288 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
7289 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
7294 /* Assumed size arrays and assumed shape arrays must be dummy
7298 && (sym
->as
->type
== AS_ASSUMED_SIZE
7299 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
7300 && sym
->attr
.dummy
== 0)
7302 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
7303 gfc_error ("Assumed size array at %L must be a dummy argument",
7306 gfc_error ("Assumed shape array at %L must be a dummy argument",
7311 /* Make sure symbols with known intent or optional are really dummy
7312 variable. Because of ENTRY statement, this has to be deferred
7313 until resolution time. */
7315 if (!sym
->attr
.dummy
7316 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
7318 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
7322 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
7324 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7325 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
7329 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
7331 gfc_charlen
*cl
= sym
->ts
.cl
;
7332 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7334 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7335 "attribute must have constant length",
7336 sym
->name
, &sym
->declared_at
);
7340 if (sym
->ts
.is_c_interop
7341 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
7343 gfc_error ("C interoperable character dummy variable '%s' at %L "
7344 "with VALUE attribute must have length one",
7345 sym
->name
, &sym
->declared_at
);
7350 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7351 do this for something that was implicitly typed because that is handled
7352 in gfc_set_default_type. Handle dummy arguments and procedure
7353 definitions separately. Also, anything that is use associated is not
7354 handled here but instead is handled in the module it is declared in.
7355 Finally, derived type definitions are allowed to be BIND(C) since that
7356 only implies that they're interoperable, and they are checked fully for
7357 interoperability when a variable is declared of that type. */
7358 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
7359 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
7360 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
7364 /* First, make sure the variable is declared at the
7365 module-level scope (J3/04-007, Section 15.3). */
7366 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
7367 sym
->attr
.in_common
== 0)
7369 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7370 "is neither a COMMON block nor declared at the "
7371 "module level scope", sym
->name
, &(sym
->declared_at
));
7374 else if (sym
->common_head
!= NULL
)
7376 t
= verify_com_block_vars_c_interop (sym
->common_head
);
7380 /* If type() declaration, we need to verify that the components
7381 of the given type are all C interoperable, etc. */
7382 if (sym
->ts
.type
== BT_DERIVED
&&
7383 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
7385 /* Make sure the user marked the derived type as BIND(C). If
7386 not, call the verify routine. This could print an error
7387 for the derived type more than once if multiple variables
7388 of that type are declared. */
7389 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
7390 verify_bind_c_derived_type (sym
->ts
.derived
);
7394 /* Verify the variable itself as C interoperable if it
7395 is BIND(C). It is not possible for this to succeed if
7396 the verify_bind_c_derived_type failed, so don't have to handle
7397 any error returned by verify_bind_c_derived_type. */
7398 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7404 /* clear the is_bind_c flag to prevent reporting errors more than
7405 once if something failed. */
7406 sym
->attr
.is_bind_c
= 0;
7411 /* If a derived type symbol has reached this point, without its
7412 type being declared, we have an error. Notice that most
7413 conditions that produce undefined derived types have already
7414 been dealt with. However, the likes of:
7415 implicit type(t) (t) ..... call foo (t) will get us here if
7416 the type is not declared in the scope of the implicit
7417 statement. Change the type to BT_UNKNOWN, both because it is so
7418 and to prevent an ICE. */
7419 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
)
7421 gfc_error ("The derived type '%s' at %L is of type '%s', "
7422 "which has not been defined", sym
->name
,
7423 &sym
->declared_at
, sym
->ts
.derived
->name
);
7424 sym
->ts
.type
= BT_UNKNOWN
;
7428 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7429 default initialization is defined (5.1.2.4.4). */
7430 if (sym
->ts
.type
== BT_DERIVED
7432 && sym
->attr
.intent
== INTENT_OUT
7434 && sym
->as
->type
== AS_ASSUMED_SIZE
)
7436 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
7440 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7441 "ASSUMED SIZE and so cannot have a default initializer",
7442 sym
->name
, &sym
->declared_at
);
7448 switch (sym
->attr
.flavor
)
7451 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
7456 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
7461 if (resolve_fl_namelist (sym
) == FAILURE
)
7466 if (resolve_fl_parameter (sym
) == FAILURE
)
7474 /* Resolve array specifier. Check as well some constraints
7475 on COMMON blocks. */
7477 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
7479 /* Set the formal_arg_flag so that check_conflict will not throw
7480 an error for host associated variables in the specification
7481 expression for an array_valued function. */
7482 if (sym
->attr
.function
&& sym
->as
)
7483 formal_arg_flag
= 1;
7485 gfc_resolve_array_spec (sym
->as
, check_constant
);
7487 formal_arg_flag
= 0;
7489 /* Resolve formal namespaces. */
7490 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
7491 gfc_resolve (sym
->formal_ns
);
7493 /* Check threadprivate restrictions. */
7494 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
7495 && (!sym
->attr
.in_common
7496 && sym
->module
== NULL
7497 && (sym
->ns
->proc_name
== NULL
7498 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
7499 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
7501 /* If we have come this far we can apply default-initializers, as
7502 described in 14.7.5, to those variables that have not already
7503 been assigned one. */
7504 if (sym
->ts
.type
== BT_DERIVED
7505 && sym
->attr
.referenced
7506 && sym
->ns
== gfc_current_ns
7508 && !sym
->attr
.allocatable
7509 && !sym
->attr
.alloc_comp
)
7511 symbol_attribute
*a
= &sym
->attr
;
7513 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
7514 && !a
->in_common
&& !a
->use_assoc
7515 && !(a
->function
&& sym
!= sym
->result
))
7516 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
7517 apply_default_init (sym
);
7522 /************* Resolve DATA statements *************/
7526 gfc_data_value
*vnode
;
7532 /* Advance the values structure to point to the next value in the data list. */
7535 next_data_value (void)
7537 while (values
.left
== 0)
7539 if (values
.vnode
->next
== NULL
)
7542 values
.vnode
= values
.vnode
->next
;
7543 values
.left
= values
.vnode
->repeat
;
7551 check_data_variable (gfc_data_variable
*var
, locus
*where
)
7557 ar_type mark
= AR_UNKNOWN
;
7559 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
7563 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
7567 mpz_init_set_si (offset
, 0);
7570 if (e
->expr_type
!= EXPR_VARIABLE
)
7571 gfc_internal_error ("check_data_variable(): Bad expression");
7573 if (e
->symtree
->n
.sym
->ns
->is_block_data
7574 && !e
->symtree
->n
.sym
->attr
.in_common
)
7576 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
7577 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
7582 mpz_init_set_ui (size
, 1);
7589 /* Find the array section reference. */
7590 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7592 if (ref
->type
!= REF_ARRAY
)
7594 if (ref
->u
.ar
.type
== AR_ELEMENT
)
7600 /* Set marks according to the reference pattern. */
7601 switch (ref
->u
.ar
.type
)
7609 /* Get the start position of array section. */
7610 gfc_get_section_index (ar
, section_index
, &offset
);
7618 if (gfc_array_size (e
, &size
) == FAILURE
)
7620 gfc_error ("Nonconstant array section at %L in DATA statement",
7629 while (mpz_cmp_ui (size
, 0) > 0)
7631 if (next_data_value () == FAILURE
)
7633 gfc_error ("DATA statement at %L has more variables than values",
7639 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
7643 /* If we have more than one element left in the repeat count,
7644 and we have more than one element left in the target variable,
7645 then create a range assignment. */
7646 /* ??? Only done for full arrays for now, since array sections
7648 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
7649 && values
.left
> 1 && mpz_cmp_ui (size
, 1) > 0)
7653 if (mpz_cmp_ui (size
, values
.left
) >= 0)
7655 mpz_init_set_ui (range
, values
.left
);
7656 mpz_sub_ui (size
, size
, values
.left
);
7661 mpz_init_set (range
, size
);
7662 values
.left
-= mpz_get_ui (size
);
7663 mpz_set_ui (size
, 0);
7666 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
7669 mpz_add (offset
, offset
, range
);
7673 /* Assign initial value to symbol. */
7677 mpz_sub_ui (size
, size
, 1);
7679 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
7683 if (mark
== AR_FULL
)
7684 mpz_add_ui (offset
, offset
, 1);
7686 /* Modify the array section indexes and recalculate the offset
7687 for next element. */
7688 else if (mark
== AR_SECTION
)
7689 gfc_advance_section (section_index
, ar
, &offset
);
7693 if (mark
== AR_SECTION
)
7695 for (i
= 0; i
< ar
->dimen
; i
++)
7696 mpz_clear (section_index
[i
]);
7706 static try traverse_data_var (gfc_data_variable
*, locus
*);
7708 /* Iterate over a list of elements in a DATA statement. */
7711 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
7714 iterator_stack frame
;
7715 gfc_expr
*e
, *start
, *end
, *step
;
7716 try retval
= SUCCESS
;
7718 mpz_init (frame
.value
);
7720 start
= gfc_copy_expr (var
->iter
.start
);
7721 end
= gfc_copy_expr (var
->iter
.end
);
7722 step
= gfc_copy_expr (var
->iter
.step
);
7724 if (gfc_simplify_expr (start
, 1) == FAILURE
7725 || start
->expr_type
!= EXPR_CONSTANT
)
7727 gfc_error ("iterator start at %L does not simplify", &start
->where
);
7731 if (gfc_simplify_expr (end
, 1) == FAILURE
7732 || end
->expr_type
!= EXPR_CONSTANT
)
7734 gfc_error ("iterator end at %L does not simplify", &end
->where
);
7738 if (gfc_simplify_expr (step
, 1) == FAILURE
7739 || step
->expr_type
!= EXPR_CONSTANT
)
7741 gfc_error ("iterator step at %L does not simplify", &step
->where
);
7746 mpz_init_set (trip
, end
->value
.integer
);
7747 mpz_sub (trip
, trip
, start
->value
.integer
);
7748 mpz_add (trip
, trip
, step
->value
.integer
);
7750 mpz_div (trip
, trip
, step
->value
.integer
);
7752 mpz_set (frame
.value
, start
->value
.integer
);
7754 frame
.prev
= iter_stack
;
7755 frame
.variable
= var
->iter
.var
->symtree
;
7756 iter_stack
= &frame
;
7758 while (mpz_cmp_ui (trip
, 0) > 0)
7760 if (traverse_data_var (var
->list
, where
) == FAILURE
)
7767 e
= gfc_copy_expr (var
->expr
);
7768 if (gfc_simplify_expr (e
, 1) == FAILURE
)
7776 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
7778 mpz_sub_ui (trip
, trip
, 1);
7783 mpz_clear (frame
.value
);
7785 gfc_free_expr (start
);
7786 gfc_free_expr (end
);
7787 gfc_free_expr (step
);
7789 iter_stack
= frame
.prev
;
7794 /* Type resolve variables in the variable list of a DATA statement. */
7797 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
7801 for (; var
; var
= var
->next
)
7803 if (var
->expr
== NULL
)
7804 t
= traverse_data_list (var
, where
);
7806 t
= check_data_variable (var
, where
);
7816 /* Resolve the expressions and iterators associated with a data statement.
7817 This is separate from the assignment checking because data lists should
7818 only be resolved once. */
7821 resolve_data_variables (gfc_data_variable
*d
)
7823 for (; d
; d
= d
->next
)
7825 if (d
->list
== NULL
)
7827 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
7832 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
7835 if (resolve_data_variables (d
->list
) == FAILURE
)
7844 /* Resolve a single DATA statement. We implement this by storing a pointer to
7845 the value list into static variables, and then recursively traversing the
7846 variables list, expanding iterators and such. */
7849 resolve_data (gfc_data
* d
)
7851 if (resolve_data_variables (d
->var
) == FAILURE
)
7854 values
.vnode
= d
->value
;
7855 values
.left
= (d
->value
== NULL
) ? 0 : d
->value
->repeat
;
7857 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
7860 /* At this point, we better not have any values left. */
7862 if (next_data_value () == SUCCESS
)
7863 gfc_error ("DATA statement at %L has more values than variables",
7868 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
7869 accessed by host or use association, is a dummy argument to a pure function,
7870 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
7871 is storage associated with any such variable, shall not be used in the
7872 following contexts: (clients of this function). */
7874 /* Determines if a variable is not 'pure', ie not assignable within a pure
7875 procedure. Returns zero if assignment is OK, nonzero if there is a
7878 gfc_impure_variable (gfc_symbol
*sym
)
7882 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
7885 if (sym
->ns
!= gfc_current_ns
)
7886 return !sym
->attr
.function
;
7888 proc
= sym
->ns
->proc_name
;
7889 if (sym
->attr
.dummy
&& gfc_pure (proc
)
7890 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
7892 proc
->attr
.function
))
7895 /* TODO: Sort out what can be storage associated, if anything, and include
7896 it here. In principle equivalences should be scanned but it does not
7897 seem to be possible to storage associate an impure variable this way. */
7902 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
7903 symbol of the current procedure. */
7906 gfc_pure (gfc_symbol
*sym
)
7908 symbol_attribute attr
;
7911 sym
= gfc_current_ns
->proc_name
;
7917 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
7921 /* Test whether the current procedure is elemental or not. */
7924 gfc_elemental (gfc_symbol
*sym
)
7926 symbol_attribute attr
;
7929 sym
= gfc_current_ns
->proc_name
;
7934 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
7938 /* Warn about unused labels. */
7941 warn_unused_fortran_label (gfc_st_label
*label
)
7946 warn_unused_fortran_label (label
->left
);
7948 if (label
->defined
== ST_LABEL_UNKNOWN
)
7951 switch (label
->referenced
)
7953 case ST_LABEL_UNKNOWN
:
7954 gfc_warning ("Label %d at %L defined but not used", label
->value
,
7958 case ST_LABEL_BAD_TARGET
:
7959 gfc_warning ("Label %d at %L defined but cannot be used",
7960 label
->value
, &label
->where
);
7967 warn_unused_fortran_label (label
->right
);
7971 /* Returns the sequence type of a symbol or sequence. */
7974 sequence_type (gfc_typespec ts
)
7983 if (ts
.derived
->components
== NULL
)
7984 return SEQ_NONDEFAULT
;
7986 result
= sequence_type (ts
.derived
->components
->ts
);
7987 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
7988 if (sequence_type (c
->ts
) != result
)
7994 if (ts
.kind
!= gfc_default_character_kind
)
7995 return SEQ_NONDEFAULT
;
7997 return SEQ_CHARACTER
;
8000 if (ts
.kind
!= gfc_default_integer_kind
)
8001 return SEQ_NONDEFAULT
;
8006 if (!(ts
.kind
== gfc_default_real_kind
8007 || ts
.kind
== gfc_default_double_kind
))
8008 return SEQ_NONDEFAULT
;
8013 if (ts
.kind
!= gfc_default_complex_kind
)
8014 return SEQ_NONDEFAULT
;
8019 if (ts
.kind
!= gfc_default_logical_kind
)
8020 return SEQ_NONDEFAULT
;
8025 return SEQ_NONDEFAULT
;
8030 /* Resolve derived type EQUIVALENCE object. */
8033 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
8036 gfc_component
*c
= derived
->components
;
8041 /* Shall not be an object of nonsequence derived type. */
8042 if (!derived
->attr
.sequence
)
8044 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8045 "attribute to be an EQUIVALENCE object", sym
->name
,
8050 /* Shall not have allocatable components. */
8051 if (derived
->attr
.alloc_comp
)
8053 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8054 "components to be an EQUIVALENCE object",sym
->name
,
8059 for (; c
; c
= c
->next
)
8063 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
8066 /* Shall not be an object of sequence derived type containing a pointer
8067 in the structure. */
8070 gfc_error ("Derived type variable '%s' at %L with pointer "
8071 "component(s) cannot be an EQUIVALENCE object",
8072 sym
->name
, &e
->where
);
8080 /* Resolve equivalence object.
8081 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8082 an allocatable array, an object of nonsequence derived type, an object of
8083 sequence derived type containing a pointer at any level of component
8084 selection, an automatic object, a function name, an entry name, a result
8085 name, a named constant, a structure component, or a subobject of any of
8086 the preceding objects. A substring shall not have length zero. A
8087 derived type shall not have components with default initialization nor
8088 shall two objects of an equivalence group be initialized.
8089 Either all or none of the objects shall have an protected attribute.
8090 The simple constraints are done in symbol.c(check_conflict) and the rest
8091 are implemented here. */
8094 resolve_equivalence (gfc_equiv
*eq
)
8097 gfc_symbol
*derived
;
8098 gfc_symbol
*first_sym
;
8101 locus
*last_where
= NULL
;
8102 seq_type eq_type
, last_eq_type
;
8103 gfc_typespec
*last_ts
;
8104 int object
, cnt_protected
;
8105 const char *value_name
;
8109 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
8111 first_sym
= eq
->expr
->symtree
->n
.sym
;
8115 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
8119 e
->ts
= e
->symtree
->n
.sym
->ts
;
8120 /* match_varspec might not know yet if it is seeing
8121 array reference or substring reference, as it doesn't
8123 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
8125 gfc_ref
*ref
= e
->ref
;
8126 sym
= e
->symtree
->n
.sym
;
8128 if (sym
->attr
.dimension
)
8130 ref
->u
.ar
.as
= sym
->as
;
8134 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8135 if (e
->ts
.type
== BT_CHARACTER
8137 && ref
->type
== REF_ARRAY
8138 && ref
->u
.ar
.dimen
== 1
8139 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
8140 && ref
->u
.ar
.stride
[0] == NULL
)
8142 gfc_expr
*start
= ref
->u
.ar
.start
[0];
8143 gfc_expr
*end
= ref
->u
.ar
.end
[0];
8146 /* Optimize away the (:) reference. */
8147 if (start
== NULL
&& end
== NULL
)
8152 e
->ref
->next
= ref
->next
;
8157 ref
->type
= REF_SUBSTRING
;
8159 start
= gfc_int_expr (1);
8160 ref
->u
.ss
.start
= start
;
8161 if (end
== NULL
&& e
->ts
.cl
)
8162 end
= gfc_copy_expr (e
->ts
.cl
->length
);
8163 ref
->u
.ss
.end
= end
;
8164 ref
->u
.ss
.length
= e
->ts
.cl
;
8171 /* Any further ref is an error. */
8174 gcc_assert (ref
->type
== REF_ARRAY
);
8175 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8181 if (gfc_resolve_expr (e
) == FAILURE
)
8184 sym
= e
->symtree
->n
.sym
;
8186 if (sym
->attr
.protected)
8188 if (cnt_protected
> 0 && cnt_protected
!= object
)
8190 gfc_error ("Either all or none of the objects in the "
8191 "EQUIVALENCE set at %L shall have the "
8192 "PROTECTED attribute",
8197 /* Shall not equivalence common block variables in a PURE procedure. */
8198 if (sym
->ns
->proc_name
8199 && sym
->ns
->proc_name
->attr
.pure
8200 && sym
->attr
.in_common
)
8202 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8203 "object in the pure procedure '%s'",
8204 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
8208 /* Shall not be a named constant. */
8209 if (e
->expr_type
== EXPR_CONSTANT
)
8211 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8212 "object", sym
->name
, &e
->where
);
8216 derived
= e
->ts
.derived
;
8217 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
8220 /* Check that the types correspond correctly:
8222 A numeric sequence structure may be equivalenced to another sequence
8223 structure, an object of default integer type, default real type, double
8224 precision real type, default logical type such that components of the
8225 structure ultimately only become associated to objects of the same
8226 kind. A character sequence structure may be equivalenced to an object
8227 of default character kind or another character sequence structure.
8228 Other objects may be equivalenced only to objects of the same type and
8231 /* Identical types are unconditionally OK. */
8232 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
8233 goto identical_types
;
8235 last_eq_type
= sequence_type (*last_ts
);
8236 eq_type
= sequence_type (sym
->ts
);
8238 /* Since the pair of objects is not of the same type, mixed or
8239 non-default sequences can be rejected. */
8241 msg
= "Sequence %s with mixed components in EQUIVALENCE "
8242 "statement at %L with different type objects";
8244 && last_eq_type
== SEQ_MIXED
8245 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
8247 || (eq_type
== SEQ_MIXED
8248 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8249 &e
->where
) == FAILURE
))
8252 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
8253 "statement at %L with objects of different type";
8255 && last_eq_type
== SEQ_NONDEFAULT
8256 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
8257 last_where
) == FAILURE
)
8258 || (eq_type
== SEQ_NONDEFAULT
8259 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8260 &e
->where
) == FAILURE
))
8263 msg
="Non-CHARACTER object '%s' in default CHARACTER "
8264 "EQUIVALENCE statement at %L";
8265 if (last_eq_type
== SEQ_CHARACTER
8266 && eq_type
!= SEQ_CHARACTER
8267 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8268 &e
->where
) == FAILURE
)
8271 msg
="Non-NUMERIC object '%s' in default NUMERIC "
8272 "EQUIVALENCE statement at %L";
8273 if (last_eq_type
== SEQ_NUMERIC
8274 && eq_type
!= SEQ_NUMERIC
8275 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8276 &e
->where
) == FAILURE
)
8281 last_where
= &e
->where
;
8286 /* Shall not be an automatic array. */
8287 if (e
->ref
->type
== REF_ARRAY
8288 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
8290 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8291 "an EQUIVALENCE object", sym
->name
, &e
->where
);
8298 /* Shall not be a structure component. */
8299 if (r
->type
== REF_COMPONENT
)
8301 gfc_error ("Structure component '%s' at %L cannot be an "
8302 "EQUIVALENCE object",
8303 r
->u
.c
.component
->name
, &e
->where
);
8307 /* A substring shall not have length zero. */
8308 if (r
->type
== REF_SUBSTRING
)
8310 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
8312 gfc_error ("Substring at %L has length zero",
8313 &r
->u
.ss
.start
->where
);
8323 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8326 resolve_fntype (gfc_namespace
*ns
)
8331 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
8334 /* If there are any entries, ns->proc_name is the entry master
8335 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8337 sym
= ns
->entries
->sym
;
8339 sym
= ns
->proc_name
;
8340 if (sym
->result
== sym
8341 && sym
->ts
.type
== BT_UNKNOWN
8342 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
8343 && !sym
->attr
.untyped
)
8345 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8346 sym
->name
, &sym
->declared_at
);
8347 sym
->attr
.untyped
= 1;
8350 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
8351 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
8352 sym
->ts
.derived
->ns
->default_access
)
8353 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
8355 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8356 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
8360 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
8362 if (el
->sym
->result
== el
->sym
8363 && el
->sym
->ts
.type
== BT_UNKNOWN
8364 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
8365 && !el
->sym
->attr
.untyped
)
8367 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8368 el
->sym
->name
, &el
->sym
->declared_at
);
8369 el
->sym
->attr
.untyped
= 1;
8374 /* 12.3.2.1.1 Defined operators. */
8377 gfc_resolve_uops (gfc_symtree
*symtree
)
8381 gfc_formal_arglist
*formal
;
8383 if (symtree
== NULL
)
8386 gfc_resolve_uops (symtree
->left
);
8387 gfc_resolve_uops (symtree
->right
);
8389 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
8392 if (!sym
->attr
.function
)
8393 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8394 sym
->name
, &sym
->declared_at
);
8396 if (sym
->ts
.type
== BT_CHARACTER
8397 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
8398 && !(sym
->result
&& sym
->result
->ts
.cl
8399 && sym
->result
->ts
.cl
->length
))
8400 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8401 "character length", sym
->name
, &sym
->declared_at
);
8403 formal
= sym
->formal
;
8404 if (!formal
|| !formal
->sym
)
8406 gfc_error ("User operator procedure '%s' at %L must have at least "
8407 "one argument", sym
->name
, &sym
->declared_at
);
8411 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8412 gfc_error ("First argument of operator interface at %L must be "
8413 "INTENT(IN)", &sym
->declared_at
);
8415 if (formal
->sym
->attr
.optional
)
8416 gfc_error ("First argument of operator interface at %L cannot be "
8417 "optional", &sym
->declared_at
);
8419 formal
= formal
->next
;
8420 if (!formal
|| !formal
->sym
)
8423 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8424 gfc_error ("Second argument of operator interface at %L must be "
8425 "INTENT(IN)", &sym
->declared_at
);
8427 if (formal
->sym
->attr
.optional
)
8428 gfc_error ("Second argument of operator interface at %L cannot be "
8429 "optional", &sym
->declared_at
);
8432 gfc_error ("Operator interface at %L must have, at most, two "
8433 "arguments", &sym
->declared_at
);
8438 /* Examine all of the expressions associated with a program unit,
8439 assign types to all intermediate expressions, make sure that all
8440 assignments are to compatible types and figure out which names
8441 refer to which functions or subroutines. It doesn't check code
8442 block, which is handled by resolve_code. */
8445 resolve_types (gfc_namespace
*ns
)
8452 gfc_current_ns
= ns
;
8454 resolve_entries (ns
);
8456 resolve_common_blocks (ns
->common_root
);
8458 resolve_contained_functions (ns
);
8460 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
8462 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
8463 resolve_charlen (cl
);
8465 gfc_traverse_ns (ns
, resolve_symbol
);
8467 resolve_fntype (ns
);
8469 for (n
= ns
->contained
; n
; n
= n
->sibling
)
8471 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
8472 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8473 "also be PURE", n
->proc_name
->name
,
8474 &n
->proc_name
->declared_at
);
8480 gfc_check_interfaces (ns
);
8482 gfc_traverse_ns (ns
, resolve_values
);
8488 for (d
= ns
->data
; d
; d
= d
->next
)
8492 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
8494 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
8496 if (ns
->common_root
!= NULL
)
8497 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
8499 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
8500 resolve_equivalence (eq
);
8502 /* Warn about unused labels. */
8503 if (warn_unused_label
)
8504 warn_unused_fortran_label (ns
->st_labels
);
8506 gfc_resolve_uops (ns
->uop_root
);
8510 /* Call resolve_code recursively. */
8513 resolve_codes (gfc_namespace
*ns
)
8517 for (n
= ns
->contained
; n
; n
= n
->sibling
)
8520 gfc_current_ns
= ns
;
8522 /* Set to an out of range value. */
8523 current_entry_id
= -1;
8525 bitmap_obstack_initialize (&labels_obstack
);
8526 resolve_code (ns
->code
, ns
);
8527 bitmap_obstack_release (&labels_obstack
);
8531 /* This function is called after a complete program unit has been compiled.
8532 Its purpose is to examine all of the expressions associated with a program
8533 unit, assign types to all intermediate expressions, make sure that all
8534 assignments are to compatible types and figure out which names refer to
8535 which functions or subroutines. */
8538 gfc_resolve (gfc_namespace
*ns
)
8540 gfc_namespace
*old_ns
;
8542 old_ns
= gfc_current_ns
;
8547 gfc_current_ns
= old_ns
;