2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
26 #include "constructor.h"
28 /**************** Array reference matching subroutines *****************/
30 /* Copy an array reference structure. */
33 gfc_copy_array_ref (gfc_array_ref
*src
)
41 dest
= gfc_get_array_ref ();
45 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
47 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
48 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
49 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
52 dest
->offset
= gfc_copy_expr (src
->offset
);
58 /* Match a single dimension of an array reference. This can be a
59 single element or an array section. Any modifications we've made
60 to the ar structure are cleaned up by the caller. If the init
61 is set, we require the subscript to be a valid initialization
65 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
67 match m
= MATCH_ERROR
;
71 i
= ar
->dimen
+ ar
->codimen
;
73 ar
->c_where
[i
] = gfc_current_locus
;
74 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
82 if (gfc_match_char (':') == MATCH_YES
)
85 /* Get start element. */
86 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
90 m
= gfc_match_init_expr (&ar
->start
[i
]);
92 m
= gfc_match_expr (&ar
->start
[i
]);
94 if (m
== MATCH_NO
&& gfc_match_char ('*') == MATCH_YES
)
96 else if (m
== MATCH_NO
)
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO
)
106 gfc_error ("Unexpected '*' in coarray subscript at %C");
110 /* Get an optional end element. Because we've seen the colon, we
111 definitely have a range along this dimension. */
113 ar
->dimen_type
[i
] = DIMEN_RANGE
;
115 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
118 m
= gfc_match_init_expr (&ar
->end
[i
]);
120 m
= gfc_match_expr (&ar
->end
[i
]);
122 if (m
== MATCH_ERROR
)
125 /* See if we have an optional stride. */
126 if (gfc_match_char (':') == MATCH_YES
)
130 gfc_error ("Strides not allowed in coarray subscript at %C");
134 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
135 : gfc_match_expr (&ar
->stride
[i
]);
138 gfc_error ("Expected array subscript stride at %C");
145 ar
->dimen_type
[i
] = DIMEN_STAR
;
151 /* Match an array reference, whether it is the whole array or a
152 particular elements or a section. If init is set, the reference has
153 to consist of init expressions. */
156 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
160 bool matched_bracket
= false;
162 memset (ar
, '\0', sizeof (ar
));
164 ar
->where
= gfc_current_locus
;
166 ar
->type
= AR_UNKNOWN
;
168 if (gfc_match_char ('[') == MATCH_YES
)
170 matched_bracket
= true;
174 if (gfc_match_char ('(') != MATCH_YES
)
181 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
183 m
= match_subscript (ar
, init
, false);
184 if (m
== MATCH_ERROR
)
187 if (gfc_match_char (')') == MATCH_YES
)
193 if (gfc_match_char (',') != MATCH_YES
)
195 gfc_error ("Invalid form of array reference at %C");
200 gfc_error ("Array reference at %C cannot have more than %d dimensions",
205 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
213 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
215 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
221 gfc_error ("Unexpected coarray designator at %C");
225 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
227 m
= match_subscript (ar
, init
, ar
->codimen
== (corank
- 1));
228 if (m
== MATCH_ERROR
)
231 if (gfc_match_char (']') == MATCH_YES
)
234 if (ar
->codimen
< corank
)
236 gfc_error ("Too few codimensions at %C, expected %d not %d",
237 corank
, ar
->codimen
);
240 if (ar
->codimen
> corank
)
242 gfc_error ("Too many codimensions at %C, expected %d not %d",
243 corank
, ar
->codimen
);
249 if (gfc_match_char (',') != MATCH_YES
)
251 if (gfc_match_char ('*') == MATCH_YES
)
252 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
253 ar
->codimen
+ 1, corank
);
255 gfc_error ("Invalid form of coarray reference at %C");
258 if (ar
->codimen
>= corank
)
260 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
261 ar
->codimen
+ 1, corank
);
266 gfc_error ("Array reference at %C cannot have more than %d dimensions",
273 /************** Array specification matching subroutines ***************/
275 /* Free all of the expressions associated with array bounds
279 gfc_free_array_spec (gfc_array_spec
*as
)
286 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
288 gfc_free_expr (as
->lower
[i
]);
289 gfc_free_expr (as
->upper
[i
]);
296 /* Take an array bound, resolves the expression, that make up the
297 shape and check associated constraints. */
300 resolve_array_bound (gfc_expr
*e
, int check_constant
)
305 if (gfc_resolve_expr (e
) == FAILURE
306 || gfc_specification_expr (e
) == FAILURE
)
309 if (check_constant
&& !gfc_is_constant_expr (e
))
311 if (e
->expr_type
== EXPR_VARIABLE
)
312 gfc_error ("Variable '%s' at %L in this context must be constant",
313 e
->symtree
->n
.sym
->name
, &e
->where
);
315 gfc_error ("Expression at %L in this context must be constant",
324 /* Takes an array specification, resolves the expressions that make up
325 the shape and make sure everything is integral. */
328 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
336 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
339 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
343 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
346 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
349 /* If the size is negative in this dimension, set it to zero. */
350 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
351 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
352 && mpz_cmp (as
->upper
[i
]->value
.integer
,
353 as
->lower
[i
]->value
.integer
) < 0)
355 gfc_free_expr (as
->upper
[i
]);
356 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
357 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
358 as
->upper
[i
]->value
.integer
, 1);
366 /* Match a single array element specification. The return values as
367 well as the upper and lower bounds of the array spec are filled
368 in according to what we see on the input. The caller makes sure
369 individual specifications make sense as a whole.
372 Parsed Lower Upper Returned
373 ------------------------------------
374 : NULL NULL AS_DEFERRED (*)
376 x: x NULL AS_ASSUMED_SHAPE
378 x:* x NULL AS_ASSUMED_SIZE
379 * 1 NULL AS_ASSUMED_SIZE
381 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
382 is fixed during the resolution of formal interfaces.
384 Anything else AS_UNKNOWN. */
387 match_array_element_spec (gfc_array_spec
*as
)
389 gfc_expr
**upper
, **lower
;
392 lower
= &as
->lower
[as
->rank
+ as
->corank
- 1];
393 upper
= &as
->upper
[as
->rank
+ as
->corank
- 1];
395 if (gfc_match_char ('*') == MATCH_YES
)
397 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
398 return AS_ASSUMED_SIZE
;
401 if (gfc_match_char (':') == MATCH_YES
)
404 m
= gfc_match_expr (upper
);
406 gfc_error ("Expected expression in array specification at %C");
409 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
412 if (gfc_match_char (':') == MATCH_NO
)
414 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
421 if (gfc_match_char ('*') == MATCH_YES
)
422 return AS_ASSUMED_SIZE
;
424 m
= gfc_match_expr (upper
);
425 if (m
== MATCH_ERROR
)
428 return AS_ASSUMED_SHAPE
;
429 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
436 /* Matches an array specification, incidentally figuring out what sort
437 it is. Match either a normal array specification, or a coarray spec
438 or both. Optionally allow [:] for coarrays. */
441 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
443 array_type current_type
;
447 as
= gfc_get_array_spec ();
452 if (gfc_match_char ('(') != MATCH_YES
)
462 current_type
= match_array_element_spec (as
);
464 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
465 and implied-shape specifications. If the rank is at least 2, we can
466 distinguish between them. But for rank 1, we currently return
467 ASSUMED_SIZE; this gets adjusted later when we know for sure
468 whether the symbol parsed is a PARAMETER or not. */
472 if (current_type
== AS_UNKNOWN
)
474 as
->type
= current_type
;
478 { /* See how current spec meshes with the existing. */
482 case AS_IMPLIED_SHAPE
:
483 if (current_type
!= AS_ASSUMED_SHAPE
)
485 gfc_error ("Bad array specification for implied-shape"
492 if (current_type
== AS_ASSUMED_SIZE
)
494 as
->type
= AS_ASSUMED_SIZE
;
498 if (current_type
== AS_EXPLICIT
)
501 gfc_error ("Bad array specification for an explicitly shaped "
506 case AS_ASSUMED_SHAPE
:
507 if ((current_type
== AS_ASSUMED_SHAPE
)
508 || (current_type
== AS_DEFERRED
))
511 gfc_error ("Bad array specification for assumed shape "
516 if (current_type
== AS_DEFERRED
)
519 if (current_type
== AS_ASSUMED_SHAPE
)
521 as
->type
= AS_ASSUMED_SHAPE
;
525 gfc_error ("Bad specification for deferred shape array at %C");
528 case AS_ASSUMED_SIZE
:
529 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
531 as
->type
= AS_IMPLIED_SHAPE
;
535 gfc_error ("Bad specification for assumed size array at %C");
539 if (gfc_match_char (')') == MATCH_YES
)
542 if (gfc_match_char (',') != MATCH_YES
)
544 gfc_error ("Expected another dimension in array declaration at %C");
548 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
550 gfc_error ("Array specification at %C has more than %d dimensions",
555 if (as
->corank
+ as
->rank
>= 7
556 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Array "
557 "specification at %C with more than 7 dimensions")
566 if (gfc_match_char ('[') != MATCH_YES
)
569 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Coarray declaration at %C")
573 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
575 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
579 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
581 gfc_error ("Array specification at %C has more than %d "
582 "dimensions", GFC_MAX_DIMENSIONS
);
589 current_type
= match_array_element_spec (as
);
591 if (current_type
== AS_UNKNOWN
)
595 as
->cotype
= current_type
;
598 { /* See how current spec meshes with the existing. */
599 case AS_IMPLIED_SHAPE
:
604 if (current_type
== AS_ASSUMED_SIZE
)
606 as
->cotype
= AS_ASSUMED_SIZE
;
610 if (current_type
== AS_EXPLICIT
)
613 gfc_error ("Bad array specification for an explicitly "
614 "shaped array at %C");
618 case AS_ASSUMED_SHAPE
:
619 if ((current_type
== AS_ASSUMED_SHAPE
)
620 || (current_type
== AS_DEFERRED
))
623 gfc_error ("Bad array specification for assumed shape "
628 if (current_type
== AS_DEFERRED
)
631 if (current_type
== AS_ASSUMED_SHAPE
)
633 as
->cotype
= AS_ASSUMED_SHAPE
;
637 gfc_error ("Bad specification for deferred shape array at %C");
640 case AS_ASSUMED_SIZE
:
641 gfc_error ("Bad specification for assumed size array at %C");
645 if (gfc_match_char (']') == MATCH_YES
)
648 if (gfc_match_char (',') != MATCH_YES
)
650 gfc_error ("Expected another dimension in array declaration at %C");
654 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
656 gfc_error ("Array specification at %C has more than %d "
657 "dimensions", GFC_MAX_DIMENSIONS
);
662 if (current_type
== AS_EXPLICIT
)
664 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
668 if (as
->cotype
== AS_ASSUMED_SIZE
)
669 as
->cotype
= AS_EXPLICIT
;
672 as
->type
= as
->cotype
;
675 if (as
->rank
== 0 && as
->corank
== 0)
678 gfc_free_array_spec (as
);
682 /* If a lower bounds of an assumed shape array is blank, put in one. */
683 if (as
->type
== AS_ASSUMED_SHAPE
)
685 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
687 if (as
->lower
[i
] == NULL
)
688 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
697 /* Something went wrong. */
698 gfc_free_array_spec (as
);
703 /* Given a symbol and an array specification, modify the symbol to
704 have that array specification. The error locus is needed in case
705 something goes wrong. On failure, the caller must free the spec. */
708 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
716 && gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
720 && gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
731 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
732 the codimension is simply added. */
733 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
735 sym
->as
->cotype
= as
->cotype
;
736 sym
->as
->corank
= as
->corank
;
737 for (i
= 0; i
< as
->corank
; i
++)
739 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
740 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
745 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
746 the dimension is added - but first the codimensions (if existing
747 need to be shifted to make space for the dimension. */
748 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
750 sym
->as
->rank
= as
->rank
;
751 sym
->as
->type
= as
->type
;
752 sym
->as
->cray_pointee
= as
->cray_pointee
;
753 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
755 for (i
= 0; i
< sym
->as
->corank
; i
++)
757 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
758 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
760 for (i
= 0; i
< as
->rank
; i
++)
762 sym
->as
->lower
[i
] = as
->lower
[i
];
763 sym
->as
->upper
[i
] = as
->upper
[i
];
772 /* Copy an array specification. */
775 gfc_copy_array_spec (gfc_array_spec
*src
)
777 gfc_array_spec
*dest
;
783 dest
= gfc_get_array_spec ();
787 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
789 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
790 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
797 /* Returns nonzero if the two expressions are equal. Only handles integer
801 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
803 if (bound1
== NULL
|| bound2
== NULL
804 || bound1
->expr_type
!= EXPR_CONSTANT
805 || bound2
->expr_type
!= EXPR_CONSTANT
806 || bound1
->ts
.type
!= BT_INTEGER
807 || bound2
->ts
.type
!= BT_INTEGER
)
808 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
810 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
817 /* Compares two array specifications. They must be constant or deferred
821 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
825 if (as1
== NULL
&& as2
== NULL
)
828 if (as1
== NULL
|| as2
== NULL
)
831 if (as1
->rank
!= as2
->rank
)
834 if (as1
->corank
!= as2
->corank
)
840 if (as1
->type
!= as2
->type
)
843 if (as1
->type
== AS_EXPLICIT
)
844 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
846 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
849 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
857 /****************** Array constructor functions ******************/
860 /* Given an expression node that might be an array constructor and a
861 symbol, make sure that no iterators in this or child constructors
862 use the symbol as an implied-DO iterator. Returns nonzero if a
863 duplicate was found. */
866 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
871 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
875 if (e
->expr_type
== EXPR_ARRAY
876 && check_duplicate_iterator (e
->value
.constructor
, master
))
879 if (c
->iterator
== NULL
)
882 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
884 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
885 "same name", master
->name
, &c
->where
);
895 /* Forward declaration because these functions are mutually recursive. */
896 static match
match_array_cons_element (gfc_constructor_base
*);
898 /* Match a list of array elements. */
901 match_array_list (gfc_constructor_base
*result
)
903 gfc_constructor_base head
;
911 old_loc
= gfc_current_locus
;
913 if (gfc_match_char ('(') == MATCH_NO
)
916 memset (&iter
, '\0', sizeof (gfc_iterator
));
919 m
= match_array_cons_element (&head
);
923 if (gfc_match_char (',') != MATCH_YES
)
931 m
= gfc_match_iterator (&iter
, 0);
934 if (m
== MATCH_ERROR
)
937 m
= match_array_cons_element (&head
);
938 if (m
== MATCH_ERROR
)
945 goto cleanup
; /* Could be a complex constant */
948 if (gfc_match_char (',') != MATCH_YES
)
957 if (gfc_match_char (')') != MATCH_YES
)
960 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
966 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
967 e
->value
.constructor
= head
;
969 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
970 p
->iterator
= gfc_get_iterator ();
976 gfc_error ("Syntax error in array constructor at %C");
980 gfc_constructor_free (head
);
981 gfc_free_iterator (&iter
, 0);
982 gfc_current_locus
= old_loc
;
987 /* Match a single element of an array constructor, which can be a
988 single expression or a list of elements. */
991 match_array_cons_element (gfc_constructor_base
*result
)
996 m
= match_array_list (result
);
1000 m
= gfc_match_expr (&expr
);
1004 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1009 /* Match an array constructor. */
1012 gfc_match_array_constructor (gfc_expr
**result
)
1014 gfc_constructor_base head
, new_cons
;
1019 const char *end_delim
;
1022 if (gfc_match (" (/") == MATCH_NO
)
1024 if (gfc_match (" [") == MATCH_NO
)
1028 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: [...] "
1029 "style array constructors at %C") == FAILURE
)
1037 where
= gfc_current_locus
;
1038 head
= new_cons
= NULL
;
1041 /* Try to match an optional "type-spec ::" */
1042 if (gfc_match_decl_type_spec (&ts
, 0) == MATCH_YES
)
1044 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1048 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Array constructor "
1049 "including type specification at %C") == FAILURE
)
1054 gfc_error ("Type-spec at %L cannot contain a deferred "
1055 "type parameter", &where
);
1062 gfc_current_locus
= where
;
1064 if (gfc_match (end_delim
) == MATCH_YES
)
1070 gfc_error ("Empty array constructor at %C is not allowed");
1077 m
= match_array_cons_element (&head
);
1078 if (m
== MATCH_ERROR
)
1083 if (gfc_match_char (',') == MATCH_NO
)
1087 if (gfc_match (end_delim
) == MATCH_NO
)
1091 /* Size must be calculated at resolution time. */
1094 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1098 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1100 expr
->value
.constructor
= head
;
1102 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1108 gfc_error ("Syntax error in array constructor at %C");
1111 gfc_constructor_free (head
);
1117 /************** Check array constructors for correctness **************/
1119 /* Given an expression, compare it's type with the type of the current
1120 constructor. Returns nonzero if an error was issued. The
1121 cons_state variable keeps track of whether the type of the
1122 constructor being read or resolved is known to be good, bad or just
1125 static gfc_typespec constructor_ts
;
1127 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1131 check_element_type (gfc_expr
*expr
, bool convert
)
1133 if (cons_state
== CONS_BAD
)
1134 return 0; /* Suppress further errors */
1136 if (cons_state
== CONS_START
)
1138 if (expr
->ts
.type
== BT_UNKNOWN
)
1139 cons_state
= CONS_BAD
;
1142 cons_state
= CONS_GOOD
;
1143 constructor_ts
= expr
->ts
;
1149 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1153 return gfc_convert_type (expr
, &constructor_ts
, 1) == SUCCESS
? 0 : 1;
1155 gfc_error ("Element in %s array constructor at %L is %s",
1156 gfc_typename (&constructor_ts
), &expr
->where
,
1157 gfc_typename (&expr
->ts
));
1159 cons_state
= CONS_BAD
;
1164 /* Recursive work function for gfc_check_constructor_type(). */
1167 check_constructor_type (gfc_constructor_base base
, bool convert
)
1172 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1176 if (e
->expr_type
== EXPR_ARRAY
)
1178 if (check_constructor_type (e
->value
.constructor
, convert
) == FAILURE
)
1184 if (check_element_type (e
, convert
))
1192 /* Check that all elements of an array constructor are the same type.
1193 On FAILURE, an error has been generated. */
1196 gfc_check_constructor_type (gfc_expr
*e
)
1200 if (e
->ts
.type
!= BT_UNKNOWN
)
1202 cons_state
= CONS_GOOD
;
1203 constructor_ts
= e
->ts
;
1207 cons_state
= CONS_START
;
1208 gfc_clear_ts (&constructor_ts
);
1211 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1212 typespec, and we will now convert the values on the fly. */
1213 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1214 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1215 e
->ts
= constructor_ts
;
1222 typedef struct cons_stack
1224 gfc_iterator
*iterator
;
1225 struct cons_stack
*previous
;
1229 static cons_stack
*base
;
1231 static gfc_try
check_constructor (gfc_constructor_base
, gfc_try (*) (gfc_expr
*));
1233 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1234 that that variable is an iteration variables. */
1237 gfc_check_iter_variable (gfc_expr
*expr
)
1242 sym
= expr
->symtree
->n
.sym
;
1244 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1245 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1252 /* Recursive work function for gfc_check_constructor(). This amounts
1253 to calling the check function for each expression in the
1254 constructor, giving variables with the names of iterators a pass. */
1257 check_constructor (gfc_constructor_base ctor
, gfc_try (*check_function
) (gfc_expr
*))
1264 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1268 if (e
->expr_type
!= EXPR_ARRAY
)
1270 if ((*check_function
) (e
) == FAILURE
)
1275 element
.previous
= base
;
1276 element
.iterator
= c
->iterator
;
1279 t
= check_constructor (e
->value
.constructor
, check_function
);
1280 base
= element
.previous
;
1286 /* Nothing went wrong, so all OK. */
1291 /* Checks a constructor to see if it is a particular kind of
1292 expression -- specification, restricted, or initialization as
1293 determined by the check_function. */
1296 gfc_check_constructor (gfc_expr
*expr
, gfc_try (*check_function
) (gfc_expr
*))
1298 cons_stack
*base_save
;
1304 t
= check_constructor (expr
->value
.constructor
, check_function
);
1312 /**************** Simplification of array constructors ****************/
1314 iterator_stack
*iter_stack
;
1318 gfc_constructor_base base
;
1319 int extract_count
, extract_n
;
1320 gfc_expr
*extracted
;
1324 gfc_component
*component
;
1326 gfc_try (*expand_work_function
) (gfc_expr
*);
1330 static expand_info current_expand
;
1332 static gfc_try
expand_constructor (gfc_constructor_base
);
1335 /* Work function that counts the number of elements present in a
1339 count_elements (gfc_expr
*e
)
1344 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1347 if (gfc_array_size (e
, &result
) == FAILURE
)
1353 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1362 /* Work function that extracts a particular element from an array
1363 constructor, freeing the rest. */
1366 extract_element (gfc_expr
*e
)
1369 { /* Something unextractable */
1374 if (current_expand
.extract_count
== current_expand
.extract_n
)
1375 current_expand
.extracted
= e
;
1379 current_expand
.extract_count
++;
1385 /* Work function that constructs a new constructor out of the old one,
1386 stringing new elements together. */
1389 expand (gfc_expr
*e
)
1391 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1394 c
->n
.component
= current_expand
.component
;
1399 /* Given an initialization expression that is a variable reference,
1400 substitute the current value of the iteration variable. */
1403 gfc_simplify_iterator_var (gfc_expr
*e
)
1407 for (p
= iter_stack
; p
; p
= p
->prev
)
1408 if (e
->symtree
== p
->variable
)
1412 return; /* Variable not found */
1414 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1416 mpz_set (e
->value
.integer
, p
->value
);
1422 /* Expand an expression with that is inside of a constructor,
1423 recursing into other constructors if present. */
1426 expand_expr (gfc_expr
*e
)
1428 if (e
->expr_type
== EXPR_ARRAY
)
1429 return expand_constructor (e
->value
.constructor
);
1431 e
= gfc_copy_expr (e
);
1433 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1439 return current_expand
.expand_work_function (e
);
1444 expand_iterator (gfc_constructor
*c
)
1446 gfc_expr
*start
, *end
, *step
;
1447 iterator_stack frame
;
1456 mpz_init (frame
.value
);
1459 start
= gfc_copy_expr (c
->iterator
->start
);
1460 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1463 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1466 end
= gfc_copy_expr (c
->iterator
->end
);
1467 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1470 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1473 step
= gfc_copy_expr (c
->iterator
->step
);
1474 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1477 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1480 if (mpz_sgn (step
->value
.integer
) == 0)
1482 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1486 /* Calculate the trip count of the loop. */
1487 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1488 mpz_add (trip
, trip
, step
->value
.integer
);
1489 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1491 mpz_set (frame
.value
, start
->value
.integer
);
1493 frame
.prev
= iter_stack
;
1494 frame
.variable
= c
->iterator
->var
->symtree
;
1495 iter_stack
= &frame
;
1497 while (mpz_sgn (trip
) > 0)
1499 if (expand_expr (c
->expr
) == FAILURE
)
1502 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1503 mpz_sub_ui (trip
, trip
, 1);
1509 gfc_free_expr (start
);
1510 gfc_free_expr (end
);
1511 gfc_free_expr (step
);
1514 mpz_clear (frame
.value
);
1516 iter_stack
= frame
.prev
;
1522 /* Expand a constructor into constant constructors without any
1523 iterators, calling the work function for each of the expanded
1524 expressions. The work function needs to either save or free the
1525 passed expression. */
1528 expand_constructor (gfc_constructor_base base
)
1533 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1535 if (c
->iterator
!= NULL
)
1537 if (expand_iterator (c
) == FAILURE
)
1544 if (e
->expr_type
== EXPR_ARRAY
)
1546 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1552 e
= gfc_copy_expr (e
);
1553 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1558 current_expand
.offset
= &c
->offset
;
1559 current_expand
.component
= c
->n
.component
;
1560 if (current_expand
.expand_work_function (e
) == FAILURE
)
1567 /* Given an array expression and an element number (starting at zero),
1568 return a pointer to the array element. NULL is returned if the
1569 size of the array has been exceeded. The expression node returned
1570 remains a part of the array and should not be freed. Access is not
1571 efficient at all, but this is another place where things do not
1572 have to be particularly fast. */
1575 gfc_get_array_element (gfc_expr
*array
, int element
)
1577 expand_info expand_save
;
1581 expand_save
= current_expand
;
1582 current_expand
.extract_n
= element
;
1583 current_expand
.expand_work_function
= extract_element
;
1584 current_expand
.extracted
= NULL
;
1585 current_expand
.extract_count
= 0;
1589 rc
= expand_constructor (array
->value
.constructor
);
1590 e
= current_expand
.extracted
;
1591 current_expand
= expand_save
;
1600 /* Top level subroutine for expanding constructors. We only expand
1601 constructor if they are small enough. */
1604 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1606 expand_info expand_save
;
1610 /* If we can successfully get an array element at the max array size then
1611 the array is too big to expand, so we just return. */
1612 f
= gfc_get_array_element (e
, gfc_option
.flag_max_array_constructor
);
1618 gfc_error ("The number of elements in the array constructor "
1619 "at %L requires an increase of the allowed %d "
1620 "upper limit. See -fmax-array-constructor "
1621 "option", &e
->where
,
1622 gfc_option
.flag_max_array_constructor
);
1628 /* We now know the array is not too big so go ahead and try to expand it. */
1629 expand_save
= current_expand
;
1630 current_expand
.base
= NULL
;
1634 current_expand
.expand_work_function
= expand
;
1636 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1638 gfc_constructor_free (current_expand
.base
);
1643 gfc_constructor_free (e
->value
.constructor
);
1644 e
->value
.constructor
= current_expand
.base
;
1649 current_expand
= expand_save
;
1655 /* Work function for checking that an element of a constructor is a
1656 constant, after removal of any iteration variables. We return
1657 FAILURE if not so. */
1660 is_constant_element (gfc_expr
*e
)
1664 rv
= gfc_is_constant_expr (e
);
1667 return rv
? SUCCESS
: FAILURE
;
1671 /* Given an array constructor, determine if the constructor is
1672 constant or not by expanding it and making sure that all elements
1673 are constants. This is a bit of a hack since something like (/ (i,
1674 i=1,100000000) /) will take a while as* opposed to a more clever
1675 function that traverses the expression tree. FIXME. */
1678 gfc_constant_ac (gfc_expr
*e
)
1680 expand_info expand_save
;
1684 expand_save
= current_expand
;
1685 current_expand
.expand_work_function
= is_constant_element
;
1687 rc
= expand_constructor (e
->value
.constructor
);
1689 current_expand
= expand_save
;
1697 /* Returns nonzero if an array constructor has been completely
1698 expanded (no iterators) and zero if iterators are present. */
1701 gfc_expanded_ac (gfc_expr
*e
)
1705 if (e
->expr_type
== EXPR_ARRAY
)
1706 for (c
= gfc_constructor_first (e
->value
.constructor
);
1707 c
; c
= gfc_constructor_next (c
))
1708 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1715 /*************** Type resolution of array constructors ***************/
1717 /* Recursive array list resolution function. All of the elements must
1718 be of the same type. */
1721 resolve_array_list (gfc_constructor_base base
)
1728 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1730 if (c
->iterator
!= NULL
1731 && gfc_resolve_iterator (c
->iterator
, false) == FAILURE
)
1734 if (gfc_resolve_expr (c
->expr
) == FAILURE
)
1741 /* Resolve character array constructor. If it has a specified constant character
1742 length, pad/truncate the elements here; if the length is not specified and
1743 all elements are of compile-time known length, emit an error as this is
1747 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1752 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1753 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1755 if (expr
->ts
.u
.cl
== NULL
)
1757 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1758 p
; p
= gfc_constructor_next (p
))
1759 if (p
->expr
->ts
.u
.cl
!= NULL
)
1761 /* Ensure that if there is a char_len around that it is
1762 used; otherwise the middle-end confuses them! */
1763 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1767 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1774 if (expr
->ts
.u
.cl
->length
== NULL
)
1776 /* Check that all constant string elements have the same length until
1777 we reach the end or find a variable-length one. */
1779 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1780 p
; p
= gfc_constructor_next (p
))
1782 int current_length
= -1;
1784 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1785 if (ref
->type
== REF_SUBSTRING
1786 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1787 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1790 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1791 current_length
= p
->expr
->value
.character
.length
;
1795 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1796 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1797 current_length
= (int) j
;
1799 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1800 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1803 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1804 current_length
= (int) j
;
1809 gcc_assert (current_length
!= -1);
1811 if (found_length
== -1)
1812 found_length
= current_length
;
1813 else if (found_length
!= current_length
)
1815 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1816 " constructor at %L", found_length
, current_length
,
1821 gcc_assert (found_length
== current_length
);
1824 gcc_assert (found_length
!= -1);
1826 /* Update the character length of the array constructor. */
1827 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1828 NULL
, found_length
);
1832 /* We've got a character length specified. It should be an integer,
1833 otherwise an error is signalled elsewhere. */
1834 gcc_assert (expr
->ts
.u
.cl
->length
);
1836 /* If we've got a constant character length, pad according to this.
1837 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1838 max_length only if they pass. */
1839 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1841 /* Now pad/truncate the elements accordingly to the specified character
1842 length. This is ok inside this conditional, as in the case above
1843 (without typespec) all elements are verified to have the same length
1845 if (found_length
!= -1)
1846 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1847 p
; p
= gfc_constructor_next (p
))
1848 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1850 gfc_expr
*cl
= NULL
;
1851 int current_length
= -1;
1854 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1856 cl
= p
->expr
->ts
.u
.cl
->length
;
1857 gfc_extract_int (cl
, ¤t_length
);
1860 /* If gfc_extract_int above set current_length, we implicitly
1861 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1863 has_ts
= (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length_from_typespec
);
1866 || (current_length
!= -1 && current_length
!= found_length
))
1867 gfc_set_constant_character_len (found_length
, p
->expr
,
1868 has_ts
? -1 : found_length
);
1876 /* Resolve all of the expressions in an array list. */
1879 gfc_resolve_array_constructor (gfc_expr
*expr
)
1883 t
= resolve_array_list (expr
->value
.constructor
);
1885 t
= gfc_check_constructor_type (expr
);
1887 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1888 the call to this function, so we don't need to call it here; if it was
1889 called twice, an error message there would be duplicated. */
1895 /* Copy an iterator structure. */
1898 gfc_copy_iterator (gfc_iterator
*src
)
1905 dest
= gfc_get_iterator ();
1907 dest
->var
= gfc_copy_expr (src
->var
);
1908 dest
->start
= gfc_copy_expr (src
->start
);
1909 dest
->end
= gfc_copy_expr (src
->end
);
1910 dest
->step
= gfc_copy_expr (src
->step
);
1916 /********* Subroutines for determining the size of an array *********/
1918 /* These are needed just to accommodate RESHAPE(). There are no
1919 diagnostics here, we just return a negative number if something
1923 /* Get the size of single dimension of an array specification. The
1924 array is guaranteed to be one dimensional. */
1927 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
1932 if (dimen
< 0 || dimen
> as
->rank
- 1)
1933 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1935 if (as
->type
!= AS_EXPLICIT
1936 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1937 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
1938 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
1939 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
1944 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1945 as
->lower
[dimen
]->value
.integer
);
1947 mpz_add_ui (*result
, *result
, 1);
1954 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
1959 mpz_init_set_ui (*result
, 1);
1961 for (d
= 0; d
< as
->rank
; d
++)
1963 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1965 mpz_clear (*result
);
1969 mpz_mul (*result
, *result
, size
);
1977 /* Get the number of elements in an array section. Optionally, also supply
1981 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
1983 mpz_t upper
, lower
, stride
;
1986 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1987 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1989 switch (ar
->dimen_type
[dimen
])
1993 mpz_set_ui (*result
, 1);
1998 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2007 if (ar
->start
[dimen
] == NULL
)
2009 if (ar
->as
->lower
[dimen
] == NULL
2010 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2012 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2016 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2018 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2021 if (ar
->end
[dimen
] == NULL
)
2023 if (ar
->as
->upper
[dimen
] == NULL
2024 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2026 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2030 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2032 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2035 if (ar
->stride
[dimen
] == NULL
)
2036 mpz_set_ui (stride
, 1);
2039 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2041 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2045 mpz_sub (*result
, upper
, lower
);
2046 mpz_add (*result
, *result
, stride
);
2047 mpz_div (*result
, *result
, stride
);
2049 /* Zero stride caught earlier. */
2050 if (mpz_cmp_ui (*result
, 0) < 0)
2051 mpz_set_ui (*result
, 0);
2058 mpz_sub_ui (*end
, *result
, 1UL);
2059 mpz_mul (*end
, *end
, stride
);
2060 mpz_add (*end
, *end
, lower
);
2070 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2078 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2083 mpz_init_set_ui (*result
, 1);
2085 for (d
= 0; d
< ar
->dimen
; d
++)
2087 if (gfc_ref_dimen_size (ar
, d
, &size
, NULL
) == FAILURE
)
2089 mpz_clear (*result
);
2093 mpz_mul (*result
, *result
, size
);
2101 /* Given an array expression and a dimension, figure out how many
2102 elements it has along that dimension. Returns SUCCESS if we were
2103 able to return a result in the 'result' variable, FAILURE
2107 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2112 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
2113 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2115 switch (array
->expr_type
)
2119 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2121 if (ref
->type
!= REF_ARRAY
)
2124 if (ref
->u
.ar
.type
== AR_FULL
)
2125 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2127 if (ref
->u
.ar
.type
== AR_SECTION
)
2129 for (i
= 0; dimen
>= 0; i
++)
2130 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2133 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2137 if (array
->shape
&& array
->shape
[dimen
])
2139 mpz_init_set (*result
, array
->shape
[dimen
]);
2143 if (array
->symtree
->n
.sym
->attr
.generic
2144 && array
->value
.function
.esym
!= NULL
)
2146 if (spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
)
2150 else if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
)
2157 if (array
->shape
== NULL
) {
2158 /* Expressions with rank > 1 should have "shape" properly set */
2159 if ( array
->rank
!= 1 )
2160 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2161 return gfc_array_size(array
, result
);
2166 if (array
->shape
== NULL
)
2169 mpz_init_set (*result
, array
->shape
[dimen
]);
2178 /* Given an array expression, figure out how many elements are in the
2179 array. Returns SUCCESS if this is possible, and sets the 'result'
2180 variable. Otherwise returns FAILURE. */
2183 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2185 expand_info expand_save
;
2190 switch (array
->expr_type
)
2193 gfc_push_suppress_errors ();
2195 expand_save
= current_expand
;
2197 current_expand
.count
= result
;
2198 mpz_init_set_ui (*result
, 0);
2200 current_expand
.expand_work_function
= count_elements
;
2203 t
= expand_constructor (array
->value
.constructor
);
2205 gfc_pop_suppress_errors ();
2208 mpz_clear (*result
);
2209 current_expand
= expand_save
;
2213 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2215 if (ref
->type
!= REF_ARRAY
)
2218 if (ref
->u
.ar
.type
== AR_FULL
)
2219 return spec_size (ref
->u
.ar
.as
, result
);
2221 if (ref
->u
.ar
.type
== AR_SECTION
)
2222 return ref_size (&ref
->u
.ar
, result
);
2225 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2229 if (array
->rank
== 0 || array
->shape
== NULL
)
2232 mpz_init_set_ui (*result
, 1);
2234 for (i
= 0; i
< array
->rank
; i
++)
2235 mpz_mul (*result
, *result
, array
->shape
[i
]);
2244 /* Given an array reference, return the shape of the reference in an
2245 array of mpz_t integers. */
2248 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2258 for (; d
< ar
->as
->rank
; d
++)
2259 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
2265 for (i
= 0; i
< ar
->dimen
; i
++)
2267 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2269 if (gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
) == FAILURE
)
2282 for (d
--; d
>= 0; d
--)
2283 mpz_clear (shape
[d
]);
2289 /* Given an array expression, find the array reference structure that
2290 characterizes the reference. */
2293 gfc_find_array_ref (gfc_expr
*e
)
2297 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2298 if (ref
->type
== REF_ARRAY
2299 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
2300 || (ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.dimen
== 0)))
2304 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2310 /* Find out if an array shape is known at compile time. */
2313 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2317 if (as
->type
!= AS_EXPLICIT
)
2320 for (i
= 0; i
< as
->rank
; i
++)
2321 if (!gfc_is_constant_expr (as
->lower
[i
])
2322 || !gfc_is_constant_expr (as
->upper
[i
]))