2 Copyright (C) 2000-2016 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"
27 #include "constructor.h"
29 /**************** Array reference matching subroutines *****************/
31 /* Copy an array reference structure. */
34 gfc_copy_array_ref (gfc_array_ref
*src
)
42 dest
= gfc_get_array_ref ();
46 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
48 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
49 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
50 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
57 /* Match a single dimension of an array reference. This can be a
58 single element or an array section. Any modifications we've made
59 to the ar structure are cleaned up by the caller. If the init
60 is set, we require the subscript to be a valid initialization
64 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
66 match m
= MATCH_ERROR
;
70 i
= ar
->dimen
+ ar
->codimen
;
72 gfc_gobble_whitespace ();
73 ar
->c_where
[i
] = gfc_current_locus
;
74 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
82 if (gfc_match_char (':') == MATCH_YES
)
85 /* Get start element. */
86 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
90 m
= gfc_match_init_expr (&ar
->start
[i
]);
92 m
= gfc_match_expr (&ar
->start
[i
]);
95 gfc_error ("Expected array subscript at %C");
99 if (gfc_match_char (':') == MATCH_NO
)
104 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
108 /* Get an optional end element. Because we've seen the colon, we
109 definitely have a range along this dimension. */
111 ar
->dimen_type
[i
] = DIMEN_RANGE
;
113 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
116 m
= gfc_match_init_expr (&ar
->end
[i
]);
118 m
= gfc_match_expr (&ar
->end
[i
]);
120 if (m
== MATCH_ERROR
)
123 /* See if we have an optional stride. */
124 if (gfc_match_char (':') == MATCH_YES
)
128 gfc_error ("Strides not allowed in coarray subscript at %C");
132 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
133 : gfc_match_expr (&ar
->stride
[i
]);
136 gfc_error ("Expected array subscript stride at %C");
143 ar
->dimen_type
[i
] = DIMEN_STAR
;
149 /* Match an array reference, whether it is the whole array or particular
150 elements or a section. If init is set, the reference has to consist
151 of init expressions. */
154 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
158 bool matched_bracket
= false;
160 bool stat_just_seen
= false;
162 memset (ar
, '\0', sizeof (*ar
));
164 ar
->where
= gfc_current_locus
;
166 ar
->type
= AR_UNKNOWN
;
168 if (gfc_match_char ('[') == MATCH_YES
)
170 matched_bracket
= true;
174 if (gfc_match_char ('(') != MATCH_YES
)
181 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
183 m
= match_subscript (ar
, init
, false);
184 if (m
== MATCH_ERROR
)
187 if (gfc_match_char (')') == MATCH_YES
)
193 if (gfc_match_char (',') != MATCH_YES
)
195 gfc_error ("Invalid form of array reference at %C");
200 gfc_error ("Array reference at %C cannot have more than %d dimensions",
205 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
213 if (flag_coarray
== GFC_FCOARRAY_NONE
)
215 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
221 gfc_error ("Unexpected coarray designator at %C");
227 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
229 m
= match_subscript (ar
, init
, true);
230 if (m
== MATCH_ERROR
)
233 stat_just_seen
= false;
234 if (gfc_match(" , stat = %e",&tmp
) == MATCH_YES
&& ar
->stat
== NULL
)
237 stat_just_seen
= true;
240 if (ar
->stat
&& !stat_just_seen
)
242 gfc_error ("STAT= attribute in %C misplaced");
246 if (gfc_match_char (']') == MATCH_YES
)
249 if (ar
->codimen
< corank
)
251 gfc_error ("Too few codimensions at %C, expected %d not %d",
252 corank
, ar
->codimen
);
255 if (ar
->codimen
> corank
)
257 gfc_error ("Too many codimensions at %C, expected %d not %d",
258 corank
, ar
->codimen
);
264 if (gfc_match_char (',') != MATCH_YES
)
266 if (gfc_match_char ('*') == MATCH_YES
)
267 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
268 ar
->codimen
+ 1, corank
);
270 gfc_error ("Invalid form of coarray reference at %C");
273 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
275 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
276 ar
->codimen
+ 1, corank
);
280 if (ar
->codimen
>= corank
)
282 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
283 ar
->codimen
+ 1, corank
);
288 gfc_error ("Array reference at %C cannot have more than %d dimensions",
295 /************** Array specification matching subroutines ***************/
297 /* Free all of the expressions associated with array bounds
301 gfc_free_array_spec (gfc_array_spec
*as
)
308 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
310 gfc_free_expr (as
->lower
[i
]);
311 gfc_free_expr (as
->upper
[i
]);
318 /* Take an array bound, resolves the expression, that make up the
319 shape and check associated constraints. */
322 resolve_array_bound (gfc_expr
*e
, int check_constant
)
327 if (!gfc_resolve_expr (e
)
328 || !gfc_specification_expr (e
))
331 if (check_constant
&& !gfc_is_constant_expr (e
))
333 if (e
->expr_type
== EXPR_VARIABLE
)
334 gfc_error ("Variable %qs at %L in this context must be constant",
335 e
->symtree
->n
.sym
->name
, &e
->where
);
337 gfc_error ("Expression at %L in this context must be constant",
346 /* Takes an array specification, resolves the expressions that make up
347 the shape and make sure everything is integral. */
350 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
361 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
364 if (!resolve_array_bound (e
, check_constant
))
368 if (!resolve_array_bound (e
, check_constant
))
371 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
374 /* If the size is negative in this dimension, set it to zero. */
375 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
376 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
377 && mpz_cmp (as
->upper
[i
]->value
.integer
,
378 as
->lower
[i
]->value
.integer
) < 0)
380 gfc_free_expr (as
->upper
[i
]);
381 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
382 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
383 as
->upper
[i
]->value
.integer
, 1);
393 /* Match a single array element specification. The return values as
394 well as the upper and lower bounds of the array spec are filled
395 in according to what we see on the input. The caller makes sure
396 individual specifications make sense as a whole.
399 Parsed Lower Upper Returned
400 ------------------------------------
401 : NULL NULL AS_DEFERRED (*)
403 x: x NULL AS_ASSUMED_SHAPE
405 x:* x NULL AS_ASSUMED_SIZE
406 * 1 NULL AS_ASSUMED_SIZE
408 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
409 is fixed during the resolution of formal interfaces.
411 Anything else AS_UNKNOWN. */
414 match_array_element_spec (gfc_array_spec
*as
)
416 gfc_expr
**upper
, **lower
;
420 rank
= as
->rank
== -1 ? 0 : as
->rank
;
421 lower
= &as
->lower
[rank
+ as
->corank
- 1];
422 upper
= &as
->upper
[rank
+ as
->corank
- 1];
424 if (gfc_match_char ('*') == MATCH_YES
)
426 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
427 return AS_ASSUMED_SIZE
;
430 if (gfc_match_char (':') == MATCH_YES
)
433 m
= gfc_match_expr (upper
);
435 gfc_error ("Expected expression in array specification at %C");
438 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
441 if (((*upper
)->expr_type
== EXPR_CONSTANT
442 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
443 ((*upper
)->expr_type
== EXPR_FUNCTION
444 && (*upper
)->ts
.type
== BT_UNKNOWN
446 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
448 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
449 gfc_basic_typename ((*upper
)->ts
.type
));
453 if (gfc_match_char (':') == MATCH_NO
)
455 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
462 if (gfc_match_char ('*') == MATCH_YES
)
463 return AS_ASSUMED_SIZE
;
465 m
= gfc_match_expr (upper
);
466 if (m
== MATCH_ERROR
)
469 return AS_ASSUMED_SHAPE
;
470 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
473 if (((*upper
)->expr_type
== EXPR_CONSTANT
474 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
475 ((*upper
)->expr_type
== EXPR_FUNCTION
476 && (*upper
)->ts
.type
== BT_UNKNOWN
478 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
480 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
481 gfc_basic_typename ((*upper
)->ts
.type
));
489 /* Matches an array specification, incidentally figuring out what sort
490 it is. Match either a normal array specification, or a coarray spec
491 or both. Optionally allow [:] for coarrays. */
494 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
496 array_type current_type
;
500 as
= gfc_get_array_spec ();
505 if (gfc_match_char ('(') != MATCH_YES
)
512 if (gfc_match (" .. )") == MATCH_YES
)
514 as
->type
= AS_ASSUMED_RANK
;
517 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C"))
528 current_type
= match_array_element_spec (as
);
530 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
531 and implied-shape specifications. If the rank is at least 2, we can
532 distinguish between them. But for rank 1, we currently return
533 ASSUMED_SIZE; this gets adjusted later when we know for sure
534 whether the symbol parsed is a PARAMETER or not. */
538 if (current_type
== AS_UNKNOWN
)
540 as
->type
= current_type
;
544 { /* See how current spec meshes with the existing. */
548 case AS_IMPLIED_SHAPE
:
549 if (current_type
!= AS_ASSUMED_SHAPE
)
551 gfc_error ("Bad array specification for implied-shape"
558 if (current_type
== AS_ASSUMED_SIZE
)
560 as
->type
= AS_ASSUMED_SIZE
;
564 if (current_type
== AS_EXPLICIT
)
567 gfc_error ("Bad array specification for an explicitly shaped "
572 case AS_ASSUMED_SHAPE
:
573 if ((current_type
== AS_ASSUMED_SHAPE
)
574 || (current_type
== AS_DEFERRED
))
577 gfc_error ("Bad array specification for assumed shape "
582 if (current_type
== AS_DEFERRED
)
585 if (current_type
== AS_ASSUMED_SHAPE
)
587 as
->type
= AS_ASSUMED_SHAPE
;
591 gfc_error ("Bad specification for deferred shape array at %C");
594 case AS_ASSUMED_SIZE
:
595 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
597 as
->type
= AS_IMPLIED_SHAPE
;
601 gfc_error ("Bad specification for assumed size array at %C");
604 case AS_ASSUMED_RANK
:
608 if (gfc_match_char (')') == MATCH_YES
)
611 if (gfc_match_char (',') != MATCH_YES
)
613 gfc_error ("Expected another dimension in array declaration at %C");
617 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
619 gfc_error ("Array specification at %C has more than %d dimensions",
624 if (as
->corank
+ as
->rank
>= 7
625 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
626 "with more than 7 dimensions"))
634 if (gfc_match_char ('[') != MATCH_YES
)
637 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
640 if (flag_coarray
== GFC_FCOARRAY_NONE
)
642 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
646 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
648 gfc_error ("Array specification at %C has more than %d "
649 "dimensions", GFC_MAX_DIMENSIONS
);
656 current_type
= match_array_element_spec (as
);
658 if (current_type
== AS_UNKNOWN
)
662 as
->cotype
= current_type
;
665 { /* See how current spec meshes with the existing. */
666 case AS_IMPLIED_SHAPE
:
671 if (current_type
== AS_ASSUMED_SIZE
)
673 as
->cotype
= AS_ASSUMED_SIZE
;
677 if (current_type
== AS_EXPLICIT
)
680 gfc_error ("Bad array specification for an explicitly "
681 "shaped array at %C");
685 case AS_ASSUMED_SHAPE
:
686 if ((current_type
== AS_ASSUMED_SHAPE
)
687 || (current_type
== AS_DEFERRED
))
690 gfc_error ("Bad array specification for assumed shape "
695 if (current_type
== AS_DEFERRED
)
698 if (current_type
== AS_ASSUMED_SHAPE
)
700 as
->cotype
= AS_ASSUMED_SHAPE
;
704 gfc_error ("Bad specification for deferred shape array at %C");
707 case AS_ASSUMED_SIZE
:
708 gfc_error ("Bad specification for assumed size array at %C");
711 case AS_ASSUMED_RANK
:
715 if (gfc_match_char (']') == MATCH_YES
)
718 if (gfc_match_char (',') != MATCH_YES
)
720 gfc_error ("Expected another dimension in array declaration at %C");
724 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
726 gfc_error ("Array specification at %C has more than %d "
727 "dimensions", GFC_MAX_DIMENSIONS
);
732 if (current_type
== AS_EXPLICIT
)
734 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
738 if (as
->cotype
== AS_ASSUMED_SIZE
)
739 as
->cotype
= AS_EXPLICIT
;
742 as
->type
= as
->cotype
;
745 if (as
->rank
== 0 && as
->corank
== 0)
748 gfc_free_array_spec (as
);
752 /* If a lower bounds of an assumed shape array is blank, put in one. */
753 if (as
->type
== AS_ASSUMED_SHAPE
)
755 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
757 if (as
->lower
[i
] == NULL
)
758 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
767 /* Something went wrong. */
768 gfc_free_array_spec (as
);
773 /* Given a symbol and an array specification, modify the symbol to
774 have that array specification. The error locus is needed in case
775 something goes wrong. On failure, the caller must free the spec. */
778 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
786 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
790 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
799 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
800 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
802 gfc_error ("The assumed-rank array %qs at %L shall not have a "
803 "codimension", sym
->name
, error_loc
);
809 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
810 the codimension is simply added. */
811 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
813 sym
->as
->cotype
= as
->cotype
;
814 sym
->as
->corank
= as
->corank
;
815 for (i
= 0; i
< as
->corank
; i
++)
817 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
818 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
823 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
824 the dimension is added - but first the codimensions (if existing
825 need to be shifted to make space for the dimension. */
826 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
828 sym
->as
->rank
= as
->rank
;
829 sym
->as
->type
= as
->type
;
830 sym
->as
->cray_pointee
= as
->cray_pointee
;
831 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
833 for (i
= 0; i
< sym
->as
->corank
; i
++)
835 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
836 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
838 for (i
= 0; i
< as
->rank
; i
++)
840 sym
->as
->lower
[i
] = as
->lower
[i
];
841 sym
->as
->upper
[i
] = as
->upper
[i
];
850 /* Copy an array specification. */
853 gfc_copy_array_spec (gfc_array_spec
*src
)
855 gfc_array_spec
*dest
;
861 dest
= gfc_get_array_spec ();
865 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
867 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
868 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
875 /* Returns nonzero if the two expressions are equal. Only handles integer
879 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
881 if (bound1
== NULL
|| bound2
== NULL
882 || bound1
->expr_type
!= EXPR_CONSTANT
883 || bound2
->expr_type
!= EXPR_CONSTANT
884 || bound1
->ts
.type
!= BT_INTEGER
885 || bound2
->ts
.type
!= BT_INTEGER
)
886 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
888 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
895 /* Compares two array specifications. They must be constant or deferred
899 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
903 if (as1
== NULL
&& as2
== NULL
)
906 if (as1
== NULL
|| as2
== NULL
)
909 if (as1
->rank
!= as2
->rank
)
912 if (as1
->corank
!= as2
->corank
)
918 if (as1
->type
!= as2
->type
)
921 if (as1
->type
== AS_EXPLICIT
)
922 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
924 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
927 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
935 /****************** Array constructor functions ******************/
938 /* Given an expression node that might be an array constructor and a
939 symbol, make sure that no iterators in this or child constructors
940 use the symbol as an implied-DO iterator. Returns nonzero if a
941 duplicate was found. */
944 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
949 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
953 if (e
->expr_type
== EXPR_ARRAY
954 && check_duplicate_iterator (e
->value
.constructor
, master
))
957 if (c
->iterator
== NULL
)
960 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
962 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
963 "same name", master
->name
, &c
->where
);
973 /* Forward declaration because these functions are mutually recursive. */
974 static match
match_array_cons_element (gfc_constructor_base
*);
976 /* Match a list of array elements. */
979 match_array_list (gfc_constructor_base
*result
)
981 gfc_constructor_base head
;
989 old_loc
= gfc_current_locus
;
991 if (gfc_match_char ('(') == MATCH_NO
)
994 memset (&iter
, '\0', sizeof (gfc_iterator
));
997 m
= match_array_cons_element (&head
);
1001 if (gfc_match_char (',') != MATCH_YES
)
1009 m
= gfc_match_iterator (&iter
, 0);
1012 if (m
== MATCH_ERROR
)
1015 m
= match_array_cons_element (&head
);
1016 if (m
== MATCH_ERROR
)
1023 goto cleanup
; /* Could be a complex constant */
1026 if (gfc_match_char (',') != MATCH_YES
)
1035 if (gfc_match_char (')') != MATCH_YES
)
1038 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1044 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1045 e
->value
.constructor
= head
;
1047 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1048 p
->iterator
= gfc_get_iterator ();
1049 *p
->iterator
= iter
;
1054 gfc_error ("Syntax error in array constructor at %C");
1058 gfc_constructor_free (head
);
1059 gfc_free_iterator (&iter
, 0);
1060 gfc_current_locus
= old_loc
;
1065 /* Match a single element of an array constructor, which can be a
1066 single expression or a list of elements. */
1069 match_array_cons_element (gfc_constructor_base
*result
)
1074 m
= match_array_list (result
);
1078 m
= gfc_match_expr (&expr
);
1082 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1087 /* Match an array constructor. */
1090 gfc_match_array_constructor (gfc_expr
**result
)
1092 gfc_constructor_base head
, new_cons
;
1093 gfc_undo_change_set changed_syms
;
1098 const char *end_delim
;
1101 if (gfc_match (" (/") == MATCH_NO
)
1103 if (gfc_match (" [") == MATCH_NO
)
1107 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1108 "style array constructors at %C"))
1116 where
= gfc_current_locus
;
1117 head
= new_cons
= NULL
;
1120 /* Try to match an optional "type-spec ::" */
1122 gfc_new_undo_checkpoint (changed_syms
);
1123 m
= gfc_match_type_spec (&ts
);
1126 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1130 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1131 "including type specification at %C"))
1133 gfc_restore_last_undo_checkpoint ();
1139 gfc_error ("Type-spec at %L cannot contain a deferred "
1140 "type parameter", &where
);
1141 gfc_restore_last_undo_checkpoint ();
1146 else if (m
== MATCH_ERROR
)
1148 gfc_restore_last_undo_checkpoint ();
1153 gfc_drop_last_undo_checkpoint ();
1156 gfc_restore_last_undo_checkpoint ();
1157 gfc_current_locus
= where
;
1160 if (gfc_match (end_delim
) == MATCH_YES
)
1166 gfc_error ("Empty array constructor at %C is not allowed");
1173 m
= match_array_cons_element (&head
);
1174 if (m
== MATCH_ERROR
)
1179 if (gfc_match_char (',') == MATCH_NO
)
1183 if (gfc_match (end_delim
) == MATCH_NO
)
1187 /* Size must be calculated at resolution time. */
1190 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1193 /* If the typespec is CHARACTER, check that array elements can
1194 be converted. See PR fortran/67803. */
1195 if (ts
.type
== BT_CHARACTER
)
1199 c
= gfc_constructor_first (head
);
1200 for (; c
; c
= gfc_constructor_next (c
))
1202 if (gfc_numeric_ts (&c
->expr
->ts
)
1203 || c
->expr
->ts
.type
== BT_LOGICAL
)
1205 gfc_error ("Incompatible typespec for array element at %L",
1210 /* Special case null(). */
1211 if (c
->expr
->expr_type
== EXPR_FUNCTION
1212 && c
->expr
->ts
.type
== BT_UNKNOWN
1213 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1215 gfc_error ("Incompatible typespec for array element at %L",
1223 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1225 expr
->value
.constructor
= head
;
1227 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1234 gfc_error ("Syntax error in array constructor at %C");
1237 gfc_constructor_free (head
);
1243 /************** Check array constructors for correctness **************/
1245 /* Given an expression, compare it's type with the type of the current
1246 constructor. Returns nonzero if an error was issued. The
1247 cons_state variable keeps track of whether the type of the
1248 constructor being read or resolved is known to be good, bad or just
1251 static gfc_typespec constructor_ts
;
1253 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1257 check_element_type (gfc_expr
*expr
, bool convert
)
1259 if (cons_state
== CONS_BAD
)
1260 return 0; /* Suppress further errors */
1262 if (cons_state
== CONS_START
)
1264 if (expr
->ts
.type
== BT_UNKNOWN
)
1265 cons_state
= CONS_BAD
;
1268 cons_state
= CONS_GOOD
;
1269 constructor_ts
= expr
->ts
;
1275 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1279 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1281 gfc_error ("Element in %s array constructor at %L is %s",
1282 gfc_typename (&constructor_ts
), &expr
->where
,
1283 gfc_typename (&expr
->ts
));
1285 cons_state
= CONS_BAD
;
1290 /* Recursive work function for gfc_check_constructor_type(). */
1293 check_constructor_type (gfc_constructor_base base
, bool convert
)
1298 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1302 if (e
->expr_type
== EXPR_ARRAY
)
1304 if (!check_constructor_type (e
->value
.constructor
, convert
))
1310 if (check_element_type (e
, convert
))
1318 /* Check that all elements of an array constructor are the same type.
1319 On false, an error has been generated. */
1322 gfc_check_constructor_type (gfc_expr
*e
)
1326 if (e
->ts
.type
!= BT_UNKNOWN
)
1328 cons_state
= CONS_GOOD
;
1329 constructor_ts
= e
->ts
;
1333 cons_state
= CONS_START
;
1334 gfc_clear_ts (&constructor_ts
);
1337 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1338 typespec, and we will now convert the values on the fly. */
1339 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1340 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1341 e
->ts
= constructor_ts
;
1348 typedef struct cons_stack
1350 gfc_iterator
*iterator
;
1351 struct cons_stack
*previous
;
1355 static cons_stack
*base
;
1357 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1359 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1360 that that variable is an iteration variables. */
1363 gfc_check_iter_variable (gfc_expr
*expr
)
1368 sym
= expr
->symtree
->n
.sym
;
1370 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1371 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1378 /* Recursive work function for gfc_check_constructor(). This amounts
1379 to calling the check function for each expression in the
1380 constructor, giving variables with the names of iterators a pass. */
1383 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1390 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1397 if (e
->expr_type
!= EXPR_ARRAY
)
1399 if (!(*check_function
)(e
))
1404 element
.previous
= base
;
1405 element
.iterator
= c
->iterator
;
1408 t
= check_constructor (e
->value
.constructor
, check_function
);
1409 base
= element
.previous
;
1415 /* Nothing went wrong, so all OK. */
1420 /* Checks a constructor to see if it is a particular kind of
1421 expression -- specification, restricted, or initialization as
1422 determined by the check_function. */
1425 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1427 cons_stack
*base_save
;
1433 t
= check_constructor (expr
->value
.constructor
, check_function
);
1441 /**************** Simplification of array constructors ****************/
1443 iterator_stack
*iter_stack
;
1447 gfc_constructor_base base
;
1448 int extract_count
, extract_n
;
1449 gfc_expr
*extracted
;
1453 gfc_component
*component
;
1456 bool (*expand_work_function
) (gfc_expr
*);
1460 static expand_info current_expand
;
1462 static bool expand_constructor (gfc_constructor_base
);
1465 /* Work function that counts the number of elements present in a
1469 count_elements (gfc_expr
*e
)
1474 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1477 if (!gfc_array_size (e
, &result
))
1483 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1492 /* Work function that extracts a particular element from an array
1493 constructor, freeing the rest. */
1496 extract_element (gfc_expr
*e
)
1499 { /* Something unextractable */
1504 if (current_expand
.extract_count
== current_expand
.extract_n
)
1505 current_expand
.extracted
= e
;
1509 current_expand
.extract_count
++;
1515 /* Work function that constructs a new constructor out of the old one,
1516 stringing new elements together. */
1519 expand (gfc_expr
*e
)
1521 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1524 c
->n
.component
= current_expand
.component
;
1529 /* Given an initialization expression that is a variable reference,
1530 substitute the current value of the iteration variable. */
1533 gfc_simplify_iterator_var (gfc_expr
*e
)
1537 for (p
= iter_stack
; p
; p
= p
->prev
)
1538 if (e
->symtree
== p
->variable
)
1542 return; /* Variable not found */
1544 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1546 mpz_set (e
->value
.integer
, p
->value
);
1552 /* Expand an expression with that is inside of a constructor,
1553 recursing into other constructors if present. */
1556 expand_expr (gfc_expr
*e
)
1558 if (e
->expr_type
== EXPR_ARRAY
)
1559 return expand_constructor (e
->value
.constructor
);
1561 e
= gfc_copy_expr (e
);
1563 if (!gfc_simplify_expr (e
, 1))
1569 return current_expand
.expand_work_function (e
);
1574 expand_iterator (gfc_constructor
*c
)
1576 gfc_expr
*start
, *end
, *step
;
1577 iterator_stack frame
;
1586 mpz_init (frame
.value
);
1589 start
= gfc_copy_expr (c
->iterator
->start
);
1590 if (!gfc_simplify_expr (start
, 1))
1593 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1596 end
= gfc_copy_expr (c
->iterator
->end
);
1597 if (!gfc_simplify_expr (end
, 1))
1600 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1603 step
= gfc_copy_expr (c
->iterator
->step
);
1604 if (!gfc_simplify_expr (step
, 1))
1607 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1610 if (mpz_sgn (step
->value
.integer
) == 0)
1612 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1616 /* Calculate the trip count of the loop. */
1617 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1618 mpz_add (trip
, trip
, step
->value
.integer
);
1619 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1621 mpz_set (frame
.value
, start
->value
.integer
);
1623 frame
.prev
= iter_stack
;
1624 frame
.variable
= c
->iterator
->var
->symtree
;
1625 iter_stack
= &frame
;
1627 while (mpz_sgn (trip
) > 0)
1629 if (!expand_expr (c
->expr
))
1632 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1633 mpz_sub_ui (trip
, trip
, 1);
1639 gfc_free_expr (start
);
1640 gfc_free_expr (end
);
1641 gfc_free_expr (step
);
1644 mpz_clear (frame
.value
);
1646 iter_stack
= frame
.prev
;
1652 /* Expand a constructor into constant constructors without any
1653 iterators, calling the work function for each of the expanded
1654 expressions. The work function needs to either save or free the
1655 passed expression. */
1658 expand_constructor (gfc_constructor_base base
)
1663 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1665 if (c
->iterator
!= NULL
)
1667 if (!expand_iterator (c
))
1674 if (e
->expr_type
== EXPR_ARRAY
)
1676 if (!expand_constructor (e
->value
.constructor
))
1682 e
= gfc_copy_expr (e
);
1683 if (!gfc_simplify_expr (e
, 1))
1688 current_expand
.offset
= &c
->offset
;
1689 current_expand
.repeat
= &c
->repeat
;
1690 current_expand
.component
= c
->n
.component
;
1691 if (!current_expand
.expand_work_function(e
))
1698 /* Given an array expression and an element number (starting at zero),
1699 return a pointer to the array element. NULL is returned if the
1700 size of the array has been exceeded. The expression node returned
1701 remains a part of the array and should not be freed. Access is not
1702 efficient at all, but this is another place where things do not
1703 have to be particularly fast. */
1706 gfc_get_array_element (gfc_expr
*array
, int element
)
1708 expand_info expand_save
;
1712 expand_save
= current_expand
;
1713 current_expand
.extract_n
= element
;
1714 current_expand
.expand_work_function
= extract_element
;
1715 current_expand
.extracted
= NULL
;
1716 current_expand
.extract_count
= 0;
1720 rc
= expand_constructor (array
->value
.constructor
);
1721 e
= current_expand
.extracted
;
1722 current_expand
= expand_save
;
1731 /* Top level subroutine for expanding constructors. We only expand
1732 constructor if they are small enough. */
1735 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1737 expand_info expand_save
;
1741 /* If we can successfully get an array element at the max array size then
1742 the array is too big to expand, so we just return. */
1743 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1749 gfc_error ("The number of elements in the array constructor "
1750 "at %L requires an increase of the allowed %d "
1751 "upper limit. See %<-fmax-array-constructor%> "
1752 "option", &e
->where
, flag_max_array_constructor
);
1758 /* We now know the array is not too big so go ahead and try to expand it. */
1759 expand_save
= current_expand
;
1760 current_expand
.base
= NULL
;
1764 current_expand
.expand_work_function
= expand
;
1766 if (!expand_constructor (e
->value
.constructor
))
1768 gfc_constructor_free (current_expand
.base
);
1773 gfc_constructor_free (e
->value
.constructor
);
1774 e
->value
.constructor
= current_expand
.base
;
1779 current_expand
= expand_save
;
1785 /* Work function for checking that an element of a constructor is a
1786 constant, after removal of any iteration variables. We return
1790 is_constant_element (gfc_expr
*e
)
1794 rv
= gfc_is_constant_expr (e
);
1797 return rv
? true : false;
1801 /* Given an array constructor, determine if the constructor is
1802 constant or not by expanding it and making sure that all elements
1803 are constants. This is a bit of a hack since something like (/ (i,
1804 i=1,100000000) /) will take a while as* opposed to a more clever
1805 function that traverses the expression tree. FIXME. */
1808 gfc_constant_ac (gfc_expr
*e
)
1810 expand_info expand_save
;
1814 expand_save
= current_expand
;
1815 current_expand
.expand_work_function
= is_constant_element
;
1817 rc
= expand_constructor (e
->value
.constructor
);
1819 current_expand
= expand_save
;
1827 /* Returns nonzero if an array constructor has been completely
1828 expanded (no iterators) and zero if iterators are present. */
1831 gfc_expanded_ac (gfc_expr
*e
)
1835 if (e
->expr_type
== EXPR_ARRAY
)
1836 for (c
= gfc_constructor_first (e
->value
.constructor
);
1837 c
; c
= gfc_constructor_next (c
))
1838 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1845 /*************** Type resolution of array constructors ***************/
1848 /* The symbol expr_is_sought_symbol_ref will try to find. */
1849 static const gfc_symbol
*sought_symbol
= NULL
;
1852 /* Tells whether the expression E is a variable reference to the symbol
1853 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1855 To be used with gfc_expr_walker: if a reference is found we don't need
1856 to look further so we return 1 to skip any further walk. */
1859 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1862 gfc_expr
*expr
= *e
;
1863 locus
*sym_loc
= (locus
*)where
;
1865 if (expr
->expr_type
== EXPR_VARIABLE
1866 && expr
->symtree
->n
.sym
== sought_symbol
)
1868 *sym_loc
= expr
->where
;
1876 /* Tells whether the expression EXPR contains a reference to the symbol
1877 SYM and in that case sets the position SYM_LOC where the reference is. */
1880 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1884 sought_symbol
= sym
;
1885 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1886 sought_symbol
= NULL
;
1891 /* Recursive array list resolution function. All of the elements must
1892 be of the same type. */
1895 resolve_array_list (gfc_constructor_base base
)
1903 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1908 gfc_symbol
*iter_var
;
1911 if (!gfc_resolve_iterator (iter
, false, true))
1914 /* Check for bounds referencing the iterator variable. */
1915 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1916 iter_var
= iter
->var
->symtree
->n
.sym
;
1917 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1919 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1920 "expression references control variable "
1921 "at %L", &iter_var_loc
))
1924 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1926 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1927 "expression references control variable "
1928 "at %L", &iter_var_loc
))
1931 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1933 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1934 "expression references control variable "
1935 "at %L", &iter_var_loc
))
1940 if (!gfc_resolve_expr (c
->expr
))
1943 if (UNLIMITED_POLY (c
->expr
))
1945 gfc_error ("Array constructor value at %L shall not be unlimited "
1946 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1954 /* Resolve character array constructor. If it has a specified constant character
1955 length, pad/truncate the elements here; if the length is not specified and
1956 all elements are of compile-time known length, emit an error as this is
1960 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1965 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1966 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1968 if (expr
->ts
.u
.cl
== NULL
)
1970 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1971 p
; p
= gfc_constructor_next (p
))
1972 if (p
->expr
->ts
.u
.cl
!= NULL
)
1974 /* Ensure that if there is a char_len around that it is
1975 used; otherwise the middle-end confuses them! */
1976 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1980 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1987 if (expr
->ts
.u
.cl
->length
== NULL
)
1989 /* Check that all constant string elements have the same length until
1990 we reach the end or find a variable-length one. */
1992 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1993 p
; p
= gfc_constructor_next (p
))
1995 int current_length
= -1;
1997 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1998 if (ref
->type
== REF_SUBSTRING
1999 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2000 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2003 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2004 current_length
= p
->expr
->value
.character
.length
;
2008 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
2009 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
2010 current_length
= (int) j
;
2012 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2013 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2016 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2017 current_length
= (int) j
;
2022 gcc_assert (current_length
!= -1);
2024 if (found_length
== -1)
2025 found_length
= current_length
;
2026 else if (found_length
!= current_length
)
2028 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
2029 " constructor at %L", found_length
, current_length
,
2034 gcc_assert (found_length
== current_length
);
2037 gcc_assert (found_length
!= -1);
2039 /* Update the character length of the array constructor. */
2040 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2041 NULL
, found_length
);
2045 /* We've got a character length specified. It should be an integer,
2046 otherwise an error is signalled elsewhere. */
2047 gcc_assert (expr
->ts
.u
.cl
->length
);
2049 /* If we've got a constant character length, pad according to this.
2050 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2051 max_length only if they pass. */
2052 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
2054 /* Now pad/truncate the elements accordingly to the specified character
2055 length. This is ok inside this conditional, as in the case above
2056 (without typespec) all elements are verified to have the same length
2058 if (found_length
!= -1)
2059 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2060 p
; p
= gfc_constructor_next (p
))
2061 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2063 gfc_expr
*cl
= NULL
;
2064 int current_length
= -1;
2067 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2069 cl
= p
->expr
->ts
.u
.cl
->length
;
2070 gfc_extract_int (cl
, ¤t_length
);
2073 /* If gfc_extract_int above set current_length, we implicitly
2074 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2076 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2079 || (current_length
!= -1 && current_length
!= found_length
))
2080 gfc_set_constant_character_len (found_length
, p
->expr
,
2081 has_ts
? -1 : found_length
);
2089 /* Resolve all of the expressions in an array list. */
2092 gfc_resolve_array_constructor (gfc_expr
*expr
)
2096 t
= resolve_array_list (expr
->value
.constructor
);
2098 t
= gfc_check_constructor_type (expr
);
2100 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2101 the call to this function, so we don't need to call it here; if it was
2102 called twice, an error message there would be duplicated. */
2108 /* Copy an iterator structure. */
2111 gfc_copy_iterator (gfc_iterator
*src
)
2118 dest
= gfc_get_iterator ();
2120 dest
->var
= gfc_copy_expr (src
->var
);
2121 dest
->start
= gfc_copy_expr (src
->start
);
2122 dest
->end
= gfc_copy_expr (src
->end
);
2123 dest
->step
= gfc_copy_expr (src
->step
);
2129 /********* Subroutines for determining the size of an array *********/
2131 /* These are needed just to accommodate RESHAPE(). There are no
2132 diagnostics here, we just return a negative number if something
2136 /* Get the size of single dimension of an array specification. The
2137 array is guaranteed to be one dimensional. */
2140 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2145 if (dimen
< 0 || dimen
> as
->rank
- 1)
2146 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2148 if (as
->type
!= AS_EXPLICIT
2149 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2150 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2151 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2152 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2157 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2158 as
->lower
[dimen
]->value
.integer
);
2160 mpz_add_ui (*result
, *result
, 1);
2167 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2172 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2175 mpz_init_set_ui (*result
, 1);
2177 for (d
= 0; d
< as
->rank
; d
++)
2179 if (!spec_dimen_size (as
, d
, &size
))
2181 mpz_clear (*result
);
2185 mpz_mul (*result
, *result
, size
);
2193 /* Get the number of elements in an array section. Optionally, also supply
2197 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2199 mpz_t upper
, lower
, stride
;
2203 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2204 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2206 switch (ar
->dimen_type
[dimen
])
2210 mpz_set_ui (*result
, 1);
2215 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2222 if (ar
->stride
[dimen
] == NULL
)
2223 mpz_set_ui (stride
, 1);
2226 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2231 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2234 /* Calculate the number of elements via gfc_dep_differce, but only if
2235 start and end are both supplied in the reference or the array spec.
2236 This is to guard against strange but valid code like
2241 print *,size(a(n-1:))
2243 where the user changes the value of a variable. If we have to
2244 determine end as well, we cannot do this using gfc_dep_difference.
2245 Fall back to the constants-only code then. */
2251 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2253 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2254 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2255 ar
->as
->lower
[dimen
], &diff
);
2260 mpz_add (*result
, diff
, stride
);
2261 mpz_div (*result
, *result
, stride
);
2262 if (mpz_cmp_ui (*result
, 0) < 0)
2263 mpz_set_ui (*result
, 0);
2272 /* Constant-only code here, which covers more cases
2278 if (ar
->start
[dimen
] == NULL
)
2280 if (ar
->as
->lower
[dimen
] == NULL
2281 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2282 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2284 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2288 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2290 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2293 if (ar
->end
[dimen
] == NULL
)
2295 if (ar
->as
->upper
[dimen
] == NULL
2296 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2297 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2299 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2303 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2305 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2309 mpz_sub (*result
, upper
, lower
);
2310 mpz_add (*result
, *result
, stride
);
2311 mpz_div (*result
, *result
, stride
);
2313 /* Zero stride caught earlier. */
2314 if (mpz_cmp_ui (*result
, 0) < 0)
2315 mpz_set_ui (*result
, 0);
2322 mpz_sub_ui (*end
, *result
, 1UL);
2323 mpz_mul (*end
, *end
, stride
);
2324 mpz_add (*end
, *end
, lower
);
2334 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2342 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2347 mpz_init_set_ui (*result
, 1);
2349 for (d
= 0; d
< ar
->dimen
; d
++)
2351 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2353 mpz_clear (*result
);
2357 mpz_mul (*result
, *result
, size
);
2365 /* Given an array expression and a dimension, figure out how many
2366 elements it has along that dimension. Returns true if we were
2367 able to return a result in the 'result' variable, false
2371 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2376 gcc_assert (array
!= NULL
);
2378 if (array
->ts
.type
== BT_CLASS
)
2381 if (array
->rank
== -1)
2384 if (dimen
< 0 || dimen
> array
->rank
- 1)
2385 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2387 switch (array
->expr_type
)
2391 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2393 if (ref
->type
!= REF_ARRAY
)
2396 if (ref
->u
.ar
.type
== AR_FULL
)
2397 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2399 if (ref
->u
.ar
.type
== AR_SECTION
)
2401 for (i
= 0; dimen
>= 0; i
++)
2402 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2405 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2409 if (array
->shape
&& array
->shape
[dimen
])
2411 mpz_init_set (*result
, array
->shape
[dimen
]);
2415 if (array
->symtree
->n
.sym
->attr
.generic
2416 && array
->value
.function
.esym
!= NULL
)
2418 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2421 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2427 if (array
->shape
== NULL
) {
2428 /* Expressions with rank > 1 should have "shape" properly set */
2429 if ( array
->rank
!= 1 )
2430 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2431 return gfc_array_size(array
, result
);
2436 if (array
->shape
== NULL
)
2439 mpz_init_set (*result
, array
->shape
[dimen
]);
2448 /* Given an array expression, figure out how many elements are in the
2449 array. Returns true if this is possible, and sets the 'result'
2450 variable. Otherwise returns false. */
2453 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2455 expand_info expand_save
;
2460 if (array
->ts
.type
== BT_CLASS
)
2463 switch (array
->expr_type
)
2466 gfc_push_suppress_errors ();
2468 expand_save
= current_expand
;
2470 current_expand
.count
= result
;
2471 mpz_init_set_ui (*result
, 0);
2473 current_expand
.expand_work_function
= count_elements
;
2476 t
= expand_constructor (array
->value
.constructor
);
2478 gfc_pop_suppress_errors ();
2481 mpz_clear (*result
);
2482 current_expand
= expand_save
;
2486 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2488 if (ref
->type
!= REF_ARRAY
)
2491 if (ref
->u
.ar
.type
== AR_FULL
)
2492 return spec_size (ref
->u
.ar
.as
, result
);
2494 if (ref
->u
.ar
.type
== AR_SECTION
)
2495 return ref_size (&ref
->u
.ar
, result
);
2498 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2502 if (array
->rank
== 0 || array
->shape
== NULL
)
2505 mpz_init_set_ui (*result
, 1);
2507 for (i
= 0; i
< array
->rank
; i
++)
2508 mpz_mul (*result
, *result
, array
->shape
[i
]);
2517 /* Given an array reference, return the shape of the reference in an
2518 array of mpz_t integers. */
2521 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2531 for (; d
< ar
->as
->rank
; d
++)
2532 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2538 for (i
= 0; i
< ar
->dimen
; i
++)
2540 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2542 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2555 gfc_clear_shape (shape
, d
);
2560 /* Given an array expression, find the array reference structure that
2561 characterizes the reference. */
2564 gfc_find_array_ref (gfc_expr
*e
)
2568 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2569 if (ref
->type
== REF_ARRAY
2570 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2574 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2580 /* Find out if an array shape is known at compile time. */
2583 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2587 if (as
->type
!= AS_EXPLICIT
)
2590 for (i
= 0; i
< as
->rank
; i
++)
2591 if (!gfc_is_constant_expr (as
->lower
[i
])
2592 || !gfc_is_constant_expr (as
->upper
[i
]))