2 Copyright (C) 2000-2019 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;
161 bool team_just_seen
= false;
163 memset (ar
, '\0', sizeof (*ar
));
165 ar
->where
= gfc_current_locus
;
167 ar
->type
= AR_UNKNOWN
;
169 if (gfc_match_char ('[') == MATCH_YES
)
171 matched_bracket
= true;
175 if (gfc_match_char ('(') != MATCH_YES
)
182 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
184 m
= match_subscript (ar
, init
, false);
185 if (m
== MATCH_ERROR
)
188 if (gfc_match_char (')') == MATCH_YES
)
194 if (gfc_match_char (',') != MATCH_YES
)
196 gfc_error ("Invalid form of array reference at %C");
202 && !gfc_notify_std (GFC_STD_F2008
,
203 "Array reference at %C has more than 7 dimensions"))
206 gfc_error ("Array reference at %C cannot have more than %d dimensions",
211 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
219 if (flag_coarray
== GFC_FCOARRAY_NONE
)
221 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
227 gfc_error ("Unexpected coarray designator at %C");
233 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
235 m
= match_subscript (ar
, init
, true);
236 if (m
== MATCH_ERROR
)
239 team_just_seen
= false;
240 stat_just_seen
= false;
241 if (gfc_match (" , team = %e", &tmp
) == MATCH_YES
&& ar
->team
== NULL
)
244 team_just_seen
= true;
247 if (ar
->team
&& !team_just_seen
)
249 gfc_error ("TEAM= attribute in %C misplaced");
253 if (gfc_match (" , stat = %e",&tmp
) == MATCH_YES
&& ar
->stat
== NULL
)
256 stat_just_seen
= true;
259 if (ar
->stat
&& !stat_just_seen
)
261 gfc_error ("STAT= attribute in %C misplaced");
265 if (gfc_match_char (']') == MATCH_YES
)
268 if (ar
->codimen
< corank
)
270 gfc_error ("Too few codimensions at %C, expected %d not %d",
271 corank
, ar
->codimen
);
274 if (ar
->codimen
> corank
)
276 gfc_error ("Too many codimensions at %C, expected %d not %d",
277 corank
, ar
->codimen
);
283 if (gfc_match_char (',') != MATCH_YES
)
285 if (gfc_match_char ('*') == MATCH_YES
)
286 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
287 ar
->codimen
+ 1, corank
);
289 gfc_error ("Invalid form of coarray reference at %C");
292 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
294 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
295 ar
->codimen
+ 1, corank
);
299 if (ar
->codimen
>= corank
)
301 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
302 ar
->codimen
+ 1, corank
);
307 gfc_error ("Array reference at %C cannot have more than %d dimensions",
314 /************** Array specification matching subroutines ***************/
316 /* Free all of the expressions associated with array bounds
320 gfc_free_array_spec (gfc_array_spec
*as
)
327 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
329 gfc_free_expr (as
->lower
[i
]);
330 gfc_free_expr (as
->upper
[i
]);
337 /* Take an array bound, resolves the expression, that make up the
338 shape and check associated constraints. */
341 resolve_array_bound (gfc_expr
*e
, int check_constant
)
346 if (!gfc_resolve_expr (e
)
347 || !gfc_specification_expr (e
))
350 if (check_constant
&& !gfc_is_constant_expr (e
))
352 if (e
->expr_type
== EXPR_VARIABLE
)
353 gfc_error ("Variable %qs at %L in this context must be constant",
354 e
->symtree
->n
.sym
->name
, &e
->where
);
356 gfc_error ("Expression at %L in this context must be constant",
365 /* Takes an array specification, resolves the expressions that make up
366 the shape and make sure everything is integral. */
369 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
380 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
383 if (!resolve_array_bound (e
, check_constant
))
387 if (!resolve_array_bound (e
, check_constant
))
390 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
393 /* If the size is negative in this dimension, set it to zero. */
394 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
395 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
396 && mpz_cmp (as
->upper
[i
]->value
.integer
,
397 as
->lower
[i
]->value
.integer
) < 0)
399 gfc_free_expr (as
->upper
[i
]);
400 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
401 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
402 as
->upper
[i
]->value
.integer
, 1);
412 /* Match a single array element specification. The return values as
413 well as the upper and lower bounds of the array spec are filled
414 in according to what we see on the input. The caller makes sure
415 individual specifications make sense as a whole.
418 Parsed Lower Upper Returned
419 ------------------------------------
420 : NULL NULL AS_DEFERRED (*)
422 x: x NULL AS_ASSUMED_SHAPE
424 x:* x NULL AS_ASSUMED_SIZE
425 * 1 NULL AS_ASSUMED_SIZE
427 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
428 is fixed during the resolution of formal interfaces.
430 Anything else AS_UNKNOWN. */
433 match_array_element_spec (gfc_array_spec
*as
)
435 gfc_expr
**upper
, **lower
;
439 rank
= as
->rank
== -1 ? 0 : as
->rank
;
440 lower
= &as
->lower
[rank
+ as
->corank
- 1];
441 upper
= &as
->upper
[rank
+ as
->corank
- 1];
443 if (gfc_match_char ('*') == MATCH_YES
)
445 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
446 return AS_ASSUMED_SIZE
;
449 if (gfc_match_char (':') == MATCH_YES
)
452 m
= gfc_match_expr (upper
);
454 gfc_error ("Expected expression in array specification at %C");
457 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
460 if (((*upper
)->expr_type
== EXPR_CONSTANT
461 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
462 ((*upper
)->expr_type
== EXPR_FUNCTION
463 && (*upper
)->ts
.type
== BT_UNKNOWN
465 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
467 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
468 gfc_basic_typename ((*upper
)->ts
.type
));
472 if (gfc_match_char (':') == MATCH_NO
)
474 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
481 if (gfc_match_char ('*') == MATCH_YES
)
482 return AS_ASSUMED_SIZE
;
484 m
= gfc_match_expr (upper
);
485 if (m
== MATCH_ERROR
)
488 return AS_ASSUMED_SHAPE
;
489 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
492 if (((*upper
)->expr_type
== EXPR_CONSTANT
493 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
494 ((*upper
)->expr_type
== EXPR_FUNCTION
495 && (*upper
)->ts
.type
== BT_UNKNOWN
497 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
499 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
500 gfc_basic_typename ((*upper
)->ts
.type
));
508 /* Matches an array specification, incidentally figuring out what sort
509 it is. Match either a normal array specification, or a coarray spec
510 or both. Optionally allow [:] for coarrays. */
513 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
515 array_type current_type
;
519 as
= gfc_get_array_spec ();
524 if (gfc_match_char ('(') != MATCH_YES
)
531 if (gfc_match (" .. )") == MATCH_YES
)
533 as
->type
= AS_ASSUMED_RANK
;
536 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
547 current_type
= match_array_element_spec (as
);
549 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
550 and implied-shape specifications. If the rank is at least 2, we can
551 distinguish between them. But for rank 1, we currently return
552 ASSUMED_SIZE; this gets adjusted later when we know for sure
553 whether the symbol parsed is a PARAMETER or not. */
557 if (current_type
== AS_UNKNOWN
)
559 as
->type
= current_type
;
563 { /* See how current spec meshes with the existing. */
567 case AS_IMPLIED_SHAPE
:
568 if (current_type
!= AS_ASSUMED_SHAPE
)
570 gfc_error ("Bad array specification for implied-shape"
577 if (current_type
== AS_ASSUMED_SIZE
)
579 as
->type
= AS_ASSUMED_SIZE
;
583 if (current_type
== AS_EXPLICIT
)
586 gfc_error ("Bad array specification for an explicitly shaped "
591 case AS_ASSUMED_SHAPE
:
592 if ((current_type
== AS_ASSUMED_SHAPE
)
593 || (current_type
== AS_DEFERRED
))
596 gfc_error ("Bad array specification for assumed shape "
601 if (current_type
== AS_DEFERRED
)
604 if (current_type
== AS_ASSUMED_SHAPE
)
606 as
->type
= AS_ASSUMED_SHAPE
;
610 gfc_error ("Bad specification for deferred shape array at %C");
613 case AS_ASSUMED_SIZE
:
614 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
616 as
->type
= AS_IMPLIED_SHAPE
;
620 gfc_error ("Bad specification for assumed size array at %C");
623 case AS_ASSUMED_RANK
:
627 if (gfc_match_char (')') == MATCH_YES
)
630 if (gfc_match_char (',') != MATCH_YES
)
632 gfc_error ("Expected another dimension in array declaration at %C");
636 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
638 gfc_error ("Array specification at %C has more than %d dimensions",
643 if (as
->corank
+ as
->rank
>= 7
644 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
645 "with more than 7 dimensions"))
653 if (gfc_match_char ('[') != MATCH_YES
)
656 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
659 if (flag_coarray
== GFC_FCOARRAY_NONE
)
661 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
665 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
667 gfc_error ("Array specification at %C has more than %d "
668 "dimensions", GFC_MAX_DIMENSIONS
);
675 current_type
= match_array_element_spec (as
);
677 if (current_type
== AS_UNKNOWN
)
681 as
->cotype
= current_type
;
684 { /* See how current spec meshes with the existing. */
685 case AS_IMPLIED_SHAPE
:
690 if (current_type
== AS_ASSUMED_SIZE
)
692 as
->cotype
= AS_ASSUMED_SIZE
;
696 if (current_type
== AS_EXPLICIT
)
699 gfc_error ("Bad array specification for an explicitly "
700 "shaped array at %C");
704 case AS_ASSUMED_SHAPE
:
705 if ((current_type
== AS_ASSUMED_SHAPE
)
706 || (current_type
== AS_DEFERRED
))
709 gfc_error ("Bad array specification for assumed shape "
714 if (current_type
== AS_DEFERRED
)
717 if (current_type
== AS_ASSUMED_SHAPE
)
719 as
->cotype
= AS_ASSUMED_SHAPE
;
723 gfc_error ("Bad specification for deferred shape array at %C");
726 case AS_ASSUMED_SIZE
:
727 gfc_error ("Bad specification for assumed size array at %C");
730 case AS_ASSUMED_RANK
:
734 if (gfc_match_char (']') == MATCH_YES
)
737 if (gfc_match_char (',') != MATCH_YES
)
739 gfc_error ("Expected another dimension in array declaration at %C");
743 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
745 gfc_error ("Array specification at %C has more than %d "
746 "dimensions", GFC_MAX_DIMENSIONS
);
751 if (current_type
== AS_EXPLICIT
)
753 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
757 if (as
->cotype
== AS_ASSUMED_SIZE
)
758 as
->cotype
= AS_EXPLICIT
;
761 as
->type
= as
->cotype
;
764 if (as
->rank
== 0 && as
->corank
== 0)
767 gfc_free_array_spec (as
);
771 /* If a lower bounds of an assumed shape array is blank, put in one. */
772 if (as
->type
== AS_ASSUMED_SHAPE
)
774 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
776 if (as
->lower
[i
] == NULL
)
777 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
786 /* Something went wrong. */
787 gfc_free_array_spec (as
);
792 /* Given a symbol and an array specification, modify the symbol to
793 have that array specification. The error locus is needed in case
794 something goes wrong. On failure, the caller must free the spec. */
797 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
805 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
809 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
818 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
819 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
821 gfc_error ("The assumed-rank array %qs at %L shall not have a "
822 "codimension", sym
->name
, error_loc
);
828 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
829 the codimension is simply added. */
830 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
832 sym
->as
->cotype
= as
->cotype
;
833 sym
->as
->corank
= as
->corank
;
834 for (i
= 0; i
< as
->corank
; i
++)
836 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
837 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
842 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
843 the dimension is added - but first the codimensions (if existing
844 need to be shifted to make space for the dimension. */
845 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
847 sym
->as
->rank
= as
->rank
;
848 sym
->as
->type
= as
->type
;
849 sym
->as
->cray_pointee
= as
->cray_pointee
;
850 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
852 for (i
= 0; i
< sym
->as
->corank
; i
++)
854 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
855 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
857 for (i
= 0; i
< as
->rank
; i
++)
859 sym
->as
->lower
[i
] = as
->lower
[i
];
860 sym
->as
->upper
[i
] = as
->upper
[i
];
869 /* Copy an array specification. */
872 gfc_copy_array_spec (gfc_array_spec
*src
)
874 gfc_array_spec
*dest
;
880 dest
= gfc_get_array_spec ();
884 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
886 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
887 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
894 /* Returns nonzero if the two expressions are equal. Only handles integer
898 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
900 if (bound1
== NULL
|| bound2
== NULL
901 || bound1
->expr_type
!= EXPR_CONSTANT
902 || bound2
->expr_type
!= EXPR_CONSTANT
903 || bound1
->ts
.type
!= BT_INTEGER
904 || bound2
->ts
.type
!= BT_INTEGER
)
905 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
907 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
914 /* Compares two array specifications. They must be constant or deferred
918 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
922 if (as1
== NULL
&& as2
== NULL
)
925 if (as1
== NULL
|| as2
== NULL
)
928 if (as1
->rank
!= as2
->rank
)
931 if (as1
->corank
!= as2
->corank
)
937 if (as1
->type
!= as2
->type
)
940 if (as1
->type
== AS_EXPLICIT
)
941 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
943 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
946 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
954 /****************** Array constructor functions ******************/
957 /* Given an expression node that might be an array constructor and a
958 symbol, make sure that no iterators in this or child constructors
959 use the symbol as an implied-DO iterator. Returns nonzero if a
960 duplicate was found. */
963 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
968 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
972 if (e
->expr_type
== EXPR_ARRAY
973 && check_duplicate_iterator (e
->value
.constructor
, master
))
976 if (c
->iterator
== NULL
)
979 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
981 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
982 "same name", master
->name
, &c
->where
);
992 /* Forward declaration because these functions are mutually recursive. */
993 static match
match_array_cons_element (gfc_constructor_base
*);
995 /* Match a list of array elements. */
998 match_array_list (gfc_constructor_base
*result
)
1000 gfc_constructor_base head
;
1008 old_loc
= gfc_current_locus
;
1010 if (gfc_match_char ('(') == MATCH_NO
)
1013 memset (&iter
, '\0', sizeof (gfc_iterator
));
1016 m
= match_array_cons_element (&head
);
1020 if (gfc_match_char (',') != MATCH_YES
)
1028 m
= gfc_match_iterator (&iter
, 0);
1031 if (m
== MATCH_ERROR
)
1034 m
= match_array_cons_element (&head
);
1035 if (m
== MATCH_ERROR
)
1042 goto cleanup
; /* Could be a complex constant */
1045 if (gfc_match_char (',') != MATCH_YES
)
1054 if (gfc_match_char (')') != MATCH_YES
)
1057 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1063 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1064 e
->value
.constructor
= head
;
1066 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1067 p
->iterator
= gfc_get_iterator ();
1068 *p
->iterator
= iter
;
1073 gfc_error ("Syntax error in array constructor at %C");
1077 gfc_constructor_free (head
);
1078 gfc_free_iterator (&iter
, 0);
1079 gfc_current_locus
= old_loc
;
1084 /* Match a single element of an array constructor, which can be a
1085 single expression or a list of elements. */
1088 match_array_cons_element (gfc_constructor_base
*result
)
1093 m
= match_array_list (result
);
1097 m
= gfc_match_expr (&expr
);
1101 if (expr
->expr_type
== EXPR_FUNCTION
1102 && expr
->ts
.type
== BT_UNKNOWN
1103 && strcmp(expr
->symtree
->name
, "null") == 0)
1105 gfc_error ("NULL() at %C cannot appear in an array constructor");
1106 gfc_free_expr (expr
);
1110 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1115 /* Match an array constructor. */
1118 gfc_match_array_constructor (gfc_expr
**result
)
1121 gfc_constructor_base head
;
1126 const char *end_delim
;
1132 if (gfc_match (" (/") == MATCH_NO
)
1134 if (gfc_match (" [") == MATCH_NO
)
1138 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1139 "style array constructors at %C"))
1147 where
= gfc_current_locus
;
1149 /* Try to match an optional "type-spec ::" */
1151 m
= gfc_match_type_spec (&ts
);
1154 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1158 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1159 "including type specification at %C"))
1164 gfc_error ("Type-spec at %L cannot contain a deferred "
1165 "type parameter", &where
);
1169 if (ts
.type
== BT_CHARACTER
1170 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1172 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1173 "type parameter", &where
);
1178 else if (m
== MATCH_ERROR
)
1182 gfc_current_locus
= where
;
1184 if (gfc_match (end_delim
) == MATCH_YES
)
1190 gfc_error ("Empty array constructor at %C is not allowed");
1197 m
= match_array_cons_element (&head
);
1198 if (m
== MATCH_ERROR
)
1203 if (gfc_match_char (',') == MATCH_NO
)
1207 if (gfc_match (end_delim
) == MATCH_NO
)
1211 /* Size must be calculated at resolution time. */
1214 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1217 /* If the typespec is CHARACTER, check that array elements can
1218 be converted. See PR fortran/67803. */
1219 if (ts
.type
== BT_CHARACTER
)
1221 c
= gfc_constructor_first (head
);
1222 for (; c
; c
= gfc_constructor_next (c
))
1224 if (gfc_numeric_ts (&c
->expr
->ts
)
1225 || c
->expr
->ts
.type
== BT_LOGICAL
)
1227 gfc_error ("Incompatible typespec for array element at %L",
1232 /* Special case null(). */
1233 if (c
->expr
->expr_type
== EXPR_FUNCTION
1234 && c
->expr
->ts
.type
== BT_UNKNOWN
1235 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1237 gfc_error ("Incompatible typespec for array element at %L",
1244 /* Walk the constructor and ensure type conversion for numeric types. */
1245 if (gfc_numeric_ts (&ts
))
1247 c
= gfc_constructor_first (head
);
1248 for (; c
; c
= gfc_constructor_next (c
))
1249 if (!gfc_convert_type (c
->expr
, &ts
, 1)
1250 && c
->expr
->ts
.type
!= BT_UNKNOWN
)
1255 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1257 expr
->value
.constructor
= head
;
1259 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1266 gfc_error ("Syntax error in array constructor at %C");
1269 gfc_constructor_free (head
);
1275 /************** Check array constructors for correctness **************/
1277 /* Given an expression, compare it's type with the type of the current
1278 constructor. Returns nonzero if an error was issued. The
1279 cons_state variable keeps track of whether the type of the
1280 constructor being read or resolved is known to be good, bad or just
1283 static gfc_typespec constructor_ts
;
1285 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1289 check_element_type (gfc_expr
*expr
, bool convert
)
1291 if (cons_state
== CONS_BAD
)
1292 return 0; /* Suppress further errors */
1294 if (cons_state
== CONS_START
)
1296 if (expr
->ts
.type
== BT_UNKNOWN
)
1297 cons_state
= CONS_BAD
;
1300 cons_state
= CONS_GOOD
;
1301 constructor_ts
= expr
->ts
;
1307 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1311 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1313 gfc_error ("Element in %s array constructor at %L is %s",
1314 gfc_typename (&constructor_ts
), &expr
->where
,
1315 gfc_typename (&expr
->ts
));
1317 cons_state
= CONS_BAD
;
1322 /* Recursive work function for gfc_check_constructor_type(). */
1325 check_constructor_type (gfc_constructor_base base
, bool convert
)
1330 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1334 if (e
->expr_type
== EXPR_ARRAY
)
1336 if (!check_constructor_type (e
->value
.constructor
, convert
))
1342 if (check_element_type (e
, convert
))
1350 /* Check that all elements of an array constructor are the same type.
1351 On false, an error has been generated. */
1354 gfc_check_constructor_type (gfc_expr
*e
)
1358 if (e
->ts
.type
!= BT_UNKNOWN
)
1360 cons_state
= CONS_GOOD
;
1361 constructor_ts
= e
->ts
;
1365 cons_state
= CONS_START
;
1366 gfc_clear_ts (&constructor_ts
);
1369 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1370 typespec, and we will now convert the values on the fly. */
1371 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1372 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1373 e
->ts
= constructor_ts
;
1380 typedef struct cons_stack
1382 gfc_iterator
*iterator
;
1383 struct cons_stack
*previous
;
1387 static cons_stack
*base
;
1389 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1391 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1392 that that variable is an iteration variables. */
1395 gfc_check_iter_variable (gfc_expr
*expr
)
1400 sym
= expr
->symtree
->n
.sym
;
1402 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1403 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1410 /* Recursive work function for gfc_check_constructor(). This amounts
1411 to calling the check function for each expression in the
1412 constructor, giving variables with the names of iterators a pass. */
1415 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1422 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1429 if (e
->expr_type
!= EXPR_ARRAY
)
1431 if (!(*check_function
)(e
))
1436 element
.previous
= base
;
1437 element
.iterator
= c
->iterator
;
1440 t
= check_constructor (e
->value
.constructor
, check_function
);
1441 base
= element
.previous
;
1447 /* Nothing went wrong, so all OK. */
1452 /* Checks a constructor to see if it is a particular kind of
1453 expression -- specification, restricted, or initialization as
1454 determined by the check_function. */
1457 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1459 cons_stack
*base_save
;
1465 t
= check_constructor (expr
->value
.constructor
, check_function
);
1473 /**************** Simplification of array constructors ****************/
1475 iterator_stack
*iter_stack
;
1479 gfc_constructor_base base
;
1480 int extract_count
, extract_n
;
1481 gfc_expr
*extracted
;
1485 gfc_component
*component
;
1488 bool (*expand_work_function
) (gfc_expr
*);
1492 static expand_info current_expand
;
1494 static bool expand_constructor (gfc_constructor_base
);
1497 /* Work function that counts the number of elements present in a
1501 count_elements (gfc_expr
*e
)
1506 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1509 if (!gfc_array_size (e
, &result
))
1515 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1524 /* Work function that extracts a particular element from an array
1525 constructor, freeing the rest. */
1528 extract_element (gfc_expr
*e
)
1531 { /* Something unextractable */
1536 if (current_expand
.extract_count
== current_expand
.extract_n
)
1537 current_expand
.extracted
= e
;
1541 current_expand
.extract_count
++;
1547 /* Work function that constructs a new constructor out of the old one,
1548 stringing new elements together. */
1551 expand (gfc_expr
*e
)
1553 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1556 c
->n
.component
= current_expand
.component
;
1561 /* Given an initialization expression that is a variable reference,
1562 substitute the current value of the iteration variable. */
1565 gfc_simplify_iterator_var (gfc_expr
*e
)
1569 for (p
= iter_stack
; p
; p
= p
->prev
)
1570 if (e
->symtree
== p
->variable
)
1574 return; /* Variable not found */
1576 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1578 mpz_set (e
->value
.integer
, p
->value
);
1584 /* Expand an expression with that is inside of a constructor,
1585 recursing into other constructors if present. */
1588 expand_expr (gfc_expr
*e
)
1590 if (e
->expr_type
== EXPR_ARRAY
)
1591 return expand_constructor (e
->value
.constructor
);
1593 e
= gfc_copy_expr (e
);
1595 if (!gfc_simplify_expr (e
, 1))
1601 return current_expand
.expand_work_function (e
);
1606 expand_iterator (gfc_constructor
*c
)
1608 gfc_expr
*start
, *end
, *step
;
1609 iterator_stack frame
;
1618 mpz_init (frame
.value
);
1621 start
= gfc_copy_expr (c
->iterator
->start
);
1622 if (!gfc_simplify_expr (start
, 1))
1625 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1628 end
= gfc_copy_expr (c
->iterator
->end
);
1629 if (!gfc_simplify_expr (end
, 1))
1632 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1635 step
= gfc_copy_expr (c
->iterator
->step
);
1636 if (!gfc_simplify_expr (step
, 1))
1639 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1642 if (mpz_sgn (step
->value
.integer
) == 0)
1644 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1648 /* Calculate the trip count of the loop. */
1649 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1650 mpz_add (trip
, trip
, step
->value
.integer
);
1651 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1653 mpz_set (frame
.value
, start
->value
.integer
);
1655 frame
.prev
= iter_stack
;
1656 frame
.variable
= c
->iterator
->var
->symtree
;
1657 iter_stack
= &frame
;
1659 while (mpz_sgn (trip
) > 0)
1661 if (!expand_expr (c
->expr
))
1664 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1665 mpz_sub_ui (trip
, trip
, 1);
1671 gfc_free_expr (start
);
1672 gfc_free_expr (end
);
1673 gfc_free_expr (step
);
1676 mpz_clear (frame
.value
);
1678 iter_stack
= frame
.prev
;
1684 /* Expand a constructor into constant constructors without any
1685 iterators, calling the work function for each of the expanded
1686 expressions. The work function needs to either save or free the
1687 passed expression. */
1690 expand_constructor (gfc_constructor_base base
)
1695 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1697 if (c
->iterator
!= NULL
)
1699 if (!expand_iterator (c
))
1706 if (e
->expr_type
== EXPR_ARRAY
)
1708 if (!expand_constructor (e
->value
.constructor
))
1714 e
= gfc_copy_expr (e
);
1715 if (!gfc_simplify_expr (e
, 1))
1720 current_expand
.offset
= &c
->offset
;
1721 current_expand
.repeat
= &c
->repeat
;
1722 current_expand
.component
= c
->n
.component
;
1723 if (!current_expand
.expand_work_function(e
))
1730 /* Given an array expression and an element number (starting at zero),
1731 return a pointer to the array element. NULL is returned if the
1732 size of the array has been exceeded. The expression node returned
1733 remains a part of the array and should not be freed. Access is not
1734 efficient at all, but this is another place where things do not
1735 have to be particularly fast. */
1738 gfc_get_array_element (gfc_expr
*array
, int element
)
1740 expand_info expand_save
;
1744 expand_save
= current_expand
;
1745 current_expand
.extract_n
= element
;
1746 current_expand
.expand_work_function
= extract_element
;
1747 current_expand
.extracted
= NULL
;
1748 current_expand
.extract_count
= 0;
1752 rc
= expand_constructor (array
->value
.constructor
);
1753 e
= current_expand
.extracted
;
1754 current_expand
= expand_save
;
1763 /* Top level subroutine for expanding constructors. We only expand
1764 constructor if they are small enough. */
1767 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1769 expand_info expand_save
;
1773 /* If we can successfully get an array element at the max array size then
1774 the array is too big to expand, so we just return. */
1775 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1781 gfc_error ("The number of elements in the array constructor "
1782 "at %L requires an increase of the allowed %d "
1783 "upper limit. See %<-fmax-array-constructor%> "
1784 "option", &e
->where
, flag_max_array_constructor
);
1790 /* We now know the array is not too big so go ahead and try to expand it. */
1791 expand_save
= current_expand
;
1792 current_expand
.base
= NULL
;
1796 current_expand
.expand_work_function
= expand
;
1798 if (!expand_constructor (e
->value
.constructor
))
1800 gfc_constructor_free (current_expand
.base
);
1805 gfc_constructor_free (e
->value
.constructor
);
1806 e
->value
.constructor
= current_expand
.base
;
1811 current_expand
= expand_save
;
1817 /* Work function for checking that an element of a constructor is a
1818 constant, after removal of any iteration variables. We return
1822 is_constant_element (gfc_expr
*e
)
1826 rv
= gfc_is_constant_expr (e
);
1829 return rv
? true : false;
1833 /* Given an array constructor, determine if the constructor is
1834 constant or not by expanding it and making sure that all elements
1835 are constants. This is a bit of a hack since something like (/ (i,
1836 i=1,100000000) /) will take a while as* opposed to a more clever
1837 function that traverses the expression tree. FIXME. */
1840 gfc_constant_ac (gfc_expr
*e
)
1842 expand_info expand_save
;
1846 expand_save
= current_expand
;
1847 current_expand
.expand_work_function
= is_constant_element
;
1849 rc
= expand_constructor (e
->value
.constructor
);
1851 current_expand
= expand_save
;
1859 /* Returns nonzero if an array constructor has been completely
1860 expanded (no iterators) and zero if iterators are present. */
1863 gfc_expanded_ac (gfc_expr
*e
)
1867 if (e
->expr_type
== EXPR_ARRAY
)
1868 for (c
= gfc_constructor_first (e
->value
.constructor
);
1869 c
; c
= gfc_constructor_next (c
))
1870 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1877 /*************** Type resolution of array constructors ***************/
1880 /* The symbol expr_is_sought_symbol_ref will try to find. */
1881 static const gfc_symbol
*sought_symbol
= NULL
;
1884 /* Tells whether the expression E is a variable reference to the symbol
1885 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1887 To be used with gfc_expr_walker: if a reference is found we don't need
1888 to look further so we return 1 to skip any further walk. */
1891 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1894 gfc_expr
*expr
= *e
;
1895 locus
*sym_loc
= (locus
*)where
;
1897 if (expr
->expr_type
== EXPR_VARIABLE
1898 && expr
->symtree
->n
.sym
== sought_symbol
)
1900 *sym_loc
= expr
->where
;
1908 /* Tells whether the expression EXPR contains a reference to the symbol
1909 SYM and in that case sets the position SYM_LOC where the reference is. */
1912 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1916 sought_symbol
= sym
;
1917 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1918 sought_symbol
= NULL
;
1923 /* Recursive array list resolution function. All of the elements must
1924 be of the same type. */
1927 resolve_array_list (gfc_constructor_base base
)
1935 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1940 gfc_symbol
*iter_var
;
1943 if (!gfc_resolve_iterator (iter
, false, true))
1946 /* Check for bounds referencing the iterator variable. */
1947 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1948 iter_var
= iter
->var
->symtree
->n
.sym
;
1949 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1951 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1952 "expression references control variable "
1953 "at %L", &iter_var_loc
))
1956 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1958 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1959 "expression references control variable "
1960 "at %L", &iter_var_loc
))
1963 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1965 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1966 "expression references control variable "
1967 "at %L", &iter_var_loc
))
1972 if (!gfc_resolve_expr (c
->expr
))
1975 if (UNLIMITED_POLY (c
->expr
))
1977 gfc_error ("Array constructor value at %L shall not be unlimited "
1978 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1986 /* Resolve character array constructor. If it has a specified constant character
1987 length, pad/truncate the elements here; if the length is not specified and
1988 all elements are of compile-time known length, emit an error as this is
1992 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1995 HOST_WIDE_INT found_length
;
1997 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1998 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2000 if (expr
->ts
.u
.cl
== NULL
)
2002 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2003 p
; p
= gfc_constructor_next (p
))
2004 if (p
->expr
->ts
.u
.cl
!= NULL
)
2006 /* Ensure that if there is a char_len around that it is
2007 used; otherwise the middle-end confuses them! */
2008 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2012 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2017 /* Early exit for zero size arrays. */
2021 HOST_WIDE_INT arraysize
;
2023 gfc_array_size (expr
, &size
);
2024 arraysize
= mpz_get_ui (size
);
2033 if (expr
->ts
.u
.cl
->length
== NULL
)
2035 /* Check that all constant string elements have the same length until
2036 we reach the end or find a variable-length one. */
2038 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2039 p
; p
= gfc_constructor_next (p
))
2041 HOST_WIDE_INT current_length
= -1;
2043 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2044 if (ref
->type
== REF_SUBSTRING
2046 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2048 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2051 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2052 current_length
= p
->expr
->value
.character
.length
;
2054 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2055 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2056 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2057 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2058 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2062 if (current_length
< 0)
2065 if (found_length
== -1)
2066 found_length
= current_length
;
2067 else if (found_length
!= current_length
)
2069 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2070 " constructor at %L", (long) found_length
,
2071 (long) current_length
, &p
->expr
->where
);
2075 gcc_assert (found_length
== current_length
);
2078 gcc_assert (found_length
!= -1);
2080 /* Update the character length of the array constructor. */
2081 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2082 NULL
, found_length
);
2086 /* We've got a character length specified. It should be an integer,
2087 otherwise an error is signalled elsewhere. */
2088 gcc_assert (expr
->ts
.u
.cl
->length
);
2090 /* If we've got a constant character length, pad according to this.
2091 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2092 max_length only if they pass. */
2093 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2095 /* Now pad/truncate the elements accordingly to the specified character
2096 length. This is ok inside this conditional, as in the case above
2097 (without typespec) all elements are verified to have the same length
2099 if (found_length
!= -1)
2100 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2101 p
; p
= gfc_constructor_next (p
))
2102 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2104 gfc_expr
*cl
= NULL
;
2105 HOST_WIDE_INT current_length
= -1;
2108 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2110 cl
= p
->expr
->ts
.u
.cl
->length
;
2111 gfc_extract_hwi (cl
, ¤t_length
);
2114 /* If gfc_extract_int above set current_length, we implicitly
2115 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2117 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2120 || (current_length
!= -1 && current_length
!= found_length
))
2121 gfc_set_constant_character_len (found_length
, p
->expr
,
2122 has_ts
? -1 : found_length
);
2130 /* Resolve all of the expressions in an array list. */
2133 gfc_resolve_array_constructor (gfc_expr
*expr
)
2137 t
= resolve_array_list (expr
->value
.constructor
);
2139 t
= gfc_check_constructor_type (expr
);
2141 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2142 the call to this function, so we don't need to call it here; if it was
2143 called twice, an error message there would be duplicated. */
2149 /* Copy an iterator structure. */
2152 gfc_copy_iterator (gfc_iterator
*src
)
2159 dest
= gfc_get_iterator ();
2161 dest
->var
= gfc_copy_expr (src
->var
);
2162 dest
->start
= gfc_copy_expr (src
->start
);
2163 dest
->end
= gfc_copy_expr (src
->end
);
2164 dest
->step
= gfc_copy_expr (src
->step
);
2165 dest
->unroll
= src
->unroll
;
2171 /********* Subroutines for determining the size of an array *********/
2173 /* These are needed just to accommodate RESHAPE(). There are no
2174 diagnostics here, we just return a negative number if something
2178 /* Get the size of single dimension of an array specification. The
2179 array is guaranteed to be one dimensional. */
2182 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2187 if (dimen
< 0 || dimen
> as
->rank
- 1)
2188 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2190 if (as
->type
!= AS_EXPLICIT
2191 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2192 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2193 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2194 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2199 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2200 as
->lower
[dimen
]->value
.integer
);
2202 mpz_add_ui (*result
, *result
, 1);
2209 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2214 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2217 mpz_init_set_ui (*result
, 1);
2219 for (d
= 0; d
< as
->rank
; d
++)
2221 if (!spec_dimen_size (as
, d
, &size
))
2223 mpz_clear (*result
);
2227 mpz_mul (*result
, *result
, size
);
2235 /* Get the number of elements in an array section. Optionally, also supply
2239 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2241 mpz_t upper
, lower
, stride
;
2244 gfc_expr
*stride_expr
= NULL
;
2246 if (dimen
< 0 || ar
== NULL
)
2247 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2249 if (dimen
> ar
->dimen
- 1)
2251 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2255 switch (ar
->dimen_type
[dimen
])
2259 mpz_set_ui (*result
, 1);
2264 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2271 if (ar
->stride
[dimen
] == NULL
)
2272 mpz_set_ui (stride
, 1);
2275 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2277 if(!gfc_simplify_expr(stride_expr
, 1))
2278 gfc_internal_error("Simplification error");
2280 if (stride_expr
->expr_type
!= EXPR_CONSTANT
2281 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2286 mpz_set (stride
, stride_expr
->value
.integer
);
2287 gfc_free_expr(stride_expr
);
2290 /* Calculate the number of elements via gfc_dep_differce, but only if
2291 start and end are both supplied in the reference or the array spec.
2292 This is to guard against strange but valid code like
2297 print *,size(a(n-1:))
2299 where the user changes the value of a variable. If we have to
2300 determine end as well, we cannot do this using gfc_dep_difference.
2301 Fall back to the constants-only code then. */
2307 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2309 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2310 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2311 ar
->as
->lower
[dimen
], &diff
);
2316 mpz_add (*result
, diff
, stride
);
2317 mpz_div (*result
, *result
, stride
);
2318 if (mpz_cmp_ui (*result
, 0) < 0)
2319 mpz_set_ui (*result
, 0);
2328 /* Constant-only code here, which covers more cases
2334 if (ar
->start
[dimen
] == NULL
)
2336 if (ar
->as
->lower
[dimen
] == NULL
2337 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2338 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2340 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2344 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2346 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2349 if (ar
->end
[dimen
] == NULL
)
2351 if (ar
->as
->upper
[dimen
] == NULL
2352 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2353 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2355 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2359 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2361 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2365 mpz_sub (*result
, upper
, lower
);
2366 mpz_add (*result
, *result
, stride
);
2367 mpz_div (*result
, *result
, stride
);
2369 /* Zero stride caught earlier. */
2370 if (mpz_cmp_ui (*result
, 0) < 0)
2371 mpz_set_ui (*result
, 0);
2378 mpz_sub_ui (*end
, *result
, 1UL);
2379 mpz_mul (*end
, *end
, stride
);
2380 mpz_add (*end
, *end
, lower
);
2390 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2398 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2403 mpz_init_set_ui (*result
, 1);
2405 for (d
= 0; d
< ar
->dimen
; d
++)
2407 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2409 mpz_clear (*result
);
2413 mpz_mul (*result
, *result
, size
);
2421 /* Given an array expression and a dimension, figure out how many
2422 elements it has along that dimension. Returns true if we were
2423 able to return a result in the 'result' variable, false
2427 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2432 gcc_assert (array
!= NULL
);
2434 if (array
->ts
.type
== BT_CLASS
)
2437 if (array
->rank
== -1)
2440 if (dimen
< 0 || dimen
> array
->rank
- 1)
2441 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2443 switch (array
->expr_type
)
2447 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2449 if (ref
->type
!= REF_ARRAY
)
2452 if (ref
->u
.ar
.type
== AR_FULL
)
2453 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2455 if (ref
->u
.ar
.type
== AR_SECTION
)
2457 for (i
= 0; dimen
>= 0; i
++)
2458 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2461 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2465 if (array
->shape
&& array
->shape
[dimen
])
2467 mpz_init_set (*result
, array
->shape
[dimen
]);
2471 if (array
->symtree
->n
.sym
->attr
.generic
2472 && array
->value
.function
.esym
!= NULL
)
2474 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2477 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2483 if (array
->shape
== NULL
) {
2484 /* Expressions with rank > 1 should have "shape" properly set */
2485 if ( array
->rank
!= 1 )
2486 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2487 return gfc_array_size(array
, result
);
2492 if (array
->shape
== NULL
)
2495 mpz_init_set (*result
, array
->shape
[dimen
]);
2504 /* Given an array expression, figure out how many elements are in the
2505 array. Returns true if this is possible, and sets the 'result'
2506 variable. Otherwise returns false. */
2509 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2511 expand_info expand_save
;
2516 if (array
->ts
.type
== BT_CLASS
)
2519 switch (array
->expr_type
)
2522 gfc_push_suppress_errors ();
2524 expand_save
= current_expand
;
2526 current_expand
.count
= result
;
2527 mpz_init_set_ui (*result
, 0);
2529 current_expand
.expand_work_function
= count_elements
;
2532 t
= expand_constructor (array
->value
.constructor
);
2534 gfc_pop_suppress_errors ();
2537 mpz_clear (*result
);
2538 current_expand
= expand_save
;
2542 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2544 if (ref
->type
!= REF_ARRAY
)
2547 if (ref
->u
.ar
.type
== AR_FULL
)
2548 return spec_size (ref
->u
.ar
.as
, result
);
2550 if (ref
->u
.ar
.type
== AR_SECTION
)
2551 return ref_size (&ref
->u
.ar
, result
);
2554 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2558 if (array
->rank
== 0 || array
->shape
== NULL
)
2561 mpz_init_set_ui (*result
, 1);
2563 for (i
= 0; i
< array
->rank
; i
++)
2564 mpz_mul (*result
, *result
, array
->shape
[i
]);
2573 /* Given an array reference, return the shape of the reference in an
2574 array of mpz_t integers. */
2577 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2587 for (; d
< ar
->as
->rank
; d
++)
2588 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2594 for (i
= 0; i
< ar
->dimen
; i
++)
2596 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2598 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2611 gfc_clear_shape (shape
, d
);
2616 /* Given an array expression, find the array reference structure that
2617 characterizes the reference. */
2620 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2624 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2625 if (ref
->type
== REF_ARRAY
2626 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2634 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2641 /* Find out if an array shape is known at compile time. */
2644 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2646 if (as
->type
!= AS_EXPLICIT
)
2649 for (int i
= 0; i
< as
->rank
; i
++)
2650 if (!gfc_is_constant_expr (as
->lower
[i
])
2651 || !gfc_is_constant_expr (as
->upper
[i
]))