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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code
*head
, *current
, *tail
;
47 struct code_stack
*prev
;
49 /* This bitmap keeps track of the targets valid for a branch from
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL block. */
60 static int forall_flag
;
62 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
64 static int omp_workshare_flag
;
66 /* Nonzero if we are processing a formal arglist. The corresponding function
67 resets the flag each time that it is read. */
68 static int formal_arg_flag
= 0;
70 /* True if we are resolving a specification expression. */
71 static int specification_expr
= 0;
73 /* The id of the last entry seen. */
74 static int current_entry_id
;
76 /* We use bitmaps to determine if a branch target is valid. */
77 static bitmap_obstack labels_obstack
;
80 gfc_is_formal_arg (void)
82 return formal_arg_flag
;
85 /* Resolve types of formal argument lists. These have to be done early so that
86 the formal argument lists of module procedures can be copied to the
87 containing module before the individual procedures are resolved
88 individually. We also resolve argument lists of procedures in interface
89 blocks because they are self-contained scoping units.
91 Since a dummy argument cannot be a non-dummy procedure, the only
92 resort left for untyped names are the IMPLICIT types. */
95 resolve_formal_arglist (gfc_symbol
*proc
)
97 gfc_formal_arglist
*f
;
101 if (proc
->result
!= NULL
)
106 if (gfc_elemental (proc
)
107 || sym
->attr
.pointer
|| sym
->attr
.allocatable
108 || (sym
->as
&& sym
->as
->rank
> 0))
109 proc
->attr
.always_explicit
= 1;
113 for (f
= proc
->formal
; f
; f
= f
->next
)
119 /* Alternate return placeholder. */
120 if (gfc_elemental (proc
))
121 gfc_error ("Alternate return specifier in elemental subroutine "
122 "'%s' at %L is not allowed", proc
->name
,
124 if (proc
->attr
.function
)
125 gfc_error ("Alternate return specifier in function "
126 "'%s' at %L is not allowed", proc
->name
,
131 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
132 resolve_formal_arglist (sym
);
134 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
136 if (gfc_pure (proc
) && !gfc_pure (sym
))
138 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
139 "also be PURE", sym
->name
, &sym
->declared_at
);
143 if (gfc_elemental (proc
))
145 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
146 "procedure", &sym
->declared_at
);
150 if (sym
->attr
.function
151 && sym
->ts
.type
== BT_UNKNOWN
152 && sym
->attr
.intrinsic
)
154 gfc_intrinsic_sym
*isym
;
155 isym
= gfc_find_function (sym
->name
);
156 if (isym
== NULL
|| !isym
->specific
)
158 gfc_error ("Unable to find a specific INTRINSIC procedure "
159 "for the reference '%s' at %L", sym
->name
,
168 if (sym
->ts
.type
== BT_UNKNOWN
)
170 if (!sym
->attr
.function
|| sym
->result
== sym
)
171 gfc_set_default_type (sym
, 1, sym
->ns
);
174 gfc_resolve_array_spec (sym
->as
, 0);
176 /* We can't tell if an array with dimension (:) is assumed or deferred
177 shape until we know if it has the pointer or allocatable attributes.
179 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
180 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
182 sym
->as
->type
= AS_ASSUMED_SHAPE
;
183 for (i
= 0; i
< sym
->as
->rank
; i
++)
184 sym
->as
->lower
[i
] = gfc_int_expr (1);
187 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
188 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
189 || sym
->attr
.optional
)
190 proc
->attr
.always_explicit
= 1;
192 /* If the flavor is unknown at this point, it has to be a variable.
193 A procedure specification would have already set the type. */
195 if (sym
->attr
.flavor
== FL_UNKNOWN
)
196 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
198 if (gfc_pure (proc
) && !sym
->attr
.pointer
199 && sym
->attr
.flavor
!= FL_PROCEDURE
)
201 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
202 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
203 "INTENT(IN)", sym
->name
, proc
->name
,
206 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
207 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
208 "have its INTENT specified", sym
->name
, proc
->name
,
212 if (gfc_elemental (proc
))
216 gfc_error ("Argument '%s' of elemental procedure at %L must "
217 "be scalar", sym
->name
, &sym
->declared_at
);
221 if (sym
->attr
.pointer
)
223 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
224 "have the POINTER attribute", sym
->name
,
229 if (sym
->attr
.flavor
== FL_PROCEDURE
)
231 gfc_error ("Dummy procedure '%s' not allowed in elemental "
232 "procedure '%s' at %L", sym
->name
, proc
->name
,
238 /* Each dummy shall be specified to be scalar. */
239 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
243 gfc_error ("Argument '%s' of statement function at %L must "
244 "be scalar", sym
->name
, &sym
->declared_at
);
248 if (sym
->ts
.type
== BT_CHARACTER
)
250 gfc_charlen
*cl
= sym
->ts
.cl
;
251 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
253 gfc_error ("Character-valued argument '%s' of statement "
254 "function at %L must have constant length",
255 sym
->name
, &sym
->declared_at
);
265 /* Work function called when searching for symbols that have argument lists
266 associated with them. */
269 find_arglists (gfc_symbol
*sym
)
271 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
274 resolve_formal_arglist (sym
);
278 /* Given a namespace, resolve all formal argument lists within the namespace.
282 resolve_formal_arglists (gfc_namespace
*ns
)
287 gfc_traverse_ns (ns
, find_arglists
);
292 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
296 /* If this namespace is not a function or an entry master function,
298 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
299 || sym
->attr
.entry_master
)
302 /* Try to find out of what the return type is. */
303 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
305 t
= gfc_set_default_type (sym
->result
, 0, ns
);
307 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
309 if (sym
->result
== sym
)
310 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
311 sym
->name
, &sym
->declared_at
);
313 gfc_error ("Result '%s' of contained function '%s' at %L has "
314 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
315 &sym
->result
->declared_at
);
316 sym
->result
->attr
.untyped
= 1;
320 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
321 type, lists the only ways a character length value of * can be used:
322 dummy arguments of procedures, named constants, and function results
323 in external functions. Internal function results are not on that list;
324 ergo, not permitted. */
326 if (sym
->result
->ts
.type
== BT_CHARACTER
)
328 gfc_charlen
*cl
= sym
->result
->ts
.cl
;
329 if (!cl
|| !cl
->length
)
330 gfc_error ("Character-valued internal function '%s' at %L must "
331 "not be assumed length", sym
->name
, &sym
->declared_at
);
336 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
337 introduce duplicates. */
340 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
342 gfc_formal_arglist
*f
, *new_arglist
;
345 for (; new_args
!= NULL
; new_args
= new_args
->next
)
347 new_sym
= new_args
->sym
;
348 /* See if this arg is already in the formal argument list. */
349 for (f
= proc
->formal
; f
; f
= f
->next
)
351 if (new_sym
== f
->sym
)
358 /* Add a new argument. Argument order is not important. */
359 new_arglist
= gfc_get_formal_arglist ();
360 new_arglist
->sym
= new_sym
;
361 new_arglist
->next
= proc
->formal
;
362 proc
->formal
= new_arglist
;
367 /* Flag the arguments that are not present in all entries. */
370 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
372 gfc_formal_arglist
*f
, *head
;
375 for (f
= proc
->formal
; f
; f
= f
->next
)
380 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
382 if (new_args
->sym
== f
->sym
)
389 f
->sym
->attr
.not_always_present
= 1;
394 /* Resolve alternate entry points. If a symbol has multiple entry points we
395 create a new master symbol for the main routine, and turn the existing
396 symbol into an entry point. */
399 resolve_entries (gfc_namespace
*ns
)
401 gfc_namespace
*old_ns
;
405 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
406 static int master_count
= 0;
408 if (ns
->proc_name
== NULL
)
411 /* No need to do anything if this procedure doesn't have alternate entry
416 /* We may already have resolved alternate entry points. */
417 if (ns
->proc_name
->attr
.entry_master
)
420 /* If this isn't a procedure something has gone horribly wrong. */
421 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
423 /* Remember the current namespace. */
424 old_ns
= gfc_current_ns
;
428 /* Add the main entry point to the list of entry points. */
429 el
= gfc_get_entry_list ();
430 el
->sym
= ns
->proc_name
;
432 el
->next
= ns
->entries
;
434 ns
->proc_name
->attr
.entry
= 1;
436 /* If it is a module function, it needs to be in the right namespace
437 so that gfc_get_fake_result_decl can gather up the results. The
438 need for this arose in get_proc_name, where these beasts were
439 left in their own namespace, to keep prior references linked to
440 the entry declaration.*/
441 if (ns
->proc_name
->attr
.function
442 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
445 /* Do the same for entries where the master is not a module
446 procedure. These are retained in the module namespace because
447 of the module procedure declaration. */
448 for (el
= el
->next
; el
; el
= el
->next
)
449 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
450 && el
->sym
->attr
.mod_proc
)
454 /* Add an entry statement for it. */
461 /* Create a new symbol for the master function. */
462 /* Give the internal function a unique name (within this file).
463 Also include the function name so the user has some hope of figuring
464 out what is going on. */
465 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
466 master_count
++, ns
->proc_name
->name
);
467 gfc_get_ha_symbol (name
, &proc
);
468 gcc_assert (proc
!= NULL
);
470 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
471 if (ns
->proc_name
->attr
.subroutine
)
472 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
476 gfc_typespec
*ts
, *fts
;
477 gfc_array_spec
*as
, *fas
;
478 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
480 fas
= ns
->entries
->sym
->as
;
481 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
482 fts
= &ns
->entries
->sym
->result
->ts
;
483 if (fts
->type
== BT_UNKNOWN
)
484 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
485 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
487 ts
= &el
->sym
->result
->ts
;
489 as
= as
? as
: el
->sym
->result
->as
;
490 if (ts
->type
== BT_UNKNOWN
)
491 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
493 if (! gfc_compare_types (ts
, fts
)
494 || (el
->sym
->result
->attr
.dimension
495 != ns
->entries
->sym
->result
->attr
.dimension
)
496 || (el
->sym
->result
->attr
.pointer
497 != ns
->entries
->sym
->result
->attr
.pointer
))
499 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
500 && gfc_compare_array_spec (as
, fas
) == 0)
501 gfc_error ("Function %s at %L has entries with mismatched "
502 "array specifications", ns
->entries
->sym
->name
,
503 &ns
->entries
->sym
->declared_at
);
504 /* The characteristics need to match and thus both need to have
505 the same string length, i.e. both len=*, or both len=4.
506 Having both len=<variable> is also possible, but difficult to
507 check at compile time. */
508 else if (ts
->type
== BT_CHARACTER
&& ts
->cl
&& fts
->cl
509 && (((ts
->cl
->length
&& !fts
->cl
->length
)
510 ||(!ts
->cl
->length
&& fts
->cl
->length
))
512 && ts
->cl
->length
->expr_type
513 != fts
->cl
->length
->expr_type
)
515 && ts
->cl
->length
->expr_type
== EXPR_CONSTANT
516 && mpz_cmp (ts
->cl
->length
->value
.integer
,
517 fts
->cl
->length
->value
.integer
) != 0)))
518 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
519 "entries returning variables of different "
520 "string lengths", ns
->entries
->sym
->name
,
521 &ns
->entries
->sym
->declared_at
);
526 sym
= ns
->entries
->sym
->result
;
527 /* All result types the same. */
529 if (sym
->attr
.dimension
)
530 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
531 if (sym
->attr
.pointer
)
532 gfc_add_pointer (&proc
->attr
, NULL
);
536 /* Otherwise the result will be passed through a union by
538 proc
->attr
.mixed_entry_master
= 1;
539 for (el
= ns
->entries
; el
; el
= el
->next
)
541 sym
= el
->sym
->result
;
542 if (sym
->attr
.dimension
)
544 if (el
== ns
->entries
)
545 gfc_error ("FUNCTION result %s can't be an array in "
546 "FUNCTION %s at %L", sym
->name
,
547 ns
->entries
->sym
->name
, &sym
->declared_at
);
549 gfc_error ("ENTRY result %s can't be an array in "
550 "FUNCTION %s at %L", sym
->name
,
551 ns
->entries
->sym
->name
, &sym
->declared_at
);
553 else if (sym
->attr
.pointer
)
555 if (el
== ns
->entries
)
556 gfc_error ("FUNCTION result %s can't be a POINTER in "
557 "FUNCTION %s at %L", sym
->name
,
558 ns
->entries
->sym
->name
, &sym
->declared_at
);
560 gfc_error ("ENTRY result %s can't be a POINTER in "
561 "FUNCTION %s at %L", sym
->name
,
562 ns
->entries
->sym
->name
, &sym
->declared_at
);
567 if (ts
->type
== BT_UNKNOWN
)
568 ts
= gfc_get_default_type (sym
, NULL
);
572 if (ts
->kind
== gfc_default_integer_kind
)
576 if (ts
->kind
== gfc_default_real_kind
577 || ts
->kind
== gfc_default_double_kind
)
581 if (ts
->kind
== gfc_default_complex_kind
)
585 if (ts
->kind
== gfc_default_logical_kind
)
589 /* We will issue error elsewhere. */
597 if (el
== ns
->entries
)
598 gfc_error ("FUNCTION result %s can't be of type %s "
599 "in FUNCTION %s at %L", sym
->name
,
600 gfc_typename (ts
), ns
->entries
->sym
->name
,
603 gfc_error ("ENTRY result %s can't be of type %s "
604 "in FUNCTION %s at %L", sym
->name
,
605 gfc_typename (ts
), ns
->entries
->sym
->name
,
612 proc
->attr
.access
= ACCESS_PRIVATE
;
613 proc
->attr
.entry_master
= 1;
615 /* Merge all the entry point arguments. */
616 for (el
= ns
->entries
; el
; el
= el
->next
)
617 merge_argument_lists (proc
, el
->sym
->formal
);
619 /* Check the master formal arguments for any that are not
620 present in all entry points. */
621 for (el
= ns
->entries
; el
; el
= el
->next
)
622 check_argument_lists (proc
, el
->sym
->formal
);
624 /* Use the master function for the function body. */
625 ns
->proc_name
= proc
;
627 /* Finalize the new symbols. */
628 gfc_commit_symbols ();
630 /* Restore the original namespace. */
631 gfc_current_ns
= old_ns
;
636 has_default_initializer (gfc_symbol
*der
)
640 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
641 for (c
= der
->components
; c
; c
= c
->next
)
642 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
643 || (c
->ts
.type
== BT_DERIVED
644 && (!c
->pointer
&& has_default_initializer (c
->ts
.derived
))))
650 /* Resolve common variables. */
652 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
654 gfc_symbol
*csym
= sym
;
656 for (; csym
; csym
= csym
->common_next
)
658 if (csym
->value
|| csym
->attr
.data
)
660 if (!csym
->ns
->is_block_data
)
661 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
662 "but only in BLOCK DATA initialization is "
663 "allowed", csym
->name
, &csym
->declared_at
);
664 else if (!named_common
)
665 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
666 "in a blank COMMON but initialization is only "
667 "allowed in named common blocks", csym
->name
,
671 if (csym
->ts
.type
!= BT_DERIVED
)
674 if (!(csym
->ts
.derived
->attr
.sequence
675 || csym
->ts
.derived
->attr
.is_bind_c
))
676 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
677 "has neither the SEQUENCE nor the BIND(C) "
678 "attribute", csym
->name
, &csym
->declared_at
);
679 if (csym
->ts
.derived
->attr
.alloc_comp
)
680 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
681 "has an ultimate component that is "
682 "allocatable", csym
->name
, &csym
->declared_at
);
683 if (has_default_initializer (csym
->ts
.derived
))
684 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
685 "may not have default initializer", csym
->name
,
690 /* Resolve common blocks. */
692 resolve_common_blocks (gfc_symtree
*common_root
)
696 if (common_root
== NULL
)
699 if (common_root
->left
)
700 resolve_common_blocks (common_root
->left
);
701 if (common_root
->right
)
702 resolve_common_blocks (common_root
->right
);
704 resolve_common_vars (common_root
->n
.common
->head
, true);
706 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
710 if (sym
->attr
.flavor
== FL_PARAMETER
)
711 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
712 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
714 if (sym
->attr
.intrinsic
)
715 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
716 sym
->name
, &common_root
->n
.common
->where
);
717 else if (sym
->attr
.result
718 ||(sym
->attr
.function
&& gfc_current_ns
->proc_name
== sym
))
719 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
720 "that is also a function result", sym
->name
,
721 &common_root
->n
.common
->where
);
722 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
723 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
724 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
725 "that is also a global procedure", sym
->name
,
726 &common_root
->n
.common
->where
);
730 /* Resolve contained function types. Because contained functions can call one
731 another, they have to be worked out before any of the contained procedures
734 The good news is that if a function doesn't already have a type, the only
735 way it can get one is through an IMPLICIT type or a RESULT variable, because
736 by definition contained functions are contained namespace they're contained
737 in, not in a sibling or parent namespace. */
740 resolve_contained_functions (gfc_namespace
*ns
)
742 gfc_namespace
*child
;
745 resolve_formal_arglists (ns
);
747 for (child
= ns
->contained
; child
; child
= child
->sibling
)
749 /* Resolve alternate entry points first. */
750 resolve_entries (child
);
752 /* Then check function return types. */
753 resolve_contained_fntype (child
->proc_name
, child
);
754 for (el
= child
->entries
; el
; el
= el
->next
)
755 resolve_contained_fntype (el
->sym
, child
);
760 /* Resolve all of the elements of a structure constructor and make sure that
761 the types are correct. */
764 resolve_structure_cons (gfc_expr
*expr
)
766 gfc_constructor
*cons
;
772 cons
= expr
->value
.constructor
;
773 /* A constructor may have references if it is the result of substituting a
774 parameter variable. In this case we just pull out the component we
777 comp
= expr
->ref
->u
.c
.sym
->components
;
779 comp
= expr
->ts
.derived
->components
;
781 /* See if the user is trying to invoke a structure constructor for one of
782 the iso_c_binding derived types. */
783 if (expr
->ts
.derived
&& expr
->ts
.derived
->ts
.is_iso_c
&& cons
784 && cons
->expr
!= NULL
)
786 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
787 expr
->ts
.derived
->name
, &(expr
->where
));
791 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
798 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
804 rank
= comp
->as
? comp
->as
->rank
: 0;
805 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
806 && (comp
->allocatable
|| cons
->expr
->rank
))
808 gfc_error ("The rank of the element in the derived type "
809 "constructor at %L does not match that of the "
810 "component (%d/%d)", &cons
->expr
->where
,
811 cons
->expr
->rank
, rank
);
815 /* If we don't have the right type, try to convert it. */
817 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
820 if (comp
->pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
821 gfc_error ("The element in the derived type constructor at %L, "
822 "for pointer component '%s', is %s but should be %s",
823 &cons
->expr
->where
, comp
->name
,
824 gfc_basic_typename (cons
->expr
->ts
.type
),
825 gfc_basic_typename (comp
->ts
.type
));
827 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
830 if (!comp
->pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
833 a
= gfc_expr_attr (cons
->expr
);
835 if (!a
.pointer
&& !a
.target
)
838 gfc_error ("The element in the derived type constructor at %L, "
839 "for pointer component '%s' should be a POINTER or "
840 "a TARGET", &cons
->expr
->where
, comp
->name
);
848 /****************** Expression name resolution ******************/
850 /* Returns 0 if a symbol was not declared with a type or
851 attribute declaration statement, nonzero otherwise. */
854 was_declared (gfc_symbol
*sym
)
860 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
863 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
864 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
865 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
872 /* Determine if a symbol is generic or not. */
875 generic_sym (gfc_symbol
*sym
)
879 if (sym
->attr
.generic
||
880 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
883 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
886 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
893 return generic_sym (s
);
900 /* Determine if a symbol is specific or not. */
903 specific_sym (gfc_symbol
*sym
)
907 if (sym
->attr
.if_source
== IFSRC_IFBODY
908 || sym
->attr
.proc
== PROC_MODULE
909 || sym
->attr
.proc
== PROC_INTERNAL
910 || sym
->attr
.proc
== PROC_ST_FUNCTION
911 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
912 || sym
->attr
.external
)
915 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
918 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
920 return (s
== NULL
) ? 0 : specific_sym (s
);
924 /* Figure out if the procedure is specific, generic or unknown. */
927 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
931 procedure_kind (gfc_symbol
*sym
)
933 if (generic_sym (sym
))
934 return PTYPE_GENERIC
;
936 if (specific_sym (sym
))
937 return PTYPE_SPECIFIC
;
939 return PTYPE_UNKNOWN
;
942 /* Check references to assumed size arrays. The flag need_full_assumed_size
943 is nonzero when matching actual arguments. */
945 static int need_full_assumed_size
= 0;
948 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
954 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
957 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
958 if (ref
->type
== REF_ARRAY
)
959 for (dim
= 0; dim
< ref
->u
.ar
.as
->rank
; dim
++)
960 last
= (ref
->u
.ar
.end
[dim
] == NULL
)
961 && (ref
->u
.ar
.type
== DIMEN_ELEMENT
);
965 gfc_error ("The upper bound in the last dimension must "
966 "appear in the reference to the assumed size "
967 "array '%s' at %L", sym
->name
, &e
->where
);
974 /* Look for bad assumed size array references in argument expressions
975 of elemental and array valued intrinsic procedures. Since this is
976 called from procedure resolution functions, it only recurses at
980 resolve_assumed_size_actual (gfc_expr
*e
)
985 switch (e
->expr_type
)
988 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
993 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
994 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1005 /* Resolve an actual argument list. Most of the time, this is just
1006 resolving the expressions in the list.
1007 The exception is that we sometimes have to decide whether arguments
1008 that look like procedure arguments are really simple variable
1012 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
)
1015 gfc_symtree
*parent_st
;
1017 int save_need_full_assumed_size
;
1019 for (; arg
; arg
= arg
->next
)
1024 /* Check the label is a valid branching target. */
1027 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1029 gfc_error ("Label %d referenced at %L is never defined",
1030 arg
->label
->value
, &arg
->label
->where
);
1037 if (e
->expr_type
== FL_VARIABLE
&& e
->symtree
->ambiguous
)
1039 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1044 if (e
->ts
.type
!= BT_PROCEDURE
)
1046 save_need_full_assumed_size
= need_full_assumed_size
;
1047 if (e
->expr_type
!= FL_VARIABLE
)
1048 need_full_assumed_size
= 0;
1049 if (gfc_resolve_expr (e
) != SUCCESS
)
1051 need_full_assumed_size
= save_need_full_assumed_size
;
1055 /* See if the expression node should really be a variable reference. */
1057 sym
= e
->symtree
->n
.sym
;
1059 if (sym
->attr
.flavor
== FL_PROCEDURE
1060 || sym
->attr
.intrinsic
1061 || sym
->attr
.external
)
1065 /* If a procedure is not already determined to be something else
1066 check if it is intrinsic. */
1067 if (!sym
->attr
.intrinsic
1068 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1069 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1070 && gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1071 sym
->attr
.intrinsic
= 1;
1073 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1075 gfc_error ("Statement function '%s' at %L is not allowed as an "
1076 "actual argument", sym
->name
, &e
->where
);
1079 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1080 sym
->attr
.subroutine
);
1081 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1083 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1084 "actual argument", sym
->name
, &e
->where
);
1087 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1088 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1090 gfc_error ("Internal procedure '%s' is not allowed as an "
1091 "actual argument at %L", sym
->name
, &e
->where
);
1094 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1096 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1097 "allowed as an actual argument at %L", sym
->name
,
1101 /* Check if a generic interface has a specific procedure
1102 with the same name before emitting an error. */
1103 if (sym
->attr
.generic
)
1106 for (p
= sym
->generic
; p
; p
= p
->next
)
1107 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1109 e
->symtree
= gfc_find_symtree
1110 (p
->sym
->ns
->sym_root
, sym
->name
);
1115 if (p
== NULL
|| e
->symtree
== NULL
)
1116 gfc_error ("GENERIC procedure '%s' is not "
1117 "allowed as an actual argument at %L", sym
->name
,
1121 /* If the symbol is the function that names the current (or
1122 parent) scope, then we really have a variable reference. */
1124 if (sym
->attr
.function
&& sym
->result
== sym
1125 && (sym
->ns
->proc_name
== sym
1126 || (sym
->ns
->parent
!= NULL
1127 && sym
->ns
->parent
->proc_name
== sym
)))
1130 /* If all else fails, see if we have a specific intrinsic. */
1131 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1133 gfc_intrinsic_sym
*isym
;
1135 isym
= gfc_find_function (sym
->name
);
1136 if (isym
== NULL
|| !isym
->specific
)
1138 gfc_error ("Unable to find a specific INTRINSIC procedure "
1139 "for the reference '%s' at %L", sym
->name
,
1144 sym
->attr
.intrinsic
= 1;
1145 sym
->attr
.function
= 1;
1150 /* See if the name is a module procedure in a parent unit. */
1152 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1155 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1157 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1161 if (parent_st
== NULL
)
1164 sym
= parent_st
->n
.sym
;
1165 e
->symtree
= parent_st
; /* Point to the right thing. */
1167 if (sym
->attr
.flavor
== FL_PROCEDURE
1168 || sym
->attr
.intrinsic
1169 || sym
->attr
.external
)
1175 e
->expr_type
= EXPR_VARIABLE
;
1177 if (sym
->as
!= NULL
)
1179 e
->rank
= sym
->as
->rank
;
1180 e
->ref
= gfc_get_ref ();
1181 e
->ref
->type
= REF_ARRAY
;
1182 e
->ref
->u
.ar
.type
= AR_FULL
;
1183 e
->ref
->u
.ar
.as
= sym
->as
;
1186 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1187 primary.c (match_actual_arg). If above code determines that it
1188 is a variable instead, it needs to be resolved as it was not
1189 done at the beginning of this function. */
1190 save_need_full_assumed_size
= need_full_assumed_size
;
1191 if (e
->expr_type
!= FL_VARIABLE
)
1192 need_full_assumed_size
= 0;
1193 if (gfc_resolve_expr (e
) != SUCCESS
)
1195 need_full_assumed_size
= save_need_full_assumed_size
;
1198 /* Check argument list functions %VAL, %LOC and %REF. There is
1199 nothing to do for %REF. */
1200 if (arg
->name
&& arg
->name
[0] == '%')
1202 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1204 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1206 gfc_error ("By-value argument at %L is not of numeric "
1213 gfc_error ("By-value argument at %L cannot be an array or "
1214 "an array section", &e
->where
);
1218 /* Intrinsics are still PROC_UNKNOWN here. However,
1219 since same file external procedures are not resolvable
1220 in gfortran, it is a good deal easier to leave them to
1222 if (ptype
!= PROC_UNKNOWN
1223 && ptype
!= PROC_DUMMY
1224 && ptype
!= PROC_EXTERNAL
1225 && ptype
!= PROC_MODULE
)
1227 gfc_error ("By-value argument at %L is not allowed "
1228 "in this context", &e
->where
);
1233 /* Statement functions have already been excluded above. */
1234 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1235 && e
->ts
.type
== BT_PROCEDURE
)
1237 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1239 gfc_error ("Passing internal procedure at %L by location "
1240 "not allowed", &e
->where
);
1251 /* Do the checks of the actual argument list that are specific to elemental
1252 procedures. If called with c == NULL, we have a function, otherwise if
1253 expr == NULL, we have a subroutine. */
1256 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1258 gfc_actual_arglist
*arg0
;
1259 gfc_actual_arglist
*arg
;
1260 gfc_symbol
*esym
= NULL
;
1261 gfc_intrinsic_sym
*isym
= NULL
;
1263 gfc_intrinsic_arg
*iformal
= NULL
;
1264 gfc_formal_arglist
*eformal
= NULL
;
1265 bool formal_optional
= false;
1266 bool set_by_optional
= false;
1270 /* Is this an elemental procedure? */
1271 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1273 if (expr
->value
.function
.esym
!= NULL
1274 && expr
->value
.function
.esym
->attr
.elemental
)
1276 arg0
= expr
->value
.function
.actual
;
1277 esym
= expr
->value
.function
.esym
;
1279 else if (expr
->value
.function
.isym
!= NULL
1280 && expr
->value
.function
.isym
->elemental
)
1282 arg0
= expr
->value
.function
.actual
;
1283 isym
= expr
->value
.function
.isym
;
1288 else if (c
&& c
->ext
.actual
!= NULL
&& c
->symtree
->n
.sym
->attr
.elemental
)
1290 arg0
= c
->ext
.actual
;
1291 esym
= c
->symtree
->n
.sym
;
1296 /* The rank of an elemental is the rank of its array argument(s). */
1297 for (arg
= arg0
; arg
; arg
= arg
->next
)
1299 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1301 rank
= arg
->expr
->rank
;
1302 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1303 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1304 set_by_optional
= true;
1306 /* Function specific; set the result rank and shape. */
1310 if (!expr
->shape
&& arg
->expr
->shape
)
1312 expr
->shape
= gfc_get_shape (rank
);
1313 for (i
= 0; i
< rank
; i
++)
1314 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1321 /* If it is an array, it shall not be supplied as an actual argument
1322 to an elemental procedure unless an array of the same rank is supplied
1323 as an actual argument corresponding to a nonoptional dummy argument of
1324 that elemental procedure(12.4.1.5). */
1325 formal_optional
= false;
1327 iformal
= isym
->formal
;
1329 eformal
= esym
->formal
;
1331 for (arg
= arg0
; arg
; arg
= arg
->next
)
1335 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1336 formal_optional
= true;
1337 eformal
= eformal
->next
;
1339 else if (isym
&& iformal
)
1341 if (iformal
->optional
)
1342 formal_optional
= true;
1343 iformal
= iformal
->next
;
1346 formal_optional
= true;
1348 if (pedantic
&& arg
->expr
!= NULL
1349 && arg
->expr
->expr_type
== EXPR_VARIABLE
1350 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1353 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1354 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1356 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1357 "MISSING, it cannot be the actual argument of an "
1358 "ELEMENTAL procedure unless there is a non-optional "
1359 "argument with the same rank (12.4.1.5)",
1360 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1365 for (arg
= arg0
; arg
; arg
= arg
->next
)
1367 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1370 /* Being elemental, the last upper bound of an assumed size array
1371 argument must be present. */
1372 if (resolve_assumed_size_actual (arg
->expr
))
1375 /* Elemental procedure's array actual arguments must conform. */
1378 if (gfc_check_conformance ("elemental procedure", arg
->expr
, e
)
1386 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1387 is an array, the intent inout/out variable needs to be also an array. */
1388 if (rank
> 0 && esym
&& expr
== NULL
)
1389 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1390 arg
= arg
->next
, eformal
= eformal
->next
)
1391 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1392 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1393 && arg
->expr
&& arg
->expr
->rank
== 0)
1395 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1396 "ELEMENTAL subroutine '%s' is a scalar, but another "
1397 "actual argument is an array", &arg
->expr
->where
,
1398 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1399 : "INOUT", eformal
->sym
->name
, esym
->name
);
1406 /* Go through each actual argument in ACTUAL and see if it can be
1407 implemented as an inlined, non-copying intrinsic. FNSYM is the
1408 function being called, or NULL if not known. */
1411 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1413 gfc_actual_arglist
*ap
;
1416 for (ap
= actual
; ap
; ap
= ap
->next
)
1418 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1419 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
))
1420 ap
->expr
->inline_noncopying_intrinsic
= 1;
1424 /* This function does the checking of references to global procedures
1425 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1426 77 and 95 standards. It checks for a gsymbol for the name, making
1427 one if it does not already exist. If it already exists, then the
1428 reference being resolved must correspond to the type of gsymbol.
1429 Otherwise, the new symbol is equipped with the attributes of the
1430 reference. The corresponding code that is called in creating
1431 global entities is parse.c. */
1434 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1439 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1441 gsym
= gfc_get_gsymbol (sym
->name
);
1443 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1444 gfc_global_used (gsym
, where
);
1446 if (gsym
->type
== GSYM_UNKNOWN
)
1449 gsym
->where
= *where
;
1456 /************* Function resolution *************/
1458 /* Resolve a function call known to be generic.
1459 Section 14.1.2.4.1. */
1462 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1466 if (sym
->attr
.generic
)
1468 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1471 expr
->value
.function
.name
= s
->name
;
1472 expr
->value
.function
.esym
= s
;
1474 if (s
->ts
.type
!= BT_UNKNOWN
)
1476 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1477 expr
->ts
= s
->result
->ts
;
1480 expr
->rank
= s
->as
->rank
;
1481 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1482 expr
->rank
= s
->result
->as
->rank
;
1484 gfc_set_sym_referenced (expr
->value
.function
.esym
);
1489 /* TODO: Need to search for elemental references in generic
1493 if (sym
->attr
.intrinsic
)
1494 return gfc_intrinsic_func_interface (expr
, 0);
1501 resolve_generic_f (gfc_expr
*expr
)
1506 sym
= expr
->symtree
->n
.sym
;
1510 m
= resolve_generic_f0 (expr
, sym
);
1513 else if (m
== MATCH_ERROR
)
1517 if (sym
->ns
->parent
== NULL
)
1519 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1523 if (!generic_sym (sym
))
1527 /* Last ditch attempt. See if the reference is to an intrinsic
1528 that possesses a matching interface. 14.1.2.4 */
1529 if (sym
&& !gfc_intrinsic_name (sym
->name
, 0))
1531 gfc_error ("There is no specific function for the generic '%s' at %L",
1532 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1536 m
= gfc_intrinsic_func_interface (expr
, 0);
1540 gfc_error ("Generic function '%s' at %L is not consistent with a "
1541 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1548 /* Resolve a function call known to be specific. */
1551 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1555 /* See if we have an intrinsic interface. */
1557 if (sym
->interface
!= NULL
&& sym
->interface
->attr
.intrinsic
)
1559 gfc_intrinsic_sym
*isym
;
1560 isym
= gfc_find_function (sym
->interface
->name
);
1562 /* Existance of isym should be checked already. */
1566 sym
->attr
.function
= 1;
1567 sym
->attr
.proc
= PROC_EXTERNAL
;
1571 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1573 if (sym
->attr
.dummy
)
1575 sym
->attr
.proc
= PROC_DUMMY
;
1579 sym
->attr
.proc
= PROC_EXTERNAL
;
1583 if (sym
->attr
.proc
== PROC_MODULE
1584 || sym
->attr
.proc
== PROC_ST_FUNCTION
1585 || sym
->attr
.proc
== PROC_INTERNAL
)
1588 if (sym
->attr
.intrinsic
)
1590 m
= gfc_intrinsic_func_interface (expr
, 1);
1594 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1595 "with an intrinsic", sym
->name
, &expr
->where
);
1603 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1606 expr
->value
.function
.name
= sym
->name
;
1607 expr
->value
.function
.esym
= sym
;
1608 if (sym
->as
!= NULL
)
1609 expr
->rank
= sym
->as
->rank
;
1616 resolve_specific_f (gfc_expr
*expr
)
1621 sym
= expr
->symtree
->n
.sym
;
1625 m
= resolve_specific_f0 (sym
, expr
);
1628 if (m
== MATCH_ERROR
)
1631 if (sym
->ns
->parent
== NULL
)
1634 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1640 gfc_error ("Unable to resolve the specific function '%s' at %L",
1641 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1647 /* Resolve a procedure call not known to be generic nor specific. */
1650 resolve_unknown_f (gfc_expr
*expr
)
1655 sym
= expr
->symtree
->n
.sym
;
1657 if (sym
->attr
.dummy
)
1659 sym
->attr
.proc
= PROC_DUMMY
;
1660 expr
->value
.function
.name
= sym
->name
;
1664 /* See if we have an intrinsic function reference. */
1666 if (gfc_intrinsic_name (sym
->name
, 0))
1668 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1673 /* The reference is to an external name. */
1675 sym
->attr
.proc
= PROC_EXTERNAL
;
1676 expr
->value
.function
.name
= sym
->name
;
1677 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1679 if (sym
->as
!= NULL
)
1680 expr
->rank
= sym
->as
->rank
;
1682 /* Type of the expression is either the type of the symbol or the
1683 default type of the symbol. */
1686 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1688 if (sym
->ts
.type
!= BT_UNKNOWN
)
1692 ts
= gfc_get_default_type (sym
, sym
->ns
);
1694 if (ts
->type
== BT_UNKNOWN
)
1696 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1697 sym
->name
, &expr
->where
);
1708 /* Return true, if the symbol is an external procedure. */
1710 is_external_proc (gfc_symbol
*sym
)
1712 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1713 && !(sym
->attr
.intrinsic
1714 || gfc_intrinsic_name (sym
->name
, sym
->attr
.subroutine
))
1715 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1716 && !sym
->attr
.use_assoc
1724 /* Figure out if a function reference is pure or not. Also set the name
1725 of the function for a potential error message. Return nonzero if the
1726 function is PURE, zero if not. */
1728 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
1731 pure_function (gfc_expr
*e
, const char **name
)
1737 if (e
->symtree
!= NULL
1738 && e
->symtree
->n
.sym
!= NULL
1739 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1740 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
1742 if (e
->value
.function
.esym
)
1744 pure
= gfc_pure (e
->value
.function
.esym
);
1745 *name
= e
->value
.function
.esym
->name
;
1747 else if (e
->value
.function
.isym
)
1749 pure
= e
->value
.function
.isym
->pure
1750 || e
->value
.function
.isym
->elemental
;
1751 *name
= e
->value
.function
.isym
->name
;
1755 /* Implicit functions are not pure. */
1757 *name
= e
->value
.function
.name
;
1765 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
1766 int *f ATTRIBUTE_UNUSED
)
1770 /* Don't bother recursing into other statement functions
1771 since they will be checked individually for purity. */
1772 if (e
->expr_type
!= EXPR_FUNCTION
1774 || e
->symtree
->n
.sym
== sym
1775 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1778 return pure_function (e
, &name
) ? false : true;
1783 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
1785 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
1790 is_scalar_expr_ptr (gfc_expr
*expr
)
1792 try retval
= SUCCESS
;
1797 /* See if we have a gfc_ref, which means we have a substring, array
1798 reference, or a component. */
1799 if (expr
->ref
!= NULL
)
1802 while (ref
->next
!= NULL
)
1808 if (ref
->u
.ss
.length
!= NULL
1809 && ref
->u
.ss
.length
->length
!= NULL
1811 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1813 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1815 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1816 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1817 if (end
- start
+ 1 != 1)
1824 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1826 else if (ref
->u
.ar
.type
== AR_FULL
)
1828 /* The user can give a full array if the array is of size 1. */
1829 if (ref
->u
.ar
.as
!= NULL
1830 && ref
->u
.ar
.as
->rank
== 1
1831 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1832 && ref
->u
.ar
.as
->lower
[0] != NULL
1833 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1834 && ref
->u
.ar
.as
->upper
[0] != NULL
1835 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1837 /* If we have a character string, we need to check if
1838 its length is one. */
1839 if (expr
->ts
.type
== BT_CHARACTER
)
1841 if (expr
->ts
.cl
== NULL
1842 || expr
->ts
.cl
->length
== NULL
1843 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
1849 /* We have constant lower and upper bounds. If the
1850 difference between is 1, it can be considered a
1852 start
= (int) mpz_get_si
1853 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
1854 end
= (int) mpz_get_si
1855 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
1856 if (end
- start
+ 1 != 1)
1871 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
1873 /* Character string. Make sure it's of length 1. */
1874 if (expr
->ts
.cl
== NULL
1875 || expr
->ts
.cl
->length
== NULL
1876 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
1879 else if (expr
->rank
!= 0)
1886 /* Match one of the iso_c_binding functions (c_associated or c_loc)
1887 and, in the case of c_associated, set the binding label based on
1891 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
1892 gfc_symbol
**new_sym
)
1894 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1895 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
1896 int optional_arg
= 0;
1897 try retval
= SUCCESS
;
1898 gfc_symbol
*args_sym
;
1899 gfc_typespec
*arg_ts
;
1900 gfc_ref
*parent_ref
;
1903 if (args
->expr
->expr_type
== EXPR_CONSTANT
1904 || args
->expr
->expr_type
== EXPR_OP
1905 || args
->expr
->expr_type
== EXPR_NULL
)
1907 gfc_error ("Argument to '%s' at %L is not a variable",
1908 sym
->name
, &(args
->expr
->where
));
1912 args_sym
= args
->expr
->symtree
->n
.sym
;
1914 /* The typespec for the actual arg should be that stored in the expr
1915 and not necessarily that of the expr symbol (args_sym), because
1916 the actual expression could be a part-ref of the expr symbol. */
1917 arg_ts
= &(args
->expr
->ts
);
1919 /* Get the parent reference (if any) for the expression. This happens for
1920 cases such as a%b%c. */
1921 parent_ref
= args
->expr
->ref
;
1923 if (parent_ref
!= NULL
)
1925 curr_ref
= parent_ref
->next
;
1926 while (curr_ref
!= NULL
&& curr_ref
->next
!= NULL
)
1928 parent_ref
= curr_ref
;
1929 curr_ref
= curr_ref
->next
;
1933 /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref
1934 is for a REF_COMPONENT, then we need to use it as the parent_ref for
1935 the name, etc. Otherwise, the current parent_ref should be correct. */
1936 if (curr_ref
!= NULL
&& curr_ref
->type
== REF_COMPONENT
)
1937 parent_ref
= curr_ref
;
1939 if (parent_ref
== args
->expr
->ref
)
1941 else if (parent_ref
!= NULL
&& parent_ref
->type
!= REF_COMPONENT
)
1942 gfc_internal_error ("Unexpected expression reference type in "
1943 "gfc_iso_c_func_interface");
1945 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
1947 /* If the user gave two args then they are providing something for
1948 the optional arg (the second cptr). Therefore, set the name and
1949 binding label to the c_associated for two cptrs. Otherwise,
1950 set c_associated to expect one cptr. */
1954 sprintf (name
, "%s_2", sym
->name
);
1955 sprintf (binding_label
, "%s_2", sym
->binding_label
);
1961 sprintf (name
, "%s_1", sym
->name
);
1962 sprintf (binding_label
, "%s_1", sym
->binding_label
);
1966 /* Get a new symbol for the version of c_associated that
1968 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
1970 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
1971 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
1973 sprintf (name
, "%s", sym
->name
);
1974 sprintf (binding_label
, "%s", sym
->binding_label
);
1976 /* Error check the call. */
1977 if (args
->next
!= NULL
)
1979 gfc_error_now ("More actual than formal arguments in '%s' "
1980 "call at %L", name
, &(args
->expr
->where
));
1983 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
1985 /* Make sure we have either the target or pointer attribute. */
1986 if (!(args_sym
->attr
.target
)
1987 && !(args_sym
->attr
.pointer
)
1988 && (parent_ref
== NULL
||
1989 !parent_ref
->u
.c
.component
->pointer
))
1991 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
1992 "a TARGET or an associated pointer",
1994 sym
->name
, &(args
->expr
->where
));
1998 /* See if we have interoperable type and type param. */
1999 if (verify_c_interop (arg_ts
,
2000 (parent_ref
? parent_ref
->u
.c
.component
->name
2002 &(args
->expr
->where
)) == SUCCESS
2003 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2005 if (args_sym
->attr
.target
== 1)
2007 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2008 has the target attribute and is interoperable. */
2009 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2010 allocatable variable that has the TARGET attribute and
2011 is not an array of zero size. */
2012 if (args_sym
->attr
.allocatable
== 1)
2014 if (args_sym
->attr
.dimension
!= 0
2015 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2017 gfc_error_now ("Allocatable variable '%s' used as a "
2018 "parameter to '%s' at %L must not be "
2019 "an array of zero size",
2020 args_sym
->name
, sym
->name
,
2021 &(args
->expr
->where
));
2027 /* A non-allocatable target variable with C
2028 interoperable type and type parameters must be
2030 if (args_sym
&& args_sym
->attr
.dimension
)
2032 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2034 gfc_error ("Assumed-shape array '%s' at %L "
2035 "cannot be an argument to the "
2036 "procedure '%s' because "
2037 "it is not C interoperable",
2039 &(args
->expr
->where
), sym
->name
);
2042 else if (args_sym
->as
->type
== AS_DEFERRED
)
2044 gfc_error ("Deferred-shape array '%s' at %L "
2045 "cannot be an argument to the "
2046 "procedure '%s' because "
2047 "it is not C interoperable",
2049 &(args
->expr
->where
), sym
->name
);
2054 /* Make sure it's not a character string. Arrays of
2055 any type should be ok if the variable is of a C
2056 interoperable type. */
2057 if (arg_ts
->type
== BT_CHARACTER
)
2058 if (arg_ts
->cl
!= NULL
2059 && (arg_ts
->cl
->length
== NULL
2060 || arg_ts
->cl
->length
->expr_type
2063 (arg_ts
->cl
->length
->value
.integer
, 1)
2065 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2067 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2068 "at %L must have a length of 1",
2069 args_sym
->name
, sym
->name
,
2070 &(args
->expr
->where
));
2075 else if ((args_sym
->attr
.pointer
== 1 ||
2077 && parent_ref
->u
.c
.component
->pointer
))
2078 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2080 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2082 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2083 "associated scalar POINTER", args_sym
->name
,
2084 sym
->name
, &(args
->expr
->where
));
2090 /* The parameter is not required to be C interoperable. If it
2091 is not C interoperable, it must be a nonpolymorphic scalar
2092 with no length type parameters. It still must have either
2093 the pointer or target attribute, and it can be
2094 allocatable (but must be allocated when c_loc is called). */
2095 if (args
->expr
->rank
!= 0
2096 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2098 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2099 "scalar", args_sym
->name
, sym
->name
,
2100 &(args
->expr
->where
));
2103 else if (arg_ts
->type
== BT_CHARACTER
2104 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2106 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2107 "%L must have a length of 1",
2108 args_sym
->name
, sym
->name
,
2109 &(args
->expr
->where
));
2114 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2116 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2118 /* TODO: Update this error message to allow for procedure
2119 pointers once they are implemented. */
2120 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2122 args_sym
->name
, sym
->name
,
2123 &(args
->expr
->where
));
2126 else if (args_sym
->attr
.is_bind_c
!= 1)
2128 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2130 args_sym
->name
, sym
->name
,
2131 &(args
->expr
->where
));
2136 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2141 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2142 "iso_c_binding function: '%s'!\n", sym
->name
);
2149 /* Resolve a function call, which means resolving the arguments, then figuring
2150 out which entity the name refers to. */
2151 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2152 to INTENT(OUT) or INTENT(INOUT). */
2155 resolve_function (gfc_expr
*expr
)
2157 gfc_actual_arglist
*arg
;
2162 procedure_type p
= PROC_INTRINSIC
;
2166 sym
= expr
->symtree
->n
.sym
;
2168 if (sym
&& sym
->attr
.flavor
== FL_VARIABLE
)
2170 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2174 if (sym
&& sym
->attr
.abstract
)
2176 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2177 sym
->name
, &expr
->where
);
2181 /* If the procedure is external, check for usage. */
2182 if (sym
&& is_external_proc (sym
))
2183 resolve_global_procedure (sym
, &expr
->where
, 0);
2185 /* Switch off assumed size checking and do this again for certain kinds
2186 of procedure, once the procedure itself is resolved. */
2187 need_full_assumed_size
++;
2189 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2190 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2192 if (resolve_actual_arglist (expr
->value
.function
.actual
, p
) == FAILURE
)
2195 /* Need to setup the call to the correct c_associated, depending on
2196 the number of cptrs to user gives to compare. */
2197 if (sym
&& sym
->attr
.is_iso_c
== 1)
2199 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2203 /* Get the symtree for the new symbol (resolved func).
2204 the old one will be freed later, when it's no longer used. */
2205 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2208 /* Resume assumed_size checking. */
2209 need_full_assumed_size
--;
2211 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2213 && sym
->ts
.cl
->length
== NULL
2215 && expr
->value
.function
.esym
== NULL
2216 && !sym
->attr
.contained
)
2218 /* Internal procedures are taken care of in resolve_contained_fntype. */
2219 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2220 "be used at %L since it is not a dummy argument",
2221 sym
->name
, &expr
->where
);
2225 /* See if function is already resolved. */
2227 if (expr
->value
.function
.name
!= NULL
)
2229 if (expr
->ts
.type
== BT_UNKNOWN
)
2235 /* Apply the rules of section 14.1.2. */
2237 switch (procedure_kind (sym
))
2240 t
= resolve_generic_f (expr
);
2243 case PTYPE_SPECIFIC
:
2244 t
= resolve_specific_f (expr
);
2248 t
= resolve_unknown_f (expr
);
2252 gfc_internal_error ("resolve_function(): bad function type");
2256 /* If the expression is still a function (it might have simplified),
2257 then we check to see if we are calling an elemental function. */
2259 if (expr
->expr_type
!= EXPR_FUNCTION
)
2262 temp
= need_full_assumed_size
;
2263 need_full_assumed_size
= 0;
2265 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2268 if (omp_workshare_flag
2269 && expr
->value
.function
.esym
2270 && ! gfc_elemental (expr
->value
.function
.esym
))
2272 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2273 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2278 #define GENERIC_ID expr->value.function.isym->id
2279 else if (expr
->value
.function
.actual
!= NULL
2280 && expr
->value
.function
.isym
!= NULL
2281 && GENERIC_ID
!= GFC_ISYM_LBOUND
2282 && GENERIC_ID
!= GFC_ISYM_LEN
2283 && GENERIC_ID
!= GFC_ISYM_LOC
2284 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2286 /* Array intrinsics must also have the last upper bound of an
2287 assumed size array argument. UBOUND and SIZE have to be
2288 excluded from the check if the second argument is anything
2291 inquiry
= GENERIC_ID
== GFC_ISYM_UBOUND
2292 || GENERIC_ID
== GFC_ISYM_SIZE
;
2294 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2296 if (inquiry
&& arg
->next
!= NULL
&& arg
->next
->expr
)
2298 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2301 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2306 if (arg
->expr
!= NULL
2307 && arg
->expr
->rank
> 0
2308 && resolve_assumed_size_actual (arg
->expr
))
2314 need_full_assumed_size
= temp
;
2317 if (!pure_function (expr
, &name
) && name
)
2321 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2322 "FORALL %s", name
, &expr
->where
,
2323 forall_flag
== 2 ? "mask" : "block");
2326 else if (gfc_pure (NULL
))
2328 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2329 "procedure within a PURE procedure", name
, &expr
->where
);
2334 /* Functions without the RECURSIVE attribution are not allowed to
2335 * call themselves. */
2336 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2338 gfc_symbol
*esym
, *proc
;
2339 esym
= expr
->value
.function
.esym
;
2340 proc
= gfc_current_ns
->proc_name
;
2343 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
2344 "RECURSIVE", name
, &expr
->where
);
2348 if (esym
->attr
.entry
&& esym
->ns
->entries
&& proc
->ns
->entries
2349 && esym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2351 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
2352 "'%s' is not declared as RECURSIVE",
2353 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2358 /* Character lengths of use associated functions may contains references to
2359 symbols not referenced from the current program unit otherwise. Make sure
2360 those symbols are marked as referenced. */
2362 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2363 && expr
->value
.function
.esym
->attr
.use_assoc
)
2365 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2369 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2370 expr
->value
.function
.actual
);
2372 /* Make sure that the expression has a typespec that works. */
2373 if (expr
->ts
.type
== BT_UNKNOWN
)
2375 if (expr
->symtree
->n
.sym
->result
2376 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2377 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2384 /************* Subroutine resolution *************/
2387 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2393 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2394 sym
->name
, &c
->loc
);
2395 else if (gfc_pure (NULL
))
2396 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2402 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2406 if (sym
->attr
.generic
)
2408 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2411 c
->resolved_sym
= s
;
2412 pure_subroutine (c
, s
);
2416 /* TODO: Need to search for elemental references in generic interface. */
2419 if (sym
->attr
.intrinsic
)
2420 return gfc_intrinsic_sub_interface (c
, 0);
2427 resolve_generic_s (gfc_code
*c
)
2432 sym
= c
->symtree
->n
.sym
;
2436 m
= resolve_generic_s0 (c
, sym
);
2439 else if (m
== MATCH_ERROR
)
2443 if (sym
->ns
->parent
== NULL
)
2445 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2449 if (!generic_sym (sym
))
2453 /* Last ditch attempt. See if the reference is to an intrinsic
2454 that possesses a matching interface. 14.1.2.4 */
2455 sym
= c
->symtree
->n
.sym
;
2457 if (!gfc_intrinsic_name (sym
->name
, 1))
2459 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2460 sym
->name
, &c
->loc
);
2464 m
= gfc_intrinsic_sub_interface (c
, 0);
2468 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2469 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2475 /* Set the name and binding label of the subroutine symbol in the call
2476 expression represented by 'c' to include the type and kind of the
2477 second parameter. This function is for resolving the appropriate
2478 version of c_f_pointer() and c_f_procpointer(). For example, a
2479 call to c_f_pointer() for a default integer pointer could have a
2480 name of c_f_pointer_i4. If no second arg exists, which is an error
2481 for these two functions, it defaults to the generic symbol's name
2482 and binding label. */
2485 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2486 char *name
, char *binding_label
)
2488 gfc_expr
*arg
= NULL
;
2492 /* The second arg of c_f_pointer and c_f_procpointer determines
2493 the type and kind for the procedure name. */
2494 arg
= c
->ext
.actual
->next
->expr
;
2498 /* Set up the name to have the given symbol's name,
2499 plus the type and kind. */
2500 /* a derived type is marked with the type letter 'u' */
2501 if (arg
->ts
.type
== BT_DERIVED
)
2504 kind
= 0; /* set the kind as 0 for now */
2508 type
= gfc_type_letter (arg
->ts
.type
);
2509 kind
= arg
->ts
.kind
;
2512 if (arg
->ts
.type
== BT_CHARACTER
)
2513 /* Kind info for character strings not needed. */
2516 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2517 /* Set up the binding label as the given symbol's label plus
2518 the type and kind. */
2519 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2523 /* If the second arg is missing, set the name and label as
2524 was, cause it should at least be found, and the missing
2525 arg error will be caught by compare_parameters(). */
2526 sprintf (name
, "%s", sym
->name
);
2527 sprintf (binding_label
, "%s", sym
->binding_label
);
2534 /* Resolve a generic version of the iso_c_binding procedure given
2535 (sym) to the specific one based on the type and kind of the
2536 argument(s). Currently, this function resolves c_f_pointer() and
2537 c_f_procpointer based on the type and kind of the second argument
2538 (FPTR). Other iso_c_binding procedures aren't specially handled.
2539 Upon successfully exiting, c->resolved_sym will hold the resolved
2540 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2544 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2546 gfc_symbol
*new_sym
;
2547 /* this is fine, since we know the names won't use the max */
2548 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2549 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2550 /* default to success; will override if find error */
2551 match m
= MATCH_YES
;
2553 /* Make sure the actual arguments are in the necessary order (based on the
2554 formal args) before resolving. */
2555 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2557 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2558 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2560 set_name_and_label (c
, sym
, name
, binding_label
);
2562 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2564 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2566 /* Make sure we got a third arg if the second arg has non-zero
2567 rank. We must also check that the type and rank are
2568 correct since we short-circuit this check in
2569 gfc_procedure_use() (called above to sort actual args). */
2570 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2572 if(c
->ext
.actual
->next
->next
== NULL
2573 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2576 gfc_error ("Missing SHAPE parameter for call to %s "
2577 "at %L", sym
->name
, &(c
->loc
));
2579 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2581 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2584 gfc_error ("SHAPE parameter for call to %s at %L must "
2585 "be a rank 1 INTEGER array", sym
->name
,
2592 if (m
!= MATCH_ERROR
)
2594 /* the 1 means to add the optional arg to formal list */
2595 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2597 /* for error reporting, say it's declared where the original was */
2598 new_sym
->declared_at
= sym
->declared_at
;
2603 /* no differences for c_loc or c_funloc */
2607 /* set the resolved symbol */
2608 if (m
!= MATCH_ERROR
)
2609 c
->resolved_sym
= new_sym
;
2611 c
->resolved_sym
= sym
;
2617 /* Resolve a subroutine call known to be specific. */
2620 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2624 /* See if we have an intrinsic interface. */
2625 if (sym
->interface
!= NULL
&& !sym
->interface
->attr
.abstract
2626 && !sym
->interface
->attr
.subroutine
)
2628 gfc_intrinsic_sym
*isym
;
2630 isym
= gfc_find_function (sym
->interface
->name
);
2632 /* Existance of isym should be checked already. */
2636 sym
->attr
.function
= 1;
2640 if(sym
->attr
.is_iso_c
)
2642 m
= gfc_iso_c_sub_interface (c
,sym
);
2646 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2648 if (sym
->attr
.dummy
)
2650 sym
->attr
.proc
= PROC_DUMMY
;
2654 sym
->attr
.proc
= PROC_EXTERNAL
;
2658 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2661 if (sym
->attr
.intrinsic
)
2663 m
= gfc_intrinsic_sub_interface (c
, 1);
2667 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2668 "with an intrinsic", sym
->name
, &c
->loc
);
2676 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2678 c
->resolved_sym
= sym
;
2679 pure_subroutine (c
, sym
);
2686 resolve_specific_s (gfc_code
*c
)
2691 sym
= c
->symtree
->n
.sym
;
2695 m
= resolve_specific_s0 (c
, sym
);
2698 if (m
== MATCH_ERROR
)
2701 if (sym
->ns
->parent
== NULL
)
2704 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2710 sym
= c
->symtree
->n
.sym
;
2711 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2712 sym
->name
, &c
->loc
);
2718 /* Resolve a subroutine call not known to be generic nor specific. */
2721 resolve_unknown_s (gfc_code
*c
)
2725 sym
= c
->symtree
->n
.sym
;
2727 if (sym
->attr
.dummy
)
2729 sym
->attr
.proc
= PROC_DUMMY
;
2733 /* See if we have an intrinsic function reference. */
2735 if (gfc_intrinsic_name (sym
->name
, 1))
2737 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2742 /* The reference is to an external name. */
2745 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2747 c
->resolved_sym
= sym
;
2749 pure_subroutine (c
, sym
);
2755 /* Resolve a subroutine call. Although it was tempting to use the same code
2756 for functions, subroutines and functions are stored differently and this
2757 makes things awkward. */
2760 resolve_call (gfc_code
*c
)
2763 procedure_type ptype
= PROC_INTRINSIC
;
2765 if (c
->symtree
&& c
->symtree
->n
.sym
2766 && c
->symtree
->n
.sym
->ts
.type
!= BT_UNKNOWN
)
2768 gfc_error ("'%s' at %L has a type, which is not consistent with "
2769 "the CALL at %L", c
->symtree
->n
.sym
->name
,
2770 &c
->symtree
->n
.sym
->declared_at
, &c
->loc
);
2774 /* If external, check for usage. */
2775 if (c
->symtree
&& is_external_proc (c
->symtree
->n
.sym
))
2776 resolve_global_procedure (c
->symtree
->n
.sym
, &c
->loc
, 1);
2778 /* Subroutines without the RECURSIVE attribution are not allowed to
2779 * call themselves. */
2780 if (c
->symtree
&& c
->symtree
->n
.sym
&& !c
->symtree
->n
.sym
->attr
.recursive
)
2782 gfc_symbol
*csym
, *proc
;
2783 csym
= c
->symtree
->n
.sym
;
2784 proc
= gfc_current_ns
->proc_name
;
2787 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
2788 "RECURSIVE", csym
->name
, &c
->loc
);
2792 if (csym
->attr
.entry
&& csym
->ns
->entries
&& proc
->ns
->entries
2793 && csym
->ns
->entries
->sym
== proc
->ns
->entries
->sym
)
2795 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
2796 "'%s' is not declared as RECURSIVE",
2797 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2802 /* Switch off assumed size checking and do this again for certain kinds
2803 of procedure, once the procedure itself is resolved. */
2804 need_full_assumed_size
++;
2806 if (c
->symtree
&& c
->symtree
->n
.sym
)
2807 ptype
= c
->symtree
->n
.sym
->attr
.proc
;
2809 if (resolve_actual_arglist (c
->ext
.actual
, ptype
) == FAILURE
)
2812 /* Resume assumed_size checking. */
2813 need_full_assumed_size
--;
2816 if (c
->resolved_sym
== NULL
)
2817 switch (procedure_kind (c
->symtree
->n
.sym
))
2820 t
= resolve_generic_s (c
);
2823 case PTYPE_SPECIFIC
:
2824 t
= resolve_specific_s (c
);
2828 t
= resolve_unknown_s (c
);
2832 gfc_internal_error ("resolve_subroutine(): bad function type");
2835 /* Some checks of elemental subroutine actual arguments. */
2836 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2840 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
2845 /* Compare the shapes of two arrays that have non-NULL shapes. If both
2846 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
2847 match. If both op1->shape and op2->shape are non-NULL return FAILURE
2848 if their shapes do not match. If either op1->shape or op2->shape is
2849 NULL, return SUCCESS. */
2852 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
2859 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
2861 for (i
= 0; i
< op1
->rank
; i
++)
2863 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
2865 gfc_error ("Shapes for operands at %L and %L are not conformable",
2866 &op1
->where
, &op2
->where
);
2877 /* Resolve an operator expression node. This can involve replacing the
2878 operation with a user defined function call. */
2881 resolve_operator (gfc_expr
*e
)
2883 gfc_expr
*op1
, *op2
;
2885 bool dual_locus_error
;
2888 /* Resolve all subnodes-- give them types. */
2890 switch (e
->value
.op
.operator)
2893 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
2896 /* Fall through... */
2899 case INTRINSIC_UPLUS
:
2900 case INTRINSIC_UMINUS
:
2901 case INTRINSIC_PARENTHESES
:
2902 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
2907 /* Typecheck the new node. */
2909 op1
= e
->value
.op
.op1
;
2910 op2
= e
->value
.op
.op2
;
2911 dual_locus_error
= false;
2913 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
2914 || (op2
&& op2
->expr_type
== EXPR_NULL
))
2916 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
2920 switch (e
->value
.op
.operator)
2922 case INTRINSIC_UPLUS
:
2923 case INTRINSIC_UMINUS
:
2924 if (op1
->ts
.type
== BT_INTEGER
2925 || op1
->ts
.type
== BT_REAL
2926 || op1
->ts
.type
== BT_COMPLEX
)
2932 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
2933 gfc_op2string (e
->value
.op
.operator), gfc_typename (&e
->ts
));
2936 case INTRINSIC_PLUS
:
2937 case INTRINSIC_MINUS
:
2938 case INTRINSIC_TIMES
:
2939 case INTRINSIC_DIVIDE
:
2940 case INTRINSIC_POWER
:
2941 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
2943 gfc_type_convert_binary (e
);
2948 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
2949 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2950 gfc_typename (&op2
->ts
));
2953 case INTRINSIC_CONCAT
:
2954 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
2956 e
->ts
.type
= BT_CHARACTER
;
2957 e
->ts
.kind
= op1
->ts
.kind
;
2962 _("Operands of string concatenation operator at %%L are %s/%s"),
2963 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
2969 case INTRINSIC_NEQV
:
2970 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
2972 e
->ts
.type
= BT_LOGICAL
;
2973 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
2974 if (op1
->ts
.kind
< e
->ts
.kind
)
2975 gfc_convert_type (op1
, &e
->ts
, 2);
2976 else if (op2
->ts
.kind
< e
->ts
.kind
)
2977 gfc_convert_type (op2
, &e
->ts
, 2);
2981 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
2982 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
2983 gfc_typename (&op2
->ts
));
2988 if (op1
->ts
.type
== BT_LOGICAL
)
2990 e
->ts
.type
= BT_LOGICAL
;
2991 e
->ts
.kind
= op1
->ts
.kind
;
2995 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
2996 gfc_typename (&op1
->ts
));
3000 case INTRINSIC_GT_OS
:
3002 case INTRINSIC_GE_OS
:
3004 case INTRINSIC_LT_OS
:
3006 case INTRINSIC_LE_OS
:
3007 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3009 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3013 /* Fall through... */
3016 case INTRINSIC_EQ_OS
:
3018 case INTRINSIC_NE_OS
:
3019 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
)
3021 e
->ts
.type
= BT_LOGICAL
;
3022 e
->ts
.kind
= gfc_default_logical_kind
;
3026 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3028 gfc_type_convert_binary (e
);
3030 e
->ts
.type
= BT_LOGICAL
;
3031 e
->ts
.kind
= gfc_default_logical_kind
;
3035 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3037 _("Logicals at %%L must be compared with %s instead of %s"),
3038 (e
->value
.op
.operator == INTRINSIC_EQ
3039 || e
->value
.op
.operator == INTRINSIC_EQ_OS
)
3040 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.operator));
3043 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3044 gfc_op2string (e
->value
.op
.operator), gfc_typename (&op1
->ts
),
3045 gfc_typename (&op2
->ts
));
3049 case INTRINSIC_USER
:
3050 if (e
->value
.op
.uop
->operator == NULL
)
3051 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3052 else if (op2
== NULL
)
3053 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3054 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3056 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3057 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3058 gfc_typename (&op2
->ts
));
3062 case INTRINSIC_PARENTHESES
:
3064 if (e
->ts
.type
== BT_CHARACTER
)
3065 e
->ts
.cl
= op1
->ts
.cl
;
3069 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3072 /* Deal with arrayness of an operand through an operator. */
3076 switch (e
->value
.op
.operator)
3078 case INTRINSIC_PLUS
:
3079 case INTRINSIC_MINUS
:
3080 case INTRINSIC_TIMES
:
3081 case INTRINSIC_DIVIDE
:
3082 case INTRINSIC_POWER
:
3083 case INTRINSIC_CONCAT
:
3087 case INTRINSIC_NEQV
:
3089 case INTRINSIC_EQ_OS
:
3091 case INTRINSIC_NE_OS
:
3093 case INTRINSIC_GT_OS
:
3095 case INTRINSIC_GE_OS
:
3097 case INTRINSIC_LT_OS
:
3099 case INTRINSIC_LE_OS
:
3101 if (op1
->rank
== 0 && op2
->rank
== 0)
3104 if (op1
->rank
== 0 && op2
->rank
!= 0)
3106 e
->rank
= op2
->rank
;
3108 if (e
->shape
== NULL
)
3109 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3112 if (op1
->rank
!= 0 && op2
->rank
== 0)
3114 e
->rank
= op1
->rank
;
3116 if (e
->shape
== NULL
)
3117 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3120 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3122 if (op1
->rank
== op2
->rank
)
3124 e
->rank
= op1
->rank
;
3125 if (e
->shape
== NULL
)
3127 t
= compare_shapes(op1
, op2
);
3131 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3136 /* Allow higher level expressions to work. */
3139 /* Try user-defined operators, and otherwise throw an error. */
3140 dual_locus_error
= true;
3142 _("Inconsistent ranks for operator at %%L and %%L"));
3149 case INTRINSIC_PARENTHESES
:
3151 case INTRINSIC_UPLUS
:
3152 case INTRINSIC_UMINUS
:
3153 /* Simply copy arrayness attribute */
3154 e
->rank
= op1
->rank
;
3156 if (e
->shape
== NULL
)
3157 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3165 /* Attempt to simplify the expression. */
3168 t
= gfc_simplify_expr (e
, 0);
3169 /* Some calls do not succeed in simplification and return FAILURE
3170 even though there is no error; eg. variable references to
3171 PARAMETER arrays. */
3172 if (!gfc_is_constant_expr (e
))
3179 if (gfc_extend_expr (e
) == SUCCESS
)
3182 if (dual_locus_error
)
3183 gfc_error (msg
, &op1
->where
, &op2
->where
);
3185 gfc_error (msg
, &e
->where
);
3191 /************** Array resolution subroutines **************/
3194 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3197 /* Compare two integer expressions. */
3200 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3204 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3205 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3208 /* If either of the types isn't INTEGER, we must have
3209 raised an error earlier. */
3211 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3214 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3224 /* Compare an integer expression with an integer. */
3227 compare_bound_int (gfc_expr
*a
, int b
)
3231 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3234 if (a
->ts
.type
!= BT_INTEGER
)
3235 gfc_internal_error ("compare_bound_int(): Bad expression");
3237 i
= mpz_cmp_si (a
->value
.integer
, b
);
3247 /* Compare an integer expression with a mpz_t. */
3250 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3254 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3257 if (a
->ts
.type
!= BT_INTEGER
)
3258 gfc_internal_error ("compare_bound_int(): Bad expression");
3260 i
= mpz_cmp (a
->value
.integer
, b
);
3270 /* Compute the last value of a sequence given by a triplet.
3271 Return 0 if it wasn't able to compute the last value, or if the
3272 sequence if empty, and 1 otherwise. */
3275 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3276 gfc_expr
*stride
, mpz_t last
)
3280 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3281 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3282 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3285 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3286 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3289 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3291 if (compare_bound (start
, end
) == CMP_GT
)
3293 mpz_set (last
, end
->value
.integer
);
3297 if (compare_bound_int (stride
, 0) == CMP_GT
)
3299 /* Stride is positive */
3300 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3305 /* Stride is negative */
3306 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3311 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3312 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3313 mpz_sub (last
, end
->value
.integer
, rem
);
3320 /* Compare a single dimension of an array reference to the array
3324 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3328 /* Given start, end and stride values, calculate the minimum and
3329 maximum referenced indexes. */
3331 switch (ar
->dimen_type
[i
])
3337 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3339 gfc_warning ("Array reference at %L is out of bounds "
3340 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3341 mpz_get_si (ar
->start
[i
]->value
.integer
),
3342 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3345 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3347 gfc_warning ("Array reference at %L is out of bounds "
3348 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3349 mpz_get_si (ar
->start
[i
]->value
.integer
),
3350 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3358 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3359 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3361 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3363 /* Check for zero stride, which is not allowed. */
3364 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3366 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3370 /* if start == len || (stride > 0 && start < len)
3371 || (stride < 0 && start > len),
3372 then the array section contains at least one element. In this
3373 case, there is an out-of-bounds access if
3374 (start < lower || start > upper). */
3375 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3376 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3377 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3378 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3379 && comp_start_end
== CMP_GT
))
3381 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3383 gfc_warning ("Lower array reference at %L is out of bounds "
3384 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3385 mpz_get_si (AR_START
->value
.integer
),
3386 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3389 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3391 gfc_warning ("Lower array reference at %L is out of bounds "
3392 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3393 mpz_get_si (AR_START
->value
.integer
),
3394 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3399 /* If we can compute the highest index of the array section,
3400 then it also has to be between lower and upper. */
3401 mpz_init (last_value
);
3402 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3405 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
3407 gfc_warning ("Upper array reference at %L is out of bounds "
3408 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3409 mpz_get_si (last_value
),
3410 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3411 mpz_clear (last_value
);
3414 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3416 gfc_warning ("Upper array reference at %L is out of bounds "
3417 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3418 mpz_get_si (last_value
),
3419 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3420 mpz_clear (last_value
);
3424 mpz_clear (last_value
);
3432 gfc_internal_error ("check_dimension(): Bad array reference");
3439 /* Compare an array reference with an array specification. */
3442 compare_spec_to_ref (gfc_array_ref
*ar
)
3449 /* TODO: Full array sections are only allowed as actual parameters. */
3450 if (as
->type
== AS_ASSUMED_SIZE
3451 && (/*ar->type == AR_FULL
3452 ||*/ (ar
->type
== AR_SECTION
3453 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3455 gfc_error ("Rightmost upper bound of assumed size array section "
3456 "not specified at %L", &ar
->where
);
3460 if (ar
->type
== AR_FULL
)
3463 if (as
->rank
!= ar
->dimen
)
3465 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3466 &ar
->where
, ar
->dimen
, as
->rank
);
3470 for (i
= 0; i
< as
->rank
; i
++)
3471 if (check_dimension (i
, ar
, as
) == FAILURE
)
3478 /* Resolve one part of an array index. */
3481 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3488 if (gfc_resolve_expr (index
) == FAILURE
)
3491 if (check_scalar
&& index
->rank
!= 0)
3493 gfc_error ("Array index at %L must be scalar", &index
->where
);
3497 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3499 gfc_error ("Array index at %L must be of INTEGER type",
3504 if (index
->ts
.type
== BT_REAL
)
3505 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3506 &index
->where
) == FAILURE
)
3509 if (index
->ts
.kind
!= gfc_index_integer_kind
3510 || index
->ts
.type
!= BT_INTEGER
)
3513 ts
.type
= BT_INTEGER
;
3514 ts
.kind
= gfc_index_integer_kind
;
3516 gfc_convert_type_warn (index
, &ts
, 2, 0);
3522 /* Resolve a dim argument to an intrinsic function. */
3525 gfc_resolve_dim_arg (gfc_expr
*dim
)
3530 if (gfc_resolve_expr (dim
) == FAILURE
)
3535 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3540 if (dim
->ts
.type
!= BT_INTEGER
)
3542 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3546 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3550 ts
.type
= BT_INTEGER
;
3551 ts
.kind
= gfc_index_integer_kind
;
3553 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3559 /* Given an expression that contains array references, update those array
3560 references to point to the right array specifications. While this is
3561 filled in during matching, this information is difficult to save and load
3562 in a module, so we take care of it here.
3564 The idea here is that the original array reference comes from the
3565 base symbol. We traverse the list of reference structures, setting
3566 the stored reference to references. Component references can
3567 provide an additional array specification. */
3570 find_array_spec (gfc_expr
*e
)
3574 gfc_symbol
*derived
;
3577 as
= e
->symtree
->n
.sym
->as
;
3580 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3585 gfc_internal_error ("find_array_spec(): Missing spec");
3592 if (derived
== NULL
)
3593 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3595 c
= derived
->components
;
3597 for (; c
; c
= c
->next
)
3598 if (c
== ref
->u
.c
.component
)
3600 /* Track the sequence of component references. */
3601 if (c
->ts
.type
== BT_DERIVED
)
3602 derived
= c
->ts
.derived
;
3607 gfc_internal_error ("find_array_spec(): Component not found");
3612 gfc_internal_error ("find_array_spec(): unused as(1)");
3623 gfc_internal_error ("find_array_spec(): unused as(2)");
3627 /* Resolve an array reference. */
3630 resolve_array_ref (gfc_array_ref
*ar
)
3632 int i
, check_scalar
;
3635 for (i
= 0; i
< ar
->dimen
; i
++)
3637 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3639 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3641 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3643 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3648 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3652 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3656 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3657 if (e
->expr_type
== EXPR_VARIABLE
3658 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3659 ar
->start
[i
] = gfc_get_parentheses (e
);
3663 gfc_error ("Array index at %L is an array of rank %d",
3664 &ar
->c_where
[i
], e
->rank
);
3669 /* If the reference type is unknown, figure out what kind it is. */
3671 if (ar
->type
== AR_UNKNOWN
)
3673 ar
->type
= AR_ELEMENT
;
3674 for (i
= 0; i
< ar
->dimen
; i
++)
3675 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3676 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3678 ar
->type
= AR_SECTION
;
3683 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3691 resolve_substring (gfc_ref
*ref
)
3693 if (ref
->u
.ss
.start
!= NULL
)
3695 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3698 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3700 gfc_error ("Substring start index at %L must be of type INTEGER",
3701 &ref
->u
.ss
.start
->where
);
3705 if (ref
->u
.ss
.start
->rank
!= 0)
3707 gfc_error ("Substring start index at %L must be scalar",
3708 &ref
->u
.ss
.start
->where
);
3712 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3713 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3714 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3716 gfc_error ("Substring start index at %L is less than one",
3717 &ref
->u
.ss
.start
->where
);
3722 if (ref
->u
.ss
.end
!= NULL
)
3724 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3727 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3729 gfc_error ("Substring end index at %L must be of type INTEGER",
3730 &ref
->u
.ss
.end
->where
);
3734 if (ref
->u
.ss
.end
->rank
!= 0)
3736 gfc_error ("Substring end index at %L must be scalar",
3737 &ref
->u
.ss
.end
->where
);
3741 if (ref
->u
.ss
.length
!= NULL
3742 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3743 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3744 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3746 gfc_error ("Substring end index at %L exceeds the string length",
3747 &ref
->u
.ss
.start
->where
);
3756 /* This function supplies missing substring charlens. */
3759 gfc_resolve_substring_charlen (gfc_expr
*e
)
3762 gfc_expr
*start
, *end
;
3764 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
3765 if (char_ref
->type
== REF_SUBSTRING
)
3771 gcc_assert (char_ref
->next
== NULL
);
3775 if (e
->ts
.cl
->length
)
3776 gfc_free_expr (e
->ts
.cl
->length
);
3777 else if (e
->expr_type
== EXPR_VARIABLE
3778 && e
->symtree
->n
.sym
->attr
.dummy
)
3782 e
->ts
.type
= BT_CHARACTER
;
3783 e
->ts
.kind
= gfc_default_character_kind
;
3787 e
->ts
.cl
= gfc_get_charlen ();
3788 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
3789 gfc_current_ns
->cl_list
= e
->ts
.cl
;
3792 if (char_ref
->u
.ss
.start
)
3793 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
3795 start
= gfc_int_expr (1);
3797 if (char_ref
->u
.ss
.end
)
3798 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
3799 else if (e
->expr_type
== EXPR_VARIABLE
)
3800 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.cl
->length
);
3807 /* Length = (end - start +1). */
3808 e
->ts
.cl
->length
= gfc_subtract (end
, start
);
3809 e
->ts
.cl
->length
= gfc_add (e
->ts
.cl
->length
, gfc_int_expr (1));
3811 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
3812 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
3814 /* Make sure that the length is simplified. */
3815 gfc_simplify_expr (e
->ts
.cl
->length
, 1);
3816 gfc_resolve_expr (e
->ts
.cl
->length
);
3820 /* Resolve subtype references. */
3823 resolve_ref (gfc_expr
*expr
)
3825 int current_part_dimension
, n_components
, seen_part_dimension
;
3828 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3829 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3831 find_array_spec (expr
);
3835 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3839 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
3847 resolve_substring (ref
);
3851 /* Check constraints on part references. */
3853 current_part_dimension
= 0;
3854 seen_part_dimension
= 0;
3857 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3862 switch (ref
->u
.ar
.type
)
3866 current_part_dimension
= 1;
3870 current_part_dimension
= 0;
3874 gfc_internal_error ("resolve_ref(): Bad array reference");
3880 if (current_part_dimension
|| seen_part_dimension
)
3882 if (ref
->u
.c
.component
->pointer
)
3884 gfc_error ("Component to the right of a part reference "
3885 "with nonzero rank must not have the POINTER "
3886 "attribute at %L", &expr
->where
);
3889 else if (ref
->u
.c
.component
->allocatable
)
3891 gfc_error ("Component to the right of a part reference "
3892 "with nonzero rank must not have the ALLOCATABLE "
3893 "attribute at %L", &expr
->where
);
3905 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
3906 || ref
->next
== NULL
)
3907 && current_part_dimension
3908 && seen_part_dimension
)
3910 gfc_error ("Two or more part references with nonzero rank must "
3911 "not be specified at %L", &expr
->where
);
3915 if (ref
->type
== REF_COMPONENT
)
3917 if (current_part_dimension
)
3918 seen_part_dimension
= 1;
3920 /* reset to make sure */
3921 current_part_dimension
= 0;
3929 /* Given an expression, determine its shape. This is easier than it sounds.
3930 Leaves the shape array NULL if it is not possible to determine the shape. */
3933 expression_shape (gfc_expr
*e
)
3935 mpz_t array
[GFC_MAX_DIMENSIONS
];
3938 if (e
->rank
== 0 || e
->shape
!= NULL
)
3941 for (i
= 0; i
< e
->rank
; i
++)
3942 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
3945 e
->shape
= gfc_get_shape (e
->rank
);
3947 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
3952 for (i
--; i
>= 0; i
--)
3953 mpz_clear (array
[i
]);
3957 /* Given a variable expression node, compute the rank of the expression by
3958 examining the base symbol and any reference structures it may have. */
3961 expression_rank (gfc_expr
*e
)
3968 if (e
->expr_type
== EXPR_ARRAY
)
3970 /* Constructors can have a rank different from one via RESHAPE(). */
3972 if (e
->symtree
== NULL
)
3978 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
3979 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
3985 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3987 if (ref
->type
!= REF_ARRAY
)
3990 if (ref
->u
.ar
.type
== AR_FULL
)
3992 rank
= ref
->u
.ar
.as
->rank
;
3996 if (ref
->u
.ar
.type
== AR_SECTION
)
3998 /* Figure out the rank of the section. */
4000 gfc_internal_error ("expression_rank(): Two array specs");
4002 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4003 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4004 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4014 expression_shape (e
);
4018 /* Resolve a variable expression. */
4021 resolve_variable (gfc_expr
*e
)
4028 if (e
->symtree
== NULL
)
4031 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
4034 sym
= e
->symtree
->n
.sym
;
4035 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
4037 e
->ts
.type
= BT_PROCEDURE
;
4041 if (sym
->ts
.type
!= BT_UNKNOWN
)
4042 gfc_variable_attr (e
, &e
->ts
);
4045 /* Must be a simple variable reference. */
4046 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
4051 if (check_assumed_size_reference (sym
, e
))
4054 /* Deal with forward references to entries during resolve_code, to
4055 satisfy, at least partially, 12.5.2.5. */
4056 if (gfc_current_ns
->entries
4057 && current_entry_id
== sym
->entry_id
4060 && cs_base
->current
->op
!= EXEC_ENTRY
)
4062 gfc_entry_list
*entry
;
4063 gfc_formal_arglist
*formal
;
4067 /* If the symbol is a dummy... */
4068 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4070 entry
= gfc_current_ns
->entries
;
4073 /* ...test if the symbol is a parameter of previous entries. */
4074 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4075 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4077 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4081 /* If it has not been seen as a dummy, this is an error. */
4084 if (specification_expr
)
4085 gfc_error ("Variable '%s', used in a specification expression"
4086 ", is referenced at %L before the ENTRY statement "
4087 "in which it is a parameter",
4088 sym
->name
, &cs_base
->current
->loc
);
4090 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4091 "statement in which it is a parameter",
4092 sym
->name
, &cs_base
->current
->loc
);
4097 /* Now do the same check on the specification expressions. */
4098 specification_expr
= 1;
4099 if (sym
->ts
.type
== BT_CHARACTER
4100 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
4104 for (n
= 0; n
< sym
->as
->rank
; n
++)
4106 specification_expr
= 1;
4107 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
4109 specification_expr
= 1;
4110 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
4113 specification_expr
= 0;
4116 /* Update the symbol's entry level. */
4117 sym
->entry_id
= current_entry_id
+ 1;
4124 /* Checks to see that the correct symbol has been host associated.
4125 The only situation where this arises is that in which a twice
4126 contained function is parsed after the host association is made.
4127 Therefore, on detecting this, the line is rematched, having got
4128 rid of the existing references and actual_arg_list. */
4130 check_host_association (gfc_expr
*e
)
4132 gfc_symbol
*sym
, *old_sym
;
4136 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
4138 if (e
->symtree
== NULL
|| e
->symtree
->n
.sym
== NULL
)
4141 old_sym
= e
->symtree
->n
.sym
;
4143 if (old_sym
->attr
.use_assoc
)
4146 if (gfc_current_ns
->parent
4147 && old_sym
->ns
!= gfc_current_ns
)
4149 gfc_find_symbol (old_sym
->name
, gfc_current_ns
, 1, &sym
);
4150 if (sym
&& old_sym
!= sym
4151 && sym
->attr
.flavor
== FL_PROCEDURE
4152 && sym
->attr
.contained
)
4154 temp_locus
= gfc_current_locus
;
4155 gfc_current_locus
= e
->where
;
4157 gfc_buffer_error (1);
4159 gfc_free_ref_list (e
->ref
);
4164 gfc_free_actual_arglist (e
->value
.function
.actual
);
4165 e
->value
.function
.actual
= NULL
;
4168 if (e
->shape
!= NULL
)
4170 for (n
= 0; n
< e
->rank
; n
++)
4171 mpz_clear (e
->shape
[n
]);
4173 gfc_free (e
->shape
);
4176 gfc_match_rvalue (&expr
);
4178 gfc_buffer_error (0);
4180 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
4186 gfc_current_locus
= temp_locus
;
4189 /* This might have changed! */
4190 return e
->expr_type
== EXPR_FUNCTION
;
4195 gfc_resolve_character_operator (gfc_expr
*e
)
4197 gfc_expr
*op1
= e
->value
.op
.op1
;
4198 gfc_expr
*op2
= e
->value
.op
.op2
;
4199 gfc_expr
*e1
= NULL
;
4200 gfc_expr
*e2
= NULL
;
4202 gcc_assert (e
->value
.op
.operator == INTRINSIC_CONCAT
);
4204 if (op1
->ts
.cl
&& op1
->ts
.cl
->length
)
4205 e1
= gfc_copy_expr (op1
->ts
.cl
->length
);
4206 else if (op1
->expr_type
== EXPR_CONSTANT
)
4207 e1
= gfc_int_expr (op1
->value
.character
.length
);
4209 if (op2
->ts
.cl
&& op2
->ts
.cl
->length
)
4210 e2
= gfc_copy_expr (op2
->ts
.cl
->length
);
4211 else if (op2
->expr_type
== EXPR_CONSTANT
)
4212 e2
= gfc_int_expr (op2
->value
.character
.length
);
4214 e
->ts
.cl
= gfc_get_charlen ();
4215 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4216 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4221 e
->ts
.cl
->length
= gfc_add (e1
, e2
);
4222 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
4223 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
4224 gfc_simplify_expr (e
->ts
.cl
->length
, 0);
4225 gfc_resolve_expr (e
->ts
.cl
->length
);
4231 /* Ensure that an character expression has a charlen and, if possible, a
4232 length expression. */
4235 fixup_charlen (gfc_expr
*e
)
4237 /* The cases fall through so that changes in expression type and the need
4238 for multiple fixes are picked up. In all circumstances, a charlen should
4239 be available for the middle end to hang a backend_decl on. */
4240 switch (e
->expr_type
)
4243 gfc_resolve_character_operator (e
);
4246 if (e
->expr_type
== EXPR_ARRAY
)
4247 gfc_resolve_character_array_constructor (e
);
4249 case EXPR_SUBSTRING
:
4250 if (!e
->ts
.cl
&& e
->ref
)
4251 gfc_resolve_substring_charlen (e
);
4256 e
->ts
.cl
= gfc_get_charlen ();
4257 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4258 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4266 /* Resolve an expression. That is, make sure that types of operands agree
4267 with their operators, intrinsic operators are converted to function calls
4268 for overloaded types and unresolved function references are resolved. */
4271 gfc_resolve_expr (gfc_expr
*e
)
4278 switch (e
->expr_type
)
4281 t
= resolve_operator (e
);
4287 if (check_host_association (e
))
4288 t
= resolve_function (e
);
4291 t
= resolve_variable (e
);
4293 expression_rank (e
);
4296 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.cl
== NULL
&& e
->ref
4297 && e
->ref
->type
!= REF_SUBSTRING
)
4298 gfc_resolve_substring_charlen (e
);
4302 case EXPR_SUBSTRING
:
4303 t
= resolve_ref (e
);
4313 if (resolve_ref (e
) == FAILURE
)
4316 t
= gfc_resolve_array_constructor (e
);
4317 /* Also try to expand a constructor. */
4320 expression_rank (e
);
4321 gfc_expand_constructor (e
);
4324 /* This provides the opportunity for the length of constructors with
4325 character valued function elements to propagate the string length
4326 to the expression. */
4327 if (e
->ts
.type
== BT_CHARACTER
)
4328 gfc_resolve_character_array_constructor (e
);
4332 case EXPR_STRUCTURE
:
4333 t
= resolve_ref (e
);
4337 t
= resolve_structure_cons (e
);
4341 t
= gfc_simplify_expr (e
, 0);
4345 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4348 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.cl
)
4355 /* Resolve an expression from an iterator. They must be scalar and have
4356 INTEGER or (optionally) REAL type. */
4359 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
4360 const char *name_msgid
)
4362 if (gfc_resolve_expr (expr
) == FAILURE
)
4365 if (expr
->rank
!= 0)
4367 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4371 if (expr
->ts
.type
!= BT_INTEGER
)
4373 if (expr
->ts
.type
== BT_REAL
)
4376 return gfc_notify_std (GFC_STD_F95_DEL
,
4377 "Deleted feature: %s at %L must be integer",
4378 _(name_msgid
), &expr
->where
);
4381 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4388 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4396 /* Resolve the expressions in an iterator structure. If REAL_OK is
4397 false allow only INTEGER type iterators, otherwise allow REAL types. */
4400 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4402 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4406 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4408 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4413 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4414 "Start expression in DO loop") == FAILURE
)
4417 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4418 "End expression in DO loop") == FAILURE
)
4421 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4422 "Step expression in DO loop") == FAILURE
)
4425 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4427 if ((iter
->step
->ts
.type
== BT_INTEGER
4428 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4429 || (iter
->step
->ts
.type
== BT_REAL
4430 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4432 gfc_error ("Step expression in DO loop at %L cannot be zero",
4433 &iter
->step
->where
);
4438 /* Convert start, end, and step to the same type as var. */
4439 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4440 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4441 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4443 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4444 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4445 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4447 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4448 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4449 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4455 /* Traversal function for find_forall_index. f == 2 signals that
4456 that variable itself is not to be checked - only the references. */
4459 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
4461 if (expr
->expr_type
!= EXPR_VARIABLE
)
4464 /* A scalar assignment */
4465 if (!expr
->ref
|| *f
== 1)
4467 if (expr
->symtree
->n
.sym
== sym
)
4479 /* Check whether the FORALL index appears in the expression or not.
4480 Returns SUCCESS if SYM is found in EXPR. */
4483 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
4485 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
4492 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4493 to be a scalar INTEGER variable. The subscripts and stride are scalar
4494 INTEGERs, and if stride is a constant it must be nonzero.
4495 Furthermore "A subscript or stride in a forall-triplet-spec shall
4496 not contain a reference to any index-name in the
4497 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4500 resolve_forall_iterators (gfc_forall_iterator
*it
)
4502 gfc_forall_iterator
*iter
, *iter2
;
4504 for (iter
= it
; iter
; iter
= iter
->next
)
4506 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4507 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4508 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4511 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4512 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4513 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4514 &iter
->start
->where
);
4515 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4516 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4518 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4519 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4520 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4522 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4523 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4525 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4527 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4528 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4529 &iter
->stride
->where
, "INTEGER");
4531 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4532 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4533 gfc_error ("FORALL stride expression at %L cannot be zero",
4534 &iter
->stride
->where
);
4536 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4537 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4540 for (iter
= it
; iter
; iter
= iter
->next
)
4541 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
4543 if (find_forall_index (iter2
->start
,
4544 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4545 || find_forall_index (iter2
->end
,
4546 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4547 || find_forall_index (iter2
->stride
,
4548 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
4549 gfc_error ("FORALL index '%s' may not appear in triplet "
4550 "specification at %L", iter
->var
->symtree
->name
,
4551 &iter2
->start
->where
);
4556 /* Given a pointer to a symbol that is a derived type, see if it's
4557 inaccessible, i.e. if it's defined in another module and the components are
4558 PRIVATE. The search is recursive if necessary. Returns zero if no
4559 inaccessible components are found, nonzero otherwise. */
4562 derived_inaccessible (gfc_symbol
*sym
)
4566 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
4569 for (c
= sym
->components
; c
; c
= c
->next
)
4571 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
4579 /* Resolve the argument of a deallocate expression. The expression must be
4580 a pointer or a full array. */
4583 resolve_deallocate_expr (gfc_expr
*e
)
4585 symbol_attribute attr
;
4586 int allocatable
, pointer
, check_intent_in
;
4589 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4590 check_intent_in
= 1;
4592 if (gfc_resolve_expr (e
) == FAILURE
)
4595 if (e
->expr_type
!= EXPR_VARIABLE
)
4598 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4599 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4600 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4603 check_intent_in
= 0;
4608 if (ref
->u
.ar
.type
!= AR_FULL
)
4613 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4614 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4615 pointer
= ref
->u
.c
.component
->pointer
;
4624 attr
= gfc_expr_attr (e
);
4626 if (allocatable
== 0 && attr
.pointer
== 0)
4629 gfc_error ("Expression in DEALLOCATE statement at %L must be "
4630 "ALLOCATABLE or a POINTER", &e
->where
);
4634 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4636 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
4637 e
->symtree
->n
.sym
->name
, &e
->where
);
4645 /* Returns true if the expression e contains a reference to the symbol sym. */
4647 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4649 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
4656 find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
4658 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
4662 /* Given the expression node e for an allocatable/pointer of derived type to be
4663 allocated, get the expression node to be initialized afterwards (needed for
4664 derived types with default initializers, and derived types with allocatable
4665 components that need nullification.) */
4668 expr_to_initialize (gfc_expr
*e
)
4674 result
= gfc_copy_expr (e
);
4676 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
4677 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
4678 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
4680 ref
->u
.ar
.type
= AR_FULL
;
4682 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4683 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
4685 result
->rank
= ref
->u
.ar
.dimen
;
4693 /* Resolve the expression in an ALLOCATE statement, doing the additional
4694 checks to see whether the expression is OK or not. The expression must
4695 have a trailing array reference that gives the size of the array. */
4698 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
4700 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
4701 symbol_attribute attr
;
4702 gfc_ref
*ref
, *ref2
;
4709 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
4710 check_intent_in
= 1;
4712 if (gfc_resolve_expr (e
) == FAILURE
)
4715 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
4716 sym
= code
->expr
->symtree
->n
.sym
;
4720 /* Make sure the expression is allocatable or a pointer. If it is
4721 pointer, the next-to-last reference must be a pointer. */
4725 if (e
->expr_type
!= EXPR_VARIABLE
)
4728 attr
= gfc_expr_attr (e
);
4729 pointer
= attr
.pointer
;
4730 dimension
= attr
.dimension
;
4734 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
4735 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
4736 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
4738 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
4740 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
4741 "not be allocated in the same statement at %L",
4742 sym
->name
, &e
->where
);
4746 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
4749 check_intent_in
= 0;
4754 if (ref
->next
!= NULL
)
4759 allocatable
= (ref
->u
.c
.component
->as
!= NULL
4760 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
4762 pointer
= ref
->u
.c
.component
->pointer
;
4763 dimension
= ref
->u
.c
.component
->dimension
;
4774 if (allocatable
== 0 && pointer
== 0)
4776 gfc_error ("Expression in ALLOCATE statement at %L must be "
4777 "ALLOCATABLE or a POINTER", &e
->where
);
4782 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
4784 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
4785 e
->symtree
->n
.sym
->name
, &e
->where
);
4789 /* Add default initializer for those derived types that need them. */
4790 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
4792 init_st
= gfc_get_code ();
4793 init_st
->loc
= code
->loc
;
4794 init_st
->op
= EXEC_INIT_ASSIGN
;
4795 init_st
->expr
= expr_to_initialize (e
);
4796 init_st
->expr2
= init_e
;
4797 init_st
->next
= code
->next
;
4798 code
->next
= init_st
;
4801 if (pointer
&& dimension
== 0)
4804 /* Make sure the next-to-last reference node is an array specification. */
4806 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
4808 gfc_error ("Array specification required in ALLOCATE statement "
4809 "at %L", &e
->where
);
4813 /* Make sure that the array section reference makes sense in the
4814 context of an ALLOCATE specification. */
4818 for (i
= 0; i
< ar
->dimen
; i
++)
4820 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
4823 switch (ar
->dimen_type
[i
])
4829 if (ar
->start
[i
] != NULL
4830 && ar
->end
[i
] != NULL
4831 && ar
->stride
[i
] == NULL
)
4834 /* Fall Through... */
4838 gfc_error ("Bad array specification in ALLOCATE statement at %L",
4845 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
4847 sym
= a
->expr
->symtree
->n
.sym
;
4849 /* TODO - check derived type components. */
4850 if (sym
->ts
.type
== BT_DERIVED
)
4853 if ((ar
->start
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->start
[i
]))
4854 || (ar
->end
[i
] != NULL
&& find_sym_in_expr (sym
, ar
->end
[i
])))
4856 gfc_error ("'%s' must not appear an the array specification at "
4857 "%L in the same ALLOCATE statement where it is "
4858 "itself allocated", sym
->name
, &ar
->where
);
4868 /************ SELECT CASE resolution subroutines ************/
4870 /* Callback function for our mergesort variant. Determines interval
4871 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
4872 op1 > op2. Assumes we're not dealing with the default case.
4873 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
4874 There are nine situations to check. */
4877 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
4881 if (op1
->low
== NULL
) /* op1 = (:L) */
4883 /* op2 = (:N), so overlap. */
4885 /* op2 = (M:) or (M:N), L < M */
4886 if (op2
->low
!= NULL
4887 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
4890 else if (op1
->high
== NULL
) /* op1 = (K:) */
4892 /* op2 = (M:), so overlap. */
4894 /* op2 = (:N) or (M:N), K > N */
4895 if (op2
->high
!= NULL
4896 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
4899 else /* op1 = (K:L) */
4901 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
4902 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
4904 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
4905 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
4907 else /* op2 = (M:N) */
4911 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
4914 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
4923 /* Merge-sort a double linked case list, detecting overlap in the
4924 process. LIST is the head of the double linked case list before it
4925 is sorted. Returns the head of the sorted list if we don't see any
4926 overlap, or NULL otherwise. */
4929 check_case_overlap (gfc_case
*list
)
4931 gfc_case
*p
, *q
, *e
, *tail
;
4932 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
4934 /* If the passed list was empty, return immediately. */
4941 /* Loop unconditionally. The only exit from this loop is a return
4942 statement, when we've finished sorting the case list. */
4949 /* Count the number of merges we do in this pass. */
4952 /* Loop while there exists a merge to be done. */
4957 /* Count this merge. */
4960 /* Cut the list in two pieces by stepping INSIZE places
4961 forward in the list, starting from P. */
4964 for (i
= 0; i
< insize
; i
++)
4973 /* Now we have two lists. Merge them! */
4974 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
4976 /* See from which the next case to merge comes from. */
4979 /* P is empty so the next case must come from Q. */
4984 else if (qsize
== 0 || q
== NULL
)
4993 cmp
= compare_cases (p
, q
);
4996 /* The whole case range for P is less than the
5004 /* The whole case range for Q is greater than
5005 the case range for P. */
5012 /* The cases overlap, or they are the same
5013 element in the list. Either way, we must
5014 issue an error and get the next case from P. */
5015 /* FIXME: Sort P and Q by line number. */
5016 gfc_error ("CASE label at %L overlaps with CASE "
5017 "label at %L", &p
->where
, &q
->where
);
5025 /* Add the next element to the merged list. */
5034 /* P has now stepped INSIZE places along, and so has Q. So
5035 they're the same. */
5040 /* If we have done only one merge or none at all, we've
5041 finished sorting the cases. */
5050 /* Otherwise repeat, merging lists twice the size. */
5056 /* Check to see if an expression is suitable for use in a CASE statement.
5057 Makes sure that all case expressions are scalar constants of the same
5058 type. Return FAILURE if anything is wrong. */
5061 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
5063 if (e
== NULL
) return SUCCESS
;
5065 if (e
->ts
.type
!= case_expr
->ts
.type
)
5067 gfc_error ("Expression in CASE statement at %L must be of type %s",
5068 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
5072 /* C805 (R808) For a given case-construct, each case-value shall be of
5073 the same type as case-expr. For character type, length differences
5074 are allowed, but the kind type parameters shall be the same. */
5076 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
5078 gfc_error("Expression in CASE statement at %L must be kind %d",
5079 &e
->where
, case_expr
->ts
.kind
);
5083 /* Convert the case value kind to that of case expression kind, if needed.
5084 FIXME: Should a warning be issued? */
5085 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
5086 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
5090 gfc_error ("Expression in CASE statement at %L must be scalar",
5099 /* Given a completely parsed select statement, we:
5101 - Validate all expressions and code within the SELECT.
5102 - Make sure that the selection expression is not of the wrong type.
5103 - Make sure that no case ranges overlap.
5104 - Eliminate unreachable cases and unreachable code resulting from
5105 removing case labels.
5107 The standard does allow unreachable cases, e.g. CASE (5:3). But
5108 they are a hassle for code generation, and to prevent that, we just
5109 cut them out here. This is not necessary for overlapping cases
5110 because they are illegal and we never even try to generate code.
5112 We have the additional caveat that a SELECT construct could have
5113 been a computed GOTO in the source code. Fortunately we can fairly
5114 easily work around that here: The case_expr for a "real" SELECT CASE
5115 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5116 we have to do is make sure that the case_expr is a scalar integer
5120 resolve_select (gfc_code
*code
)
5123 gfc_expr
*case_expr
;
5124 gfc_case
*cp
, *default_case
, *tail
, *head
;
5125 int seen_unreachable
;
5131 if (code
->expr
== NULL
)
5133 /* This was actually a computed GOTO statement. */
5134 case_expr
= code
->expr2
;
5135 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
5136 gfc_error ("Selection expression in computed GOTO statement "
5137 "at %L must be a scalar integer expression",
5140 /* Further checking is not necessary because this SELECT was built
5141 by the compiler, so it should always be OK. Just move the
5142 case_expr from expr2 to expr so that we can handle computed
5143 GOTOs as normal SELECTs from here on. */
5144 code
->expr
= code
->expr2
;
5149 case_expr
= code
->expr
;
5151 type
= case_expr
->ts
.type
;
5152 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
5154 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5155 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
5157 /* Punt. Going on here just produce more garbage error messages. */
5161 if (case_expr
->rank
!= 0)
5163 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5164 "expression", &case_expr
->where
);
5170 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5171 of the SELECT CASE expression and its CASE values. Walk the lists
5172 of case values, and if we find a mismatch, promote case_expr to
5173 the appropriate kind. */
5175 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
5177 for (body
= code
->block
; body
; body
= body
->block
)
5179 /* Walk the case label list. */
5180 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5182 /* Intercept the DEFAULT case. It does not have a kind. */
5183 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5186 /* Unreachable case ranges are discarded, so ignore. */
5187 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5188 && cp
->low
!= cp
->high
5189 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5192 /* FIXME: Should a warning be issued? */
5194 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
5195 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
5197 if (cp
->high
!= NULL
5198 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
5199 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
5204 /* Assume there is no DEFAULT case. */
5205 default_case
= NULL
;
5210 for (body
= code
->block
; body
; body
= body
->block
)
5212 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5214 seen_unreachable
= 0;
5216 /* Walk the case label list, making sure that all case labels
5218 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5220 /* Count the number of cases in the whole construct. */
5223 /* Intercept the DEFAULT case. */
5224 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5226 if (default_case
!= NULL
)
5228 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5229 "by a second DEFAULT CASE at %L",
5230 &default_case
->where
, &cp
->where
);
5241 /* Deal with single value cases and case ranges. Errors are
5242 issued from the validation function. */
5243 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
5244 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
5250 if (type
== BT_LOGICAL
5251 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
5252 || cp
->low
!= cp
->high
))
5254 gfc_error ("Logical range in CASE statement at %L is not "
5255 "allowed", &cp
->low
->where
);
5260 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
5263 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
5264 if (value
& seen_logical
)
5266 gfc_error ("constant logical value in CASE statement "
5267 "is repeated at %L",
5272 seen_logical
|= value
;
5275 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5276 && cp
->low
!= cp
->high
5277 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5279 if (gfc_option
.warn_surprising
)
5280 gfc_warning ("Range specification at %L can never "
5281 "be matched", &cp
->where
);
5283 cp
->unreachable
= 1;
5284 seen_unreachable
= 1;
5288 /* If the case range can be matched, it can also overlap with
5289 other cases. To make sure it does not, we put it in a
5290 double linked list here. We sort that with a merge sort
5291 later on to detect any overlapping cases. */
5295 head
->right
= head
->left
= NULL
;
5300 tail
->right
->left
= tail
;
5307 /* It there was a failure in the previous case label, give up
5308 for this case label list. Continue with the next block. */
5312 /* See if any case labels that are unreachable have been seen.
5313 If so, we eliminate them. This is a bit of a kludge because
5314 the case lists for a single case statement (label) is a
5315 single forward linked lists. */
5316 if (seen_unreachable
)
5318 /* Advance until the first case in the list is reachable. */
5319 while (body
->ext
.case_list
!= NULL
5320 && body
->ext
.case_list
->unreachable
)
5322 gfc_case
*n
= body
->ext
.case_list
;
5323 body
->ext
.case_list
= body
->ext
.case_list
->next
;
5325 gfc_free_case_list (n
);
5328 /* Strip all other unreachable cases. */
5329 if (body
->ext
.case_list
)
5331 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
5333 if (cp
->next
->unreachable
)
5335 gfc_case
*n
= cp
->next
;
5336 cp
->next
= cp
->next
->next
;
5338 gfc_free_case_list (n
);
5345 /* See if there were overlapping cases. If the check returns NULL,
5346 there was overlap. In that case we don't do anything. If head
5347 is non-NULL, we prepend the DEFAULT case. The sorted list can
5348 then used during code generation for SELECT CASE constructs with
5349 a case expression of a CHARACTER type. */
5352 head
= check_case_overlap (head
);
5354 /* Prepend the default_case if it is there. */
5355 if (head
!= NULL
&& default_case
)
5357 default_case
->left
= NULL
;
5358 default_case
->right
= head
;
5359 head
->left
= default_case
;
5363 /* Eliminate dead blocks that may be the result if we've seen
5364 unreachable case labels for a block. */
5365 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5367 if (body
->block
->ext
.case_list
== NULL
)
5369 /* Cut the unreachable block from the code chain. */
5370 gfc_code
*c
= body
->block
;
5371 body
->block
= c
->block
;
5373 /* Kill the dead block, but not the blocks below it. */
5375 gfc_free_statements (c
);
5379 /* More than two cases is legal but insane for logical selects.
5380 Issue a warning for it. */
5381 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5383 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5388 /* Resolve a transfer statement. This is making sure that:
5389 -- a derived type being transferred has only non-pointer components
5390 -- a derived type being transferred doesn't have private components, unless
5391 it's being transferred from the module where the type was defined
5392 -- we're not trying to transfer a whole assumed size array. */
5395 resolve_transfer (gfc_code
*code
)
5404 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5407 sym
= exp
->symtree
->n
.sym
;
5410 /* Go to actual component transferred. */
5411 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5412 if (ref
->type
== REF_COMPONENT
)
5413 ts
= &ref
->u
.c
.component
->ts
;
5415 if (ts
->type
== BT_DERIVED
)
5417 /* Check that transferred derived type doesn't contain POINTER
5419 if (ts
->derived
->attr
.pointer_comp
)
5421 gfc_error ("Data transfer element at %L cannot have "
5422 "POINTER components", &code
->loc
);
5426 if (ts
->derived
->attr
.alloc_comp
)
5428 gfc_error ("Data transfer element at %L cannot have "
5429 "ALLOCATABLE components", &code
->loc
);
5433 if (derived_inaccessible (ts
->derived
))
5435 gfc_error ("Data transfer element at %L cannot have "
5436 "PRIVATE components",&code
->loc
);
5441 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5442 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5444 gfc_error ("Data transfer element at %L cannot be a full reference to "
5445 "an assumed-size array", &code
->loc
);
5451 /*********** Toplevel code resolution subroutines ***********/
5453 /* Find the set of labels that are reachable from this block. We also
5454 record the last statement in each block so that we don't have to do
5455 a linear search to find the END DO statements of the blocks. */
5458 reachable_labels (gfc_code
*block
)
5465 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5467 /* Collect labels in this block. */
5468 for (c
= block
; c
; c
= c
->next
)
5471 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5473 if (!c
->next
&& cs_base
->prev
)
5474 cs_base
->prev
->tail
= c
;
5477 /* Merge with labels from parent block. */
5480 gcc_assert (cs_base
->prev
->reachable_labels
);
5481 bitmap_ior_into (cs_base
->reachable_labels
,
5482 cs_base
->prev
->reachable_labels
);
5486 /* Given a branch to a label and a namespace, if the branch is conforming.
5487 The code node describes where the branch is located. */
5490 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5497 /* Step one: is this a valid branching target? */
5499 if (label
->defined
== ST_LABEL_UNKNOWN
)
5501 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5506 if (label
->defined
!= ST_LABEL_TARGET
)
5508 gfc_error ("Statement at %L is not a valid branch target statement "
5509 "for the branch statement at %L", &label
->where
, &code
->loc
);
5513 /* Step two: make sure this branch is not a branch to itself ;-) */
5515 if (code
->here
== label
)
5517 gfc_warning ("Branch at %L causes an infinite loop", &code
->loc
);
5521 /* Step three: See if the label is in the same block as the
5522 branching statement. The hard work has been done by setting up
5523 the bitmap reachable_labels. */
5525 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
5527 /* The label is not in an enclosing block, so illegal. This was
5528 allowed in Fortran 66, so we allow it as extension. No
5529 further checks are necessary in this case. */
5530 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
5531 "as the GOTO statement at %L", &label
->where
,
5536 /* Step four: Make sure that the branching target is legal if
5537 the statement is an END {SELECT,IF}. */
5539 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5540 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
5543 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
5545 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
5546 "END of construct at %L", &code
->loc
,
5547 &stack
->current
->next
->loc
);
5548 return; /* We know this is not an END DO. */
5551 /* Step five: Make sure that we're not jumping to the end of a DO
5552 loop from within the loop. */
5554 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
5555 if ((stack
->current
->op
== EXEC_DO
5556 || stack
->current
->op
== EXEC_DO_WHILE
)
5557 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
5559 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
5560 "to END of construct at %L", &code
->loc
,
5568 /* Check whether EXPR1 has the same shape as EXPR2. */
5571 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
5573 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5574 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
5575 try result
= FAILURE
;
5578 /* Compare the rank. */
5579 if (expr1
->rank
!= expr2
->rank
)
5582 /* Compare the size of each dimension. */
5583 for (i
=0; i
<expr1
->rank
; i
++)
5585 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
5588 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
5591 if (mpz_cmp (shape
[i
], shape2
[i
]))
5595 /* When either of the two expression is an assumed size array, we
5596 ignore the comparison of dimension sizes. */
5601 for (i
--; i
>= 0; i
--)
5603 mpz_clear (shape
[i
]);
5604 mpz_clear (shape2
[i
]);
5610 /* Check whether a WHERE assignment target or a WHERE mask expression
5611 has the same shape as the outmost WHERE mask expression. */
5614 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
5620 cblock
= code
->block
;
5622 /* Store the first WHERE mask-expr of the WHERE statement or construct.
5623 In case of nested WHERE, only the outmost one is stored. */
5624 if (mask
== NULL
) /* outmost WHERE */
5626 else /* inner WHERE */
5633 /* Check if the mask-expr has a consistent shape with the
5634 outmost WHERE mask-expr. */
5635 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
5636 gfc_error ("WHERE mask at %L has inconsistent shape",
5637 &cblock
->expr
->where
);
5640 /* the assignment statement of a WHERE statement, or the first
5641 statement in where-body-construct of a WHERE construct */
5642 cnext
= cblock
->next
;
5647 /* WHERE assignment statement */
5650 /* Check shape consistent for WHERE assignment target. */
5651 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
5652 gfc_error ("WHERE assignment target at %L has "
5653 "inconsistent shape", &cnext
->expr
->where
);
5657 case EXEC_ASSIGN_CALL
:
5658 resolve_call (cnext
);
5659 if (!cnext
->resolved_sym
->attr
.elemental
)
5660 gfc_error("Non-ELEMETAL user-defined assignment in WHERE at %L",
5661 &cnext
->ext
.actual
->expr
->where
);
5664 /* WHERE or WHERE construct is part of a where-body-construct */
5666 resolve_where (cnext
, e
);
5670 gfc_error ("Unsupported statement inside WHERE at %L",
5673 /* the next statement within the same where-body-construct */
5674 cnext
= cnext
->next
;
5676 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5677 cblock
= cblock
->block
;
5682 /* Resolve assignment in FORALL construct.
5683 NVAR is the number of FORALL index variables, and VAR_EXPR records the
5684 FORALL index variables. */
5687 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5691 for (n
= 0; n
< nvar
; n
++)
5693 gfc_symbol
*forall_index
;
5695 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
5697 /* Check whether the assignment target is one of the FORALL index
5699 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
5700 && (code
->expr
->symtree
->n
.sym
== forall_index
))
5701 gfc_error ("Assignment to a FORALL index variable at %L",
5702 &code
->expr
->where
);
5705 /* If one of the FORALL index variables doesn't appear in the
5706 assignment target, then there will be a many-to-one
5708 if (find_forall_index (code
->expr
, forall_index
, 0) == FAILURE
)
5709 gfc_error ("The FORALL with index '%s' cause more than one "
5710 "assignment to this object at %L",
5711 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
5717 /* Resolve WHERE statement in FORALL construct. */
5720 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
5721 gfc_expr
**var_expr
)
5726 cblock
= code
->block
;
5729 /* the assignment statement of a WHERE statement, or the first
5730 statement in where-body-construct of a WHERE construct */
5731 cnext
= cblock
->next
;
5736 /* WHERE assignment statement */
5738 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
5741 /* WHERE operator assignment statement */
5742 case EXEC_ASSIGN_CALL
:
5743 resolve_call (cnext
);
5744 if (!cnext
->resolved_sym
->attr
.elemental
)
5745 gfc_error("Non-ELEMETAL user-defined assignment in WHERE at %L",
5746 &cnext
->ext
.actual
->expr
->where
);
5749 /* WHERE or WHERE construct is part of a where-body-construct */
5751 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
5755 gfc_error ("Unsupported statement inside WHERE at %L",
5758 /* the next statement within the same where-body-construct */
5759 cnext
= cnext
->next
;
5761 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
5762 cblock
= cblock
->block
;
5767 /* Traverse the FORALL body to check whether the following errors exist:
5768 1. For assignment, check if a many-to-one assignment happens.
5769 2. For WHERE statement, check the WHERE body to see if there is any
5770 many-to-one assignment. */
5773 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
5777 c
= code
->block
->next
;
5783 case EXEC_POINTER_ASSIGN
:
5784 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
5787 case EXEC_ASSIGN_CALL
:
5791 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
5792 there is no need to handle it here. */
5796 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
5801 /* The next statement in the FORALL body. */
5807 /* Given a FORALL construct, first resolve the FORALL iterator, then call
5808 gfc_resolve_forall_body to resolve the FORALL body. */
5811 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
5813 static gfc_expr
**var_expr
;
5814 static int total_var
= 0;
5815 static int nvar
= 0;
5816 gfc_forall_iterator
*fa
;
5820 /* Start to resolve a FORALL construct */
5821 if (forall_save
== 0)
5823 /* Count the total number of FORALL index in the nested FORALL
5824 construct in order to allocate the VAR_EXPR with proper size. */
5826 while ((next
!= NULL
) && (next
->op
== EXEC_FORALL
))
5828 for (fa
= next
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5830 next
= next
->block
->next
;
5833 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
5834 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
5837 /* The information about FORALL iterator, including FORALL index start, end
5838 and stride. The FORALL index can not appear in start, end or stride. */
5839 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5841 /* Check if any outer FORALL index name is the same as the current
5843 for (i
= 0; i
< nvar
; i
++)
5845 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
5847 gfc_error ("An outer FORALL construct already has an index "
5848 "with this name %L", &fa
->var
->where
);
5852 /* Record the current FORALL index. */
5853 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
5858 /* Resolve the FORALL body. */
5859 gfc_resolve_forall_body (code
, nvar
, var_expr
);
5861 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
5862 gfc_resolve_blocks (code
->block
, ns
);
5864 /* Free VAR_EXPR after the whole FORALL construct resolved. */
5865 for (i
= 0; i
< total_var
; i
++)
5866 gfc_free_expr (var_expr
[i
]);
5868 /* Reset the counters. */
5874 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
5877 static void resolve_code (gfc_code
*, gfc_namespace
*);
5880 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
5884 for (; b
; b
= b
->block
)
5886 t
= gfc_resolve_expr (b
->expr
);
5887 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
5893 if (t
== SUCCESS
&& b
->expr
!= NULL
5894 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
5895 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5902 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
5903 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
5908 resolve_branch (b
->label
, b
);
5920 case EXEC_OMP_ATOMIC
:
5921 case EXEC_OMP_CRITICAL
:
5923 case EXEC_OMP_MASTER
:
5924 case EXEC_OMP_ORDERED
:
5925 case EXEC_OMP_PARALLEL
:
5926 case EXEC_OMP_PARALLEL_DO
:
5927 case EXEC_OMP_PARALLEL_SECTIONS
:
5928 case EXEC_OMP_PARALLEL_WORKSHARE
:
5929 case EXEC_OMP_SECTIONS
:
5930 case EXEC_OMP_SINGLE
:
5931 case EXEC_OMP_WORKSHARE
:
5935 gfc_internal_error ("resolve_block(): Bad block type");
5938 resolve_code (b
->next
, ns
);
5943 /* Does everything to resolve an ordinary assignment. Returns true
5944 if this is an interface asignment. */
5946 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
5956 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
5958 lhs
= code
->ext
.actual
->expr
;
5959 rhs
= code
->ext
.actual
->next
->expr
;
5960 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
5962 gfc_error ("Subroutine '%s' called instead of assignment at "
5963 "%L must be PURE", code
->symtree
->n
.sym
->name
,
5968 /* Make a temporary rhs when there is a default initializer
5969 and rhs is the same symbol as the lhs. */
5970 if (rhs
->expr_type
== EXPR_VARIABLE
5971 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
5972 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
5973 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
5974 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
5983 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
5984 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
5985 &code
->loc
) == FAILURE
)
5988 /* Handle the case of a BOZ literal on the RHS. */
5989 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
5992 if (gfc_option
.warn_surprising
)
5993 gfc_warning ("BOZ literal at %L is bitwise transferred "
5994 "non-integer symbol '%s'", &code
->loc
,
5995 lhs
->symtree
->n
.sym
->name
);
5997 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
5999 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
6001 if (rc
== ARITH_UNDERFLOW
)
6002 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6003 ". This check can be disabled with the option "
6004 "-fno-range-check", &rhs
->where
);
6005 else if (rc
== ARITH_OVERFLOW
)
6006 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6007 ". This check can be disabled with the option "
6008 "-fno-range-check", &rhs
->where
);
6009 else if (rc
== ARITH_NAN
)
6010 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6011 ". This check can be disabled with the option "
6012 "-fno-range-check", &rhs
->where
);
6018 if (lhs
->ts
.type
== BT_CHARACTER
6019 && gfc_option
.warn_character_truncation
)
6021 if (lhs
->ts
.cl
!= NULL
6022 && lhs
->ts
.cl
->length
!= NULL
6023 && lhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6024 llen
= mpz_get_si (lhs
->ts
.cl
->length
->value
.integer
);
6026 if (rhs
->expr_type
== EXPR_CONSTANT
)
6027 rlen
= rhs
->value
.character
.length
;
6029 else if (rhs
->ts
.cl
!= NULL
6030 && rhs
->ts
.cl
->length
!= NULL
6031 && rhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6032 rlen
= mpz_get_si (rhs
->ts
.cl
->length
->value
.integer
);
6034 if (rlen
&& llen
&& rlen
> llen
)
6035 gfc_warning_now ("CHARACTER expression will be truncated "
6036 "in assignment (%d/%d) at %L",
6037 llen
, rlen
, &code
->loc
);
6040 /* Ensure that a vector index expression for the lvalue is evaluated
6041 to a temporary if the lvalue symbol is referenced in it. */
6044 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
6045 if (ref
->type
== REF_ARRAY
)
6047 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6048 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
6049 && find_sym_in_expr (lhs
->symtree
->n
.sym
,
6050 ref
->u
.ar
.start
[n
]))
6052 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
6056 if (gfc_pure (NULL
))
6058 if (gfc_impure_variable (lhs
->symtree
->n
.sym
))
6060 gfc_error ("Cannot assign to variable '%s' in PURE "
6062 lhs
->symtree
->n
.sym
->name
,
6067 if (lhs
->ts
.type
== BT_DERIVED
6068 && lhs
->expr_type
== EXPR_VARIABLE
6069 && lhs
->ts
.derived
->attr
.pointer_comp
6070 && gfc_impure_variable (rhs
->symtree
->n
.sym
))
6072 gfc_error ("The impure variable at %L is assigned to "
6073 "a derived type variable with a POINTER "
6074 "component in a PURE procedure (12.6)",
6080 gfc_check_assign (lhs
, rhs
, 1);
6084 /* Given a block of code, recursively resolve everything pointed to by this
6088 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
6090 int omp_workshare_save
;
6096 frame
.prev
= cs_base
;
6100 reachable_labels (code
);
6102 for (; code
; code
= code
->next
)
6104 frame
.current
= code
;
6105 forall_save
= forall_flag
;
6107 if (code
->op
== EXEC_FORALL
)
6110 gfc_resolve_forall (code
, ns
, forall_save
);
6113 else if (code
->block
)
6115 omp_workshare_save
= -1;
6118 case EXEC_OMP_PARALLEL_WORKSHARE
:
6119 omp_workshare_save
= omp_workshare_flag
;
6120 omp_workshare_flag
= 1;
6121 gfc_resolve_omp_parallel_blocks (code
, ns
);
6123 case EXEC_OMP_PARALLEL
:
6124 case EXEC_OMP_PARALLEL_DO
:
6125 case EXEC_OMP_PARALLEL_SECTIONS
:
6126 omp_workshare_save
= omp_workshare_flag
;
6127 omp_workshare_flag
= 0;
6128 gfc_resolve_omp_parallel_blocks (code
, ns
);
6131 gfc_resolve_omp_do_blocks (code
, ns
);
6133 case EXEC_OMP_WORKSHARE
:
6134 omp_workshare_save
= omp_workshare_flag
;
6135 omp_workshare_flag
= 1;
6138 gfc_resolve_blocks (code
->block
, ns
);
6142 if (omp_workshare_save
!= -1)
6143 omp_workshare_flag
= omp_workshare_save
;
6146 t
= gfc_resolve_expr (code
->expr
);
6147 forall_flag
= forall_save
;
6149 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
6164 /* Keep track of which entry we are up to. */
6165 current_entry_id
= code
->ext
.entry
->id
;
6169 resolve_where (code
, NULL
);
6173 if (code
->expr
!= NULL
)
6175 if (code
->expr
->ts
.type
!= BT_INTEGER
)
6176 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6177 "INTEGER variable", &code
->expr
->where
);
6178 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
6179 gfc_error ("Variable '%s' has not been assigned a target "
6180 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
6181 &code
->expr
->where
);
6184 resolve_branch (code
->label
, code
);
6188 if (code
->expr
!= NULL
6189 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
6190 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6191 "INTEGER return specifier", &code
->expr
->where
);
6194 case EXEC_INIT_ASSIGN
:
6201 if (resolve_ordinary_assign (code
, ns
))
6206 case EXEC_LABEL_ASSIGN
:
6207 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
6208 gfc_error ("Label %d referenced at %L is never defined",
6209 code
->label
->value
, &code
->label
->where
);
6211 && (code
->expr
->expr_type
!= EXPR_VARIABLE
6212 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
6213 || code
->expr
->symtree
->n
.sym
->ts
.kind
6214 != gfc_default_integer_kind
6215 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
6216 gfc_error ("ASSIGN statement at %L requires a scalar "
6217 "default INTEGER variable", &code
->expr
->where
);
6220 case EXEC_POINTER_ASSIGN
:
6224 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
6227 case EXEC_ARITHMETIC_IF
:
6229 && code
->expr
->ts
.type
!= BT_INTEGER
6230 && code
->expr
->ts
.type
!= BT_REAL
)
6231 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6232 "expression", &code
->expr
->where
);
6234 resolve_branch (code
->label
, code
);
6235 resolve_branch (code
->label2
, code
);
6236 resolve_branch (code
->label3
, code
);
6240 if (t
== SUCCESS
&& code
->expr
!= NULL
6241 && (code
->expr
->ts
.type
!= BT_LOGICAL
6242 || code
->expr
->rank
!= 0))
6243 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6244 &code
->expr
->where
);
6249 resolve_call (code
);
6253 /* Select is complicated. Also, a SELECT construct could be
6254 a transformed computed GOTO. */
6255 resolve_select (code
);
6259 if (code
->ext
.iterator
!= NULL
)
6261 gfc_iterator
*iter
= code
->ext
.iterator
;
6262 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6263 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6268 if (code
->expr
== NULL
)
6269 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6271 && (code
->expr
->rank
!= 0
6272 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6273 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6274 "a scalar LOGICAL expression", &code
->expr
->where
);
6278 if (t
== SUCCESS
&& code
->expr
!= NULL
6279 && code
->expr
->ts
.type
!= BT_INTEGER
)
6280 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
6281 "of type INTEGER", &code
->expr
->where
);
6283 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6284 resolve_allocate_expr (a
->expr
, code
);
6288 case EXEC_DEALLOCATE
:
6289 if (t
== SUCCESS
&& code
->expr
!= NULL
6290 && code
->expr
->ts
.type
!= BT_INTEGER
)
6292 ("STAT tag in DEALLOCATE statement at %L must be of type "
6293 "INTEGER", &code
->expr
->where
);
6295 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
6296 resolve_deallocate_expr (a
->expr
);
6301 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6304 resolve_branch (code
->ext
.open
->err
, code
);
6308 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6311 resolve_branch (code
->ext
.close
->err
, code
);
6314 case EXEC_BACKSPACE
:
6318 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6321 resolve_branch (code
->ext
.filepos
->err
, code
);
6325 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6328 resolve_branch (code
->ext
.inquire
->err
, code
);
6332 gcc_assert (code
->ext
.inquire
!= NULL
);
6333 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6336 resolve_branch (code
->ext
.inquire
->err
, code
);
6341 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6344 resolve_branch (code
->ext
.dt
->err
, code
);
6345 resolve_branch (code
->ext
.dt
->end
, code
);
6346 resolve_branch (code
->ext
.dt
->eor
, code
);
6350 resolve_transfer (code
);
6354 resolve_forall_iterators (code
->ext
.forall_iterator
);
6356 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6357 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6358 "expression", &code
->expr
->where
);
6361 case EXEC_OMP_ATOMIC
:
6362 case EXEC_OMP_BARRIER
:
6363 case EXEC_OMP_CRITICAL
:
6364 case EXEC_OMP_FLUSH
:
6366 case EXEC_OMP_MASTER
:
6367 case EXEC_OMP_ORDERED
:
6368 case EXEC_OMP_SECTIONS
:
6369 case EXEC_OMP_SINGLE
:
6370 case EXEC_OMP_WORKSHARE
:
6371 gfc_resolve_omp_directive (code
, ns
);
6374 case EXEC_OMP_PARALLEL
:
6375 case EXEC_OMP_PARALLEL_DO
:
6376 case EXEC_OMP_PARALLEL_SECTIONS
:
6377 case EXEC_OMP_PARALLEL_WORKSHARE
:
6378 omp_workshare_save
= omp_workshare_flag
;
6379 omp_workshare_flag
= 0;
6380 gfc_resolve_omp_directive (code
, ns
);
6381 omp_workshare_flag
= omp_workshare_save
;
6385 gfc_internal_error ("resolve_code(): Bad statement code");
6389 cs_base
= frame
.prev
;
6393 /* Resolve initial values and make sure they are compatible with
6397 resolve_values (gfc_symbol
*sym
)
6399 if (sym
->value
== NULL
)
6402 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6405 gfc_check_assign_symbol (sym
, sym
->value
);
6409 /* Verify the binding labels for common blocks that are BIND(C). The label
6410 for a BIND(C) common block must be identical in all scoping units in which
6411 the common block is declared. Further, the binding label can not collide
6412 with any other global entity in the program. */
6415 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6417 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6419 gfc_gsymbol
*binding_label_gsym
;
6420 gfc_gsymbol
*comm_name_gsym
;
6422 /* See if a global symbol exists by the common block's name. It may
6423 be NULL if the common block is use-associated. */
6424 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6425 comm_block_tree
->n
.common
->name
);
6426 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6427 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6428 "with the global entity '%s' at %L",
6429 comm_block_tree
->n
.common
->binding_label
,
6430 comm_block_tree
->n
.common
->name
,
6431 &(comm_block_tree
->n
.common
->where
),
6432 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6433 else if (comm_name_gsym
!= NULL
6434 && strcmp (comm_name_gsym
->name
,
6435 comm_block_tree
->n
.common
->name
) == 0)
6437 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6439 if (comm_name_gsym
->binding_label
== NULL
)
6440 /* No binding label for common block stored yet; save this one. */
6441 comm_name_gsym
->binding_label
=
6442 comm_block_tree
->n
.common
->binding_label
;
6444 if (strcmp (comm_name_gsym
->binding_label
,
6445 comm_block_tree
->n
.common
->binding_label
) != 0)
6447 /* Common block names match but binding labels do not. */
6448 gfc_error ("Binding label '%s' for common block '%s' at %L "
6449 "does not match the binding label '%s' for common "
6451 comm_block_tree
->n
.common
->binding_label
,
6452 comm_block_tree
->n
.common
->name
,
6453 &(comm_block_tree
->n
.common
->where
),
6454 comm_name_gsym
->binding_label
,
6455 comm_name_gsym
->name
,
6456 &(comm_name_gsym
->where
));
6461 /* There is no binding label (NAME="") so we have nothing further to
6462 check and nothing to add as a global symbol for the label. */
6463 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6466 binding_label_gsym
=
6467 gfc_find_gsymbol (gfc_gsym_root
,
6468 comm_block_tree
->n
.common
->binding_label
);
6469 if (binding_label_gsym
== NULL
)
6471 /* Need to make a global symbol for the binding label to prevent
6472 it from colliding with another. */
6473 binding_label_gsym
=
6474 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
6475 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
6476 binding_label_gsym
->type
= GSYM_COMMON
;
6480 /* If comm_name_gsym is NULL, the name common block is use
6481 associated and the name could be colliding. */
6482 if (binding_label_gsym
->type
!= GSYM_COMMON
)
6483 gfc_error ("Binding label '%s' for common block '%s' at %L "
6484 "collides with the global entity '%s' at %L",
6485 comm_block_tree
->n
.common
->binding_label
,
6486 comm_block_tree
->n
.common
->name
,
6487 &(comm_block_tree
->n
.common
->where
),
6488 binding_label_gsym
->name
,
6489 &(binding_label_gsym
->where
));
6490 else if (comm_name_gsym
!= NULL
6491 && (strcmp (binding_label_gsym
->name
,
6492 comm_name_gsym
->binding_label
) != 0)
6493 && (strcmp (binding_label_gsym
->sym_name
,
6494 comm_name_gsym
->name
) != 0))
6495 gfc_error ("Binding label '%s' for common block '%s' at %L "
6496 "collides with global entity '%s' at %L",
6497 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
6498 &(comm_block_tree
->n
.common
->where
),
6499 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6507 /* Verify any BIND(C) derived types in the namespace so we can report errors
6508 for them once, rather than for each variable declared of that type. */
6511 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
6513 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
6514 && derived_sym
->attr
.is_bind_c
== 1)
6515 verify_bind_c_derived_type (derived_sym
);
6521 /* Verify that any binding labels used in a given namespace do not collide
6522 with the names or binding labels of any global symbols. */
6525 gfc_verify_binding_labels (gfc_symbol
*sym
)
6529 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
6530 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
6532 gfc_gsymbol
*bind_c_sym
;
6534 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
6535 if (bind_c_sym
!= NULL
6536 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
6538 if (sym
->attr
.if_source
== IFSRC_DECL
6539 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
6540 && bind_c_sym
->type
!= GSYM_FUNCTION
)
6541 && ((sym
->attr
.contained
== 1
6542 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
6543 || (sym
->attr
.use_assoc
== 1
6544 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
6546 /* Make sure global procedures don't collide with anything. */
6547 gfc_error ("Binding label '%s' at %L collides with the global "
6548 "entity '%s' at %L", sym
->binding_label
,
6549 &(sym
->declared_at
), bind_c_sym
->name
,
6550 &(bind_c_sym
->where
));
6553 else if (sym
->attr
.contained
== 0
6554 && (sym
->attr
.if_source
== IFSRC_IFBODY
6555 && sym
->attr
.flavor
== FL_PROCEDURE
)
6556 && (bind_c_sym
->sym_name
!= NULL
6557 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
6559 /* Make sure procedures in interface bodies don't collide. */
6560 gfc_error ("Binding label '%s' in interface body at %L collides "
6561 "with the global entity '%s' at %L",
6563 &(sym
->declared_at
), bind_c_sym
->name
,
6564 &(bind_c_sym
->where
));
6567 else if (sym
->attr
.contained
== 0
6568 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
))
6569 if ((sym
->attr
.use_assoc
6570 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))
6571 || sym
->attr
.use_assoc
== 0)
6573 gfc_error ("Binding label '%s' at %L collides with global "
6574 "entity '%s' at %L", sym
->binding_label
,
6575 &(sym
->declared_at
), bind_c_sym
->name
,
6576 &(bind_c_sym
->where
));
6581 /* Clear the binding label to prevent checking multiple times. */
6582 sym
->binding_label
[0] = '\0';
6584 else if (bind_c_sym
== NULL
)
6586 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
6587 bind_c_sym
->where
= sym
->declared_at
;
6588 bind_c_sym
->sym_name
= sym
->name
;
6590 if (sym
->attr
.use_assoc
== 1)
6591 bind_c_sym
->mod_name
= sym
->module
;
6593 if (sym
->ns
->proc_name
!= NULL
)
6594 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
6596 if (sym
->attr
.contained
== 0)
6598 if (sym
->attr
.subroutine
)
6599 bind_c_sym
->type
= GSYM_SUBROUTINE
;
6600 else if (sym
->attr
.function
)
6601 bind_c_sym
->type
= GSYM_FUNCTION
;
6609 /* Resolve an index expression. */
6612 resolve_index_expr (gfc_expr
*e
)
6614 if (gfc_resolve_expr (e
) == FAILURE
)
6617 if (gfc_simplify_expr (e
, 0) == FAILURE
)
6620 if (gfc_specification_expr (e
) == FAILURE
)
6626 /* Resolve a charlen structure. */
6629 resolve_charlen (gfc_charlen
*cl
)
6638 specification_expr
= 1;
6640 if (resolve_index_expr (cl
->length
) == FAILURE
)
6642 specification_expr
= 0;
6646 /* "If the character length parameter value evaluates to a negative
6647 value, the length of character entities declared is zero." */
6648 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
6650 gfc_warning_now ("CHARACTER variable has zero length at %L",
6651 &cl
->length
->where
);
6652 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
6659 /* Test for non-constant shape arrays. */
6662 is_non_constant_shape_array (gfc_symbol
*sym
)
6668 not_constant
= false;
6669 if (sym
->as
!= NULL
)
6671 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
6672 has not been simplified; parameter array references. Do the
6673 simplification now. */
6674 for (i
= 0; i
< sym
->as
->rank
; i
++)
6676 e
= sym
->as
->lower
[i
];
6677 if (e
&& (resolve_index_expr (e
) == FAILURE
6678 || !gfc_is_constant_expr (e
)))
6679 not_constant
= true;
6681 e
= sym
->as
->upper
[i
];
6682 if (e
&& (resolve_index_expr (e
) == FAILURE
6683 || !gfc_is_constant_expr (e
)))
6684 not_constant
= true;
6687 return not_constant
;
6690 /* Given a symbol and an initialization expression, add code to initialize
6691 the symbol to the function entry. */
6693 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
6697 gfc_namespace
*ns
= sym
->ns
;
6699 /* Search for the function namespace if this is a contained
6700 function without an explicit result. */
6701 if (sym
->attr
.function
&& sym
== sym
->result
6702 && sym
->name
!= sym
->ns
->proc_name
->name
)
6705 for (;ns
; ns
= ns
->sibling
)
6706 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
6712 gfc_free_expr (init
);
6716 /* Build an l-value expression for the result. */
6717 lval
= gfc_lval_expr_from_sym (sym
);
6719 /* Add the code at scope entry. */
6720 init_st
= gfc_get_code ();
6721 init_st
->next
= ns
->code
;
6724 /* Assign the default initializer to the l-value. */
6725 init_st
->loc
= sym
->declared_at
;
6726 init_st
->op
= EXEC_INIT_ASSIGN
;
6727 init_st
->expr
= lval
;
6728 init_st
->expr2
= init
;
6731 /* Assign the default initializer to a derived type variable or result. */
6734 apply_default_init (gfc_symbol
*sym
)
6736 gfc_expr
*init
= NULL
;
6738 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6741 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
6742 init
= gfc_default_initializer (&sym
->ts
);
6747 build_init_assign (sym
, init
);
6750 /* Build an initializer for a local integer, real, complex, logical, or
6751 character variable, based on the command line flags finit-local-zero,
6752 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
6753 null if the symbol should not have a default initialization. */
6755 build_default_init_expr (gfc_symbol
*sym
)
6758 gfc_expr
*init_expr
;
6762 /* These symbols should never have a default initialization. */
6763 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
6764 || sym
->attr
.external
6766 || sym
->attr
.pointer
6767 || sym
->attr
.in_equivalence
6768 || sym
->attr
.in_common
6771 || sym
->attr
.cray_pointee
6772 || sym
->attr
.cray_pointer
)
6775 /* Now we'll try to build an initializer expression. */
6776 init_expr
= gfc_get_expr ();
6777 init_expr
->expr_type
= EXPR_CONSTANT
;
6778 init_expr
->ts
.type
= sym
->ts
.type
;
6779 init_expr
->ts
.kind
= sym
->ts
.kind
;
6780 init_expr
->where
= sym
->declared_at
;
6782 /* We will only initialize integers, reals, complex, logicals, and
6783 characters, and only if the corresponding command-line flags
6784 were set. Otherwise, we free init_expr and return null. */
6785 switch (sym
->ts
.type
)
6788 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
6789 mpz_init_set_si (init_expr
->value
.integer
,
6790 gfc_option
.flag_init_integer_value
);
6793 gfc_free_expr (init_expr
);
6799 mpfr_init (init_expr
->value
.real
);
6800 switch (gfc_option
.flag_init_real
)
6802 case GFC_INIT_REAL_NAN
:
6803 mpfr_set_nan (init_expr
->value
.real
);
6806 case GFC_INIT_REAL_INF
:
6807 mpfr_set_inf (init_expr
->value
.real
, 1);
6810 case GFC_INIT_REAL_NEG_INF
:
6811 mpfr_set_inf (init_expr
->value
.real
, -1);
6814 case GFC_INIT_REAL_ZERO
:
6815 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
6819 gfc_free_expr (init_expr
);
6826 mpfr_init (init_expr
->value
.complex.r
);
6827 mpfr_init (init_expr
->value
.complex.i
);
6828 switch (gfc_option
.flag_init_real
)
6830 case GFC_INIT_REAL_NAN
:
6831 mpfr_set_nan (init_expr
->value
.complex.r
);
6832 mpfr_set_nan (init_expr
->value
.complex.i
);
6835 case GFC_INIT_REAL_INF
:
6836 mpfr_set_inf (init_expr
->value
.complex.r
, 1);
6837 mpfr_set_inf (init_expr
->value
.complex.i
, 1);
6840 case GFC_INIT_REAL_NEG_INF
:
6841 mpfr_set_inf (init_expr
->value
.complex.r
, -1);
6842 mpfr_set_inf (init_expr
->value
.complex.i
, -1);
6845 case GFC_INIT_REAL_ZERO
:
6846 mpfr_set_ui (init_expr
->value
.complex.r
, 0.0, GFC_RND_MODE
);
6847 mpfr_set_ui (init_expr
->value
.complex.i
, 0.0, GFC_RND_MODE
);
6851 gfc_free_expr (init_expr
);
6858 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
6859 init_expr
->value
.logical
= 0;
6860 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
6861 init_expr
->value
.logical
= 1;
6864 gfc_free_expr (init_expr
);
6870 /* For characters, the length must be constant in order to
6871 create a default initializer. */
6872 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
6873 && sym
->ts
.cl
->length
6874 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6876 char_len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
6877 init_expr
->value
.character
.length
= char_len
;
6878 init_expr
->value
.character
.string
= gfc_getmem (char_len
+1);
6879 ch
= init_expr
->value
.character
.string
;
6880 for (i
= 0; i
< char_len
; i
++)
6881 *(ch
++) = gfc_option
.flag_init_character_value
;
6885 gfc_free_expr (init_expr
);
6891 gfc_free_expr (init_expr
);
6897 /* Add an initialization expression to a local variable. */
6899 apply_default_init_local (gfc_symbol
*sym
)
6901 gfc_expr
*init
= NULL
;
6903 /* The symbol should be a variable or a function return value. */
6904 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
6905 || (sym
->attr
.function
&& sym
->result
!= sym
))
6908 /* Try to build the initializer expression. If we can't initialize
6909 this symbol, then init will be NULL. */
6910 init
= build_default_init_expr (sym
);
6914 /* For saved variables, we don't want to add an initializer at
6915 function entry, so we just add a static initializer. */
6916 if (sym
->attr
.save
|| sym
->ns
->save_all
)
6918 /* Don't clobber an existing initializer! */
6919 gcc_assert (sym
->value
== NULL
);
6924 build_init_assign (sym
, init
);
6927 /* Resolution of common features of flavors variable and procedure. */
6930 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
6932 /* Constraints on deferred shape variable. */
6933 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
6935 if (sym
->attr
.allocatable
)
6937 if (sym
->attr
.dimension
)
6938 gfc_error ("Allocatable array '%s' at %L must have "
6939 "a deferred shape", sym
->name
, &sym
->declared_at
);
6941 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
6942 sym
->name
, &sym
->declared_at
);
6946 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
6948 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
6949 sym
->name
, &sym
->declared_at
);
6956 if (!mp_flag
&& !sym
->attr
.allocatable
6957 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
6959 gfc_error ("Array '%s' at %L cannot have a deferred shape",
6960 sym
->name
, &sym
->declared_at
);
6968 /* Additional checks for symbols with flavor variable and derived
6969 type. To be called from resolve_fl_variable. */
6972 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
6974 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
6976 /* Check to see if a derived type is blocked from being host
6977 associated by the presence of another class I symbol in the same
6978 namespace. 14.6.1.3 of the standard and the discussion on
6979 comp.lang.fortran. */
6980 if (sym
->ns
!= sym
->ts
.derived
->ns
6981 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
6984 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
6985 if (s
&& (s
->attr
.flavor
!= FL_DERIVED
6986 || !gfc_compare_derived_types (s
, sym
->ts
.derived
)))
6988 gfc_error ("The type '%s' cannot be host associated at %L "
6989 "because it is blocked by an incompatible object "
6990 "of the same name declared at %L",
6991 sym
->ts
.derived
->name
, &sym
->declared_at
,
6997 /* 4th constraint in section 11.3: "If an object of a type for which
6998 component-initialization is specified (R429) appears in the
6999 specification-part of a module and does not have the ALLOCATABLE
7000 or POINTER attribute, the object shall have the SAVE attribute."
7002 The check for initializers is performed with
7003 has_default_initializer because gfc_default_initializer generates
7004 a hidden default for allocatable components. */
7005 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
7006 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7007 && !sym
->ns
->save_all
&& !sym
->attr
.save
7008 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
7009 && has_default_initializer (sym
->ts
.derived
))
7011 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7012 "default initialization of a component",
7013 sym
->name
, &sym
->declared_at
);
7017 /* Assign default initializer. */
7018 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
7019 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
7021 sym
->value
= gfc_default_initializer (&sym
->ts
);
7028 /* Resolve symbols with flavor variable. */
7031 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
7033 int no_init_flag
, automatic_flag
;
7035 const char *auto_save_msg
;
7037 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
7040 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7043 /* Set this flag to check that variables are parameters of all entries.
7044 This check is effected by the call to gfc_resolve_expr through
7045 is_non_constant_shape_array. */
7046 specification_expr
= 1;
7048 if (sym
->ns
->proc_name
7049 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7050 || sym
->ns
->proc_name
->attr
.is_main_program
)
7051 && !sym
->attr
.use_assoc
7052 && !sym
->attr
.allocatable
7053 && !sym
->attr
.pointer
7054 && is_non_constant_shape_array (sym
))
7056 /* The shape of a main program or module array needs to be
7058 gfc_error ("The module or main program array '%s' at %L must "
7059 "have constant shape", sym
->name
, &sym
->declared_at
);
7060 specification_expr
= 0;
7064 if (sym
->ts
.type
== BT_CHARACTER
)
7066 /* Make sure that character string variables with assumed length are
7068 e
= sym
->ts
.cl
->length
;
7069 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
7071 gfc_error ("Entity with assumed character length at %L must be a "
7072 "dummy argument or a PARAMETER", &sym
->declared_at
);
7076 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
7078 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7082 if (!gfc_is_constant_expr (e
)
7083 && !(e
->expr_type
== EXPR_VARIABLE
7084 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7085 && sym
->ns
->proc_name
7086 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7087 || sym
->ns
->proc_name
->attr
.is_main_program
)
7088 && !sym
->attr
.use_assoc
)
7090 gfc_error ("'%s' at %L must have constant character length "
7091 "in this context", sym
->name
, &sym
->declared_at
);
7096 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
7097 apply_default_init_local (sym
); /* Try to apply a default initialization. */
7099 /* Determine if the symbol may not have an initializer. */
7100 no_init_flag
= automatic_flag
= 0;
7101 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
7102 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
7104 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
7105 && is_non_constant_shape_array (sym
))
7107 no_init_flag
= automatic_flag
= 1;
7109 /* Also, they must not have the SAVE attribute.
7110 SAVE_IMPLICIT is checked below. */
7111 if (sym
->attr
.save
== SAVE_EXPLICIT
)
7113 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7118 /* Reject illegal initializers. */
7119 if (!sym
->mark
&& sym
->value
)
7121 if (sym
->attr
.allocatable
)
7122 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7123 sym
->name
, &sym
->declared_at
);
7124 else if (sym
->attr
.external
)
7125 gfc_error ("External '%s' at %L cannot have an initializer",
7126 sym
->name
, &sym
->declared_at
);
7127 else if (sym
->attr
.dummy
7128 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
7129 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7130 sym
->name
, &sym
->declared_at
);
7131 else if (sym
->attr
.intrinsic
)
7132 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7133 sym
->name
, &sym
->declared_at
);
7134 else if (sym
->attr
.result
)
7135 gfc_error ("Function result '%s' at %L cannot have an initializer",
7136 sym
->name
, &sym
->declared_at
);
7137 else if (automatic_flag
)
7138 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7139 sym
->name
, &sym
->declared_at
);
7146 if (sym
->ts
.type
== BT_DERIVED
)
7147 return resolve_fl_variable_derived (sym
, no_init_flag
);
7153 /* Resolve a procedure. */
7156 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
7158 gfc_formal_arglist
*arg
;
7160 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
7161 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7162 "interfaces", sym
->name
, &sym
->declared_at
);
7164 if (sym
->attr
.function
7165 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7168 if (sym
->ts
.type
== BT_CHARACTER
)
7170 gfc_charlen
*cl
= sym
->ts
.cl
;
7172 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
7173 && resolve_charlen (cl
) == FAILURE
)
7176 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7178 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7180 gfc_error ("Character-valued statement function '%s' at %L must "
7181 "have constant length", sym
->name
, &sym
->declared_at
);
7185 if (sym
->attr
.external
&& sym
->formal
== NULL
7186 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
7188 gfc_error ("Automatic character length function '%s' at %L must "
7189 "have an explicit interface", sym
->name
,
7196 /* Ensure that derived type for are not of a private type. Internal
7197 module procedures are excluded by 2.2.3.3 - ie. they are not
7198 externally accessible and can access all the objects accessible in
7200 if (!(sym
->ns
->parent
7201 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7202 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7204 gfc_interface
*iface
;
7206 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7209 && arg
->sym
->ts
.type
== BT_DERIVED
7210 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7211 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7212 arg
->sym
->ts
.derived
->ns
->default_access
)
7213 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
7214 "PRIVATE type and cannot be a dummy argument"
7215 " of '%s', which is PUBLIC at %L",
7216 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
7219 /* Stop this message from recurring. */
7220 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7225 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7226 PRIVATE to the containing module. */
7227 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7229 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7232 && arg
->sym
->ts
.type
== BT_DERIVED
7233 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7234 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7235 arg
->sym
->ts
.derived
->ns
->default_access
)
7236 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7237 "'%s' in PUBLIC interface '%s' at %L "
7238 "takes dummy arguments of '%s' which is "
7239 "PRIVATE", iface
->sym
->name
, sym
->name
,
7240 &iface
->sym
->declared_at
,
7241 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7243 /* Stop this message from recurring. */
7244 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7250 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7251 PRIVATE to the containing module. */
7252 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7254 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7257 && arg
->sym
->ts
.type
== BT_DERIVED
7258 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7259 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7260 arg
->sym
->ts
.derived
->ns
->default_access
)
7261 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7262 "'%s' in PUBLIC interface '%s' at %L "
7263 "takes dummy arguments of '%s' which is "
7264 "PRIVATE", iface
->sym
->name
, sym
->name
,
7265 &iface
->sym
->declared_at
,
7266 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7268 /* Stop this message from recurring. */
7269 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7276 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
)
7278 gfc_error ("Function '%s' at %L cannot have an initializer",
7279 sym
->name
, &sym
->declared_at
);
7283 /* An external symbol may not have an initializer because it is taken to be
7285 if (sym
->attr
.external
&& sym
->value
)
7287 gfc_error ("External object '%s' at %L may not have an initializer",
7288 sym
->name
, &sym
->declared_at
);
7292 /* An elemental function is required to return a scalar 12.7.1 */
7293 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
7295 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7296 "result", sym
->name
, &sym
->declared_at
);
7297 /* Reset so that the error only occurs once. */
7298 sym
->attr
.elemental
= 0;
7302 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7303 char-len-param shall not be array-valued, pointer-valued, recursive
7304 or pure. ....snip... A character value of * may only be used in the
7305 following ways: (i) Dummy arg of procedure - dummy associates with
7306 actual length; (ii) To declare a named constant; or (iii) External
7307 function - but length must be declared in calling scoping unit. */
7308 if (sym
->attr
.function
7309 && sym
->ts
.type
== BT_CHARACTER
7310 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
7312 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
7313 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
7315 if (sym
->as
&& sym
->as
->rank
)
7316 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7317 "array-valued", sym
->name
, &sym
->declared_at
);
7319 if (sym
->attr
.pointer
)
7320 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7321 "pointer-valued", sym
->name
, &sym
->declared_at
);
7324 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7325 "pure", sym
->name
, &sym
->declared_at
);
7327 if (sym
->attr
.recursive
)
7328 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7329 "recursive", sym
->name
, &sym
->declared_at
);
7334 /* Appendix B.2 of the standard. Contained functions give an
7335 error anyway. Fixed-form is likely to be F77/legacy. */
7336 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
7337 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
7338 "'%s' at %L is obsolescent in fortran 95",
7339 sym
->name
, &sym
->declared_at
);
7342 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
7344 gfc_formal_arglist
*curr_arg
;
7345 int has_non_interop_arg
= 0;
7347 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7348 sym
->common_block
) == FAILURE
)
7350 /* Clear these to prevent looking at them again if there was an
7352 sym
->attr
.is_bind_c
= 0;
7353 sym
->attr
.is_c_interop
= 0;
7354 sym
->ts
.is_c_interop
= 0;
7358 /* So far, no errors have been found. */
7359 sym
->attr
.is_c_interop
= 1;
7360 sym
->ts
.is_c_interop
= 1;
7363 curr_arg
= sym
->formal
;
7364 while (curr_arg
!= NULL
)
7366 /* Skip implicitly typed dummy args here. */
7367 if (curr_arg
->sym
->attr
.implicit_type
== 0)
7368 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
7369 /* If something is found to fail, record the fact so we
7370 can mark the symbol for the procedure as not being
7371 BIND(C) to try and prevent multiple errors being
7373 has_non_interop_arg
= 1;
7375 curr_arg
= curr_arg
->next
;
7378 /* See if any of the arguments were not interoperable and if so, clear
7379 the procedure symbol to prevent duplicate error messages. */
7380 if (has_non_interop_arg
!= 0)
7382 sym
->attr
.is_c_interop
= 0;
7383 sym
->ts
.is_c_interop
= 0;
7384 sym
->attr
.is_bind_c
= 0;
7392 /* Resolve the components of a derived type. */
7395 resolve_fl_derived (gfc_symbol
*sym
)
7398 gfc_dt_list
* dt_list
;
7401 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
7403 if (c
->ts
.type
== BT_CHARACTER
)
7405 if (c
->ts
.cl
->length
== NULL
7406 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
7407 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
7409 gfc_error ("Character length of component '%s' needs to "
7410 "be a constant specification expression at %L",
7412 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
7417 if (c
->ts
.type
== BT_DERIVED
7418 && sym
->component_access
!= ACCESS_PRIVATE
7419 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
7420 && !c
->ts
.derived
->attr
.use_assoc
7421 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
7422 c
->ts
.derived
->ns
->default_access
))
7424 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
7425 "a component of '%s', which is PUBLIC at %L",
7426 c
->name
, sym
->name
, &sym
->declared_at
);
7430 if (sym
->attr
.sequence
)
7432 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
7434 gfc_error ("Component %s of SEQUENCE type declared at %L does "
7435 "not have the SEQUENCE attribute",
7436 c
->ts
.derived
->name
, &sym
->declared_at
);
7441 if (c
->ts
.type
== BT_DERIVED
&& c
->pointer
7442 && c
->ts
.derived
->components
== NULL
)
7444 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
7445 "that has not been declared", c
->name
, sym
->name
,
7450 if (c
->pointer
|| c
->allocatable
|| c
->as
== NULL
)
7453 for (i
= 0; i
< c
->as
->rank
; i
++)
7455 if (c
->as
->lower
[i
] == NULL
7456 || !gfc_is_constant_expr (c
->as
->lower
[i
])
7457 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
7458 || c
->as
->upper
[i
] == NULL
7459 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
7460 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
7462 gfc_error ("Component '%s' of '%s' at %L must have "
7463 "constant array bounds",
7464 c
->name
, sym
->name
, &c
->loc
);
7470 /* Add derived type to the derived type list. */
7471 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
7472 if (sym
== dt_list
->derived
)
7475 if (dt_list
== NULL
)
7477 dt_list
= gfc_get_dt_list ();
7478 dt_list
->next
= gfc_derived_types
;
7479 dt_list
->derived
= sym
;
7480 gfc_derived_types
= dt_list
;
7488 resolve_fl_namelist (gfc_symbol
*sym
)
7493 /* Reject PRIVATE objects in a PUBLIC namelist. */
7494 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7496 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7498 if (!nl
->sym
->attr
.use_assoc
7499 && !(sym
->ns
->parent
== nl
->sym
->ns
)
7500 && !(sym
->ns
->parent
7501 && sym
->ns
->parent
->parent
== nl
->sym
->ns
)
7502 && !gfc_check_access(nl
->sym
->attr
.access
,
7503 nl
->sym
->ns
->default_access
))
7505 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
7506 "cannot be member of PUBLIC namelist '%s' at %L",
7507 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7511 /* Types with private components that came here by USE-association. */
7512 if (nl
->sym
->ts
.type
== BT_DERIVED
7513 && derived_inaccessible (nl
->sym
->ts
.derived
))
7515 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
7516 "components and cannot be member of namelist '%s' at %L",
7517 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7521 /* Types with private components that are defined in the same module. */
7522 if (nl
->sym
->ts
.type
== BT_DERIVED
7523 && !(sym
->ns
->parent
== nl
->sym
->ts
.derived
->ns
)
7524 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
7525 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
7526 nl
->sym
->ns
->default_access
))
7528 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
7529 "cannot be a member of PUBLIC namelist '%s' at %L",
7530 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7536 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7538 /* Reject namelist arrays of assumed shape. */
7539 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
7540 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
7541 "must not have assumed shape in namelist "
7542 "'%s' at %L", nl
->sym
->name
, sym
->name
,
7543 &sym
->declared_at
) == FAILURE
)
7546 /* Reject namelist arrays that are not constant shape. */
7547 if (is_non_constant_shape_array (nl
->sym
))
7549 gfc_error ("NAMELIST array object '%s' must have constant "
7550 "shape in namelist '%s' at %L", nl
->sym
->name
,
7551 sym
->name
, &sym
->declared_at
);
7555 /* Namelist objects cannot have allocatable or pointer components. */
7556 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
7559 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
7561 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7562 "have ALLOCATABLE components",
7563 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7567 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
7569 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
7570 "have POINTER components",
7571 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
7577 /* 14.1.2 A module or internal procedure represent local entities
7578 of the same type as a namelist member and so are not allowed. */
7579 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
7581 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
7584 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
7585 if ((nl
->sym
== sym
->ns
->proc_name
)
7587 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
7591 if (nl
->sym
&& nl
->sym
->name
)
7592 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
7593 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
7595 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
7596 "attribute in '%s' at %L", nlsym
->name
,
7607 resolve_fl_parameter (gfc_symbol
*sym
)
7609 /* A parameter array's shape needs to be constant. */
7611 && (sym
->as
->type
== AS_DEFERRED
7612 || is_non_constant_shape_array (sym
)))
7614 gfc_error ("Parameter array '%s' at %L cannot be automatic "
7615 "or of deferred shape", sym
->name
, &sym
->declared_at
);
7619 /* Make sure a parameter that has been implicitly typed still
7620 matches the implicit type, since PARAMETER statements can precede
7621 IMPLICIT statements. */
7622 if (sym
->attr
.implicit_type
7623 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
7625 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
7626 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
7630 /* Make sure the types of derived parameters are consistent. This
7631 type checking is deferred until resolution because the type may
7632 refer to a derived type from the host. */
7633 if (sym
->ts
.type
== BT_DERIVED
7634 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
7636 gfc_error ("Incompatible derived type in PARAMETER at %L",
7637 &sym
->value
->where
);
7644 /* Do anything necessary to resolve a symbol. Right now, we just
7645 assume that an otherwise unknown symbol is a variable. This sort
7646 of thing commonly happens for symbols in module. */
7649 resolve_symbol (gfc_symbol
*sym
)
7651 int check_constant
, mp_flag
;
7652 gfc_symtree
*symtree
;
7653 gfc_symtree
*this_symtree
;
7657 if (sym
->attr
.flavor
== FL_UNKNOWN
)
7660 /* If we find that a flavorless symbol is an interface in one of the
7661 parent namespaces, find its symtree in this namespace, free the
7662 symbol and set the symtree to point to the interface symbol. */
7663 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
7665 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
7666 if (symtree
&& symtree
->n
.sym
->generic
)
7668 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
7672 gfc_free_symbol (sym
);
7673 symtree
->n
.sym
->refs
++;
7674 this_symtree
->n
.sym
= symtree
->n
.sym
;
7679 /* Otherwise give it a flavor according to such attributes as
7681 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
7682 sym
->attr
.flavor
= FL_VARIABLE
;
7685 sym
->attr
.flavor
= FL_PROCEDURE
;
7686 if (sym
->attr
.dimension
)
7687 sym
->attr
.function
= 1;
7691 if (sym
->attr
.procedure
&& sym
->interface
7692 && sym
->attr
.if_source
!= IFSRC_DECL
)
7694 if (sym
->interface
->attr
.procedure
)
7695 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
7696 "in a later PROCEDURE statement", sym
->interface
->name
,
7697 sym
->name
,&sym
->declared_at
);
7699 /* Get the attributes from the interface (now resolved). */
7700 if (sym
->interface
->attr
.if_source
|| sym
->interface
->attr
.intrinsic
)
7702 sym
->ts
= sym
->interface
->ts
;
7703 sym
->attr
.function
= sym
->interface
->attr
.function
;
7704 sym
->attr
.subroutine
= sym
->interface
->attr
.subroutine
;
7705 copy_formal_args (sym
, sym
->interface
);
7707 else if (sym
->interface
->name
[0] != '\0')
7709 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
7710 sym
->interface
->name
, sym
->name
, &sym
->declared_at
);
7715 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
7718 /* Symbols that are module procedures with results (functions) have
7719 the types and array specification copied for type checking in
7720 procedures that call them, as well as for saving to a module
7721 file. These symbols can't stand the scrutiny that their results
7723 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
7726 /* Make sure that the intrinsic is consistent with its internal
7727 representation. This needs to be done before assigning a default
7728 type to avoid spurious warnings. */
7729 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
7731 if (gfc_intrinsic_name (sym
->name
, 0))
7733 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
7734 gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
7735 sym
->name
, &sym
->declared_at
);
7737 else if (gfc_intrinsic_name (sym
->name
, 1))
7739 if (sym
->ts
.type
!= BT_UNKNOWN
)
7741 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
7742 sym
->name
, &sym
->declared_at
);
7748 gfc_error ("Intrinsic '%s' at %L does not exist", sym
->name
, &sym
->declared_at
);
7753 /* Assign default type to symbols that need one and don't have one. */
7754 if (sym
->ts
.type
== BT_UNKNOWN
)
7756 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
7757 gfc_set_default_type (sym
, 1, NULL
);
7759 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
7761 /* The specific case of an external procedure should emit an error
7762 in the case that there is no implicit type. */
7764 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
7767 /* Result may be in another namespace. */
7768 resolve_symbol (sym
->result
);
7770 sym
->ts
= sym
->result
->ts
;
7771 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
7772 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
7773 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
7774 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
7779 /* Assumed size arrays and assumed shape arrays must be dummy
7783 && (sym
->as
->type
== AS_ASSUMED_SIZE
7784 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
7785 && sym
->attr
.dummy
== 0)
7787 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
7788 gfc_error ("Assumed size array at %L must be a dummy argument",
7791 gfc_error ("Assumed shape array at %L must be a dummy argument",
7796 /* Make sure symbols with known intent or optional are really dummy
7797 variable. Because of ENTRY statement, this has to be deferred
7798 until resolution time. */
7800 if (!sym
->attr
.dummy
7801 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
7803 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
7807 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
7809 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
7810 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
7814 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
7816 gfc_charlen
*cl
= sym
->ts
.cl
;
7817 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7819 gfc_error ("Character dummy variable '%s' at %L with VALUE "
7820 "attribute must have constant length",
7821 sym
->name
, &sym
->declared_at
);
7825 if (sym
->ts
.is_c_interop
7826 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
7828 gfc_error ("C interoperable character dummy variable '%s' at %L "
7829 "with VALUE attribute must have length one",
7830 sym
->name
, &sym
->declared_at
);
7835 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
7836 do this for something that was implicitly typed because that is handled
7837 in gfc_set_default_type. Handle dummy arguments and procedure
7838 definitions separately. Also, anything that is use associated is not
7839 handled here but instead is handled in the module it is declared in.
7840 Finally, derived type definitions are allowed to be BIND(C) since that
7841 only implies that they're interoperable, and they are checked fully for
7842 interoperability when a variable is declared of that type. */
7843 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
7844 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
7845 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
7849 /* First, make sure the variable is declared at the
7850 module-level scope (J3/04-007, Section 15.3). */
7851 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
7852 sym
->attr
.in_common
== 0)
7854 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
7855 "is neither a COMMON block nor declared at the "
7856 "module level scope", sym
->name
, &(sym
->declared_at
));
7859 else if (sym
->common_head
!= NULL
)
7861 t
= verify_com_block_vars_c_interop (sym
->common_head
);
7865 /* If type() declaration, we need to verify that the components
7866 of the given type are all C interoperable, etc. */
7867 if (sym
->ts
.type
== BT_DERIVED
&&
7868 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
7870 /* Make sure the user marked the derived type as BIND(C). If
7871 not, call the verify routine. This could print an error
7872 for the derived type more than once if multiple variables
7873 of that type are declared. */
7874 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
7875 verify_bind_c_derived_type (sym
->ts
.derived
);
7879 /* Verify the variable itself as C interoperable if it
7880 is BIND(C). It is not possible for this to succeed if
7881 the verify_bind_c_derived_type failed, so don't have to handle
7882 any error returned by verify_bind_c_derived_type. */
7883 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7889 /* clear the is_bind_c flag to prevent reporting errors more than
7890 once if something failed. */
7891 sym
->attr
.is_bind_c
= 0;
7896 /* If a derived type symbol has reached this point, without its
7897 type being declared, we have an error. Notice that most
7898 conditions that produce undefined derived types have already
7899 been dealt with. However, the likes of:
7900 implicit type(t) (t) ..... call foo (t) will get us here if
7901 the type is not declared in the scope of the implicit
7902 statement. Change the type to BT_UNKNOWN, both because it is so
7903 and to prevent an ICE. */
7904 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
7905 && !sym
->ts
.derived
->attr
.zero_comp
)
7907 gfc_error ("The derived type '%s' at %L is of type '%s', "
7908 "which has not been defined", sym
->name
,
7909 &sym
->declared_at
, sym
->ts
.derived
->name
);
7910 sym
->ts
.type
= BT_UNKNOWN
;
7914 /* Unless the derived-type declaration is use associated, Fortran 95
7915 does not allow public entries of private derived types.
7916 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
7918 if (sym
->ts
.type
== BT_DERIVED
7919 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7920 && !sym
->ts
.derived
->attr
.use_assoc
7921 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
7922 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
7923 sym
->ts
.derived
->ns
->default_access
)
7924 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
7925 "of PRIVATE derived type '%s'",
7926 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
7927 : "variable", sym
->name
, &sym
->declared_at
,
7928 sym
->ts
.derived
->name
) == FAILURE
)
7931 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
7932 default initialization is defined (5.1.2.4.4). */
7933 if (sym
->ts
.type
== BT_DERIVED
7935 && sym
->attr
.intent
== INTENT_OUT
7937 && sym
->as
->type
== AS_ASSUMED_SIZE
)
7939 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
7943 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
7944 "ASSUMED SIZE and so cannot have a default initializer",
7945 sym
->name
, &sym
->declared_at
);
7951 switch (sym
->attr
.flavor
)
7954 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
7959 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
7964 if (resolve_fl_namelist (sym
) == FAILURE
)
7969 if (resolve_fl_parameter (sym
) == FAILURE
)
7977 /* Resolve array specifier. Check as well some constraints
7978 on COMMON blocks. */
7980 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
7982 /* Set the formal_arg_flag so that check_conflict will not throw
7983 an error for host associated variables in the specification
7984 expression for an array_valued function. */
7985 if (sym
->attr
.function
&& sym
->as
)
7986 formal_arg_flag
= 1;
7988 gfc_resolve_array_spec (sym
->as
, check_constant
);
7990 formal_arg_flag
= 0;
7992 /* Resolve formal namespaces. */
7993 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
7994 gfc_resolve (sym
->formal_ns
);
7996 /* Check threadprivate restrictions. */
7997 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
7998 && (!sym
->attr
.in_common
7999 && sym
->module
== NULL
8000 && (sym
->ns
->proc_name
== NULL
8001 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
8002 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
8004 /* If we have come this far we can apply default-initializers, as
8005 described in 14.7.5, to those variables that have not already
8006 been assigned one. */
8007 if (sym
->ts
.type
== BT_DERIVED
8008 && sym
->attr
.referenced
8009 && sym
->ns
== gfc_current_ns
8011 && !sym
->attr
.allocatable
8012 && !sym
->attr
.alloc_comp
)
8014 symbol_attribute
*a
= &sym
->attr
;
8016 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
8017 && !a
->in_common
&& !a
->use_assoc
8018 && !(a
->function
&& sym
!= sym
->result
))
8019 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
8020 apply_default_init (sym
);
8025 /************* Resolve DATA statements *************/
8029 gfc_data_value
*vnode
;
8035 /* Advance the values structure to point to the next value in the data list. */
8038 next_data_value (void)
8041 while (mpz_cmp_ui (values
.left
, 0) == 0)
8043 if (values
.vnode
->next
== NULL
)
8046 values
.vnode
= values
.vnode
->next
;
8047 mpz_set (values
.left
, values
.vnode
->repeat
);
8055 check_data_variable (gfc_data_variable
*var
, locus
*where
)
8061 ar_type mark
= AR_UNKNOWN
;
8063 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
8067 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
8071 mpz_init_set_si (offset
, 0);
8074 if (e
->expr_type
!= EXPR_VARIABLE
)
8075 gfc_internal_error ("check_data_variable(): Bad expression");
8077 if (e
->symtree
->n
.sym
->ns
->is_block_data
8078 && !e
->symtree
->n
.sym
->attr
.in_common
)
8080 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
8081 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
8084 if (e
->ref
== NULL
&& e
->symtree
->n
.sym
->as
)
8086 gfc_error ("DATA array '%s' at %L must be specified in a previous"
8087 " declaration", e
->symtree
->n
.sym
->name
, where
);
8093 mpz_init_set_ui (size
, 1);
8100 /* Find the array section reference. */
8101 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
8103 if (ref
->type
!= REF_ARRAY
)
8105 if (ref
->u
.ar
.type
== AR_ELEMENT
)
8111 /* Set marks according to the reference pattern. */
8112 switch (ref
->u
.ar
.type
)
8120 /* Get the start position of array section. */
8121 gfc_get_section_index (ar
, section_index
, &offset
);
8129 if (gfc_array_size (e
, &size
) == FAILURE
)
8131 gfc_error ("Nonconstant array section at %L in DATA statement",
8140 while (mpz_cmp_ui (size
, 0) > 0)
8142 if (next_data_value () == FAILURE
)
8144 gfc_error ("DATA statement at %L has more variables than values",
8150 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
8154 /* If we have more than one element left in the repeat count,
8155 and we have more than one element left in the target variable,
8156 then create a range assignment. */
8157 /* FIXME: Only done for full arrays for now, since array sections
8159 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
8160 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
8164 if (mpz_cmp (size
, values
.left
) >= 0)
8166 mpz_init_set (range
, values
.left
);
8167 mpz_sub (size
, size
, values
.left
);
8168 mpz_set_ui (values
.left
, 0);
8172 mpz_init_set (range
, size
);
8173 mpz_sub (values
.left
, values
.left
, size
);
8174 mpz_set_ui (size
, 0);
8177 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
8180 mpz_add (offset
, offset
, range
);
8184 /* Assign initial value to symbol. */
8187 mpz_sub_ui (values
.left
, values
.left
, 1);
8188 mpz_sub_ui (size
, size
, 1);
8190 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
8194 if (mark
== AR_FULL
)
8195 mpz_add_ui (offset
, offset
, 1);
8197 /* Modify the array section indexes and recalculate the offset
8198 for next element. */
8199 else if (mark
== AR_SECTION
)
8200 gfc_advance_section (section_index
, ar
, &offset
);
8204 if (mark
== AR_SECTION
)
8206 for (i
= 0; i
< ar
->dimen
; i
++)
8207 mpz_clear (section_index
[i
]);
8217 static try traverse_data_var (gfc_data_variable
*, locus
*);
8219 /* Iterate over a list of elements in a DATA statement. */
8222 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
8225 iterator_stack frame
;
8226 gfc_expr
*e
, *start
, *end
, *step
;
8227 try retval
= SUCCESS
;
8229 mpz_init (frame
.value
);
8231 start
= gfc_copy_expr (var
->iter
.start
);
8232 end
= gfc_copy_expr (var
->iter
.end
);
8233 step
= gfc_copy_expr (var
->iter
.step
);
8235 if (gfc_simplify_expr (start
, 1) == FAILURE
8236 || start
->expr_type
!= EXPR_CONSTANT
)
8238 gfc_error ("iterator start at %L does not simplify", &start
->where
);
8242 if (gfc_simplify_expr (end
, 1) == FAILURE
8243 || end
->expr_type
!= EXPR_CONSTANT
)
8245 gfc_error ("iterator end at %L does not simplify", &end
->where
);
8249 if (gfc_simplify_expr (step
, 1) == FAILURE
8250 || step
->expr_type
!= EXPR_CONSTANT
)
8252 gfc_error ("iterator step at %L does not simplify", &step
->where
);
8257 mpz_init_set (trip
, end
->value
.integer
);
8258 mpz_sub (trip
, trip
, start
->value
.integer
);
8259 mpz_add (trip
, trip
, step
->value
.integer
);
8261 mpz_div (trip
, trip
, step
->value
.integer
);
8263 mpz_set (frame
.value
, start
->value
.integer
);
8265 frame
.prev
= iter_stack
;
8266 frame
.variable
= var
->iter
.var
->symtree
;
8267 iter_stack
= &frame
;
8269 while (mpz_cmp_ui (trip
, 0) > 0)
8271 if (traverse_data_var (var
->list
, where
) == FAILURE
)
8278 e
= gfc_copy_expr (var
->expr
);
8279 if (gfc_simplify_expr (e
, 1) == FAILURE
)
8287 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
8289 mpz_sub_ui (trip
, trip
, 1);
8294 mpz_clear (frame
.value
);
8296 gfc_free_expr (start
);
8297 gfc_free_expr (end
);
8298 gfc_free_expr (step
);
8300 iter_stack
= frame
.prev
;
8305 /* Type resolve variables in the variable list of a DATA statement. */
8308 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
8312 for (; var
; var
= var
->next
)
8314 if (var
->expr
== NULL
)
8315 t
= traverse_data_list (var
, where
);
8317 t
= check_data_variable (var
, where
);
8327 /* Resolve the expressions and iterators associated with a data statement.
8328 This is separate from the assignment checking because data lists should
8329 only be resolved once. */
8332 resolve_data_variables (gfc_data_variable
*d
)
8334 for (; d
; d
= d
->next
)
8336 if (d
->list
== NULL
)
8338 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
8343 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
8346 if (resolve_data_variables (d
->list
) == FAILURE
)
8355 /* Resolve a single DATA statement. We implement this by storing a pointer to
8356 the value list into static variables, and then recursively traversing the
8357 variables list, expanding iterators and such. */
8360 resolve_data (gfc_data
*d
)
8363 if (resolve_data_variables (d
->var
) == FAILURE
)
8366 values
.vnode
= d
->value
;
8367 if (d
->value
== NULL
)
8368 mpz_set_ui (values
.left
, 0);
8370 mpz_set (values
.left
, d
->value
->repeat
);
8372 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
8375 /* At this point, we better not have any values left. */
8377 if (next_data_value () == SUCCESS
)
8378 gfc_error ("DATA statement at %L has more values than variables",
8383 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
8384 accessed by host or use association, is a dummy argument to a pure function,
8385 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
8386 is storage associated with any such variable, shall not be used in the
8387 following contexts: (clients of this function). */
8389 /* Determines if a variable is not 'pure', ie not assignable within a pure
8390 procedure. Returns zero if assignment is OK, nonzero if there is a
8393 gfc_impure_variable (gfc_symbol
*sym
)
8397 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
8400 if (sym
->ns
!= gfc_current_ns
)
8401 return !sym
->attr
.function
;
8403 proc
= sym
->ns
->proc_name
;
8404 if (sym
->attr
.dummy
&& gfc_pure (proc
)
8405 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
8407 proc
->attr
.function
))
8410 /* TODO: Sort out what can be storage associated, if anything, and include
8411 it here. In principle equivalences should be scanned but it does not
8412 seem to be possible to storage associate an impure variable this way. */
8417 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
8418 symbol of the current procedure. */
8421 gfc_pure (gfc_symbol
*sym
)
8423 symbol_attribute attr
;
8426 sym
= gfc_current_ns
->proc_name
;
8432 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
8436 /* Test whether the current procedure is elemental or not. */
8439 gfc_elemental (gfc_symbol
*sym
)
8441 symbol_attribute attr
;
8444 sym
= gfc_current_ns
->proc_name
;
8449 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
8453 /* Warn about unused labels. */
8456 warn_unused_fortran_label (gfc_st_label
*label
)
8461 warn_unused_fortran_label (label
->left
);
8463 if (label
->defined
== ST_LABEL_UNKNOWN
)
8466 switch (label
->referenced
)
8468 case ST_LABEL_UNKNOWN
:
8469 gfc_warning ("Label %d at %L defined but not used", label
->value
,
8473 case ST_LABEL_BAD_TARGET
:
8474 gfc_warning ("Label %d at %L defined but cannot be used",
8475 label
->value
, &label
->where
);
8482 warn_unused_fortran_label (label
->right
);
8486 /* Returns the sequence type of a symbol or sequence. */
8489 sequence_type (gfc_typespec ts
)
8498 if (ts
.derived
->components
== NULL
)
8499 return SEQ_NONDEFAULT
;
8501 result
= sequence_type (ts
.derived
->components
->ts
);
8502 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
8503 if (sequence_type (c
->ts
) != result
)
8509 if (ts
.kind
!= gfc_default_character_kind
)
8510 return SEQ_NONDEFAULT
;
8512 return SEQ_CHARACTER
;
8515 if (ts
.kind
!= gfc_default_integer_kind
)
8516 return SEQ_NONDEFAULT
;
8521 if (!(ts
.kind
== gfc_default_real_kind
8522 || ts
.kind
== gfc_default_double_kind
))
8523 return SEQ_NONDEFAULT
;
8528 if (ts
.kind
!= gfc_default_complex_kind
)
8529 return SEQ_NONDEFAULT
;
8534 if (ts
.kind
!= gfc_default_logical_kind
)
8535 return SEQ_NONDEFAULT
;
8540 return SEQ_NONDEFAULT
;
8545 /* Resolve derived type EQUIVALENCE object. */
8548 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
8551 gfc_component
*c
= derived
->components
;
8556 /* Shall not be an object of nonsequence derived type. */
8557 if (!derived
->attr
.sequence
)
8559 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
8560 "attribute to be an EQUIVALENCE object", sym
->name
,
8565 /* Shall not have allocatable components. */
8566 if (derived
->attr
.alloc_comp
)
8568 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
8569 "components to be an EQUIVALENCE object",sym
->name
,
8574 if (sym
->attr
.in_common
&& has_default_initializer (sym
->ts
.derived
))
8576 gfc_error ("Derived type variable '%s' at %L with default "
8577 "initialization cannot be in EQUIVALENCE with a variable "
8578 "in COMMON", sym
->name
, &e
->where
);
8582 for (; c
; c
= c
->next
)
8586 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
8589 /* Shall not be an object of sequence derived type containing a pointer
8590 in the structure. */
8593 gfc_error ("Derived type variable '%s' at %L with pointer "
8594 "component(s) cannot be an EQUIVALENCE object",
8595 sym
->name
, &e
->where
);
8603 /* Resolve equivalence object.
8604 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
8605 an allocatable array, an object of nonsequence derived type, an object of
8606 sequence derived type containing a pointer at any level of component
8607 selection, an automatic object, a function name, an entry name, a result
8608 name, a named constant, a structure component, or a subobject of any of
8609 the preceding objects. A substring shall not have length zero. A
8610 derived type shall not have components with default initialization nor
8611 shall two objects of an equivalence group be initialized.
8612 Either all or none of the objects shall have an protected attribute.
8613 The simple constraints are done in symbol.c(check_conflict) and the rest
8614 are implemented here. */
8617 resolve_equivalence (gfc_equiv
*eq
)
8620 gfc_symbol
*derived
;
8621 gfc_symbol
*first_sym
;
8624 locus
*last_where
= NULL
;
8625 seq_type eq_type
, last_eq_type
;
8626 gfc_typespec
*last_ts
;
8627 int object
, cnt_protected
;
8628 const char *value_name
;
8632 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
8634 first_sym
= eq
->expr
->symtree
->n
.sym
;
8638 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
8642 e
->ts
= e
->symtree
->n
.sym
->ts
;
8643 /* match_varspec might not know yet if it is seeing
8644 array reference or substring reference, as it doesn't
8646 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
8648 gfc_ref
*ref
= e
->ref
;
8649 sym
= e
->symtree
->n
.sym
;
8651 if (sym
->attr
.dimension
)
8653 ref
->u
.ar
.as
= sym
->as
;
8657 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
8658 if (e
->ts
.type
== BT_CHARACTER
8660 && ref
->type
== REF_ARRAY
8661 && ref
->u
.ar
.dimen
== 1
8662 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
8663 && ref
->u
.ar
.stride
[0] == NULL
)
8665 gfc_expr
*start
= ref
->u
.ar
.start
[0];
8666 gfc_expr
*end
= ref
->u
.ar
.end
[0];
8669 /* Optimize away the (:) reference. */
8670 if (start
== NULL
&& end
== NULL
)
8675 e
->ref
->next
= ref
->next
;
8680 ref
->type
= REF_SUBSTRING
;
8682 start
= gfc_int_expr (1);
8683 ref
->u
.ss
.start
= start
;
8684 if (end
== NULL
&& e
->ts
.cl
)
8685 end
= gfc_copy_expr (e
->ts
.cl
->length
);
8686 ref
->u
.ss
.end
= end
;
8687 ref
->u
.ss
.length
= e
->ts
.cl
;
8694 /* Any further ref is an error. */
8697 gcc_assert (ref
->type
== REF_ARRAY
);
8698 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
8704 if (gfc_resolve_expr (e
) == FAILURE
)
8707 sym
= e
->symtree
->n
.sym
;
8709 if (sym
->attr
.protected)
8711 if (cnt_protected
> 0 && cnt_protected
!= object
)
8713 gfc_error ("Either all or none of the objects in the "
8714 "EQUIVALENCE set at %L shall have the "
8715 "PROTECTED attribute",
8720 /* Shall not equivalence common block variables in a PURE procedure. */
8721 if (sym
->ns
->proc_name
8722 && sym
->ns
->proc_name
->attr
.pure
8723 && sym
->attr
.in_common
)
8725 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
8726 "object in the pure procedure '%s'",
8727 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
8731 /* Shall not be a named constant. */
8732 if (e
->expr_type
== EXPR_CONSTANT
)
8734 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
8735 "object", sym
->name
, &e
->where
);
8739 derived
= e
->ts
.derived
;
8740 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
8743 /* Check that the types correspond correctly:
8745 A numeric sequence structure may be equivalenced to another sequence
8746 structure, an object of default integer type, default real type, double
8747 precision real type, default logical type such that components of the
8748 structure ultimately only become associated to objects of the same
8749 kind. A character sequence structure may be equivalenced to an object
8750 of default character kind or another character sequence structure.
8751 Other objects may be equivalenced only to objects of the same type and
8754 /* Identical types are unconditionally OK. */
8755 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
8756 goto identical_types
;
8758 last_eq_type
= sequence_type (*last_ts
);
8759 eq_type
= sequence_type (sym
->ts
);
8761 /* Since the pair of objects is not of the same type, mixed or
8762 non-default sequences can be rejected. */
8764 msg
= "Sequence %s with mixed components in EQUIVALENCE "
8765 "statement at %L with different type objects";
8767 && last_eq_type
== SEQ_MIXED
8768 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
8770 || (eq_type
== SEQ_MIXED
8771 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8772 &e
->where
) == FAILURE
))
8775 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
8776 "statement at %L with objects of different type";
8778 && last_eq_type
== SEQ_NONDEFAULT
8779 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
8780 last_where
) == FAILURE
)
8781 || (eq_type
== SEQ_NONDEFAULT
8782 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8783 &e
->where
) == FAILURE
))
8786 msg
="Non-CHARACTER object '%s' in default CHARACTER "
8787 "EQUIVALENCE statement at %L";
8788 if (last_eq_type
== SEQ_CHARACTER
8789 && eq_type
!= SEQ_CHARACTER
8790 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8791 &e
->where
) == FAILURE
)
8794 msg
="Non-NUMERIC object '%s' in default NUMERIC "
8795 "EQUIVALENCE statement at %L";
8796 if (last_eq_type
== SEQ_NUMERIC
8797 && eq_type
!= SEQ_NUMERIC
8798 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
8799 &e
->where
) == FAILURE
)
8804 last_where
= &e
->where
;
8809 /* Shall not be an automatic array. */
8810 if (e
->ref
->type
== REF_ARRAY
8811 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
8813 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
8814 "an EQUIVALENCE object", sym
->name
, &e
->where
);
8821 /* Shall not be a structure component. */
8822 if (r
->type
== REF_COMPONENT
)
8824 gfc_error ("Structure component '%s' at %L cannot be an "
8825 "EQUIVALENCE object",
8826 r
->u
.c
.component
->name
, &e
->where
);
8830 /* A substring shall not have length zero. */
8831 if (r
->type
== REF_SUBSTRING
)
8833 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
8835 gfc_error ("Substring at %L has length zero",
8836 &r
->u
.ss
.start
->where
);
8846 /* Resolve function and ENTRY types, issue diagnostics if needed. */
8849 resolve_fntype (gfc_namespace
*ns
)
8854 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
8857 /* If there are any entries, ns->proc_name is the entry master
8858 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
8860 sym
= ns
->entries
->sym
;
8862 sym
= ns
->proc_name
;
8863 if (sym
->result
== sym
8864 && sym
->ts
.type
== BT_UNKNOWN
8865 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
8866 && !sym
->attr
.untyped
)
8868 gfc_error ("Function '%s' at %L has no IMPLICIT type",
8869 sym
->name
, &sym
->declared_at
);
8870 sym
->attr
.untyped
= 1;
8873 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
8874 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
8875 sym
->ts
.derived
->ns
->default_access
)
8876 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
8878 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
8879 sym
->name
, &sym
->declared_at
, sym
->ts
.derived
->name
);
8883 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
8885 if (el
->sym
->result
== el
->sym
8886 && el
->sym
->ts
.type
== BT_UNKNOWN
8887 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
8888 && !el
->sym
->attr
.untyped
)
8890 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
8891 el
->sym
->name
, &el
->sym
->declared_at
);
8892 el
->sym
->attr
.untyped
= 1;
8897 /* 12.3.2.1.1 Defined operators. */
8900 gfc_resolve_uops (gfc_symtree
*symtree
)
8904 gfc_formal_arglist
*formal
;
8906 if (symtree
== NULL
)
8909 gfc_resolve_uops (symtree
->left
);
8910 gfc_resolve_uops (symtree
->right
);
8912 for (itr
= symtree
->n
.uop
->operator; itr
; itr
= itr
->next
)
8915 if (!sym
->attr
.function
)
8916 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
8917 sym
->name
, &sym
->declared_at
);
8919 if (sym
->ts
.type
== BT_CHARACTER
8920 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
8921 && !(sym
->result
&& sym
->result
->ts
.cl
8922 && sym
->result
->ts
.cl
->length
))
8923 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
8924 "character length", sym
->name
, &sym
->declared_at
);
8926 formal
= sym
->formal
;
8927 if (!formal
|| !formal
->sym
)
8929 gfc_error ("User operator procedure '%s' at %L must have at least "
8930 "one argument", sym
->name
, &sym
->declared_at
);
8934 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8935 gfc_error ("First argument of operator interface at %L must be "
8936 "INTENT(IN)", &sym
->declared_at
);
8938 if (formal
->sym
->attr
.optional
)
8939 gfc_error ("First argument of operator interface at %L cannot be "
8940 "optional", &sym
->declared_at
);
8942 formal
= formal
->next
;
8943 if (!formal
|| !formal
->sym
)
8946 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
8947 gfc_error ("Second argument of operator interface at %L must be "
8948 "INTENT(IN)", &sym
->declared_at
);
8950 if (formal
->sym
->attr
.optional
)
8951 gfc_error ("Second argument of operator interface at %L cannot be "
8952 "optional", &sym
->declared_at
);
8955 gfc_error ("Operator interface at %L must have, at most, two "
8956 "arguments", &sym
->declared_at
);
8961 /* Examine all of the expressions associated with a program unit,
8962 assign types to all intermediate expressions, make sure that all
8963 assignments are to compatible types and figure out which names
8964 refer to which functions or subroutines. It doesn't check code
8965 block, which is handled by resolve_code. */
8968 resolve_types (gfc_namespace
*ns
)
8975 gfc_current_ns
= ns
;
8977 resolve_entries (ns
);
8979 resolve_common_vars (ns
->blank_common
.head
, false);
8980 resolve_common_blocks (ns
->common_root
);
8982 resolve_contained_functions (ns
);
8984 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
8986 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
8987 resolve_charlen (cl
);
8989 gfc_traverse_ns (ns
, resolve_symbol
);
8991 resolve_fntype (ns
);
8993 for (n
= ns
->contained
; n
; n
= n
->sibling
)
8995 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
8996 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
8997 "also be PURE", n
->proc_name
->name
,
8998 &n
->proc_name
->declared_at
);
9004 gfc_check_interfaces (ns
);
9006 gfc_traverse_ns (ns
, resolve_values
);
9012 for (d
= ns
->data
; d
; d
= d
->next
)
9016 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
9018 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
9020 if (ns
->common_root
!= NULL
)
9021 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
9023 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
9024 resolve_equivalence (eq
);
9026 /* Warn about unused labels. */
9027 if (warn_unused_label
)
9028 warn_unused_fortran_label (ns
->st_labels
);
9030 gfc_resolve_uops (ns
->uop_root
);
9034 /* Call resolve_code recursively. */
9037 resolve_codes (gfc_namespace
*ns
)
9041 for (n
= ns
->contained
; n
; n
= n
->sibling
)
9044 gfc_current_ns
= ns
;
9046 /* Set to an out of range value. */
9047 current_entry_id
= -1;
9049 bitmap_obstack_initialize (&labels_obstack
);
9050 resolve_code (ns
->code
, ns
);
9051 bitmap_obstack_release (&labels_obstack
);
9055 /* This function is called after a complete program unit has been compiled.
9056 Its purpose is to examine all of the expressions associated with a program
9057 unit, assign types to all intermediate expressions, make sure that all
9058 assignments are to compatible types and figure out which names refer to
9059 which functions or subroutines. */
9062 gfc_resolve (gfc_namespace
*ns
)
9064 gfc_namespace
*old_ns
;
9066 old_ns
= gfc_current_ns
;
9071 gfc_current_ns
= old_ns
;