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
;
71 i
= ar
->dimen
+ ar
->codimen
;
73 gfc_gobble_whitespace ();
74 ar
->c_where
[i
] = gfc_current_locus
;
75 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
77 /* We can't be sure of the difference between DIMEN_ELEMENT and
78 DIMEN_VECTOR until we know the type of the element itself at
81 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
83 if (gfc_match_char (':') == MATCH_YES
)
86 /* Get start element. */
87 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
91 m
= gfc_match_init_expr (&ar
->start
[i
]);
93 m
= gfc_match_expr (&ar
->start
[i
]);
95 if (ar
->start
[i
] && ar
->start
[i
]->ts
.type
== BT_BOZ
)
97 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
102 gfc_error ("Expected array subscript at %C");
106 if (gfc_match_char (':') == MATCH_NO
)
111 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
115 /* Get an optional end element. Because we've seen the colon, we
116 definitely have a range along this dimension. */
118 ar
->dimen_type
[i
] = DIMEN_RANGE
;
120 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
123 m
= gfc_match_init_expr (&ar
->end
[i
]);
125 m
= gfc_match_expr (&ar
->end
[i
]);
127 if (ar
->end
[i
] && ar
->end
[i
]->ts
.type
== BT_BOZ
)
129 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
133 if (m
== MATCH_ERROR
)
136 /* See if we have an optional stride. */
137 if (gfc_match_char (':') == MATCH_YES
)
141 gfc_error ("Strides not allowed in coarray subscript at %C");
145 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
146 : gfc_match_expr (&ar
->stride
[i
]);
148 if (ar
->stride
[i
] && ar
->stride
[i
]->ts
.type
== BT_BOZ
)
150 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
155 gfc_error ("Expected array subscript stride at %C");
162 ar
->dimen_type
[i
] = DIMEN_STAR
;
164 return (saw_boz
? MATCH_ERROR
: MATCH_YES
);
168 /* Match an array reference, whether it is the whole array or particular
169 elements or a section. If init is set, the reference has to consist
170 of init expressions. */
173 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
177 bool matched_bracket
= false;
179 bool stat_just_seen
= false;
180 bool team_just_seen
= false;
182 memset (ar
, '\0', sizeof (*ar
));
184 ar
->where
= gfc_current_locus
;
186 ar
->type
= AR_UNKNOWN
;
188 if (gfc_match_char ('[') == MATCH_YES
)
190 matched_bracket
= true;
194 if (gfc_match_char ('(') != MATCH_YES
)
201 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
203 m
= match_subscript (ar
, init
, false);
204 if (m
== MATCH_ERROR
)
207 if (gfc_match_char (')') == MATCH_YES
)
213 if (gfc_match_char (',') != MATCH_YES
)
215 gfc_error ("Invalid form of array reference at %C");
221 && !gfc_notify_std (GFC_STD_F2008
,
222 "Array reference at %C has more than 7 dimensions"))
225 gfc_error ("Array reference at %C cannot have more than %d dimensions",
230 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
238 if (flag_coarray
== GFC_FCOARRAY_NONE
)
240 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
246 gfc_error ("Unexpected coarray designator at %C");
252 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
254 m
= match_subscript (ar
, init
, true);
255 if (m
== MATCH_ERROR
)
258 team_just_seen
= false;
259 stat_just_seen
= false;
260 if (gfc_match (" , team = %e", &tmp
) == MATCH_YES
&& ar
->team
== NULL
)
263 team_just_seen
= true;
266 if (ar
->team
&& !team_just_seen
)
268 gfc_error ("TEAM= attribute in %C misplaced");
272 if (gfc_match (" , stat = %e",&tmp
) == MATCH_YES
&& ar
->stat
== NULL
)
275 stat_just_seen
= true;
278 if (ar
->stat
&& !stat_just_seen
)
280 gfc_error ("STAT= attribute in %C misplaced");
284 if (gfc_match_char (']') == MATCH_YES
)
287 if (ar
->codimen
< corank
)
289 gfc_error ("Too few codimensions at %C, expected %d not %d",
290 corank
, ar
->codimen
);
293 if (ar
->codimen
> corank
)
295 gfc_error ("Too many codimensions at %C, expected %d not %d",
296 corank
, ar
->codimen
);
302 if (gfc_match_char (',') != MATCH_YES
)
304 if (gfc_match_char ('*') == MATCH_YES
)
305 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
306 ar
->codimen
+ 1, corank
);
308 gfc_error ("Invalid form of coarray reference at %C");
311 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
313 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
314 ar
->codimen
+ 1, corank
);
318 if (ar
->codimen
>= corank
)
320 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
321 ar
->codimen
+ 1, corank
);
326 gfc_error ("Array reference at %C cannot have more than %d dimensions",
333 /************** Array specification matching subroutines ***************/
335 /* Free all of the expressions associated with array bounds
339 gfc_free_array_spec (gfc_array_spec
*as
)
348 for (i
= 0; i
< as
->rank
; i
++)
350 gfc_free_expr (as
->lower
[i
]);
351 gfc_free_expr (as
->upper
[i
]);
356 int n
= as
->rank
+ as
->corank
- (as
->cotype
== AS_EXPLICIT
? 1 : 0);
357 for (i
= 0; i
< n
; i
++)
359 gfc_free_expr (as
->lower
[i
]);
360 gfc_free_expr (as
->upper
[i
]);
368 /* Take an array bound, resolves the expression, that make up the
369 shape and check associated constraints. */
372 resolve_array_bound (gfc_expr
*e
, int check_constant
)
377 if (!gfc_resolve_expr (e
)
378 || !gfc_specification_expr (e
))
381 if (check_constant
&& !gfc_is_constant_expr (e
))
383 if (e
->expr_type
== EXPR_VARIABLE
)
384 gfc_error ("Variable %qs at %L in this context must be constant",
385 e
->symtree
->n
.sym
->name
, &e
->where
);
387 gfc_error ("Expression at %L in this context must be constant",
396 /* Takes an array specification, resolves the expressions that make up
397 the shape and make sure everything is integral. */
400 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
411 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
414 if (!resolve_array_bound (e
, check_constant
))
418 if (!resolve_array_bound (e
, check_constant
))
421 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
424 /* If the size is negative in this dimension, set it to zero. */
425 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
426 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
427 && mpz_cmp (as
->upper
[i
]->value
.integer
,
428 as
->lower
[i
]->value
.integer
) < 0)
430 gfc_free_expr (as
->upper
[i
]);
431 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
432 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
433 as
->upper
[i
]->value
.integer
, 1);
443 /* Match a single array element specification. The return values as
444 well as the upper and lower bounds of the array spec are filled
445 in according to what we see on the input. The caller makes sure
446 individual specifications make sense as a whole.
449 Parsed Lower Upper Returned
450 ------------------------------------
451 : NULL NULL AS_DEFERRED (*)
453 x: x NULL AS_ASSUMED_SHAPE
455 x:* x NULL AS_ASSUMED_SIZE
456 * 1 NULL AS_ASSUMED_SIZE
458 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
459 is fixed during the resolution of formal interfaces.
461 Anything else AS_UNKNOWN. */
464 match_array_element_spec (gfc_array_spec
*as
)
466 gfc_expr
**upper
, **lower
;
470 rank
= as
->rank
== -1 ? 0 : as
->rank
;
471 lower
= &as
->lower
[rank
+ as
->corank
- 1];
472 upper
= &as
->upper
[rank
+ as
->corank
- 1];
474 if (gfc_match_char ('*') == MATCH_YES
)
476 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
477 return AS_ASSUMED_SIZE
;
480 if (gfc_match_char (':') == MATCH_YES
)
483 m
= gfc_match_expr (upper
);
485 gfc_error ("Expected expression in array specification at %C");
488 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
491 if (((*upper
)->expr_type
== EXPR_CONSTANT
492 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
493 ((*upper
)->expr_type
== EXPR_FUNCTION
494 && (*upper
)->ts
.type
== BT_UNKNOWN
496 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
498 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
499 gfc_basic_typename ((*upper
)->ts
.type
));
503 if (gfc_match_char (':') == MATCH_NO
)
505 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
512 if (gfc_match_char ('*') == MATCH_YES
)
513 return AS_ASSUMED_SIZE
;
515 m
= gfc_match_expr (upper
);
516 if (m
== MATCH_ERROR
)
519 return AS_ASSUMED_SHAPE
;
520 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
523 if (((*upper
)->expr_type
== EXPR_CONSTANT
524 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
525 ((*upper
)->expr_type
== EXPR_FUNCTION
526 && (*upper
)->ts
.type
== BT_UNKNOWN
528 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
530 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
531 gfc_basic_typename ((*upper
)->ts
.type
));
539 /* Matches an array specification, incidentally figuring out what sort
540 it is. Match either a normal array specification, or a coarray spec
541 or both. Optionally allow [:] for coarrays. */
544 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
546 array_type current_type
;
550 as
= gfc_get_array_spec ();
555 if (gfc_match_char ('(') != MATCH_YES
)
562 if (gfc_match (" .. )") == MATCH_YES
)
564 as
->type
= AS_ASSUMED_RANK
;
567 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
578 current_type
= match_array_element_spec (as
);
580 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
581 and implied-shape specifications. If the rank is at least 2, we can
582 distinguish between them. But for rank 1, we currently return
583 ASSUMED_SIZE; this gets adjusted later when we know for sure
584 whether the symbol parsed is a PARAMETER or not. */
588 if (current_type
== AS_UNKNOWN
)
590 as
->type
= current_type
;
594 { /* See how current spec meshes with the existing. */
598 case AS_IMPLIED_SHAPE
:
599 if (current_type
!= AS_ASSUMED_SHAPE
)
601 gfc_error ("Bad array specification for implied-shape"
608 if (current_type
== AS_ASSUMED_SIZE
)
610 as
->type
= AS_ASSUMED_SIZE
;
614 if (current_type
== AS_EXPLICIT
)
617 gfc_error ("Bad array specification for an explicitly shaped "
622 case AS_ASSUMED_SHAPE
:
623 if ((current_type
== AS_ASSUMED_SHAPE
)
624 || (current_type
== AS_DEFERRED
))
627 gfc_error ("Bad array specification for assumed shape "
632 if (current_type
== AS_DEFERRED
)
635 if (current_type
== AS_ASSUMED_SHAPE
)
637 as
->type
= AS_ASSUMED_SHAPE
;
641 gfc_error ("Bad specification for deferred shape array at %C");
644 case AS_ASSUMED_SIZE
:
645 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
647 as
->type
= AS_IMPLIED_SHAPE
;
651 gfc_error ("Bad specification for assumed size array at %C");
654 case AS_ASSUMED_RANK
:
658 if (gfc_match_char (')') == MATCH_YES
)
661 if (gfc_match_char (',') != MATCH_YES
)
663 gfc_error ("Expected another dimension in array declaration at %C");
667 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
669 gfc_error ("Array specification at %C has more than %d dimensions",
674 if (as
->corank
+ as
->rank
>= 7
675 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
676 "with more than 7 dimensions"))
684 if (gfc_match_char ('[') != MATCH_YES
)
687 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
690 if (flag_coarray
== GFC_FCOARRAY_NONE
)
692 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
696 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
698 gfc_error ("Array specification at %C has more than %d "
699 "dimensions", GFC_MAX_DIMENSIONS
);
706 current_type
= match_array_element_spec (as
);
708 if (current_type
== AS_UNKNOWN
)
712 as
->cotype
= current_type
;
715 { /* See how current spec meshes with the existing. */
716 case AS_IMPLIED_SHAPE
:
721 if (current_type
== AS_ASSUMED_SIZE
)
723 as
->cotype
= AS_ASSUMED_SIZE
;
727 if (current_type
== AS_EXPLICIT
)
730 gfc_error ("Bad array specification for an explicitly "
731 "shaped array at %C");
735 case AS_ASSUMED_SHAPE
:
736 if ((current_type
== AS_ASSUMED_SHAPE
)
737 || (current_type
== AS_DEFERRED
))
740 gfc_error ("Bad array specification for assumed shape "
745 if (current_type
== AS_DEFERRED
)
748 if (current_type
== AS_ASSUMED_SHAPE
)
750 as
->cotype
= AS_ASSUMED_SHAPE
;
754 gfc_error ("Bad specification for deferred shape array at %C");
757 case AS_ASSUMED_SIZE
:
758 gfc_error ("Bad specification for assumed size array at %C");
761 case AS_ASSUMED_RANK
:
765 if (gfc_match_char (']') == MATCH_YES
)
768 if (gfc_match_char (',') != MATCH_YES
)
770 gfc_error ("Expected another dimension in array declaration at %C");
774 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
776 gfc_error ("Array specification at %C has more than %d "
777 "dimensions", GFC_MAX_DIMENSIONS
);
782 if (current_type
== AS_EXPLICIT
)
784 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
788 if (as
->cotype
== AS_ASSUMED_SIZE
)
789 as
->cotype
= AS_EXPLICIT
;
792 as
->type
= as
->cotype
;
795 if (as
->rank
== 0 && as
->corank
== 0)
798 gfc_free_array_spec (as
);
802 /* If a lower bounds of an assumed shape array is blank, put in one. */
803 if (as
->type
== AS_ASSUMED_SHAPE
)
805 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
807 if (as
->lower
[i
] == NULL
)
808 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
817 /* Something went wrong. */
818 gfc_free_array_spec (as
);
823 /* Given a symbol and an array specification, modify the symbol to
824 have that array specification. The error locus is needed in case
825 something goes wrong. On failure, the caller must free the spec. */
828 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
836 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
840 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
849 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
850 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
852 gfc_error ("The assumed-rank array %qs at %L shall not have a "
853 "codimension", sym
->name
, error_loc
);
859 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
860 the codimension is simply added. */
861 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
863 sym
->as
->cotype
= as
->cotype
;
864 sym
->as
->corank
= as
->corank
;
865 for (i
= 0; i
< as
->corank
; i
++)
867 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
868 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
873 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
874 the dimension is added - but first the codimensions (if existing
875 need to be shifted to make space for the dimension. */
876 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
878 sym
->as
->rank
= as
->rank
;
879 sym
->as
->type
= as
->type
;
880 sym
->as
->cray_pointee
= as
->cray_pointee
;
881 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
883 for (i
= 0; i
< sym
->as
->corank
; i
++)
885 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
886 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
888 for (i
= 0; i
< as
->rank
; i
++)
890 sym
->as
->lower
[i
] = as
->lower
[i
];
891 sym
->as
->upper
[i
] = as
->upper
[i
];
900 /* Copy an array specification. */
903 gfc_copy_array_spec (gfc_array_spec
*src
)
905 gfc_array_spec
*dest
;
911 dest
= gfc_get_array_spec ();
915 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
917 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
918 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
925 /* Returns nonzero if the two expressions are equal. Only handles integer
929 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
931 if (bound1
== NULL
|| bound2
== NULL
932 || bound1
->expr_type
!= EXPR_CONSTANT
933 || bound2
->expr_type
!= EXPR_CONSTANT
934 || bound1
->ts
.type
!= BT_INTEGER
935 || bound2
->ts
.type
!= BT_INTEGER
)
936 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
938 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
945 /* Compares two array specifications. They must be constant or deferred
949 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
953 if (as1
== NULL
&& as2
== NULL
)
956 if (as1
== NULL
|| as2
== NULL
)
959 if (as1
->rank
!= as2
->rank
)
962 if (as1
->corank
!= as2
->corank
)
968 if (as1
->type
!= as2
->type
)
971 if (as1
->type
== AS_EXPLICIT
)
972 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
974 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
977 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
985 /****************** Array constructor functions ******************/
988 /* Given an expression node that might be an array constructor and a
989 symbol, make sure that no iterators in this or child constructors
990 use the symbol as an implied-DO iterator. Returns nonzero if a
991 duplicate was found. */
994 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
999 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1003 if (e
->expr_type
== EXPR_ARRAY
1004 && check_duplicate_iterator (e
->value
.constructor
, master
))
1007 if (c
->iterator
== NULL
)
1010 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1012 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1013 "same name", master
->name
, &c
->where
);
1023 /* Forward declaration because these functions are mutually recursive. */
1024 static match
match_array_cons_element (gfc_constructor_base
*);
1026 /* Match a list of array elements. */
1029 match_array_list (gfc_constructor_base
*result
)
1031 gfc_constructor_base head
;
1039 old_loc
= gfc_current_locus
;
1041 if (gfc_match_char ('(') == MATCH_NO
)
1044 memset (&iter
, '\0', sizeof (gfc_iterator
));
1047 m
= match_array_cons_element (&head
);
1051 if (gfc_match_char (',') != MATCH_YES
)
1059 m
= gfc_match_iterator (&iter
, 0);
1062 if (m
== MATCH_ERROR
)
1065 m
= match_array_cons_element (&head
);
1066 if (m
== MATCH_ERROR
)
1073 goto cleanup
; /* Could be a complex constant */
1076 if (gfc_match_char (',') != MATCH_YES
)
1085 if (gfc_match_char (')') != MATCH_YES
)
1088 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1094 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1095 e
->value
.constructor
= head
;
1097 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1098 p
->iterator
= gfc_get_iterator ();
1099 *p
->iterator
= iter
;
1104 gfc_error ("Syntax error in array constructor at %C");
1108 gfc_constructor_free (head
);
1109 gfc_free_iterator (&iter
, 0);
1110 gfc_current_locus
= old_loc
;
1115 /* Match a single element of an array constructor, which can be a
1116 single expression or a list of elements. */
1119 match_array_cons_element (gfc_constructor_base
*result
)
1124 m
= match_array_list (result
);
1128 m
= gfc_match_expr (&expr
);
1132 if (expr
->ts
.type
== BT_BOZ
)
1134 gfc_error ("BOZ literal constant at %L cannot appear in an "
1135 "array constructor", &expr
->where
);
1139 if (expr
->expr_type
== EXPR_FUNCTION
1140 && expr
->ts
.type
== BT_UNKNOWN
1141 && strcmp(expr
->symtree
->name
, "null") == 0)
1143 gfc_error ("NULL() at %C cannot appear in an array constructor");
1147 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1151 gfc_free_expr (expr
);
1156 /* Convert components of an array constructor to the type in ts. */
1159 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1165 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1168 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1169 && !e
->ref
&& e
->value
.constructor
)
1171 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1172 if (m
== MATCH_ERROR
)
1175 else if (!gfc_convert_type (e
, ts
, 1) && e
->ts
.type
!= BT_UNKNOWN
)
1181 /* Match an array constructor. */
1184 gfc_match_array_constructor (gfc_expr
**result
)
1187 gfc_constructor_base head
;
1192 const char *end_delim
;
1198 if (gfc_match (" (/") == MATCH_NO
)
1200 if (gfc_match (" [") == MATCH_NO
)
1204 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1205 "style array constructors at %C"))
1213 where
= gfc_current_locus
;
1215 /* Try to match an optional "type-spec ::" */
1217 m
= gfc_match_type_spec (&ts
);
1220 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1224 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1225 "including type specification at %C"))
1230 gfc_error ("Type-spec at %L cannot contain a deferred "
1231 "type parameter", &where
);
1235 if (ts
.type
== BT_CHARACTER
1236 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1238 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1239 "type parameter", &where
);
1244 else if (m
== MATCH_ERROR
)
1248 gfc_current_locus
= where
;
1250 if (gfc_match (end_delim
) == MATCH_YES
)
1256 gfc_error ("Empty array constructor at %C is not allowed");
1263 m
= match_array_cons_element (&head
);
1264 if (m
== MATCH_ERROR
)
1269 if (gfc_match_char (',') == MATCH_NO
)
1273 if (gfc_match (end_delim
) == MATCH_NO
)
1277 /* Size must be calculated at resolution time. */
1280 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1283 /* If the typespec is CHARACTER, check that array elements can
1284 be converted. See PR fortran/67803. */
1285 if (ts
.type
== BT_CHARACTER
)
1287 c
= gfc_constructor_first (head
);
1288 for (; c
; c
= gfc_constructor_next (c
))
1290 if (gfc_numeric_ts (&c
->expr
->ts
)
1291 || c
->expr
->ts
.type
== BT_LOGICAL
)
1293 gfc_error ("Incompatible typespec for array element at %L",
1298 /* Special case null(). */
1299 if (c
->expr
->expr_type
== EXPR_FUNCTION
1300 && c
->expr
->ts
.type
== BT_UNKNOWN
1301 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1303 gfc_error ("Incompatible typespec for array element at %L",
1310 /* Walk the constructor, and if possible, do type conversion for
1312 if (gfc_numeric_ts (&ts
))
1314 m
= walk_array_constructor (&ts
, head
);
1315 if (m
== MATCH_ERROR
)
1320 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1322 expr
->value
.constructor
= head
;
1324 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1331 gfc_error ("Syntax error in array constructor at %C");
1334 gfc_constructor_free (head
);
1340 /************** Check array constructors for correctness **************/
1342 /* Given an expression, compare it's type with the type of the current
1343 constructor. Returns nonzero if an error was issued. The
1344 cons_state variable keeps track of whether the type of the
1345 constructor being read or resolved is known to be good, bad or just
1348 static gfc_typespec constructor_ts
;
1350 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1354 check_element_type (gfc_expr
*expr
, bool convert
)
1356 if (cons_state
== CONS_BAD
)
1357 return 0; /* Suppress further errors */
1359 if (cons_state
== CONS_START
)
1361 if (expr
->ts
.type
== BT_UNKNOWN
)
1362 cons_state
= CONS_BAD
;
1365 cons_state
= CONS_GOOD
;
1366 constructor_ts
= expr
->ts
;
1372 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1376 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1378 gfc_error ("Element in %s array constructor at %L is %s",
1379 gfc_typename (&constructor_ts
), &expr
->where
,
1380 gfc_typename (expr
));
1382 cons_state
= CONS_BAD
;
1387 /* Recursive work function for gfc_check_constructor_type(). */
1390 check_constructor_type (gfc_constructor_base base
, bool convert
)
1395 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1399 if (e
->expr_type
== EXPR_ARRAY
)
1401 if (!check_constructor_type (e
->value
.constructor
, convert
))
1407 if (check_element_type (e
, convert
))
1415 /* Check that all elements of an array constructor are the same type.
1416 On false, an error has been generated. */
1419 gfc_check_constructor_type (gfc_expr
*e
)
1423 if (e
->ts
.type
!= BT_UNKNOWN
)
1425 cons_state
= CONS_GOOD
;
1426 constructor_ts
= e
->ts
;
1430 cons_state
= CONS_START
;
1431 gfc_clear_ts (&constructor_ts
);
1434 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1435 typespec, and we will now convert the values on the fly. */
1436 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1437 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1438 e
->ts
= constructor_ts
;
1445 typedef struct cons_stack
1447 gfc_iterator
*iterator
;
1448 struct cons_stack
*previous
;
1452 static cons_stack
*base
;
1454 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1456 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1457 that that variable is an iteration variables. */
1460 gfc_check_iter_variable (gfc_expr
*expr
)
1465 sym
= expr
->symtree
->n
.sym
;
1467 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1468 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1475 /* Recursive work function for gfc_check_constructor(). This amounts
1476 to calling the check function for each expression in the
1477 constructor, giving variables with the names of iterators a pass. */
1480 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1487 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1494 if (e
->expr_type
!= EXPR_ARRAY
)
1496 if (!(*check_function
)(e
))
1501 element
.previous
= base
;
1502 element
.iterator
= c
->iterator
;
1505 t
= check_constructor (e
->value
.constructor
, check_function
);
1506 base
= element
.previous
;
1512 /* Nothing went wrong, so all OK. */
1517 /* Checks a constructor to see if it is a particular kind of
1518 expression -- specification, restricted, or initialization as
1519 determined by the check_function. */
1522 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1524 cons_stack
*base_save
;
1530 t
= check_constructor (expr
->value
.constructor
, check_function
);
1538 /**************** Simplification of array constructors ****************/
1540 iterator_stack
*iter_stack
;
1544 gfc_constructor_base base
;
1545 int extract_count
, extract_n
;
1546 gfc_expr
*extracted
;
1550 gfc_component
*component
;
1553 bool (*expand_work_function
) (gfc_expr
*);
1557 static expand_info current_expand
;
1559 static bool expand_constructor (gfc_constructor_base
);
1562 /* Work function that counts the number of elements present in a
1566 count_elements (gfc_expr
*e
)
1571 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1574 if (!gfc_array_size (e
, &result
))
1580 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1589 /* Work function that extracts a particular element from an array
1590 constructor, freeing the rest. */
1593 extract_element (gfc_expr
*e
)
1596 { /* Something unextractable */
1601 if (current_expand
.extract_count
== current_expand
.extract_n
)
1602 current_expand
.extracted
= e
;
1606 current_expand
.extract_count
++;
1612 /* Work function that constructs a new constructor out of the old one,
1613 stringing new elements together. */
1616 expand (gfc_expr
*e
)
1618 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1621 c
->n
.component
= current_expand
.component
;
1626 /* Given an initialization expression that is a variable reference,
1627 substitute the current value of the iteration variable. */
1630 gfc_simplify_iterator_var (gfc_expr
*e
)
1634 for (p
= iter_stack
; p
; p
= p
->prev
)
1635 if (e
->symtree
== p
->variable
)
1639 return; /* Variable not found */
1641 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1643 mpz_set (e
->value
.integer
, p
->value
);
1649 /* Expand an expression with that is inside of a constructor,
1650 recursing into other constructors if present. */
1653 expand_expr (gfc_expr
*e
)
1655 if (e
->expr_type
== EXPR_ARRAY
)
1656 return expand_constructor (e
->value
.constructor
);
1658 e
= gfc_copy_expr (e
);
1660 if (!gfc_simplify_expr (e
, 1))
1666 return current_expand
.expand_work_function (e
);
1671 expand_iterator (gfc_constructor
*c
)
1673 gfc_expr
*start
, *end
, *step
;
1674 iterator_stack frame
;
1683 mpz_init (frame
.value
);
1686 start
= gfc_copy_expr (c
->iterator
->start
);
1687 if (!gfc_simplify_expr (start
, 1))
1690 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1693 end
= gfc_copy_expr (c
->iterator
->end
);
1694 if (!gfc_simplify_expr (end
, 1))
1697 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1700 step
= gfc_copy_expr (c
->iterator
->step
);
1701 if (!gfc_simplify_expr (step
, 1))
1704 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1707 if (mpz_sgn (step
->value
.integer
) == 0)
1709 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1713 /* Calculate the trip count of the loop. */
1714 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1715 mpz_add (trip
, trip
, step
->value
.integer
);
1716 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1718 mpz_set (frame
.value
, start
->value
.integer
);
1720 frame
.prev
= iter_stack
;
1721 frame
.variable
= c
->iterator
->var
->symtree
;
1722 iter_stack
= &frame
;
1724 while (mpz_sgn (trip
) > 0)
1726 if (!expand_expr (c
->expr
))
1729 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1730 mpz_sub_ui (trip
, trip
, 1);
1736 gfc_free_expr (start
);
1737 gfc_free_expr (end
);
1738 gfc_free_expr (step
);
1741 mpz_clear (frame
.value
);
1743 iter_stack
= frame
.prev
;
1749 /* Expand a constructor into constant constructors without any
1750 iterators, calling the work function for each of the expanded
1751 expressions. The work function needs to either save or free the
1752 passed expression. */
1755 expand_constructor (gfc_constructor_base base
)
1760 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1762 if (c
->iterator
!= NULL
)
1764 if (!expand_iterator (c
))
1771 if (e
->expr_type
== EXPR_ARRAY
)
1773 if (!expand_constructor (e
->value
.constructor
))
1779 e
= gfc_copy_expr (e
);
1780 if (!gfc_simplify_expr (e
, 1))
1785 e
->from_constructor
= 1;
1786 current_expand
.offset
= &c
->offset
;
1787 current_expand
.repeat
= &c
->repeat
;
1788 current_expand
.component
= c
->n
.component
;
1789 if (!current_expand
.expand_work_function(e
))
1796 /* Given an array expression and an element number (starting at zero),
1797 return a pointer to the array element. NULL is returned if the
1798 size of the array has been exceeded. The expression node returned
1799 remains a part of the array and should not be freed. Access is not
1800 efficient at all, but this is another place where things do not
1801 have to be particularly fast. */
1804 gfc_get_array_element (gfc_expr
*array
, int element
)
1806 expand_info expand_save
;
1810 expand_save
= current_expand
;
1811 current_expand
.extract_n
= element
;
1812 current_expand
.expand_work_function
= extract_element
;
1813 current_expand
.extracted
= NULL
;
1814 current_expand
.extract_count
= 0;
1818 rc
= expand_constructor (array
->value
.constructor
);
1819 e
= current_expand
.extracted
;
1820 current_expand
= expand_save
;
1829 /* Top level subroutine for expanding constructors. We only expand
1830 constructor if they are small enough. */
1833 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1835 expand_info expand_save
;
1839 /* If we can successfully get an array element at the max array size then
1840 the array is too big to expand, so we just return. */
1841 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1847 gfc_error ("The number of elements in the array constructor "
1848 "at %L requires an increase of the allowed %d "
1849 "upper limit. See %<-fmax-array-constructor%> "
1850 "option", &e
->where
, flag_max_array_constructor
);
1856 /* We now know the array is not too big so go ahead and try to expand it. */
1857 expand_save
= current_expand
;
1858 current_expand
.base
= NULL
;
1862 current_expand
.expand_work_function
= expand
;
1864 if (!expand_constructor (e
->value
.constructor
))
1866 gfc_constructor_free (current_expand
.base
);
1871 gfc_constructor_free (e
->value
.constructor
);
1872 e
->value
.constructor
= current_expand
.base
;
1877 current_expand
= expand_save
;
1883 /* Work function for checking that an element of a constructor is a
1884 constant, after removal of any iteration variables. We return
1888 is_constant_element (gfc_expr
*e
)
1892 rv
= gfc_is_constant_expr (e
);
1895 return rv
? true : false;
1899 /* Given an array constructor, determine if the constructor is
1900 constant or not by expanding it and making sure that all elements
1901 are constants. This is a bit of a hack since something like (/ (i,
1902 i=1,100000000) /) will take a while as* opposed to a more clever
1903 function that traverses the expression tree. FIXME. */
1906 gfc_constant_ac (gfc_expr
*e
)
1908 expand_info expand_save
;
1912 expand_save
= current_expand
;
1913 current_expand
.expand_work_function
= is_constant_element
;
1915 rc
= expand_constructor (e
->value
.constructor
);
1917 current_expand
= expand_save
;
1925 /* Returns nonzero if an array constructor has been completely
1926 expanded (no iterators) and zero if iterators are present. */
1929 gfc_expanded_ac (gfc_expr
*e
)
1933 if (e
->expr_type
== EXPR_ARRAY
)
1934 for (c
= gfc_constructor_first (e
->value
.constructor
);
1935 c
; c
= gfc_constructor_next (c
))
1936 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1943 /*************** Type resolution of array constructors ***************/
1946 /* The symbol expr_is_sought_symbol_ref will try to find. */
1947 static const gfc_symbol
*sought_symbol
= NULL
;
1950 /* Tells whether the expression E is a variable reference to the symbol
1951 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1953 To be used with gfc_expr_walker: if a reference is found we don't need
1954 to look further so we return 1 to skip any further walk. */
1957 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1960 gfc_expr
*expr
= *e
;
1961 locus
*sym_loc
= (locus
*)where
;
1963 if (expr
->expr_type
== EXPR_VARIABLE
1964 && expr
->symtree
->n
.sym
== sought_symbol
)
1966 *sym_loc
= expr
->where
;
1974 /* Tells whether the expression EXPR contains a reference to the symbol
1975 SYM and in that case sets the position SYM_LOC where the reference is. */
1978 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1982 sought_symbol
= sym
;
1983 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1984 sought_symbol
= NULL
;
1989 /* Recursive array list resolution function. All of the elements must
1990 be of the same type. */
1993 resolve_array_list (gfc_constructor_base base
)
2001 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2006 gfc_symbol
*iter_var
;
2009 if (!gfc_resolve_iterator (iter
, false, true))
2012 /* Check for bounds referencing the iterator variable. */
2013 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2014 iter_var
= iter
->var
->symtree
->n
.sym
;
2015 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2017 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2018 "expression references control variable "
2019 "at %L", &iter_var_loc
))
2022 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2024 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2025 "expression references control variable "
2026 "at %L", &iter_var_loc
))
2029 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2031 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2032 "expression references control variable "
2033 "at %L", &iter_var_loc
))
2038 if (!gfc_resolve_expr (c
->expr
))
2041 if (UNLIMITED_POLY (c
->expr
))
2043 gfc_error ("Array constructor value at %L shall not be unlimited "
2044 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2052 /* Resolve character array constructor. If it has a specified constant character
2053 length, pad/truncate the elements here; if the length is not specified and
2054 all elements are of compile-time known length, emit an error as this is
2058 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2061 HOST_WIDE_INT found_length
;
2063 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2064 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2066 if (expr
->ts
.u
.cl
== NULL
)
2068 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2069 p
; p
= gfc_constructor_next (p
))
2070 if (p
->expr
->ts
.u
.cl
!= NULL
)
2072 /* Ensure that if there is a char_len around that it is
2073 used; otherwise the middle-end confuses them! */
2074 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2078 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2083 /* Early exit for zero size arrays. */
2087 HOST_WIDE_INT arraysize
;
2089 gfc_array_size (expr
, &size
);
2090 arraysize
= mpz_get_ui (size
);
2099 if (expr
->ts
.u
.cl
->length
== NULL
)
2101 /* Check that all constant string elements have the same length until
2102 we reach the end or find a variable-length one. */
2104 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2105 p
; p
= gfc_constructor_next (p
))
2107 HOST_WIDE_INT current_length
= -1;
2109 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2110 if (ref
->type
== REF_SUBSTRING
2112 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2114 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2117 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2118 current_length
= p
->expr
->value
.character
.length
;
2120 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2121 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2122 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2123 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2124 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2128 if (current_length
< 0)
2131 if (found_length
== -1)
2132 found_length
= current_length
;
2133 else if (found_length
!= current_length
)
2135 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2136 " constructor at %L", (long) found_length
,
2137 (long) current_length
, &p
->expr
->where
);
2141 gcc_assert (found_length
== current_length
);
2144 gcc_assert (found_length
!= -1);
2146 /* Update the character length of the array constructor. */
2147 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2148 NULL
, found_length
);
2152 /* We've got a character length specified. It should be an integer,
2153 otherwise an error is signalled elsewhere. */
2154 gcc_assert (expr
->ts
.u
.cl
->length
);
2156 /* If we've got a constant character length, pad according to this.
2157 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2158 max_length only if they pass. */
2159 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2161 /* Now pad/truncate the elements accordingly to the specified character
2162 length. This is ok inside this conditional, as in the case above
2163 (without typespec) all elements are verified to have the same length
2165 if (found_length
!= -1)
2166 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2167 p
; p
= gfc_constructor_next (p
))
2168 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2170 gfc_expr
*cl
= NULL
;
2171 HOST_WIDE_INT current_length
= -1;
2174 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2176 cl
= p
->expr
->ts
.u
.cl
->length
;
2177 gfc_extract_hwi (cl
, ¤t_length
);
2180 /* If gfc_extract_int above set current_length, we implicitly
2181 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2183 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2186 || (current_length
!= -1 && current_length
!= found_length
))
2187 gfc_set_constant_character_len (found_length
, p
->expr
,
2188 has_ts
? -1 : found_length
);
2196 /* Resolve all of the expressions in an array list. */
2199 gfc_resolve_array_constructor (gfc_expr
*expr
)
2203 t
= resolve_array_list (expr
->value
.constructor
);
2205 t
= gfc_check_constructor_type (expr
);
2207 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2208 the call to this function, so we don't need to call it here; if it was
2209 called twice, an error message there would be duplicated. */
2215 /* Copy an iterator structure. */
2218 gfc_copy_iterator (gfc_iterator
*src
)
2225 dest
= gfc_get_iterator ();
2227 dest
->var
= gfc_copy_expr (src
->var
);
2228 dest
->start
= gfc_copy_expr (src
->start
);
2229 dest
->end
= gfc_copy_expr (src
->end
);
2230 dest
->step
= gfc_copy_expr (src
->step
);
2231 dest
->unroll
= src
->unroll
;
2232 dest
->ivdep
= src
->ivdep
;
2233 dest
->vector
= src
->vector
;
2234 dest
->novector
= src
->novector
;
2240 /********* Subroutines for determining the size of an array *********/
2242 /* These are needed just to accommodate RESHAPE(). There are no
2243 diagnostics here, we just return a negative number if something
2247 /* Get the size of single dimension of an array specification. The
2248 array is guaranteed to be one dimensional. */
2251 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2256 if (dimen
< 0 || dimen
> as
->rank
- 1)
2257 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2259 if (as
->type
!= AS_EXPLICIT
2260 || !as
->lower
[dimen
]
2261 || !as
->upper
[dimen
])
2264 if (as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2265 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2266 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2267 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2272 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2273 as
->lower
[dimen
]->value
.integer
);
2275 mpz_add_ui (*result
, *result
, 1);
2282 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2287 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2290 mpz_init_set_ui (*result
, 1);
2292 for (d
= 0; d
< as
->rank
; d
++)
2294 if (!spec_dimen_size (as
, d
, &size
))
2296 mpz_clear (*result
);
2300 mpz_mul (*result
, *result
, size
);
2308 /* Get the number of elements in an array section. Optionally, also supply
2312 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2314 mpz_t upper
, lower
, stride
;
2317 gfc_expr
*stride_expr
= NULL
;
2319 if (dimen
< 0 || ar
== NULL
)
2320 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2322 if (dimen
> ar
->dimen
- 1)
2324 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2328 switch (ar
->dimen_type
[dimen
])
2332 mpz_set_ui (*result
, 1);
2337 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2344 if (ar
->stride
[dimen
] == NULL
)
2345 mpz_set_ui (stride
, 1);
2348 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2350 if(!gfc_simplify_expr(stride_expr
, 1))
2351 gfc_internal_error("Simplification error");
2353 if (stride_expr
->expr_type
!= EXPR_CONSTANT
2354 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2359 mpz_set (stride
, stride_expr
->value
.integer
);
2360 gfc_free_expr(stride_expr
);
2363 /* Calculate the number of elements via gfc_dep_differce, but only if
2364 start and end are both supplied in the reference or the array spec.
2365 This is to guard against strange but valid code like
2370 print *,size(a(n-1:))
2372 where the user changes the value of a variable. If we have to
2373 determine end as well, we cannot do this using gfc_dep_difference.
2374 Fall back to the constants-only code then. */
2380 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2382 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2383 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2384 ar
->as
->lower
[dimen
], &diff
);
2389 mpz_add (*result
, diff
, stride
);
2390 mpz_div (*result
, *result
, stride
);
2391 if (mpz_cmp_ui (*result
, 0) < 0)
2392 mpz_set_ui (*result
, 0);
2401 /* Constant-only code here, which covers more cases
2407 if (ar
->start
[dimen
] == NULL
)
2409 if (ar
->as
->lower
[dimen
] == NULL
2410 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2411 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2413 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2417 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2419 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2422 if (ar
->end
[dimen
] == NULL
)
2424 if (ar
->as
->upper
[dimen
] == NULL
2425 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2426 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2428 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2432 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2434 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2438 mpz_sub (*result
, upper
, lower
);
2439 mpz_add (*result
, *result
, stride
);
2440 mpz_div (*result
, *result
, stride
);
2442 /* Zero stride caught earlier. */
2443 if (mpz_cmp_ui (*result
, 0) < 0)
2444 mpz_set_ui (*result
, 0);
2451 mpz_sub_ui (*end
, *result
, 1UL);
2452 mpz_mul (*end
, *end
, stride
);
2453 mpz_add (*end
, *end
, lower
);
2463 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2471 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2476 mpz_init_set_ui (*result
, 1);
2478 for (d
= 0; d
< ar
->dimen
; d
++)
2480 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2482 mpz_clear (*result
);
2486 mpz_mul (*result
, *result
, size
);
2494 /* Given an array expression and a dimension, figure out how many
2495 elements it has along that dimension. Returns true if we were
2496 able to return a result in the 'result' variable, false
2500 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2505 gcc_assert (array
!= NULL
);
2507 if (array
->ts
.type
== BT_CLASS
)
2510 if (array
->rank
== -1)
2513 if (dimen
< 0 || dimen
> array
->rank
- 1)
2514 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2516 switch (array
->expr_type
)
2520 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2522 if (ref
->type
!= REF_ARRAY
)
2525 if (ref
->u
.ar
.type
== AR_FULL
)
2526 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2528 if (ref
->u
.ar
.type
== AR_SECTION
)
2530 for (i
= 0; dimen
>= 0; i
++)
2531 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2534 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2538 if (array
->shape
&& array
->shape
[dimen
])
2540 mpz_init_set (*result
, array
->shape
[dimen
]);
2544 if (array
->symtree
->n
.sym
->attr
.generic
2545 && array
->value
.function
.esym
!= NULL
)
2547 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2550 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2556 if (array
->shape
== NULL
) {
2557 /* Expressions with rank > 1 should have "shape" properly set */
2558 if ( array
->rank
!= 1 )
2559 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2560 return gfc_array_size(array
, result
);
2565 if (array
->shape
== NULL
)
2568 mpz_init_set (*result
, array
->shape
[dimen
]);
2577 /* Given an array expression, figure out how many elements are in the
2578 array. Returns true if this is possible, and sets the 'result'
2579 variable. Otherwise returns false. */
2582 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2584 expand_info expand_save
;
2589 if (array
->ts
.type
== BT_CLASS
)
2592 switch (array
->expr_type
)
2595 gfc_push_suppress_errors ();
2597 expand_save
= current_expand
;
2599 current_expand
.count
= result
;
2600 mpz_init_set_ui (*result
, 0);
2602 current_expand
.expand_work_function
= count_elements
;
2605 t
= expand_constructor (array
->value
.constructor
);
2607 gfc_pop_suppress_errors ();
2610 mpz_clear (*result
);
2611 current_expand
= expand_save
;
2615 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2617 if (ref
->type
!= REF_ARRAY
)
2620 if (ref
->u
.ar
.type
== AR_FULL
)
2621 return spec_size (ref
->u
.ar
.as
, result
);
2623 if (ref
->u
.ar
.type
== AR_SECTION
)
2624 return ref_size (&ref
->u
.ar
, result
);
2627 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2631 if (array
->rank
== 0 || array
->shape
== NULL
)
2634 mpz_init_set_ui (*result
, 1);
2636 for (i
= 0; i
< array
->rank
; i
++)
2637 mpz_mul (*result
, *result
, array
->shape
[i
]);
2646 /* Given an array reference, return the shape of the reference in an
2647 array of mpz_t integers. */
2650 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2660 for (; d
< ar
->as
->rank
; d
++)
2661 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2667 for (i
= 0; i
< ar
->dimen
; i
++)
2669 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2671 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2684 gfc_clear_shape (shape
, d
);
2689 /* Given an array expression, find the array reference structure that
2690 characterizes the reference. */
2693 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2697 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2698 if (ref
->type
== REF_ARRAY
2699 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2707 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2714 /* Find out if an array shape is known at compile time. */
2717 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2719 if (as
->type
!= AS_EXPLICIT
)
2722 for (int i
= 0; i
< as
->rank
; i
++)
2723 if (!gfc_is_constant_expr (as
->lower
[i
])
2724 || !gfc_is_constant_expr (as
->upper
[i
]))