2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "constructor.h"
28 /**************** Array reference matching subroutines *****************/
30 /* Copy an array reference structure. */
33 gfc_copy_array_ref (gfc_array_ref
*src
)
41 dest
= gfc_get_array_ref ();
45 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
47 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
48 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
49 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
56 /* Match a single dimension of an array reference. This can be a
57 single element or an array section. Any modifications we've made
58 to the ar structure are cleaned up by the caller. If the init
59 is set, we require the subscript to be a valid initialization
63 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
65 match m
= MATCH_ERROR
;
69 i
= ar
->dimen
+ ar
->codimen
;
71 gfc_gobble_whitespace ();
72 ar
->c_where
[i
] = gfc_current_locus
;
73 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
75 /* We can't be sure of the difference between DIMEN_ELEMENT and
76 DIMEN_VECTOR until we know the type of the element itself at
79 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
81 if (gfc_match_char (':') == MATCH_YES
)
84 /* Get start element. */
85 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
89 m
= gfc_match_init_expr (&ar
->start
[i
]);
91 m
= gfc_match_expr (&ar
->start
[i
]);
94 gfc_error ("Expected array subscript at %C");
98 if (gfc_match_char (':') == MATCH_NO
)
103 gfc_error ("Unexpected '*' in coarray subscript at %C");
107 /* Get an optional end element. Because we've seen the colon, we
108 definitely have a range along this dimension. */
110 ar
->dimen_type
[i
] = DIMEN_RANGE
;
112 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
115 m
= gfc_match_init_expr (&ar
->end
[i
]);
117 m
= gfc_match_expr (&ar
->end
[i
]);
119 if (m
== MATCH_ERROR
)
122 /* See if we have an optional stride. */
123 if (gfc_match_char (':') == MATCH_YES
)
127 gfc_error ("Strides not allowed in coarray subscript at %C");
131 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
132 : gfc_match_expr (&ar
->stride
[i
]);
135 gfc_error ("Expected array subscript stride at %C");
142 ar
->dimen_type
[i
] = DIMEN_STAR
;
148 /* Match an array reference, whether it is the whole array or a
149 particular elements or a section. If init is set, the reference has
150 to consist of init expressions. */
153 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
157 bool matched_bracket
= false;
159 memset (ar
, '\0', sizeof (*ar
));
161 ar
->where
= gfc_current_locus
;
163 ar
->type
= AR_UNKNOWN
;
165 if (gfc_match_char ('[') == MATCH_YES
)
167 matched_bracket
= true;
171 if (gfc_match_char ('(') != MATCH_YES
)
178 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
180 m
= match_subscript (ar
, init
, false);
181 if (m
== MATCH_ERROR
)
184 if (gfc_match_char (')') == MATCH_YES
)
190 if (gfc_match_char (',') != MATCH_YES
)
192 gfc_error ("Invalid form of array reference at %C");
197 gfc_error ("Array reference at %C cannot have more than %d dimensions",
202 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
210 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
212 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
218 gfc_error ("Unexpected coarray designator at %C");
222 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
224 m
= match_subscript (ar
, init
, true);
225 if (m
== MATCH_ERROR
)
228 if (gfc_match_char (']') == MATCH_YES
)
231 if (ar
->codimen
< corank
)
233 gfc_error ("Too few codimensions at %C, expected %d not %d",
234 corank
, ar
->codimen
);
237 if (ar
->codimen
> corank
)
239 gfc_error ("Too many codimensions at %C, expected %d not %d",
240 corank
, ar
->codimen
);
246 if (gfc_match_char (',') != MATCH_YES
)
248 if (gfc_match_char ('*') == MATCH_YES
)
249 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
250 ar
->codimen
+ 1, corank
);
252 gfc_error ("Invalid form of coarray reference at %C");
255 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
257 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
258 ar
->codimen
+ 1, corank
);
262 if (ar
->codimen
>= corank
)
264 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
265 ar
->codimen
+ 1, corank
);
270 gfc_error ("Array reference at %C cannot have more than %d dimensions",
277 /************** Array specification matching subroutines ***************/
279 /* Free all of the expressions associated with array bounds
283 gfc_free_array_spec (gfc_array_spec
*as
)
290 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
292 gfc_free_expr (as
->lower
[i
]);
293 gfc_free_expr (as
->upper
[i
]);
300 /* Take an array bound, resolves the expression, that make up the
301 shape and check associated constraints. */
304 resolve_array_bound (gfc_expr
*e
, int check_constant
)
309 if (!gfc_resolve_expr (e
)
310 || !gfc_specification_expr (e
))
313 if (check_constant
&& !gfc_is_constant_expr (e
))
315 if (e
->expr_type
== EXPR_VARIABLE
)
316 gfc_error ("Variable '%s' at %L in this context must be constant",
317 e
->symtree
->n
.sym
->name
, &e
->where
);
319 gfc_error ("Expression at %L in this context must be constant",
328 /* Takes an array specification, resolves the expressions that make up
329 the shape and make sure everything is integral. */
332 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
340 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
343 if (!resolve_array_bound (e
, check_constant
))
347 if (!resolve_array_bound (e
, check_constant
))
350 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
353 /* If the size is negative in this dimension, set it to zero. */
354 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
355 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
356 && mpz_cmp (as
->upper
[i
]->value
.integer
,
357 as
->lower
[i
]->value
.integer
) < 0)
359 gfc_free_expr (as
->upper
[i
]);
360 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
361 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
362 as
->upper
[i
]->value
.integer
, 1);
370 /* Match a single array element specification. The return values as
371 well as the upper and lower bounds of the array spec are filled
372 in according to what we see on the input. The caller makes sure
373 individual specifications make sense as a whole.
376 Parsed Lower Upper Returned
377 ------------------------------------
378 : NULL NULL AS_DEFERRED (*)
380 x: x NULL AS_ASSUMED_SHAPE
382 x:* x NULL AS_ASSUMED_SIZE
383 * 1 NULL AS_ASSUMED_SIZE
385 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
386 is fixed during the resolution of formal interfaces.
388 Anything else AS_UNKNOWN. */
391 match_array_element_spec (gfc_array_spec
*as
)
393 gfc_expr
**upper
, **lower
;
397 rank
= as
->rank
== -1 ? 0 : as
->rank
;
398 lower
= &as
->lower
[rank
+ as
->corank
- 1];
399 upper
= &as
->upper
[rank
+ as
->corank
- 1];
401 if (gfc_match_char ('*') == MATCH_YES
)
403 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
404 return AS_ASSUMED_SIZE
;
407 if (gfc_match_char (':') == MATCH_YES
)
410 m
= gfc_match_expr (upper
);
412 gfc_error ("Expected expression in array specification at %C");
415 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
418 if (gfc_match_char (':') == MATCH_NO
)
420 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
427 if (gfc_match_char ('*') == MATCH_YES
)
428 return AS_ASSUMED_SIZE
;
430 m
= gfc_match_expr (upper
);
431 if (m
== MATCH_ERROR
)
434 return AS_ASSUMED_SHAPE
;
435 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
442 /* Matches an array specification, incidentally figuring out what sort
443 it is. Match either a normal array specification, or a coarray spec
444 or both. Optionally allow [:] for coarrays. */
447 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
449 array_type current_type
;
453 as
= gfc_get_array_spec ();
458 if (gfc_match_char ('(') != MATCH_YES
)
465 if (gfc_match (" .. )") == MATCH_YES
)
467 as
->type
= AS_ASSUMED_RANK
;
470 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C"))
481 current_type
= match_array_element_spec (as
);
483 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
484 and implied-shape specifications. If the rank is at least 2, we can
485 distinguish between them. But for rank 1, we currently return
486 ASSUMED_SIZE; this gets adjusted later when we know for sure
487 whether the symbol parsed is a PARAMETER or not. */
491 if (current_type
== AS_UNKNOWN
)
493 as
->type
= current_type
;
497 { /* See how current spec meshes with the existing. */
501 case AS_IMPLIED_SHAPE
:
502 if (current_type
!= AS_ASSUMED_SHAPE
)
504 gfc_error ("Bad array specification for implied-shape"
511 if (current_type
== AS_ASSUMED_SIZE
)
513 as
->type
= AS_ASSUMED_SIZE
;
517 if (current_type
== AS_EXPLICIT
)
520 gfc_error ("Bad array specification for an explicitly shaped "
525 case AS_ASSUMED_SHAPE
:
526 if ((current_type
== AS_ASSUMED_SHAPE
)
527 || (current_type
== AS_DEFERRED
))
530 gfc_error ("Bad array specification for assumed shape "
535 if (current_type
== AS_DEFERRED
)
538 if (current_type
== AS_ASSUMED_SHAPE
)
540 as
->type
= AS_ASSUMED_SHAPE
;
544 gfc_error ("Bad specification for deferred shape array at %C");
547 case AS_ASSUMED_SIZE
:
548 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
550 as
->type
= AS_IMPLIED_SHAPE
;
554 gfc_error ("Bad specification for assumed size array at %C");
557 case AS_ASSUMED_RANK
:
561 if (gfc_match_char (')') == MATCH_YES
)
564 if (gfc_match_char (',') != MATCH_YES
)
566 gfc_error ("Expected another dimension in array declaration at %C");
570 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
572 gfc_error ("Array specification at %C has more than %d dimensions",
577 if (as
->corank
+ as
->rank
>= 7
578 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
579 "with more than 7 dimensions"))
587 if (gfc_match_char ('[') != MATCH_YES
)
590 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
593 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
595 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
599 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
601 gfc_error ("Array specification at %C has more than %d "
602 "dimensions", GFC_MAX_DIMENSIONS
);
609 current_type
= match_array_element_spec (as
);
611 if (current_type
== AS_UNKNOWN
)
615 as
->cotype
= current_type
;
618 { /* See how current spec meshes with the existing. */
619 case AS_IMPLIED_SHAPE
:
624 if (current_type
== AS_ASSUMED_SIZE
)
626 as
->cotype
= AS_ASSUMED_SIZE
;
630 if (current_type
== AS_EXPLICIT
)
633 gfc_error ("Bad array specification for an explicitly "
634 "shaped array at %C");
638 case AS_ASSUMED_SHAPE
:
639 if ((current_type
== AS_ASSUMED_SHAPE
)
640 || (current_type
== AS_DEFERRED
))
643 gfc_error ("Bad array specification for assumed shape "
648 if (current_type
== AS_DEFERRED
)
651 if (current_type
== AS_ASSUMED_SHAPE
)
653 as
->cotype
= AS_ASSUMED_SHAPE
;
657 gfc_error ("Bad specification for deferred shape array at %C");
660 case AS_ASSUMED_SIZE
:
661 gfc_error ("Bad specification for assumed size array at %C");
664 case AS_ASSUMED_RANK
:
668 if (gfc_match_char (']') == MATCH_YES
)
671 if (gfc_match_char (',') != MATCH_YES
)
673 gfc_error ("Expected another dimension in array declaration at %C");
677 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
679 gfc_error ("Array specification at %C has more than %d "
680 "dimensions", GFC_MAX_DIMENSIONS
);
685 if (current_type
== AS_EXPLICIT
)
687 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
691 if (as
->cotype
== AS_ASSUMED_SIZE
)
692 as
->cotype
= AS_EXPLICIT
;
695 as
->type
= as
->cotype
;
698 if (as
->rank
== 0 && as
->corank
== 0)
701 gfc_free_array_spec (as
);
705 /* If a lower bounds of an assumed shape array is blank, put in one. */
706 if (as
->type
== AS_ASSUMED_SHAPE
)
708 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
710 if (as
->lower
[i
] == NULL
)
711 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
720 /* Something went wrong. */
721 gfc_free_array_spec (as
);
726 /* Given a symbol and an array specification, modify the symbol to
727 have that array specification. The error locus is needed in case
728 something goes wrong. On failure, the caller must free the spec. */
731 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
739 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
743 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
752 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
753 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
755 gfc_error ("The assumed-rank array '%s' at %L shall not have a "
756 "codimension", sym
->name
, error_loc
);
762 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
763 the codimension is simply added. */
764 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
766 sym
->as
->cotype
= as
->cotype
;
767 sym
->as
->corank
= as
->corank
;
768 for (i
= 0; i
< as
->corank
; i
++)
770 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
771 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
776 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
777 the dimension is added - but first the codimensions (if existing
778 need to be shifted to make space for the dimension. */
779 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
781 sym
->as
->rank
= as
->rank
;
782 sym
->as
->type
= as
->type
;
783 sym
->as
->cray_pointee
= as
->cray_pointee
;
784 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
786 for (i
= 0; i
< sym
->as
->corank
; i
++)
788 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
789 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
791 for (i
= 0; i
< as
->rank
; i
++)
793 sym
->as
->lower
[i
] = as
->lower
[i
];
794 sym
->as
->upper
[i
] = as
->upper
[i
];
803 /* Copy an array specification. */
806 gfc_copy_array_spec (gfc_array_spec
*src
)
808 gfc_array_spec
*dest
;
814 dest
= gfc_get_array_spec ();
818 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
820 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
821 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
828 /* Returns nonzero if the two expressions are equal. Only handles integer
832 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
834 if (bound1
== NULL
|| bound2
== NULL
835 || bound1
->expr_type
!= EXPR_CONSTANT
836 || bound2
->expr_type
!= EXPR_CONSTANT
837 || bound1
->ts
.type
!= BT_INTEGER
838 || bound2
->ts
.type
!= BT_INTEGER
)
839 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
841 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
848 /* Compares two array specifications. They must be constant or deferred
852 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
856 if (as1
== NULL
&& as2
== NULL
)
859 if (as1
== NULL
|| as2
== NULL
)
862 if (as1
->rank
!= as2
->rank
)
865 if (as1
->corank
!= as2
->corank
)
871 if (as1
->type
!= as2
->type
)
874 if (as1
->type
== AS_EXPLICIT
)
875 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
877 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
880 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
888 /****************** Array constructor functions ******************/
891 /* Given an expression node that might be an array constructor and a
892 symbol, make sure that no iterators in this or child constructors
893 use the symbol as an implied-DO iterator. Returns nonzero if a
894 duplicate was found. */
897 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
902 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
906 if (e
->expr_type
== EXPR_ARRAY
907 && check_duplicate_iterator (e
->value
.constructor
, master
))
910 if (c
->iterator
== NULL
)
913 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
915 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
916 "same name", master
->name
, &c
->where
);
926 /* Forward declaration because these functions are mutually recursive. */
927 static match
match_array_cons_element (gfc_constructor_base
*);
929 /* Match a list of array elements. */
932 match_array_list (gfc_constructor_base
*result
)
934 gfc_constructor_base head
;
942 old_loc
= gfc_current_locus
;
944 if (gfc_match_char ('(') == MATCH_NO
)
947 memset (&iter
, '\0', sizeof (gfc_iterator
));
950 m
= match_array_cons_element (&head
);
954 if (gfc_match_char (',') != MATCH_YES
)
962 m
= gfc_match_iterator (&iter
, 0);
965 if (m
== MATCH_ERROR
)
968 m
= match_array_cons_element (&head
);
969 if (m
== MATCH_ERROR
)
976 goto cleanup
; /* Could be a complex constant */
979 if (gfc_match_char (',') != MATCH_YES
)
988 if (gfc_match_char (')') != MATCH_YES
)
991 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
997 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
998 e
->value
.constructor
= head
;
1000 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1001 p
->iterator
= gfc_get_iterator ();
1002 *p
->iterator
= iter
;
1007 gfc_error ("Syntax error in array constructor at %C");
1011 gfc_constructor_free (head
);
1012 gfc_free_iterator (&iter
, 0);
1013 gfc_current_locus
= old_loc
;
1018 /* Match a single element of an array constructor, which can be a
1019 single expression or a list of elements. */
1022 match_array_cons_element (gfc_constructor_base
*result
)
1027 m
= match_array_list (result
);
1031 m
= gfc_match_expr (&expr
);
1035 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1040 /* Match an array constructor. */
1043 gfc_match_array_constructor (gfc_expr
**result
)
1045 gfc_constructor_base head
, new_cons
;
1046 gfc_undo_change_set changed_syms
;
1051 const char *end_delim
;
1054 if (gfc_match (" (/") == MATCH_NO
)
1056 if (gfc_match (" [") == MATCH_NO
)
1060 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1061 "style array constructors at %C"))
1069 where
= gfc_current_locus
;
1070 head
= new_cons
= NULL
;
1073 /* Try to match an optional "type-spec ::" */
1075 gfc_new_undo_checkpoint (changed_syms
);
1076 if (gfc_match_type_spec (&ts
) == MATCH_YES
)
1078 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1082 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1083 "including type specification at %C"))
1085 gfc_restore_last_undo_checkpoint ();
1091 gfc_error ("Type-spec at %L cannot contain a deferred "
1092 "type parameter", &where
);
1093 gfc_restore_last_undo_checkpoint ();
1100 gfc_drop_last_undo_checkpoint ();
1103 gfc_restore_last_undo_checkpoint ();
1104 gfc_current_locus
= where
;
1107 if (gfc_match (end_delim
) == MATCH_YES
)
1113 gfc_error ("Empty array constructor at %C is not allowed");
1120 m
= match_array_cons_element (&head
);
1121 if (m
== MATCH_ERROR
)
1126 if (gfc_match_char (',') == MATCH_NO
)
1130 if (gfc_match (end_delim
) == MATCH_NO
)
1134 /* Size must be calculated at resolution time. */
1137 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1141 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1143 expr
->value
.constructor
= head
;
1145 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1151 gfc_error ("Syntax error in array constructor at %C");
1154 gfc_constructor_free (head
);
1160 /************** Check array constructors for correctness **************/
1162 /* Given an expression, compare it's type with the type of the current
1163 constructor. Returns nonzero if an error was issued. The
1164 cons_state variable keeps track of whether the type of the
1165 constructor being read or resolved is known to be good, bad or just
1168 static gfc_typespec constructor_ts
;
1170 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1174 check_element_type (gfc_expr
*expr
, bool convert
)
1176 if (cons_state
== CONS_BAD
)
1177 return 0; /* Suppress further errors */
1179 if (cons_state
== CONS_START
)
1181 if (expr
->ts
.type
== BT_UNKNOWN
)
1182 cons_state
= CONS_BAD
;
1185 cons_state
= CONS_GOOD
;
1186 constructor_ts
= expr
->ts
;
1192 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1196 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1198 gfc_error ("Element in %s array constructor at %L is %s",
1199 gfc_typename (&constructor_ts
), &expr
->where
,
1200 gfc_typename (&expr
->ts
));
1202 cons_state
= CONS_BAD
;
1207 /* Recursive work function for gfc_check_constructor_type(). */
1210 check_constructor_type (gfc_constructor_base base
, bool convert
)
1215 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1219 if (e
->expr_type
== EXPR_ARRAY
)
1221 if (!check_constructor_type (e
->value
.constructor
, convert
))
1227 if (check_element_type (e
, convert
))
1235 /* Check that all elements of an array constructor are the same type.
1236 On false, an error has been generated. */
1239 gfc_check_constructor_type (gfc_expr
*e
)
1243 if (e
->ts
.type
!= BT_UNKNOWN
)
1245 cons_state
= CONS_GOOD
;
1246 constructor_ts
= e
->ts
;
1250 cons_state
= CONS_START
;
1251 gfc_clear_ts (&constructor_ts
);
1254 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1255 typespec, and we will now convert the values on the fly. */
1256 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1257 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1258 e
->ts
= constructor_ts
;
1265 typedef struct cons_stack
1267 gfc_iterator
*iterator
;
1268 struct cons_stack
*previous
;
1272 static cons_stack
*base
;
1274 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1276 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1277 that that variable is an iteration variables. */
1280 gfc_check_iter_variable (gfc_expr
*expr
)
1285 sym
= expr
->symtree
->n
.sym
;
1287 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1288 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1295 /* Recursive work function for gfc_check_constructor(). This amounts
1296 to calling the check function for each expression in the
1297 constructor, giving variables with the names of iterators a pass. */
1300 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1307 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1311 if (e
->expr_type
!= EXPR_ARRAY
)
1313 if (!(*check_function
)(e
))
1318 element
.previous
= base
;
1319 element
.iterator
= c
->iterator
;
1322 t
= check_constructor (e
->value
.constructor
, check_function
);
1323 base
= element
.previous
;
1329 /* Nothing went wrong, so all OK. */
1334 /* Checks a constructor to see if it is a particular kind of
1335 expression -- specification, restricted, or initialization as
1336 determined by the check_function. */
1339 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1341 cons_stack
*base_save
;
1347 t
= check_constructor (expr
->value
.constructor
, check_function
);
1355 /**************** Simplification of array constructors ****************/
1357 iterator_stack
*iter_stack
;
1361 gfc_constructor_base base
;
1362 int extract_count
, extract_n
;
1363 gfc_expr
*extracted
;
1367 gfc_component
*component
;
1370 bool (*expand_work_function
) (gfc_expr
*);
1374 static expand_info current_expand
;
1376 static bool expand_constructor (gfc_constructor_base
);
1379 /* Work function that counts the number of elements present in a
1383 count_elements (gfc_expr
*e
)
1388 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1391 if (!gfc_array_size (e
, &result
))
1397 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1406 /* Work function that extracts a particular element from an array
1407 constructor, freeing the rest. */
1410 extract_element (gfc_expr
*e
)
1413 { /* Something unextractable */
1418 if (current_expand
.extract_count
== current_expand
.extract_n
)
1419 current_expand
.extracted
= e
;
1423 current_expand
.extract_count
++;
1429 /* Work function that constructs a new constructor out of the old one,
1430 stringing new elements together. */
1433 expand (gfc_expr
*e
)
1435 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1438 c
->n
.component
= current_expand
.component
;
1443 /* Given an initialization expression that is a variable reference,
1444 substitute the current value of the iteration variable. */
1447 gfc_simplify_iterator_var (gfc_expr
*e
)
1451 for (p
= iter_stack
; p
; p
= p
->prev
)
1452 if (e
->symtree
== p
->variable
)
1456 return; /* Variable not found */
1458 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1460 mpz_set (e
->value
.integer
, p
->value
);
1466 /* Expand an expression with that is inside of a constructor,
1467 recursing into other constructors if present. */
1470 expand_expr (gfc_expr
*e
)
1472 if (e
->expr_type
== EXPR_ARRAY
)
1473 return expand_constructor (e
->value
.constructor
);
1475 e
= gfc_copy_expr (e
);
1477 if (!gfc_simplify_expr (e
, 1))
1483 return current_expand
.expand_work_function (e
);
1488 expand_iterator (gfc_constructor
*c
)
1490 gfc_expr
*start
, *end
, *step
;
1491 iterator_stack frame
;
1500 mpz_init (frame
.value
);
1503 start
= gfc_copy_expr (c
->iterator
->start
);
1504 if (!gfc_simplify_expr (start
, 1))
1507 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1510 end
= gfc_copy_expr (c
->iterator
->end
);
1511 if (!gfc_simplify_expr (end
, 1))
1514 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1517 step
= gfc_copy_expr (c
->iterator
->step
);
1518 if (!gfc_simplify_expr (step
, 1))
1521 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1524 if (mpz_sgn (step
->value
.integer
) == 0)
1526 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1530 /* Calculate the trip count of the loop. */
1531 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1532 mpz_add (trip
, trip
, step
->value
.integer
);
1533 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1535 mpz_set (frame
.value
, start
->value
.integer
);
1537 frame
.prev
= iter_stack
;
1538 frame
.variable
= c
->iterator
->var
->symtree
;
1539 iter_stack
= &frame
;
1541 while (mpz_sgn (trip
) > 0)
1543 if (!expand_expr (c
->expr
))
1546 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1547 mpz_sub_ui (trip
, trip
, 1);
1553 gfc_free_expr (start
);
1554 gfc_free_expr (end
);
1555 gfc_free_expr (step
);
1558 mpz_clear (frame
.value
);
1560 iter_stack
= frame
.prev
;
1566 /* Expand a constructor into constant constructors without any
1567 iterators, calling the work function for each of the expanded
1568 expressions. The work function needs to either save or free the
1569 passed expression. */
1572 expand_constructor (gfc_constructor_base base
)
1577 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1579 if (c
->iterator
!= NULL
)
1581 if (!expand_iterator (c
))
1588 if (e
->expr_type
== EXPR_ARRAY
)
1590 if (!expand_constructor (e
->value
.constructor
))
1596 e
= gfc_copy_expr (e
);
1597 if (!gfc_simplify_expr (e
, 1))
1602 current_expand
.offset
= &c
->offset
;
1603 current_expand
.repeat
= &c
->repeat
;
1604 current_expand
.component
= c
->n
.component
;
1605 if (!current_expand
.expand_work_function(e
))
1612 /* Given an array expression and an element number (starting at zero),
1613 return a pointer to the array element. NULL is returned if the
1614 size of the array has been exceeded. The expression node returned
1615 remains a part of the array and should not be freed. Access is not
1616 efficient at all, but this is another place where things do not
1617 have to be particularly fast. */
1620 gfc_get_array_element (gfc_expr
*array
, int element
)
1622 expand_info expand_save
;
1626 expand_save
= current_expand
;
1627 current_expand
.extract_n
= element
;
1628 current_expand
.expand_work_function
= extract_element
;
1629 current_expand
.extracted
= NULL
;
1630 current_expand
.extract_count
= 0;
1634 rc
= expand_constructor (array
->value
.constructor
);
1635 e
= current_expand
.extracted
;
1636 current_expand
= expand_save
;
1645 /* Top level subroutine for expanding constructors. We only expand
1646 constructor if they are small enough. */
1649 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1651 expand_info expand_save
;
1655 /* If we can successfully get an array element at the max array size then
1656 the array is too big to expand, so we just return. */
1657 f
= gfc_get_array_element (e
, gfc_option
.flag_max_array_constructor
);
1663 gfc_error ("The number of elements in the array constructor "
1664 "at %L requires an increase of the allowed %d "
1665 "upper limit. See -fmax-array-constructor "
1666 "option", &e
->where
,
1667 gfc_option
.flag_max_array_constructor
);
1673 /* We now know the array is not too big so go ahead and try to expand it. */
1674 expand_save
= current_expand
;
1675 current_expand
.base
= NULL
;
1679 current_expand
.expand_work_function
= expand
;
1681 if (!expand_constructor (e
->value
.constructor
))
1683 gfc_constructor_free (current_expand
.base
);
1688 gfc_constructor_free (e
->value
.constructor
);
1689 e
->value
.constructor
= current_expand
.base
;
1694 current_expand
= expand_save
;
1700 /* Work function for checking that an element of a constructor is a
1701 constant, after removal of any iteration variables. We return
1705 is_constant_element (gfc_expr
*e
)
1709 rv
= gfc_is_constant_expr (e
);
1712 return rv
? true : false;
1716 /* Given an array constructor, determine if the constructor is
1717 constant or not by expanding it and making sure that all elements
1718 are constants. This is a bit of a hack since something like (/ (i,
1719 i=1,100000000) /) will take a while as* opposed to a more clever
1720 function that traverses the expression tree. FIXME. */
1723 gfc_constant_ac (gfc_expr
*e
)
1725 expand_info expand_save
;
1729 expand_save
= current_expand
;
1730 current_expand
.expand_work_function
= is_constant_element
;
1732 rc
= expand_constructor (e
->value
.constructor
);
1734 current_expand
= expand_save
;
1742 /* Returns nonzero if an array constructor has been completely
1743 expanded (no iterators) and zero if iterators are present. */
1746 gfc_expanded_ac (gfc_expr
*e
)
1750 if (e
->expr_type
== EXPR_ARRAY
)
1751 for (c
= gfc_constructor_first (e
->value
.constructor
);
1752 c
; c
= gfc_constructor_next (c
))
1753 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1760 /*************** Type resolution of array constructors ***************/
1763 /* The symbol expr_is_sought_symbol_ref will try to find. */
1764 static const gfc_symbol
*sought_symbol
= NULL
;
1767 /* Tells whether the expression E is a variable reference to the symbol
1768 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1770 To be used with gfc_expr_walker: if a reference is found we don't need
1771 to look further so we return 1 to skip any further walk. */
1774 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1777 gfc_expr
*expr
= *e
;
1778 locus
*sym_loc
= (locus
*)where
;
1780 if (expr
->expr_type
== EXPR_VARIABLE
1781 && expr
->symtree
->n
.sym
== sought_symbol
)
1783 *sym_loc
= expr
->where
;
1791 /* Tells whether the expression EXPR contains a reference to the symbol
1792 SYM and in that case sets the position SYM_LOC where the reference is. */
1795 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1799 sought_symbol
= sym
;
1800 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1801 sought_symbol
= NULL
;
1806 /* Recursive array list resolution function. All of the elements must
1807 be of the same type. */
1810 resolve_array_list (gfc_constructor_base base
)
1818 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1823 gfc_symbol
*iter_var
;
1826 if (!gfc_resolve_iterator (iter
, false, true))
1829 /* Check for bounds referencing the iterator variable. */
1830 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1831 iter_var
= iter
->var
->symtree
->n
.sym
;
1832 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1834 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1835 "expression references control variable "
1836 "at %L", &iter_var_loc
))
1839 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1841 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1842 "expression references control variable "
1843 "at %L", &iter_var_loc
))
1846 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1848 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1849 "expression references control variable "
1850 "at %L", &iter_var_loc
))
1855 if (!gfc_resolve_expr (c
->expr
))
1858 if (UNLIMITED_POLY (c
->expr
))
1860 gfc_error ("Array constructor value at %L shall not be unlimited "
1861 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1869 /* Resolve character array constructor. If it has a specified constant character
1870 length, pad/truncate the elements here; if the length is not specified and
1871 all elements are of compile-time known length, emit an error as this is
1875 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1880 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1881 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1883 if (expr
->ts
.u
.cl
== NULL
)
1885 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1886 p
; p
= gfc_constructor_next (p
))
1887 if (p
->expr
->ts
.u
.cl
!= NULL
)
1889 /* Ensure that if there is a char_len around that it is
1890 used; otherwise the middle-end confuses them! */
1891 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1895 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1902 if (expr
->ts
.u
.cl
->length
== NULL
)
1904 /* Check that all constant string elements have the same length until
1905 we reach the end or find a variable-length one. */
1907 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1908 p
; p
= gfc_constructor_next (p
))
1910 int current_length
= -1;
1912 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1913 if (ref
->type
== REF_SUBSTRING
1914 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1915 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1918 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1919 current_length
= p
->expr
->value
.character
.length
;
1923 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1924 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1925 current_length
= (int) j
;
1927 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1928 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1931 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1932 current_length
= (int) j
;
1937 gcc_assert (current_length
!= -1);
1939 if (found_length
== -1)
1940 found_length
= current_length
;
1941 else if (found_length
!= current_length
)
1943 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1944 " constructor at %L", found_length
, current_length
,
1949 gcc_assert (found_length
== current_length
);
1952 gcc_assert (found_length
!= -1);
1954 /* Update the character length of the array constructor. */
1955 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1956 NULL
, found_length
);
1960 /* We've got a character length specified. It should be an integer,
1961 otherwise an error is signalled elsewhere. */
1962 gcc_assert (expr
->ts
.u
.cl
->length
);
1964 /* If we've got a constant character length, pad according to this.
1965 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1966 max_length only if they pass. */
1967 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1969 /* Now pad/truncate the elements accordingly to the specified character
1970 length. This is ok inside this conditional, as in the case above
1971 (without typespec) all elements are verified to have the same length
1973 if (found_length
!= -1)
1974 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1975 p
; p
= gfc_constructor_next (p
))
1976 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1978 gfc_expr
*cl
= NULL
;
1979 int current_length
= -1;
1982 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1984 cl
= p
->expr
->ts
.u
.cl
->length
;
1985 gfc_extract_int (cl
, ¤t_length
);
1988 /* If gfc_extract_int above set current_length, we implicitly
1989 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1991 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
1994 || (current_length
!= -1 && current_length
!= found_length
))
1995 gfc_set_constant_character_len (found_length
, p
->expr
,
1996 has_ts
? -1 : found_length
);
2004 /* Resolve all of the expressions in an array list. */
2007 gfc_resolve_array_constructor (gfc_expr
*expr
)
2011 t
= resolve_array_list (expr
->value
.constructor
);
2013 t
= gfc_check_constructor_type (expr
);
2015 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2016 the call to this function, so we don't need to call it here; if it was
2017 called twice, an error message there would be duplicated. */
2023 /* Copy an iterator structure. */
2026 gfc_copy_iterator (gfc_iterator
*src
)
2033 dest
= gfc_get_iterator ();
2035 dest
->var
= gfc_copy_expr (src
->var
);
2036 dest
->start
= gfc_copy_expr (src
->start
);
2037 dest
->end
= gfc_copy_expr (src
->end
);
2038 dest
->step
= gfc_copy_expr (src
->step
);
2044 /********* Subroutines for determining the size of an array *********/
2046 /* These are needed just to accommodate RESHAPE(). There are no
2047 diagnostics here, we just return a negative number if something
2051 /* Get the size of single dimension of an array specification. The
2052 array is guaranteed to be one dimensional. */
2055 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2060 if (dimen
< 0 || dimen
> as
->rank
- 1)
2061 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2063 if (as
->type
!= AS_EXPLICIT
2064 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2065 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2066 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2067 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2072 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2073 as
->lower
[dimen
]->value
.integer
);
2075 mpz_add_ui (*result
, *result
, 1);
2082 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2087 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2090 mpz_init_set_ui (*result
, 1);
2092 for (d
= 0; d
< as
->rank
; d
++)
2094 if (!spec_dimen_size (as
, d
, &size
))
2096 mpz_clear (*result
);
2100 mpz_mul (*result
, *result
, size
);
2108 /* Get the number of elements in an array section. Optionally, also supply
2112 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2114 mpz_t upper
, lower
, stride
;
2118 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2119 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2121 switch (ar
->dimen_type
[dimen
])
2125 mpz_set_ui (*result
, 1);
2130 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2137 if (ar
->stride
[dimen
] == NULL
)
2138 mpz_set_ui (stride
, 1);
2141 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2146 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2149 /* Calculate the number of elements via gfc_dep_differce, but only if
2150 start and end are both supplied in the reference or the array spec.
2151 This is to guard against strange but valid code like
2156 print *,size(a(n-1:))
2158 where the user changes the value of a variable. If we have to
2159 determine end as well, we cannot do this using gfc_dep_difference.
2160 Fall back to the constants-only code then. */
2166 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2168 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2169 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2170 ar
->as
->lower
[dimen
], &diff
);
2175 mpz_add (*result
, diff
, stride
);
2176 mpz_div (*result
, *result
, stride
);
2177 if (mpz_cmp_ui (*result
, 0) < 0)
2178 mpz_set_ui (*result
, 0);
2187 /* Constant-only code here, which covers more cases
2193 if (ar
->start
[dimen
] == NULL
)
2195 if (ar
->as
->lower
[dimen
] == NULL
2196 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2198 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2202 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2204 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2207 if (ar
->end
[dimen
] == NULL
)
2209 if (ar
->as
->upper
[dimen
] == NULL
2210 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2212 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2216 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2218 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2222 mpz_sub (*result
, upper
, lower
);
2223 mpz_add (*result
, *result
, stride
);
2224 mpz_div (*result
, *result
, stride
);
2226 /* Zero stride caught earlier. */
2227 if (mpz_cmp_ui (*result
, 0) < 0)
2228 mpz_set_ui (*result
, 0);
2235 mpz_sub_ui (*end
, *result
, 1UL);
2236 mpz_mul (*end
, *end
, stride
);
2237 mpz_add (*end
, *end
, lower
);
2247 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2255 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2260 mpz_init_set_ui (*result
, 1);
2262 for (d
= 0; d
< ar
->dimen
; d
++)
2264 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2266 mpz_clear (*result
);
2270 mpz_mul (*result
, *result
, size
);
2278 /* Given an array expression and a dimension, figure out how many
2279 elements it has along that dimension. Returns true if we were
2280 able to return a result in the 'result' variable, false
2284 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2289 gcc_assert (array
!= NULL
);
2291 if (array
->ts
.type
== BT_CLASS
)
2294 if (array
->rank
== -1)
2297 if (dimen
< 0 || dimen
> array
->rank
- 1)
2298 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2300 switch (array
->expr_type
)
2304 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2306 if (ref
->type
!= REF_ARRAY
)
2309 if (ref
->u
.ar
.type
== AR_FULL
)
2310 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2312 if (ref
->u
.ar
.type
== AR_SECTION
)
2314 for (i
= 0; dimen
>= 0; i
++)
2315 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2318 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2322 if (array
->shape
&& array
->shape
[dimen
])
2324 mpz_init_set (*result
, array
->shape
[dimen
]);
2328 if (array
->symtree
->n
.sym
->attr
.generic
2329 && array
->value
.function
.esym
!= NULL
)
2331 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2334 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2340 if (array
->shape
== NULL
) {
2341 /* Expressions with rank > 1 should have "shape" properly set */
2342 if ( array
->rank
!= 1 )
2343 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2344 return gfc_array_size(array
, result
);
2349 if (array
->shape
== NULL
)
2352 mpz_init_set (*result
, array
->shape
[dimen
]);
2361 /* Given an array expression, figure out how many elements are in the
2362 array. Returns true if this is possible, and sets the 'result'
2363 variable. Otherwise returns false. */
2366 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2368 expand_info expand_save
;
2373 if (array
->ts
.type
== BT_CLASS
)
2376 switch (array
->expr_type
)
2379 gfc_push_suppress_errors ();
2381 expand_save
= current_expand
;
2383 current_expand
.count
= result
;
2384 mpz_init_set_ui (*result
, 0);
2386 current_expand
.expand_work_function
= count_elements
;
2389 t
= expand_constructor (array
->value
.constructor
);
2391 gfc_pop_suppress_errors ();
2394 mpz_clear (*result
);
2395 current_expand
= expand_save
;
2399 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2401 if (ref
->type
!= REF_ARRAY
)
2404 if (ref
->u
.ar
.type
== AR_FULL
)
2405 return spec_size (ref
->u
.ar
.as
, result
);
2407 if (ref
->u
.ar
.type
== AR_SECTION
)
2408 return ref_size (&ref
->u
.ar
, result
);
2411 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2415 if (array
->rank
== 0 || array
->shape
== NULL
)
2418 mpz_init_set_ui (*result
, 1);
2420 for (i
= 0; i
< array
->rank
; i
++)
2421 mpz_mul (*result
, *result
, array
->shape
[i
]);
2430 /* Given an array reference, return the shape of the reference in an
2431 array of mpz_t integers. */
2434 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2444 for (; d
< ar
->as
->rank
; d
++)
2445 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2451 for (i
= 0; i
< ar
->dimen
; i
++)
2453 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2455 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2468 gfc_clear_shape (shape
, d
);
2473 /* Given an array expression, find the array reference structure that
2474 characterizes the reference. */
2477 gfc_find_array_ref (gfc_expr
*e
)
2481 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2482 if (ref
->type
== REF_ARRAY
2483 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2487 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2493 /* Find out if an array shape is known at compile time. */
2496 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2500 if (as
->type
!= AS_EXPLICIT
)
2503 for (i
= 0; i
< as
->rank
; i
++)
2504 if (!gfc_is_constant_expr (as
->lower
[i
])
2505 || !gfc_is_constant_expr (as
->upper
[i
]))