2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3 2011, 2012 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/>. */
24 #include "coretypes.h"
27 #include "constructor.h"
29 /**************** Array reference matching subroutines *****************/
31 /* Copy an array reference structure. */
34 gfc_copy_array_ref (gfc_array_ref
*src
)
42 dest
= gfc_get_array_ref ();
46 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
48 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
49 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
50 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
57 /* Match a single dimension of an array reference. This can be a
58 single element or an array section. Any modifications we've made
59 to the ar structure are cleaned up by the caller. If the init
60 is set, we require the subscript to be a valid initialization
64 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
66 match m
= MATCH_ERROR
;
70 i
= ar
->dimen
+ ar
->codimen
;
72 gfc_gobble_whitespace ();
73 ar
->c_where
[i
] = gfc_current_locus
;
74 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
82 if (gfc_match_char (':') == MATCH_YES
)
85 /* Get start element. */
86 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
90 m
= gfc_match_init_expr (&ar
->start
[i
]);
92 m
= gfc_match_expr (&ar
->start
[i
]);
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
;
393 rank
= as
->rank
== -1 ? 0 : as
->rank
;
394 lower
= &as
->lower
[rank
+ as
->corank
- 1];
395 upper
= &as
->upper
[rank
+ as
->corank
- 1];
397 if (gfc_match_char ('*') == MATCH_YES
)
399 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
400 return AS_ASSUMED_SIZE
;
403 if (gfc_match_char (':') == MATCH_YES
)
406 m
= gfc_match_expr (upper
);
408 gfc_error ("Expected expression in array specification at %C");
411 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
414 if (gfc_match_char (':') == MATCH_NO
)
416 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
423 if (gfc_match_char ('*') == MATCH_YES
)
424 return AS_ASSUMED_SIZE
;
426 m
= gfc_match_expr (upper
);
427 if (m
== MATCH_ERROR
)
430 return AS_ASSUMED_SHAPE
;
431 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
438 /* Matches an array specification, incidentally figuring out what sort
439 it is. Match either a normal array specification, or a coarray spec
440 or both. Optionally allow [:] for coarrays. */
443 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
445 array_type current_type
;
449 as
= gfc_get_array_spec ();
454 if (gfc_match_char ('(') != MATCH_YES
)
461 if (gfc_match (" .. )") == MATCH_YES
)
463 as
->type
= AS_ASSUMED_RANK
;
466 if (gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C")
478 current_type
= match_array_element_spec (as
);
480 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
481 and implied-shape specifications. If the rank is at least 2, we can
482 distinguish between them. But for rank 1, we currently return
483 ASSUMED_SIZE; this gets adjusted later when we know for sure
484 whether the symbol parsed is a PARAMETER or not. */
488 if (current_type
== AS_UNKNOWN
)
490 as
->type
= current_type
;
494 { /* See how current spec meshes with the existing. */
498 case AS_IMPLIED_SHAPE
:
499 if (current_type
!= AS_ASSUMED_SHAPE
)
501 gfc_error ("Bad array specification for implied-shape"
508 if (current_type
== AS_ASSUMED_SIZE
)
510 as
->type
= AS_ASSUMED_SIZE
;
514 if (current_type
== AS_EXPLICIT
)
517 gfc_error ("Bad array specification for an explicitly shaped "
522 case AS_ASSUMED_SHAPE
:
523 if ((current_type
== AS_ASSUMED_SHAPE
)
524 || (current_type
== AS_DEFERRED
))
527 gfc_error ("Bad array specification for assumed shape "
532 if (current_type
== AS_DEFERRED
)
535 if (current_type
== AS_ASSUMED_SHAPE
)
537 as
->type
= AS_ASSUMED_SHAPE
;
541 gfc_error ("Bad specification for deferred shape array at %C");
544 case AS_ASSUMED_SIZE
:
545 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
547 as
->type
= AS_IMPLIED_SHAPE
;
551 gfc_error ("Bad specification for assumed size array at %C");
554 case AS_ASSUMED_RANK
:
558 if (gfc_match_char (')') == MATCH_YES
)
561 if (gfc_match_char (',') != MATCH_YES
)
563 gfc_error ("Expected another dimension in array declaration at %C");
567 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
569 gfc_error ("Array specification at %C has more than %d dimensions",
574 if (as
->corank
+ as
->rank
>= 7
575 && gfc_notify_std (GFC_STD_F2008
, "Array "
576 "specification at %C with more than 7 dimensions")
585 if (gfc_match_char ('[') != MATCH_YES
)
588 if (gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C")
592 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
594 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
598 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
600 gfc_error ("Array specification at %C has more than %d "
601 "dimensions", GFC_MAX_DIMENSIONS
);
608 current_type
= match_array_element_spec (as
);
610 if (current_type
== AS_UNKNOWN
)
614 as
->cotype
= current_type
;
617 { /* See how current spec meshes with the existing. */
618 case AS_IMPLIED_SHAPE
:
623 if (current_type
== AS_ASSUMED_SIZE
)
625 as
->cotype
= AS_ASSUMED_SIZE
;
629 if (current_type
== AS_EXPLICIT
)
632 gfc_error ("Bad array specification for an explicitly "
633 "shaped array at %C");
637 case AS_ASSUMED_SHAPE
:
638 if ((current_type
== AS_ASSUMED_SHAPE
)
639 || (current_type
== AS_DEFERRED
))
642 gfc_error ("Bad array specification for assumed shape "
647 if (current_type
== AS_DEFERRED
)
650 if (current_type
== AS_ASSUMED_SHAPE
)
652 as
->cotype
= AS_ASSUMED_SHAPE
;
656 gfc_error ("Bad specification for deferred shape array at %C");
659 case AS_ASSUMED_SIZE
:
660 gfc_error ("Bad specification for assumed size array at %C");
663 case AS_ASSUMED_RANK
:
667 if (gfc_match_char (']') == MATCH_YES
)
670 if (gfc_match_char (',') != MATCH_YES
)
672 gfc_error ("Expected another dimension in array declaration at %C");
676 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
678 gfc_error ("Array specification at %C has more than %d "
679 "dimensions", GFC_MAX_DIMENSIONS
);
684 if (current_type
== AS_EXPLICIT
)
686 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
690 if (as
->cotype
== AS_ASSUMED_SIZE
)
691 as
->cotype
= AS_EXPLICIT
;
694 as
->type
= as
->cotype
;
697 if (as
->rank
== 0 && as
->corank
== 0)
700 gfc_free_array_spec (as
);
704 /* If a lower bounds of an assumed shape array is blank, put in one. */
705 if (as
->type
== AS_ASSUMED_SHAPE
)
707 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
709 if (as
->lower
[i
] == NULL
)
710 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
719 /* Something went wrong. */
720 gfc_free_array_spec (as
);
725 /* Given a symbol and an array specification, modify the symbol to
726 have that array specification. The error locus is needed in case
727 something goes wrong. On failure, the caller must free the spec. */
730 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
738 && gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
742 && gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
751 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
752 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
754 gfc_error ("The assumed-rank array '%s' at %L shall not have a "
755 "codimension", sym
->name
, error_loc
);
761 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
762 the codimension is simply added. */
763 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
765 sym
->as
->cotype
= as
->cotype
;
766 sym
->as
->corank
= as
->corank
;
767 for (i
= 0; i
< as
->corank
; i
++)
769 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
770 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
775 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
776 the dimension is added - but first the codimensions (if existing
777 need to be shifted to make space for the dimension. */
778 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
780 sym
->as
->rank
= as
->rank
;
781 sym
->as
->type
= as
->type
;
782 sym
->as
->cray_pointee
= as
->cray_pointee
;
783 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
785 for (i
= 0; i
< sym
->as
->corank
; i
++)
787 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
788 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
790 for (i
= 0; i
< as
->rank
; i
++)
792 sym
->as
->lower
[i
] = as
->lower
[i
];
793 sym
->as
->upper
[i
] = as
->upper
[i
];
802 /* Copy an array specification. */
805 gfc_copy_array_spec (gfc_array_spec
*src
)
807 gfc_array_spec
*dest
;
813 dest
= gfc_get_array_spec ();
817 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
819 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
820 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
827 /* Returns nonzero if the two expressions are equal. Only handles integer
831 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
833 if (bound1
== NULL
|| bound2
== NULL
834 || bound1
->expr_type
!= EXPR_CONSTANT
835 || bound2
->expr_type
!= EXPR_CONSTANT
836 || bound1
->ts
.type
!= BT_INTEGER
837 || bound2
->ts
.type
!= BT_INTEGER
)
838 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
840 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
847 /* Compares two array specifications. They must be constant or deferred
851 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
855 if (as1
== NULL
&& as2
== NULL
)
858 if (as1
== NULL
|| as2
== NULL
)
861 if (as1
->rank
!= as2
->rank
)
864 if (as1
->corank
!= as2
->corank
)
870 if (as1
->type
!= as2
->type
)
873 if (as1
->type
== AS_EXPLICIT
)
874 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
876 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
879 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
887 /****************** Array constructor functions ******************/
890 /* Given an expression node that might be an array constructor and a
891 symbol, make sure that no iterators in this or child constructors
892 use the symbol as an implied-DO iterator. Returns nonzero if a
893 duplicate was found. */
896 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
901 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
905 if (e
->expr_type
== EXPR_ARRAY
906 && check_duplicate_iterator (e
->value
.constructor
, master
))
909 if (c
->iterator
== NULL
)
912 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
914 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
915 "same name", master
->name
, &c
->where
);
925 /* Forward declaration because these functions are mutually recursive. */
926 static match
match_array_cons_element (gfc_constructor_base
*);
928 /* Match a list of array elements. */
931 match_array_list (gfc_constructor_base
*result
)
933 gfc_constructor_base head
;
941 old_loc
= gfc_current_locus
;
943 if (gfc_match_char ('(') == MATCH_NO
)
946 memset (&iter
, '\0', sizeof (gfc_iterator
));
949 m
= match_array_cons_element (&head
);
953 if (gfc_match_char (',') != MATCH_YES
)
961 m
= gfc_match_iterator (&iter
, 0);
964 if (m
== MATCH_ERROR
)
967 m
= match_array_cons_element (&head
);
968 if (m
== MATCH_ERROR
)
975 goto cleanup
; /* Could be a complex constant */
978 if (gfc_match_char (',') != MATCH_YES
)
987 if (gfc_match_char (')') != MATCH_YES
)
990 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
996 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
997 e
->value
.constructor
= head
;
999 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1000 p
->iterator
= gfc_get_iterator ();
1001 *p
->iterator
= iter
;
1006 gfc_error ("Syntax error in array constructor at %C");
1010 gfc_constructor_free (head
);
1011 gfc_free_iterator (&iter
, 0);
1012 gfc_current_locus
= old_loc
;
1017 /* Match a single element of an array constructor, which can be a
1018 single expression or a list of elements. */
1021 match_array_cons_element (gfc_constructor_base
*result
)
1026 m
= match_array_list (result
);
1030 m
= gfc_match_expr (&expr
);
1034 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1039 /* Match an array constructor. */
1042 gfc_match_array_constructor (gfc_expr
**result
)
1044 gfc_constructor_base head
, new_cons
;
1049 const char *end_delim
;
1052 if (gfc_match (" (/") == MATCH_NO
)
1054 if (gfc_match (" [") == MATCH_NO
)
1058 if (gfc_notify_std (GFC_STD_F2003
, "[...] "
1059 "style array constructors at %C") == FAILURE
)
1067 where
= gfc_current_locus
;
1068 head
= new_cons
= NULL
;
1071 /* Try to match an optional "type-spec ::" */
1072 if (gfc_match_decl_type_spec (&ts
, 0) == MATCH_YES
)
1074 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1078 if (gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1079 "including type specification at %C") == FAILURE
)
1084 gfc_error ("Type-spec at %L cannot contain a deferred "
1085 "type parameter", &where
);
1092 gfc_current_locus
= where
;
1094 if (gfc_match (end_delim
) == MATCH_YES
)
1100 gfc_error ("Empty array constructor at %C is not allowed");
1107 m
= match_array_cons_element (&head
);
1108 if (m
== MATCH_ERROR
)
1113 if (gfc_match_char (',') == MATCH_NO
)
1117 if (gfc_match (end_delim
) == MATCH_NO
)
1121 /* Size must be calculated at resolution time. */
1124 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1128 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1130 expr
->value
.constructor
= head
;
1132 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1138 gfc_error ("Syntax error in array constructor at %C");
1141 gfc_constructor_free (head
);
1147 /************** Check array constructors for correctness **************/
1149 /* Given an expression, compare it's type with the type of the current
1150 constructor. Returns nonzero if an error was issued. The
1151 cons_state variable keeps track of whether the type of the
1152 constructor being read or resolved is known to be good, bad or just
1155 static gfc_typespec constructor_ts
;
1157 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1161 check_element_type (gfc_expr
*expr
, bool convert
)
1163 if (cons_state
== CONS_BAD
)
1164 return 0; /* Suppress further errors */
1166 if (cons_state
== CONS_START
)
1168 if (expr
->ts
.type
== BT_UNKNOWN
)
1169 cons_state
= CONS_BAD
;
1172 cons_state
= CONS_GOOD
;
1173 constructor_ts
= expr
->ts
;
1179 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1183 return gfc_convert_type (expr
, &constructor_ts
, 1) == SUCCESS
? 0 : 1;
1185 gfc_error ("Element in %s array constructor at %L is %s",
1186 gfc_typename (&constructor_ts
), &expr
->where
,
1187 gfc_typename (&expr
->ts
));
1189 cons_state
= CONS_BAD
;
1194 /* Recursive work function for gfc_check_constructor_type(). */
1197 check_constructor_type (gfc_constructor_base base
, bool convert
)
1202 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1206 if (e
->expr_type
== EXPR_ARRAY
)
1208 if (check_constructor_type (e
->value
.constructor
, convert
) == FAILURE
)
1214 if (check_element_type (e
, convert
))
1222 /* Check that all elements of an array constructor are the same type.
1223 On FAILURE, an error has been generated. */
1226 gfc_check_constructor_type (gfc_expr
*e
)
1230 if (e
->ts
.type
!= BT_UNKNOWN
)
1232 cons_state
= CONS_GOOD
;
1233 constructor_ts
= e
->ts
;
1237 cons_state
= CONS_START
;
1238 gfc_clear_ts (&constructor_ts
);
1241 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1242 typespec, and we will now convert the values on the fly. */
1243 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1244 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1245 e
->ts
= constructor_ts
;
1252 typedef struct cons_stack
1254 gfc_iterator
*iterator
;
1255 struct cons_stack
*previous
;
1259 static cons_stack
*base
;
1261 static gfc_try
check_constructor (gfc_constructor_base
, gfc_try (*) (gfc_expr
*));
1263 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1264 that that variable is an iteration variables. */
1267 gfc_check_iter_variable (gfc_expr
*expr
)
1272 sym
= expr
->symtree
->n
.sym
;
1274 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1275 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1282 /* Recursive work function for gfc_check_constructor(). This amounts
1283 to calling the check function for each expression in the
1284 constructor, giving variables with the names of iterators a pass. */
1287 check_constructor (gfc_constructor_base ctor
, gfc_try (*check_function
) (gfc_expr
*))
1294 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1298 if (e
->expr_type
!= EXPR_ARRAY
)
1300 if ((*check_function
) (e
) == FAILURE
)
1305 element
.previous
= base
;
1306 element
.iterator
= c
->iterator
;
1309 t
= check_constructor (e
->value
.constructor
, check_function
);
1310 base
= element
.previous
;
1316 /* Nothing went wrong, so all OK. */
1321 /* Checks a constructor to see if it is a particular kind of
1322 expression -- specification, restricted, or initialization as
1323 determined by the check_function. */
1326 gfc_check_constructor (gfc_expr
*expr
, gfc_try (*check_function
) (gfc_expr
*))
1328 cons_stack
*base_save
;
1334 t
= check_constructor (expr
->value
.constructor
, check_function
);
1342 /**************** Simplification of array constructors ****************/
1344 iterator_stack
*iter_stack
;
1348 gfc_constructor_base base
;
1349 int extract_count
, extract_n
;
1350 gfc_expr
*extracted
;
1354 gfc_component
*component
;
1357 gfc_try (*expand_work_function
) (gfc_expr
*);
1361 static expand_info current_expand
;
1363 static gfc_try
expand_constructor (gfc_constructor_base
);
1366 /* Work function that counts the number of elements present in a
1370 count_elements (gfc_expr
*e
)
1375 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1378 if (gfc_array_size (e
, &result
) == FAILURE
)
1384 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1393 /* Work function that extracts a particular element from an array
1394 constructor, freeing the rest. */
1397 extract_element (gfc_expr
*e
)
1400 { /* Something unextractable */
1405 if (current_expand
.extract_count
== current_expand
.extract_n
)
1406 current_expand
.extracted
= e
;
1410 current_expand
.extract_count
++;
1416 /* Work function that constructs a new constructor out of the old one,
1417 stringing new elements together. */
1420 expand (gfc_expr
*e
)
1422 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1425 c
->n
.component
= current_expand
.component
;
1430 /* Given an initialization expression that is a variable reference,
1431 substitute the current value of the iteration variable. */
1434 gfc_simplify_iterator_var (gfc_expr
*e
)
1438 for (p
= iter_stack
; p
; p
= p
->prev
)
1439 if (e
->symtree
== p
->variable
)
1443 return; /* Variable not found */
1445 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1447 mpz_set (e
->value
.integer
, p
->value
);
1453 /* Expand an expression with that is inside of a constructor,
1454 recursing into other constructors if present. */
1457 expand_expr (gfc_expr
*e
)
1459 if (e
->expr_type
== EXPR_ARRAY
)
1460 return expand_constructor (e
->value
.constructor
);
1462 e
= gfc_copy_expr (e
);
1464 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1470 return current_expand
.expand_work_function (e
);
1475 expand_iterator (gfc_constructor
*c
)
1477 gfc_expr
*start
, *end
, *step
;
1478 iterator_stack frame
;
1487 mpz_init (frame
.value
);
1490 start
= gfc_copy_expr (c
->iterator
->start
);
1491 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1494 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1497 end
= gfc_copy_expr (c
->iterator
->end
);
1498 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1501 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1504 step
= gfc_copy_expr (c
->iterator
->step
);
1505 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1508 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1511 if (mpz_sgn (step
->value
.integer
) == 0)
1513 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1517 /* Calculate the trip count of the loop. */
1518 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1519 mpz_add (trip
, trip
, step
->value
.integer
);
1520 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1522 mpz_set (frame
.value
, start
->value
.integer
);
1524 frame
.prev
= iter_stack
;
1525 frame
.variable
= c
->iterator
->var
->symtree
;
1526 iter_stack
= &frame
;
1528 while (mpz_sgn (trip
) > 0)
1530 if (expand_expr (c
->expr
) == FAILURE
)
1533 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1534 mpz_sub_ui (trip
, trip
, 1);
1540 gfc_free_expr (start
);
1541 gfc_free_expr (end
);
1542 gfc_free_expr (step
);
1545 mpz_clear (frame
.value
);
1547 iter_stack
= frame
.prev
;
1553 /* Expand a constructor into constant constructors without any
1554 iterators, calling the work function for each of the expanded
1555 expressions. The work function needs to either save or free the
1556 passed expression. */
1559 expand_constructor (gfc_constructor_base base
)
1564 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1566 if (c
->iterator
!= NULL
)
1568 if (expand_iterator (c
) == FAILURE
)
1575 if (e
->expr_type
== EXPR_ARRAY
)
1577 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1583 e
= gfc_copy_expr (e
);
1584 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1589 current_expand
.offset
= &c
->offset
;
1590 current_expand
.repeat
= &c
->repeat
;
1591 current_expand
.component
= c
->n
.component
;
1592 if (current_expand
.expand_work_function (e
) == FAILURE
)
1599 /* Given an array expression and an element number (starting at zero),
1600 return a pointer to the array element. NULL is returned if the
1601 size of the array has been exceeded. The expression node returned
1602 remains a part of the array and should not be freed. Access is not
1603 efficient at all, but this is another place where things do not
1604 have to be particularly fast. */
1607 gfc_get_array_element (gfc_expr
*array
, int element
)
1609 expand_info expand_save
;
1613 expand_save
= current_expand
;
1614 current_expand
.extract_n
= element
;
1615 current_expand
.expand_work_function
= extract_element
;
1616 current_expand
.extracted
= NULL
;
1617 current_expand
.extract_count
= 0;
1621 rc
= expand_constructor (array
->value
.constructor
);
1622 e
= current_expand
.extracted
;
1623 current_expand
= expand_save
;
1632 /* Top level subroutine for expanding constructors. We only expand
1633 constructor if they are small enough. */
1636 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1638 expand_info expand_save
;
1642 /* If we can successfully get an array element at the max array size then
1643 the array is too big to expand, so we just return. */
1644 f
= gfc_get_array_element (e
, gfc_option
.flag_max_array_constructor
);
1650 gfc_error ("The number of elements in the array constructor "
1651 "at %L requires an increase of the allowed %d "
1652 "upper limit. See -fmax-array-constructor "
1653 "option", &e
->where
,
1654 gfc_option
.flag_max_array_constructor
);
1660 /* We now know the array is not too big so go ahead and try to expand it. */
1661 expand_save
= current_expand
;
1662 current_expand
.base
= NULL
;
1666 current_expand
.expand_work_function
= expand
;
1668 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1670 gfc_constructor_free (current_expand
.base
);
1675 gfc_constructor_free (e
->value
.constructor
);
1676 e
->value
.constructor
= current_expand
.base
;
1681 current_expand
= expand_save
;
1687 /* Work function for checking that an element of a constructor is a
1688 constant, after removal of any iteration variables. We return
1689 FAILURE if not so. */
1692 is_constant_element (gfc_expr
*e
)
1696 rv
= gfc_is_constant_expr (e
);
1699 return rv
? SUCCESS
: FAILURE
;
1703 /* Given an array constructor, determine if the constructor is
1704 constant or not by expanding it and making sure that all elements
1705 are constants. This is a bit of a hack since something like (/ (i,
1706 i=1,100000000) /) will take a while as* opposed to a more clever
1707 function that traverses the expression tree. FIXME. */
1710 gfc_constant_ac (gfc_expr
*e
)
1712 expand_info expand_save
;
1716 expand_save
= current_expand
;
1717 current_expand
.expand_work_function
= is_constant_element
;
1719 rc
= expand_constructor (e
->value
.constructor
);
1721 current_expand
= expand_save
;
1729 /* Returns nonzero if an array constructor has been completely
1730 expanded (no iterators) and zero if iterators are present. */
1733 gfc_expanded_ac (gfc_expr
*e
)
1737 if (e
->expr_type
== EXPR_ARRAY
)
1738 for (c
= gfc_constructor_first (e
->value
.constructor
);
1739 c
; c
= gfc_constructor_next (c
))
1740 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1747 /*************** Type resolution of array constructors ***************/
1750 /* The symbol expr_is_sought_symbol_ref will try to find. */
1751 static const gfc_symbol
*sought_symbol
= NULL
;
1754 /* Tells whether the expression E is a variable reference to the symbol
1755 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1757 To be used with gfc_expr_walker: if a reference is found we don't need
1758 to look further so we return 1 to skip any further walk. */
1761 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1764 gfc_expr
*expr
= *e
;
1765 locus
*sym_loc
= (locus
*)where
;
1767 if (expr
->expr_type
== EXPR_VARIABLE
1768 && expr
->symtree
->n
.sym
== sought_symbol
)
1770 *sym_loc
= expr
->where
;
1778 /* Tells whether the expression EXPR contains a reference to the symbol
1779 SYM and in that case sets the position SYM_LOC where the reference is. */
1782 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1786 sought_symbol
= sym
;
1787 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1788 sought_symbol
= NULL
;
1793 /* Recursive array list resolution function. All of the elements must
1794 be of the same type. */
1797 resolve_array_list (gfc_constructor_base base
)
1805 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1810 gfc_symbol
*iter_var
;
1813 if (gfc_resolve_iterator (iter
, false) == FAILURE
)
1816 /* Check for bounds referencing the iterator variable. */
1817 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1818 iter_var
= iter
->var
->symtree
->n
.sym
;
1819 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1821 if (gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1822 "expression references control variable "
1823 "at %L", &iter_var_loc
) == FAILURE
)
1826 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1828 if (gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1829 "expression references control variable "
1830 "at %L", &iter_var_loc
) == FAILURE
)
1833 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1835 if (gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1836 "expression references control variable "
1837 "at %L", &iter_var_loc
) == FAILURE
)
1842 if (gfc_resolve_expr (c
->expr
) == FAILURE
)
1849 /* Resolve character array constructor. If it has a specified constant character
1850 length, pad/truncate the elements here; if the length is not specified and
1851 all elements are of compile-time known length, emit an error as this is
1855 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1860 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1861 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1863 if (expr
->ts
.u
.cl
== NULL
)
1865 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1866 p
; p
= gfc_constructor_next (p
))
1867 if (p
->expr
->ts
.u
.cl
!= NULL
)
1869 /* Ensure that if there is a char_len around that it is
1870 used; otherwise the middle-end confuses them! */
1871 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1875 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1882 if (expr
->ts
.u
.cl
->length
== NULL
)
1884 /* Check that all constant string elements have the same length until
1885 we reach the end or find a variable-length one. */
1887 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1888 p
; p
= gfc_constructor_next (p
))
1890 int current_length
= -1;
1892 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1893 if (ref
->type
== REF_SUBSTRING
1894 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1895 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1898 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1899 current_length
= p
->expr
->value
.character
.length
;
1903 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1904 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1905 current_length
= (int) j
;
1907 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1908 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1911 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1912 current_length
= (int) j
;
1917 gcc_assert (current_length
!= -1);
1919 if (found_length
== -1)
1920 found_length
= current_length
;
1921 else if (found_length
!= current_length
)
1923 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1924 " constructor at %L", found_length
, current_length
,
1929 gcc_assert (found_length
== current_length
);
1932 gcc_assert (found_length
!= -1);
1934 /* Update the character length of the array constructor. */
1935 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1936 NULL
, found_length
);
1940 /* We've got a character length specified. It should be an integer,
1941 otherwise an error is signalled elsewhere. */
1942 gcc_assert (expr
->ts
.u
.cl
->length
);
1944 /* If we've got a constant character length, pad according to this.
1945 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1946 max_length only if they pass. */
1947 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1949 /* Now pad/truncate the elements accordingly to the specified character
1950 length. This is ok inside this conditional, as in the case above
1951 (without typespec) all elements are verified to have the same length
1953 if (found_length
!= -1)
1954 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1955 p
; p
= gfc_constructor_next (p
))
1956 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1958 gfc_expr
*cl
= NULL
;
1959 int current_length
= -1;
1962 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1964 cl
= p
->expr
->ts
.u
.cl
->length
;
1965 gfc_extract_int (cl
, ¤t_length
);
1968 /* If gfc_extract_int above set current_length, we implicitly
1969 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1971 has_ts
= (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length_from_typespec
);
1974 || (current_length
!= -1 && current_length
!= found_length
))
1975 gfc_set_constant_character_len (found_length
, p
->expr
,
1976 has_ts
? -1 : found_length
);
1984 /* Resolve all of the expressions in an array list. */
1987 gfc_resolve_array_constructor (gfc_expr
*expr
)
1991 t
= resolve_array_list (expr
->value
.constructor
);
1993 t
= gfc_check_constructor_type (expr
);
1995 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1996 the call to this function, so we don't need to call it here; if it was
1997 called twice, an error message there would be duplicated. */
2003 /* Copy an iterator structure. */
2006 gfc_copy_iterator (gfc_iterator
*src
)
2013 dest
= gfc_get_iterator ();
2015 dest
->var
= gfc_copy_expr (src
->var
);
2016 dest
->start
= gfc_copy_expr (src
->start
);
2017 dest
->end
= gfc_copy_expr (src
->end
);
2018 dest
->step
= gfc_copy_expr (src
->step
);
2024 /********* Subroutines for determining the size of an array *********/
2026 /* These are needed just to accommodate RESHAPE(). There are no
2027 diagnostics here, we just return a negative number if something
2031 /* Get the size of single dimension of an array specification. The
2032 array is guaranteed to be one dimensional. */
2035 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2040 if (dimen
< 0 || dimen
> as
->rank
- 1)
2041 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2043 if (as
->type
!= AS_EXPLICIT
2044 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2045 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2046 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2047 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2052 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2053 as
->lower
[dimen
]->value
.integer
);
2055 mpz_add_ui (*result
, *result
, 1);
2062 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2067 if (as
->type
== AS_ASSUMED_RANK
)
2070 mpz_init_set_ui (*result
, 1);
2072 for (d
= 0; d
< as
->rank
; d
++)
2074 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
2076 mpz_clear (*result
);
2080 mpz_mul (*result
, *result
, size
);
2088 /* Get the number of elements in an array section. Optionally, also supply
2092 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2094 mpz_t upper
, lower
, stride
;
2097 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2098 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2100 switch (ar
->dimen_type
[dimen
])
2104 mpz_set_ui (*result
, 1);
2109 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2118 if (ar
->start
[dimen
] == NULL
)
2120 if (ar
->as
->lower
[dimen
] == NULL
2121 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2123 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2127 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2129 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2132 if (ar
->end
[dimen
] == NULL
)
2134 if (ar
->as
->upper
[dimen
] == NULL
2135 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2137 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2141 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2143 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2146 if (ar
->stride
[dimen
] == NULL
)
2147 mpz_set_ui (stride
, 1);
2150 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2152 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2156 mpz_sub (*result
, upper
, lower
);
2157 mpz_add (*result
, *result
, stride
);
2158 mpz_div (*result
, *result
, stride
);
2160 /* Zero stride caught earlier. */
2161 if (mpz_cmp_ui (*result
, 0) < 0)
2162 mpz_set_ui (*result
, 0);
2169 mpz_sub_ui (*end
, *result
, 1UL);
2170 mpz_mul (*end
, *end
, stride
);
2171 mpz_add (*end
, *end
, lower
);
2181 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2189 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2194 mpz_init_set_ui (*result
, 1);
2196 for (d
= 0; d
< ar
->dimen
; d
++)
2198 if (gfc_ref_dimen_size (ar
, d
, &size
, NULL
) == FAILURE
)
2200 mpz_clear (*result
);
2204 mpz_mul (*result
, *result
, size
);
2212 /* Given an array expression and a dimension, figure out how many
2213 elements it has along that dimension. Returns SUCCESS if we were
2214 able to return a result in the 'result' variable, FAILURE
2218 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2223 if (array
->ts
.type
== BT_CLASS
)
2226 if (array
->rank
== -1)
2229 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
2230 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2232 switch (array
->expr_type
)
2236 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2238 if (ref
->type
!= REF_ARRAY
)
2241 if (ref
->u
.ar
.type
== AR_FULL
)
2242 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2244 if (ref
->u
.ar
.type
== AR_SECTION
)
2246 for (i
= 0; dimen
>= 0; i
++)
2247 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2250 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2254 if (array
->shape
&& array
->shape
[dimen
])
2256 mpz_init_set (*result
, array
->shape
[dimen
]);
2260 if (array
->symtree
->n
.sym
->attr
.generic
2261 && array
->value
.function
.esym
!= NULL
)
2263 if (spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
)
2267 else if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
)
2274 if (array
->shape
== NULL
) {
2275 /* Expressions with rank > 1 should have "shape" properly set */
2276 if ( array
->rank
!= 1 )
2277 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2278 return gfc_array_size(array
, result
);
2283 if (array
->shape
== NULL
)
2286 mpz_init_set (*result
, array
->shape
[dimen
]);
2295 /* Given an array expression, figure out how many elements are in the
2296 array. Returns SUCCESS if this is possible, and sets the 'result'
2297 variable. Otherwise returns FAILURE. */
2300 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2302 expand_info expand_save
;
2307 if (array
->ts
.type
== BT_CLASS
)
2310 switch (array
->expr_type
)
2313 gfc_push_suppress_errors ();
2315 expand_save
= current_expand
;
2317 current_expand
.count
= result
;
2318 mpz_init_set_ui (*result
, 0);
2320 current_expand
.expand_work_function
= count_elements
;
2323 t
= expand_constructor (array
->value
.constructor
);
2325 gfc_pop_suppress_errors ();
2328 mpz_clear (*result
);
2329 current_expand
= expand_save
;
2333 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2335 if (ref
->type
!= REF_ARRAY
)
2338 if (ref
->u
.ar
.type
== AR_FULL
)
2339 return spec_size (ref
->u
.ar
.as
, result
);
2341 if (ref
->u
.ar
.type
== AR_SECTION
)
2342 return ref_size (&ref
->u
.ar
, result
);
2345 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2349 if (array
->rank
== 0 || array
->shape
== NULL
)
2352 mpz_init_set_ui (*result
, 1);
2354 for (i
= 0; i
< array
->rank
; i
++)
2355 mpz_mul (*result
, *result
, array
->shape
[i
]);
2364 /* Given an array reference, return the shape of the reference in an
2365 array of mpz_t integers. */
2368 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2378 for (; d
< ar
->as
->rank
; d
++)
2379 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
2385 for (i
= 0; i
< ar
->dimen
; i
++)
2387 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2389 if (gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
) == FAILURE
)
2402 gfc_clear_shape (shape
, d
);
2407 /* Given an array expression, find the array reference structure that
2408 characterizes the reference. */
2411 gfc_find_array_ref (gfc_expr
*e
)
2415 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2416 if (ref
->type
== REF_ARRAY
2417 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2421 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2427 /* Find out if an array shape is known at compile time. */
2430 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2434 if (as
->type
!= AS_EXPLICIT
)
2437 for (i
= 0; i
< as
->rank
; i
++)
2438 if (!gfc_is_constant_expr (as
->lower
[i
])
2439 || !gfc_is_constant_expr (as
->upper
[i
]))