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
++)
413 if (i
== GFC_MAX_DIMENSIONS
)
417 if (!resolve_array_bound (e
, check_constant
))
421 if (!resolve_array_bound (e
, check_constant
))
424 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
427 /* If the size is negative in this dimension, set it to zero. */
428 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
429 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
430 && mpz_cmp (as
->upper
[i
]->value
.integer
,
431 as
->lower
[i
]->value
.integer
) < 0)
433 gfc_free_expr (as
->upper
[i
]);
434 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
435 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
436 as
->upper
[i
]->value
.integer
, 1);
446 /* Match a single array element specification. The return values as
447 well as the upper and lower bounds of the array spec are filled
448 in according to what we see on the input. The caller makes sure
449 individual specifications make sense as a whole.
452 Parsed Lower Upper Returned
453 ------------------------------------
454 : NULL NULL AS_DEFERRED (*)
456 x: x NULL AS_ASSUMED_SHAPE
458 x:* x NULL AS_ASSUMED_SIZE
459 * 1 NULL AS_ASSUMED_SIZE
461 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
462 is fixed during the resolution of formal interfaces.
464 Anything else AS_UNKNOWN. */
467 match_array_element_spec (gfc_array_spec
*as
)
469 gfc_expr
**upper
, **lower
;
473 rank
= as
->rank
== -1 ? 0 : as
->rank
;
474 lower
= &as
->lower
[rank
+ as
->corank
- 1];
475 upper
= &as
->upper
[rank
+ as
->corank
- 1];
477 if (gfc_match_char ('*') == MATCH_YES
)
479 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
480 return AS_ASSUMED_SIZE
;
483 if (gfc_match_char (':') == MATCH_YES
)
486 m
= gfc_match_expr (upper
);
488 gfc_error ("Expected expression in array specification at %C");
491 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
494 if (((*upper
)->expr_type
== EXPR_CONSTANT
495 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
496 ((*upper
)->expr_type
== EXPR_FUNCTION
497 && (*upper
)->ts
.type
== BT_UNKNOWN
499 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
501 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
502 gfc_basic_typename ((*upper
)->ts
.type
));
506 if (gfc_match_char (':') == MATCH_NO
)
508 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
515 if (gfc_match_char ('*') == MATCH_YES
)
516 return AS_ASSUMED_SIZE
;
518 m
= gfc_match_expr (upper
);
519 if (m
== MATCH_ERROR
)
522 return AS_ASSUMED_SHAPE
;
523 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
526 if (((*upper
)->expr_type
== EXPR_CONSTANT
527 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
528 ((*upper
)->expr_type
== EXPR_FUNCTION
529 && (*upper
)->ts
.type
== BT_UNKNOWN
531 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
533 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
534 gfc_basic_typename ((*upper
)->ts
.type
));
542 /* Matches an array specification, incidentally figuring out what sort
543 it is. Match either a normal array specification, or a coarray spec
544 or both. Optionally allow [:] for coarrays. */
547 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
549 array_type current_type
;
553 as
= gfc_get_array_spec ();
558 if (gfc_match_char ('(') != MATCH_YES
)
565 if (gfc_match (" .. )") == MATCH_YES
)
567 as
->type
= AS_ASSUMED_RANK
;
570 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
581 current_type
= match_array_element_spec (as
);
583 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
584 and implied-shape specifications. If the rank is at least 2, we can
585 distinguish between them. But for rank 1, we currently return
586 ASSUMED_SIZE; this gets adjusted later when we know for sure
587 whether the symbol parsed is a PARAMETER or not. */
591 if (current_type
== AS_UNKNOWN
)
593 as
->type
= current_type
;
597 { /* See how current spec meshes with the existing. */
601 case AS_IMPLIED_SHAPE
:
602 if (current_type
!= AS_ASSUMED_SHAPE
)
604 gfc_error ("Bad array specification for implied-shape"
611 if (current_type
== AS_ASSUMED_SIZE
)
613 as
->type
= AS_ASSUMED_SIZE
;
617 if (current_type
== AS_EXPLICIT
)
620 gfc_error ("Bad array specification for an explicitly shaped "
625 case AS_ASSUMED_SHAPE
:
626 if ((current_type
== AS_ASSUMED_SHAPE
)
627 || (current_type
== AS_DEFERRED
))
630 gfc_error ("Bad array specification for assumed shape "
635 if (current_type
== AS_DEFERRED
)
638 if (current_type
== AS_ASSUMED_SHAPE
)
640 as
->type
= AS_ASSUMED_SHAPE
;
644 gfc_error ("Bad specification for deferred shape array at %C");
647 case AS_ASSUMED_SIZE
:
648 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
650 as
->type
= AS_IMPLIED_SHAPE
;
654 gfc_error ("Bad specification for assumed size array at %C");
657 case AS_ASSUMED_RANK
:
661 if (gfc_match_char (')') == MATCH_YES
)
664 if (gfc_match_char (',') != MATCH_YES
)
666 gfc_error ("Expected another dimension in array declaration at %C");
670 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
672 gfc_error ("Array specification at %C has more than %d dimensions",
677 if (as
->corank
+ as
->rank
>= 7
678 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
679 "with more than 7 dimensions"))
687 if (gfc_match_char ('[') != MATCH_YES
)
690 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
693 if (flag_coarray
== GFC_FCOARRAY_NONE
)
695 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
699 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
701 gfc_error ("Array specification at %C has more than %d "
702 "dimensions", GFC_MAX_DIMENSIONS
);
709 current_type
= match_array_element_spec (as
);
711 if (current_type
== AS_UNKNOWN
)
715 as
->cotype
= current_type
;
718 { /* See how current spec meshes with the existing. */
719 case AS_IMPLIED_SHAPE
:
724 if (current_type
== AS_ASSUMED_SIZE
)
726 as
->cotype
= AS_ASSUMED_SIZE
;
730 if (current_type
== AS_EXPLICIT
)
733 gfc_error ("Bad array specification for an explicitly "
734 "shaped array at %C");
738 case AS_ASSUMED_SHAPE
:
739 if ((current_type
== AS_ASSUMED_SHAPE
)
740 || (current_type
== AS_DEFERRED
))
743 gfc_error ("Bad array specification for assumed shape "
748 if (current_type
== AS_DEFERRED
)
751 if (current_type
== AS_ASSUMED_SHAPE
)
753 as
->cotype
= AS_ASSUMED_SHAPE
;
757 gfc_error ("Bad specification for deferred shape array at %C");
760 case AS_ASSUMED_SIZE
:
761 gfc_error ("Bad specification for assumed size array at %C");
764 case AS_ASSUMED_RANK
:
768 if (gfc_match_char (']') == MATCH_YES
)
771 if (gfc_match_char (',') != MATCH_YES
)
773 gfc_error ("Expected another dimension in array declaration at %C");
777 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
779 gfc_error ("Array specification at %C has more than %d "
780 "dimensions", GFC_MAX_DIMENSIONS
);
785 if (current_type
== AS_EXPLICIT
)
787 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
791 if (as
->cotype
== AS_ASSUMED_SIZE
)
792 as
->cotype
= AS_EXPLICIT
;
795 as
->type
= as
->cotype
;
798 if (as
->rank
== 0 && as
->corank
== 0)
801 gfc_free_array_spec (as
);
805 /* If a lower bounds of an assumed shape array is blank, put in one. */
806 if (as
->type
== AS_ASSUMED_SHAPE
)
808 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
810 if (as
->lower
[i
] == NULL
)
811 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
820 /* Something went wrong. */
821 gfc_free_array_spec (as
);
826 /* Given a symbol and an array specification, modify the symbol to
827 have that array specification. The error locus is needed in case
828 something goes wrong. On failure, the caller must free the spec. */
831 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
839 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
843 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
852 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
853 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
855 gfc_error ("The assumed-rank array %qs at %L shall not have a "
856 "codimension", sym
->name
, error_loc
);
862 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
863 the codimension is simply added. */
864 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
866 sym
->as
->cotype
= as
->cotype
;
867 sym
->as
->corank
= as
->corank
;
868 /* Check F2018:C822. */
869 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
872 for (i
= 0; i
< as
->corank
; i
++)
874 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
875 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
880 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
881 the dimension is added - but first the codimensions (if existing
882 need to be shifted to make space for the dimension. */
883 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
885 sym
->as
->rank
= as
->rank
;
886 sym
->as
->type
= as
->type
;
887 sym
->as
->cray_pointee
= as
->cray_pointee
;
888 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
890 /* Check F2018:C822. */
891 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
894 for (i
= 0; i
< sym
->as
->corank
; i
++)
896 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
897 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
899 for (i
= 0; i
< as
->rank
; i
++)
901 sym
->as
->lower
[i
] = as
->lower
[i
];
902 sym
->as
->upper
[i
] = as
->upper
[i
];
911 gfc_error ("rank + corank of %qs exceeds %d at %C", sym
->name
,
917 /* Copy an array specification. */
920 gfc_copy_array_spec (gfc_array_spec
*src
)
922 gfc_array_spec
*dest
;
928 dest
= gfc_get_array_spec ();
932 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
934 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
935 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
942 /* Returns nonzero if the two expressions are equal. Only handles integer
946 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
948 if (bound1
== NULL
|| bound2
== NULL
949 || bound1
->expr_type
!= EXPR_CONSTANT
950 || bound2
->expr_type
!= EXPR_CONSTANT
951 || bound1
->ts
.type
!= BT_INTEGER
952 || bound2
->ts
.type
!= BT_INTEGER
)
953 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
955 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
962 /* Compares two array specifications. They must be constant or deferred
966 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
970 if (as1
== NULL
&& as2
== NULL
)
973 if (as1
== NULL
|| as2
== NULL
)
976 if (as1
->rank
!= as2
->rank
)
979 if (as1
->corank
!= as2
->corank
)
985 if (as1
->type
!= as2
->type
)
988 if (as1
->type
== AS_EXPLICIT
)
989 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
991 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
994 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
1002 /****************** Array constructor functions ******************/
1005 /* Given an expression node that might be an array constructor and a
1006 symbol, make sure that no iterators in this or child constructors
1007 use the symbol as an implied-DO iterator. Returns nonzero if a
1008 duplicate was found. */
1011 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
1016 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1020 if (e
->expr_type
== EXPR_ARRAY
1021 && check_duplicate_iterator (e
->value
.constructor
, master
))
1024 if (c
->iterator
== NULL
)
1027 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1029 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1030 "same name", master
->name
, &c
->where
);
1040 /* Forward declaration because these functions are mutually recursive. */
1041 static match
match_array_cons_element (gfc_constructor_base
*);
1043 /* Match a list of array elements. */
1046 match_array_list (gfc_constructor_base
*result
)
1048 gfc_constructor_base head
;
1056 old_loc
= gfc_current_locus
;
1058 if (gfc_match_char ('(') == MATCH_NO
)
1061 memset (&iter
, '\0', sizeof (gfc_iterator
));
1064 m
= match_array_cons_element (&head
);
1068 if (gfc_match_char (',') != MATCH_YES
)
1076 m
= gfc_match_iterator (&iter
, 0);
1079 if (m
== MATCH_ERROR
)
1082 m
= match_array_cons_element (&head
);
1083 if (m
== MATCH_ERROR
)
1090 goto cleanup
; /* Could be a complex constant */
1093 if (gfc_match_char (',') != MATCH_YES
)
1102 if (gfc_match_char (')') != MATCH_YES
)
1105 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1111 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1112 e
->value
.constructor
= head
;
1114 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1115 p
->iterator
= gfc_get_iterator ();
1116 *p
->iterator
= iter
;
1121 gfc_error ("Syntax error in array constructor at %C");
1125 gfc_constructor_free (head
);
1126 gfc_free_iterator (&iter
, 0);
1127 gfc_current_locus
= old_loc
;
1132 /* Match a single element of an array constructor, which can be a
1133 single expression or a list of elements. */
1136 match_array_cons_element (gfc_constructor_base
*result
)
1141 m
= match_array_list (result
);
1145 m
= gfc_match_expr (&expr
);
1149 if (expr
->ts
.type
== BT_BOZ
)
1151 gfc_error ("BOZ literal constant at %L cannot appear in an "
1152 "array constructor", &expr
->where
);
1156 if (expr
->expr_type
== EXPR_FUNCTION
1157 && expr
->ts
.type
== BT_UNKNOWN
1158 && strcmp(expr
->symtree
->name
, "null") == 0)
1160 gfc_error ("NULL() at %C cannot appear in an array constructor");
1164 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1168 gfc_free_expr (expr
);
1173 /* Convert components of an array constructor to the type in ts. */
1176 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1182 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1185 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1186 && !e
->ref
&& e
->value
.constructor
)
1188 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1189 if (m
== MATCH_ERROR
)
1192 else if (!gfc_convert_type (e
, ts
, 1) && e
->ts
.type
!= BT_UNKNOWN
)
1198 /* Match an array constructor. */
1201 gfc_match_array_constructor (gfc_expr
**result
)
1204 gfc_constructor_base head
;
1209 const char *end_delim
;
1215 if (gfc_match (" (/") == MATCH_NO
)
1217 if (gfc_match (" [") == MATCH_NO
)
1221 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1222 "style array constructors at %C"))
1230 where
= gfc_current_locus
;
1232 /* Try to match an optional "type-spec ::" */
1234 m
= gfc_match_type_spec (&ts
);
1237 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1241 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1242 "including type specification at %C"))
1247 gfc_error ("Type-spec at %L cannot contain a deferred "
1248 "type parameter", &where
);
1252 if (ts
.type
== BT_CHARACTER
1253 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1255 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1256 "type parameter", &where
);
1261 else if (m
== MATCH_ERROR
)
1265 gfc_current_locus
= where
;
1267 if (gfc_match (end_delim
) == MATCH_YES
)
1273 gfc_error ("Empty array constructor at %C is not allowed");
1280 m
= match_array_cons_element (&head
);
1281 if (m
== MATCH_ERROR
)
1286 if (gfc_match_char (',') == MATCH_NO
)
1290 if (gfc_match (end_delim
) == MATCH_NO
)
1294 /* Size must be calculated at resolution time. */
1297 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1300 /* If the typespec is CHARACTER, check that array elements can
1301 be converted. See PR fortran/67803. */
1302 if (ts
.type
== BT_CHARACTER
)
1304 c
= gfc_constructor_first (head
);
1305 for (; c
; c
= gfc_constructor_next (c
))
1307 if (gfc_numeric_ts (&c
->expr
->ts
)
1308 || c
->expr
->ts
.type
== BT_LOGICAL
)
1310 gfc_error ("Incompatible typespec for array element at %L",
1315 /* Special case null(). */
1316 if (c
->expr
->expr_type
== EXPR_FUNCTION
1317 && c
->expr
->ts
.type
== BT_UNKNOWN
1318 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1320 gfc_error ("Incompatible typespec for array element at %L",
1327 /* Walk the constructor, and if possible, do type conversion for
1329 if (gfc_numeric_ts (&ts
))
1331 m
= walk_array_constructor (&ts
, head
);
1332 if (m
== MATCH_ERROR
)
1337 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1339 expr
->value
.constructor
= head
;
1341 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1348 gfc_error ("Syntax error in array constructor at %C");
1351 gfc_constructor_free (head
);
1357 /************** Check array constructors for correctness **************/
1359 /* Given an expression, compare it's type with the type of the current
1360 constructor. Returns nonzero if an error was issued. The
1361 cons_state variable keeps track of whether the type of the
1362 constructor being read or resolved is known to be good, bad or just
1365 static gfc_typespec constructor_ts
;
1367 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1371 check_element_type (gfc_expr
*expr
, bool convert
)
1373 if (cons_state
== CONS_BAD
)
1374 return 0; /* Suppress further errors */
1376 if (cons_state
== CONS_START
)
1378 if (expr
->ts
.type
== BT_UNKNOWN
)
1379 cons_state
= CONS_BAD
;
1382 cons_state
= CONS_GOOD
;
1383 constructor_ts
= expr
->ts
;
1389 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1393 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1395 gfc_error ("Element in %s array constructor at %L is %s",
1396 gfc_typename (&constructor_ts
), &expr
->where
,
1397 gfc_typename (expr
));
1399 cons_state
= CONS_BAD
;
1404 /* Recursive work function for gfc_check_constructor_type(). */
1407 check_constructor_type (gfc_constructor_base base
, bool convert
)
1412 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1416 if (e
->expr_type
== EXPR_ARRAY
)
1418 if (!check_constructor_type (e
->value
.constructor
, convert
))
1424 if (check_element_type (e
, convert
))
1432 /* Check that all elements of an array constructor are the same type.
1433 On false, an error has been generated. */
1436 gfc_check_constructor_type (gfc_expr
*e
)
1440 if (e
->ts
.type
!= BT_UNKNOWN
)
1442 cons_state
= CONS_GOOD
;
1443 constructor_ts
= e
->ts
;
1447 cons_state
= CONS_START
;
1448 gfc_clear_ts (&constructor_ts
);
1451 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1452 typespec, and we will now convert the values on the fly. */
1453 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1454 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1455 e
->ts
= constructor_ts
;
1462 typedef struct cons_stack
1464 gfc_iterator
*iterator
;
1465 struct cons_stack
*previous
;
1469 static cons_stack
*base
;
1471 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1473 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1474 that that variable is an iteration variables. */
1477 gfc_check_iter_variable (gfc_expr
*expr
)
1482 sym
= expr
->symtree
->n
.sym
;
1484 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1485 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1492 /* Recursive work function for gfc_check_constructor(). This amounts
1493 to calling the check function for each expression in the
1494 constructor, giving variables with the names of iterators a pass. */
1497 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1504 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1511 if (e
->expr_type
!= EXPR_ARRAY
)
1513 if (!(*check_function
)(e
))
1518 element
.previous
= base
;
1519 element
.iterator
= c
->iterator
;
1522 t
= check_constructor (e
->value
.constructor
, check_function
);
1523 base
= element
.previous
;
1529 /* Nothing went wrong, so all OK. */
1534 /* Checks a constructor to see if it is a particular kind of
1535 expression -- specification, restricted, or initialization as
1536 determined by the check_function. */
1539 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1541 cons_stack
*base_save
;
1547 t
= check_constructor (expr
->value
.constructor
, check_function
);
1555 /**************** Simplification of array constructors ****************/
1557 iterator_stack
*iter_stack
;
1561 gfc_constructor_base base
;
1562 int extract_count
, extract_n
;
1563 gfc_expr
*extracted
;
1567 gfc_component
*component
;
1570 bool (*expand_work_function
) (gfc_expr
*);
1574 static expand_info current_expand
;
1576 static bool expand_constructor (gfc_constructor_base
);
1579 /* Work function that counts the number of elements present in a
1583 count_elements (gfc_expr
*e
)
1588 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1591 if (!gfc_array_size (e
, &result
))
1597 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1606 /* Work function that extracts a particular element from an array
1607 constructor, freeing the rest. */
1610 extract_element (gfc_expr
*e
)
1613 { /* Something unextractable */
1618 if (current_expand
.extract_count
== current_expand
.extract_n
)
1619 current_expand
.extracted
= e
;
1623 current_expand
.extract_count
++;
1629 /* Work function that constructs a new constructor out of the old one,
1630 stringing new elements together. */
1633 expand (gfc_expr
*e
)
1635 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1638 c
->n
.component
= current_expand
.component
;
1643 /* Given an initialization expression that is a variable reference,
1644 substitute the current value of the iteration variable. */
1647 gfc_simplify_iterator_var (gfc_expr
*e
)
1651 for (p
= iter_stack
; p
; p
= p
->prev
)
1652 if (e
->symtree
== p
->variable
)
1656 return; /* Variable not found */
1658 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1660 mpz_set (e
->value
.integer
, p
->value
);
1666 /* Expand an expression with that is inside of a constructor,
1667 recursing into other constructors if present. */
1670 expand_expr (gfc_expr
*e
)
1672 if (e
->expr_type
== EXPR_ARRAY
)
1673 return expand_constructor (e
->value
.constructor
);
1675 e
= gfc_copy_expr (e
);
1677 if (!gfc_simplify_expr (e
, 1))
1683 return current_expand
.expand_work_function (e
);
1688 expand_iterator (gfc_constructor
*c
)
1690 gfc_expr
*start
, *end
, *step
;
1691 iterator_stack frame
;
1700 mpz_init (frame
.value
);
1703 start
= gfc_copy_expr (c
->iterator
->start
);
1704 if (!gfc_simplify_expr (start
, 1))
1707 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1710 end
= gfc_copy_expr (c
->iterator
->end
);
1711 if (!gfc_simplify_expr (end
, 1))
1714 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1717 step
= gfc_copy_expr (c
->iterator
->step
);
1718 if (!gfc_simplify_expr (step
, 1))
1721 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1724 if (mpz_sgn (step
->value
.integer
) == 0)
1726 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1730 /* Calculate the trip count of the loop. */
1731 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1732 mpz_add (trip
, trip
, step
->value
.integer
);
1733 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1735 mpz_set (frame
.value
, start
->value
.integer
);
1737 frame
.prev
= iter_stack
;
1738 frame
.variable
= c
->iterator
->var
->symtree
;
1739 iter_stack
= &frame
;
1741 while (mpz_sgn (trip
) > 0)
1743 if (!expand_expr (c
->expr
))
1746 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1747 mpz_sub_ui (trip
, trip
, 1);
1753 gfc_free_expr (start
);
1754 gfc_free_expr (end
);
1755 gfc_free_expr (step
);
1758 mpz_clear (frame
.value
);
1760 iter_stack
= frame
.prev
;
1766 /* Expand a constructor into constant constructors without any
1767 iterators, calling the work function for each of the expanded
1768 expressions. The work function needs to either save or free the
1769 passed expression. */
1772 expand_constructor (gfc_constructor_base base
)
1777 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1779 if (c
->iterator
!= NULL
)
1781 if (!expand_iterator (c
))
1788 if (e
->expr_type
== EXPR_ARRAY
)
1790 if (!expand_constructor (e
->value
.constructor
))
1796 e
= gfc_copy_expr (e
);
1797 if (!gfc_simplify_expr (e
, 1))
1802 e
->from_constructor
= 1;
1803 current_expand
.offset
= &c
->offset
;
1804 current_expand
.repeat
= &c
->repeat
;
1805 current_expand
.component
= c
->n
.component
;
1806 if (!current_expand
.expand_work_function(e
))
1813 /* Given an array expression and an element number (starting at zero),
1814 return a pointer to the array element. NULL is returned if the
1815 size of the array has been exceeded. The expression node returned
1816 remains a part of the array and should not be freed. Access is not
1817 efficient at all, but this is another place where things do not
1818 have to be particularly fast. */
1821 gfc_get_array_element (gfc_expr
*array
, int element
)
1823 expand_info expand_save
;
1827 expand_save
= current_expand
;
1828 current_expand
.extract_n
= element
;
1829 current_expand
.expand_work_function
= extract_element
;
1830 current_expand
.extracted
= NULL
;
1831 current_expand
.extract_count
= 0;
1835 rc
= expand_constructor (array
->value
.constructor
);
1836 e
= current_expand
.extracted
;
1837 current_expand
= expand_save
;
1846 /* Top level subroutine for expanding constructors. We only expand
1847 constructor if they are small enough. */
1850 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1852 expand_info expand_save
;
1856 /* If we can successfully get an array element at the max array size then
1857 the array is too big to expand, so we just return. */
1858 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1864 gfc_error ("The number of elements in the array constructor "
1865 "at %L requires an increase of the allowed %d "
1866 "upper limit. See %<-fmax-array-constructor%> "
1867 "option", &e
->where
, flag_max_array_constructor
);
1873 /* We now know the array is not too big so go ahead and try to expand it. */
1874 expand_save
= current_expand
;
1875 current_expand
.base
= NULL
;
1879 current_expand
.expand_work_function
= expand
;
1881 if (!expand_constructor (e
->value
.constructor
))
1883 gfc_constructor_free (current_expand
.base
);
1888 gfc_constructor_free (e
->value
.constructor
);
1889 e
->value
.constructor
= current_expand
.base
;
1894 current_expand
= expand_save
;
1900 /* Work function for checking that an element of a constructor is a
1901 constant, after removal of any iteration variables. We return
1905 is_constant_element (gfc_expr
*e
)
1909 rv
= gfc_is_constant_expr (e
);
1912 return rv
? true : false;
1916 /* Given an array constructor, determine if the constructor is
1917 constant or not by expanding it and making sure that all elements
1918 are constants. This is a bit of a hack since something like (/ (i,
1919 i=1,100000000) /) will take a while as* opposed to a more clever
1920 function that traverses the expression tree. FIXME. */
1923 gfc_constant_ac (gfc_expr
*e
)
1925 expand_info expand_save
;
1929 expand_save
= current_expand
;
1930 current_expand
.expand_work_function
= is_constant_element
;
1932 rc
= expand_constructor (e
->value
.constructor
);
1934 current_expand
= expand_save
;
1942 /* Returns nonzero if an array constructor has been completely
1943 expanded (no iterators) and zero if iterators are present. */
1946 gfc_expanded_ac (gfc_expr
*e
)
1950 if (e
->expr_type
== EXPR_ARRAY
)
1951 for (c
= gfc_constructor_first (e
->value
.constructor
);
1952 c
; c
= gfc_constructor_next (c
))
1953 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1960 /*************** Type resolution of array constructors ***************/
1963 /* The symbol expr_is_sought_symbol_ref will try to find. */
1964 static const gfc_symbol
*sought_symbol
= NULL
;
1967 /* Tells whether the expression E is a variable reference to the symbol
1968 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1970 To be used with gfc_expr_walker: if a reference is found we don't need
1971 to look further so we return 1 to skip any further walk. */
1974 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1977 gfc_expr
*expr
= *e
;
1978 locus
*sym_loc
= (locus
*)where
;
1980 if (expr
->expr_type
== EXPR_VARIABLE
1981 && expr
->symtree
->n
.sym
== sought_symbol
)
1983 *sym_loc
= expr
->where
;
1991 /* Tells whether the expression EXPR contains a reference to the symbol
1992 SYM and in that case sets the position SYM_LOC where the reference is. */
1995 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1999 sought_symbol
= sym
;
2000 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
2001 sought_symbol
= NULL
;
2006 /* Recursive array list resolution function. All of the elements must
2007 be of the same type. */
2010 resolve_array_list (gfc_constructor_base base
)
2018 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2023 gfc_symbol
*iter_var
;
2026 if (!gfc_resolve_iterator (iter
, false, true))
2029 /* Check for bounds referencing the iterator variable. */
2030 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2031 iter_var
= iter
->var
->symtree
->n
.sym
;
2032 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2034 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2035 "expression references control variable "
2036 "at %L", &iter_var_loc
))
2039 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2041 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2042 "expression references control variable "
2043 "at %L", &iter_var_loc
))
2046 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2048 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2049 "expression references control variable "
2050 "at %L", &iter_var_loc
))
2055 if (!gfc_resolve_expr (c
->expr
))
2058 if (UNLIMITED_POLY (c
->expr
))
2060 gfc_error ("Array constructor value at %L shall not be unlimited "
2061 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2069 /* Resolve character array constructor. If it has a specified constant character
2070 length, pad/truncate the elements here; if the length is not specified and
2071 all elements are of compile-time known length, emit an error as this is
2075 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2078 HOST_WIDE_INT found_length
;
2080 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2081 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2083 if (expr
->ts
.u
.cl
== NULL
)
2085 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2086 p
; p
= gfc_constructor_next (p
))
2087 if (p
->expr
->ts
.u
.cl
!= NULL
)
2089 /* Ensure that if there is a char_len around that it is
2090 used; otherwise the middle-end confuses them! */
2091 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2095 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2100 /* Early exit for zero size arrays. */
2104 HOST_WIDE_INT arraysize
;
2106 gfc_array_size (expr
, &size
);
2107 arraysize
= mpz_get_ui (size
);
2116 if (expr
->ts
.u
.cl
->length
== NULL
)
2118 /* Check that all constant string elements have the same length until
2119 we reach the end or find a variable-length one. */
2121 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2122 p
; p
= gfc_constructor_next (p
))
2124 HOST_WIDE_INT current_length
= -1;
2126 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2127 if (ref
->type
== REF_SUBSTRING
2129 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2131 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2134 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2135 current_length
= p
->expr
->value
.character
.length
;
2137 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2138 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2139 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2140 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2141 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2145 if (current_length
< 0)
2148 if (found_length
== -1)
2149 found_length
= current_length
;
2150 else if (found_length
!= current_length
)
2152 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2153 " constructor at %L", (long) found_length
,
2154 (long) current_length
, &p
->expr
->where
);
2158 gcc_assert (found_length
== current_length
);
2161 gcc_assert (found_length
!= -1);
2163 /* Update the character length of the array constructor. */
2164 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2165 NULL
, found_length
);
2169 /* We've got a character length specified. It should be an integer,
2170 otherwise an error is signalled elsewhere. */
2171 gcc_assert (expr
->ts
.u
.cl
->length
);
2173 /* If we've got a constant character length, pad according to this.
2174 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2175 max_length only if they pass. */
2176 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2178 /* Now pad/truncate the elements accordingly to the specified character
2179 length. This is ok inside this conditional, as in the case above
2180 (without typespec) all elements are verified to have the same length
2182 if (found_length
!= -1)
2183 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2184 p
; p
= gfc_constructor_next (p
))
2185 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2187 gfc_expr
*cl
= NULL
;
2188 HOST_WIDE_INT current_length
= -1;
2191 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2193 cl
= p
->expr
->ts
.u
.cl
->length
;
2194 gfc_extract_hwi (cl
, ¤t_length
);
2197 /* If gfc_extract_int above set current_length, we implicitly
2198 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2200 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2203 || (current_length
!= -1 && current_length
!= found_length
))
2204 gfc_set_constant_character_len (found_length
, p
->expr
,
2205 has_ts
? -1 : found_length
);
2213 /* Resolve all of the expressions in an array list. */
2216 gfc_resolve_array_constructor (gfc_expr
*expr
)
2220 t
= resolve_array_list (expr
->value
.constructor
);
2222 t
= gfc_check_constructor_type (expr
);
2224 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2225 the call to this function, so we don't need to call it here; if it was
2226 called twice, an error message there would be duplicated. */
2232 /* Copy an iterator structure. */
2235 gfc_copy_iterator (gfc_iterator
*src
)
2242 dest
= gfc_get_iterator ();
2244 dest
->var
= gfc_copy_expr (src
->var
);
2245 dest
->start
= gfc_copy_expr (src
->start
);
2246 dest
->end
= gfc_copy_expr (src
->end
);
2247 dest
->step
= gfc_copy_expr (src
->step
);
2248 dest
->unroll
= src
->unroll
;
2249 dest
->ivdep
= src
->ivdep
;
2250 dest
->vector
= src
->vector
;
2251 dest
->novector
= src
->novector
;
2257 /********* Subroutines for determining the size of an array *********/
2259 /* These are needed just to accommodate RESHAPE(). There are no
2260 diagnostics here, we just return a negative number if something
2264 /* Get the size of single dimension of an array specification. The
2265 array is guaranteed to be one dimensional. */
2268 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2273 if (dimen
< 0 || dimen
> as
->rank
- 1)
2274 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2276 if (as
->type
!= AS_EXPLICIT
2277 || !as
->lower
[dimen
]
2278 || !as
->upper
[dimen
])
2281 if (as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2282 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2283 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2284 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2289 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2290 as
->lower
[dimen
]->value
.integer
);
2292 mpz_add_ui (*result
, *result
, 1);
2299 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2304 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2307 mpz_init_set_ui (*result
, 1);
2309 for (d
= 0; d
< as
->rank
; d
++)
2311 if (!spec_dimen_size (as
, d
, &size
))
2313 mpz_clear (*result
);
2317 mpz_mul (*result
, *result
, size
);
2325 /* Get the number of elements in an array section. Optionally, also supply
2329 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2331 mpz_t upper
, lower
, stride
;
2334 gfc_expr
*stride_expr
= NULL
;
2336 if (dimen
< 0 || ar
== NULL
)
2337 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2339 if (dimen
> ar
->dimen
- 1)
2341 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2345 switch (ar
->dimen_type
[dimen
])
2349 mpz_set_ui (*result
, 1);
2354 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2361 if (ar
->stride
[dimen
] == NULL
)
2362 mpz_set_ui (stride
, 1);
2365 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2367 if(!gfc_simplify_expr(stride_expr
, 1))
2368 gfc_internal_error("Simplification error");
2370 if (stride_expr
->expr_type
!= EXPR_CONSTANT
2371 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2376 mpz_set (stride
, stride_expr
->value
.integer
);
2377 gfc_free_expr(stride_expr
);
2380 /* Calculate the number of elements via gfc_dep_differce, but only if
2381 start and end are both supplied in the reference or the array spec.
2382 This is to guard against strange but valid code like
2387 print *,size(a(n-1:))
2389 where the user changes the value of a variable. If we have to
2390 determine end as well, we cannot do this using gfc_dep_difference.
2391 Fall back to the constants-only code then. */
2397 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2399 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2400 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2401 ar
->as
->lower
[dimen
], &diff
);
2406 mpz_add (*result
, diff
, stride
);
2407 mpz_div (*result
, *result
, stride
);
2408 if (mpz_cmp_ui (*result
, 0) < 0)
2409 mpz_set_ui (*result
, 0);
2418 /* Constant-only code here, which covers more cases
2424 if (ar
->start
[dimen
] == NULL
)
2426 if (ar
->as
->lower
[dimen
] == NULL
2427 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2428 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2430 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2434 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2436 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2439 if (ar
->end
[dimen
] == NULL
)
2441 if (ar
->as
->upper
[dimen
] == NULL
2442 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2443 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2445 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2449 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2451 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2455 mpz_sub (*result
, upper
, lower
);
2456 mpz_add (*result
, *result
, stride
);
2457 mpz_div (*result
, *result
, stride
);
2459 /* Zero stride caught earlier. */
2460 if (mpz_cmp_ui (*result
, 0) < 0)
2461 mpz_set_ui (*result
, 0);
2468 mpz_sub_ui (*end
, *result
, 1UL);
2469 mpz_mul (*end
, *end
, stride
);
2470 mpz_add (*end
, *end
, lower
);
2480 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2488 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2493 mpz_init_set_ui (*result
, 1);
2495 for (d
= 0; d
< ar
->dimen
; d
++)
2497 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2499 mpz_clear (*result
);
2503 mpz_mul (*result
, *result
, size
);
2511 /* Given an array expression and a dimension, figure out how many
2512 elements it has along that dimension. Returns true if we were
2513 able to return a result in the 'result' variable, false
2517 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2522 gcc_assert (array
!= NULL
);
2524 if (array
->ts
.type
== BT_CLASS
)
2527 if (array
->rank
== -1)
2530 if (dimen
< 0 || dimen
> array
->rank
- 1)
2531 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2533 switch (array
->expr_type
)
2537 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2539 if (ref
->type
!= REF_ARRAY
)
2542 if (ref
->u
.ar
.type
== AR_FULL
)
2543 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2545 if (ref
->u
.ar
.type
== AR_SECTION
)
2547 for (i
= 0; dimen
>= 0; i
++)
2548 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2551 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2555 if (array
->shape
&& array
->shape
[dimen
])
2557 mpz_init_set (*result
, array
->shape
[dimen
]);
2561 if (array
->symtree
->n
.sym
->attr
.generic
2562 && array
->value
.function
.esym
!= NULL
)
2564 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2567 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2573 if (array
->shape
== NULL
) {
2574 /* Expressions with rank > 1 should have "shape" properly set */
2575 if ( array
->rank
!= 1 )
2576 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2577 return gfc_array_size(array
, result
);
2582 if (array
->shape
== NULL
)
2585 mpz_init_set (*result
, array
->shape
[dimen
]);
2594 /* Given an array expression, figure out how many elements are in the
2595 array. Returns true if this is possible, and sets the 'result'
2596 variable. Otherwise returns false. */
2599 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2601 expand_info expand_save
;
2606 if (array
->ts
.type
== BT_CLASS
)
2609 switch (array
->expr_type
)
2612 gfc_push_suppress_errors ();
2614 expand_save
= current_expand
;
2616 current_expand
.count
= result
;
2617 mpz_init_set_ui (*result
, 0);
2619 current_expand
.expand_work_function
= count_elements
;
2622 t
= expand_constructor (array
->value
.constructor
);
2624 gfc_pop_suppress_errors ();
2627 mpz_clear (*result
);
2628 current_expand
= expand_save
;
2632 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2634 if (ref
->type
!= REF_ARRAY
)
2637 if (ref
->u
.ar
.type
== AR_FULL
)
2638 return spec_size (ref
->u
.ar
.as
, result
);
2640 if (ref
->u
.ar
.type
== AR_SECTION
)
2641 return ref_size (&ref
->u
.ar
, result
);
2644 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2648 if (array
->rank
== 0 || array
->shape
== NULL
)
2651 mpz_init_set_ui (*result
, 1);
2653 for (i
= 0; i
< array
->rank
; i
++)
2654 mpz_mul (*result
, *result
, array
->shape
[i
]);
2663 /* Given an array reference, return the shape of the reference in an
2664 array of mpz_t integers. */
2667 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2677 for (; d
< ar
->as
->rank
; d
++)
2678 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2684 for (i
= 0; i
< ar
->dimen
; i
++)
2686 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2688 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2701 gfc_clear_shape (shape
, d
);
2706 /* Given an array expression, find the array reference structure that
2707 characterizes the reference. */
2710 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2714 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2715 if (ref
->type
== REF_ARRAY
2716 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2724 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2731 /* Find out if an array shape is known at compile time. */
2734 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2736 if (as
->type
!= AS_EXPLICIT
)
2739 for (int i
= 0; i
< as
->rank
; i
++)
2740 if (!gfc_is_constant_expr (as
->lower
[i
])
2741 || !gfc_is_constant_expr (as
->upper
[i
]))