Line data Source code
1 : /* Copyright (C) 2002-2025 Free Software Foundation, Inc.
2 :
3 : This file is part of GCC.
4 :
5 : GCC is free software; you can redistribute it and/or modify it under
6 : the terms of the GNU General Public License as published by the Free
7 : Software Foundation; either version 3, or (at your option) any later
8 : version.
9 :
10 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
11 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
12 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13 : for more details.
14 :
15 : You should have received a copy of the GNU General Public License
16 : along with GCC; see the file COPYING3. If not see
17 : <http://www.gnu.org/licenses/>. */
18 :
19 :
20 : #include "config.h"
21 : #include "system.h"
22 : #include "coretypes.h"
23 : #include "tree.h"
24 : #include "fold-const.h"
25 : #include "gfortran.h"
26 : #include "trans.h"
27 : #include "trans-const.h"
28 : #include "trans-types.h"
29 : #include "trans-array.h"
30 :
31 :
32 : /* Array descriptor low level access routines.
33 : ******************************************************************************/
34 :
35 : /* Build expressions to access the members of an array descriptor.
36 : It's surprisingly easy to mess up here, so never access
37 : an array descriptor by "brute force", always use these
38 : functions. This also avoids problems if we change the format
39 : of an array descriptor.
40 :
41 : To understand these magic numbers, look at the comments
42 : before gfc_build_array_type() in trans-types.cc.
43 :
44 : The code within these defines should be the only code which knows the format
45 : of an array descriptor.
46 :
47 : Any code just needing to read obtain the bounds of an array should use
48 : gfc_conv_array_* rather than the following functions as these will return
49 : know constant values, and work with arrays which do not have descriptors.
50 :
51 : Don't forget to #undef these! */
52 :
53 : #define DATA_FIELD 0
54 : #define OFFSET_FIELD 1
55 : #define DTYPE_FIELD 2
56 : #define SPAN_FIELD 3
57 : #define DIMENSION_FIELD 4
58 : #define CAF_TOKEN_FIELD 5
59 :
60 : #define STRIDE_SUBFIELD 0
61 : #define LBOUND_SUBFIELD 1
62 : #define UBOUND_SUBFIELD 2
63 :
64 :
65 : /* Get FIELD_IDX'th field in struct TYPE. */
66 :
67 : static tree
68 2050250 : get_type_field (tree type, unsigned field_idx)
69 : {
70 2050250 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
71 2050250 : gcc_assert (field != NULL_TREE);
72 :
73 2050250 : return field;
74 : }
75 :
76 :
77 : /* Return a reference to the FIELD_IDX-th field of the descriptor DESC. */
78 :
79 : static tree
80 2050022 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
81 : {
82 2050022 : tree type = TREE_TYPE (desc);
83 2050022 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
84 :
85 2050022 : tree field = get_type_field (type, field_idx);
86 :
87 2050022 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
88 2050022 : desc, field, NULL_TREE);
89 : }
90 :
91 :
92 : /* Return a reference to the data field of the array descriptor DESC. */
93 :
94 : static tree
95 451629 : conv_descriptor_data (tree desc)
96 : {
97 0 : return gfc_get_descriptor_field (desc, DATA_FIELD);
98 : }
99 :
100 : /* This provides READ-ONLY access to the data field. The field itself
101 : doesn't have the proper type. */
102 :
103 : tree
104 290443 : gfc_conv_descriptor_data_get (tree desc)
105 : {
106 290443 : tree type = TREE_TYPE (desc);
107 290443 : if (TREE_CODE (type) == REFERENCE_TYPE)
108 0 : gcc_unreachable ();
109 :
110 290443 : tree data = conv_descriptor_data (desc);
111 290443 : return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), data);
112 : }
113 :
114 : /* This provides WRITE access to the data field. */
115 :
116 : void
117 161186 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
118 : {
119 161186 : tree data = conv_descriptor_data (desc);
120 161186 : gfc_add_modify (block, data, fold_convert (TREE_TYPE (data), value));
121 161186 : }
122 :
123 :
124 : /* Return a reference to the offset field of the array descriptor DESC. */
125 :
126 : static tree
127 210795 : conv_descriptor_offset (tree desc)
128 : {
129 210795 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
130 210795 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
131 210795 : return field;
132 : }
133 :
134 : /* Return the offset value of the array descriptor DESC. */
135 :
136 : tree
137 78517 : gfc_conv_descriptor_offset_get (tree desc)
138 : {
139 78517 : return conv_descriptor_offset (desc);
140 : }
141 :
142 : /* Add code to BLOCK assigning VALUE to the offset field of the array descriptor
143 : DESC. */
144 :
145 : void
146 132278 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, tree value)
147 : {
148 132278 : tree t = conv_descriptor_offset (desc);
149 132278 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
150 132278 : }
151 :
152 :
153 : /* Return a reference to the dtype field of the array descriptor DESC. */
154 :
155 : static tree
156 177366 : conv_descriptor_dtype (tree desc)
157 : {
158 177366 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
159 177366 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
160 177366 : return field;
161 : }
162 :
163 : /* Return the dtype value of the array descriptor DESC. */
164 :
165 : tree
166 3374 : gfc_conv_descriptor_dtype_get (tree desc)
167 : {
168 3374 : return conv_descriptor_dtype (desc);
169 : }
170 :
171 : /* Add code to BLOCK assigning VALUE to the dtype field of the array descriptor
172 : DESC. */
173 :
174 : void
175 141940 : gfc_conv_descriptor_dtype_set (stmtblock_t *block, tree desc, tree value)
176 : {
177 141940 : location_t loc = input_location;
178 141940 : tree t = conv_descriptor_dtype (desc);
179 141940 : gfc_add_modify_loc (loc, block, t,
180 141940 : fold_convert_loc (loc, TREE_TYPE (t), value));
181 141940 : }
182 :
183 :
184 : /* Return a reference to the span field of the array descriptor DESC. */
185 :
186 : static tree
187 155799 : conv_descriptor_span (tree desc)
188 : {
189 155799 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
190 155799 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
191 155799 : return field;
192 : }
193 :
194 : /* Return the span value of the array descriptor DESC. */
195 :
196 : tree
197 34222 : gfc_conv_descriptor_span_get (tree desc)
198 : {
199 34222 : return conv_descriptor_span (desc);
200 : }
201 :
202 : /* Add code to BLOCK assigning VALUE to the span field of the array descriptor
203 : DESC. */
204 :
205 : void
206 121577 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, tree value)
207 : {
208 121577 : tree t = conv_descriptor_span (desc);
209 121577 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
210 121577 : }
211 :
212 :
213 : /* Return a reference to the rank field of the array descriptor DESC. */
214 :
215 : static tree
216 22235 : conv_descriptor_rank (tree desc)
217 : {
218 22235 : tree tmp;
219 22235 : tree dtype;
220 :
221 22235 : dtype = conv_descriptor_dtype (desc);
222 22235 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
223 22235 : gcc_assert (tmp != NULL_TREE
224 : && TREE_TYPE (tmp) == gfc_array_dim_rank_type);
225 22235 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
226 22235 : dtype, tmp, NULL_TREE);
227 : }
228 :
229 : /* Return the rank value of the array descriptor DESC. */
230 :
231 : tree
232 21155 : gfc_conv_descriptor_rank_get (tree desc)
233 : {
234 21155 : return conv_descriptor_rank (desc);
235 : }
236 :
237 : /* Add code to BLOCK assigning VALUE to the rank field of the array descriptor
238 : DESC. */
239 :
240 : void
241 1080 : gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, tree value)
242 : {
243 1080 : location_t loc = input_location;
244 1080 : tree t = conv_descriptor_rank (desc);
245 1080 : gfc_add_modify_loc (loc, block, t,
246 1080 : fold_convert_loc (loc, TREE_TYPE (t), value));
247 1080 : }
248 :
249 : /* Add code to BLOCK assigning VALUE to the rank field of the array descriptor
250 : DESC. */
251 :
252 : void
253 493 : gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int value)
254 : {
255 493 : gfc_conv_descriptor_rank_set (block, desc, gfc_rank_cst[value]);
256 493 : }
257 :
258 :
259 : /* Return a reference to the format version field of the array descriptor
260 : DESC. */
261 :
262 : static tree
263 127 : conv_descriptor_version (tree desc)
264 : {
265 127 : tree tmp;
266 127 : tree dtype;
267 :
268 127 : dtype = conv_descriptor_dtype (desc);
269 127 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION);
270 127 : gcc_assert (tmp != NULL_TREE
271 : && TREE_TYPE (tmp) == integer_type_node);
272 127 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
273 127 : dtype, tmp, NULL_TREE);
274 : }
275 :
276 : /* Return the format version value of the array descriptor DESC. */
277 :
278 : tree
279 48 : gfc_conv_descriptor_version_get (tree desc)
280 : {
281 48 : return conv_descriptor_version (desc);
282 : }
283 :
284 : /* Add code to BLOCK assigning VALUE to the format version field of the array
285 : descriptor DESC. */
286 :
287 : void
288 79 : gfc_conv_descriptor_version_set (stmtblock_t *block, tree desc, tree value)
289 : {
290 79 : location_t loc = input_location;
291 79 : tree t = conv_descriptor_version (desc);
292 79 : gfc_add_modify_loc (loc, block, t,
293 79 : fold_convert_loc (loc, TREE_TYPE (t), value));
294 79 : }
295 :
296 :
297 : /* Return a reference to the element length field of the array descriptor
298 : DESC. */
299 :
300 : static tree
301 9503 : conv_descriptor_elem_len (tree desc)
302 : {
303 9503 : tree tmp;
304 9503 : tree dtype;
305 :
306 9503 : dtype = conv_descriptor_dtype (desc);
307 9503 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
308 : GFC_DTYPE_ELEM_LEN);
309 9503 : gcc_assert (tmp != NULL_TREE
310 : && TREE_TYPE (tmp) == size_type_node);
311 9503 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
312 9503 : dtype, tmp, NULL_TREE);
313 : }
314 :
315 : /* Return the element length value of the array descriptor DESC. */
316 :
317 : tree
318 9069 : gfc_conv_descriptor_elem_len_get (tree desc)
319 : {
320 9069 : return conv_descriptor_elem_len (desc);
321 : }
322 :
323 : /* Add code to BLOCK assigning VALUE to the element length field of the array
324 : descriptor DESC. */
325 :
326 : void
327 434 : gfc_conv_descriptor_elem_len_set (stmtblock_t *block, tree desc, tree value)
328 : {
329 434 : location_t loc = input_location;
330 434 : tree t = conv_descriptor_elem_len (desc);
331 434 : gfc_add_modify_loc (loc, block, t,
332 434 : fold_convert_loc (loc, TREE_TYPE (t), value));
333 434 : }
334 :
335 :
336 : /* Return a reference to the type discriminator field of the array descriptor
337 : DESC. */
338 :
339 : static tree
340 187 : conv_descriptor_type (tree desc)
341 : {
342 187 : tree tmp;
343 187 : tree dtype;
344 :
345 187 : dtype = conv_descriptor_dtype (desc);
346 187 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
347 187 : gcc_assert (tmp!= NULL_TREE
348 : && TREE_TYPE (tmp) == signed_char_type_node);
349 187 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
350 187 : dtype, tmp, NULL_TREE);
351 : }
352 :
353 : /* Return the type discriminator value of the array descriptor DESC. */
354 :
355 : tree
356 54 : gfc_conv_descriptor_type_get (tree desc)
357 : {
358 54 : return conv_descriptor_type (desc);
359 : }
360 :
361 : /* Add code to BLOCK assigning VALUE to the type discriminator field of the
362 : array descriptor DESC. */
363 :
364 : void
365 133 : gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, tree value)
366 : {
367 133 : location_t loc = input_location;
368 133 : tree t = conv_descriptor_type (desc);
369 133 : gfc_add_modify_loc (loc, block, t,
370 133 : fold_convert_loc (loc, TREE_TYPE (t), value));
371 133 : }
372 :
373 : /* Add code to BLOCK assigning VALUE to the type discriminator field of the
374 : array descriptor DESC. */
375 :
376 : void
377 114 : gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, int value)
378 : {
379 114 : tree type = TREE_TYPE (desc);
380 114 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
381 :
382 114 : tree dtype = get_type_field (type, DTYPE_FIELD);
383 114 : tree field = get_type_field (TREE_TYPE (dtype), GFC_DTYPE_TYPE);
384 114 : tree type_value = build_int_cst (TREE_TYPE (field), value);
385 :
386 114 : gfc_conv_descriptor_type_set (block, desc, type_value);
387 114 : }
388 :
389 : /* Return a statement assigning VALUE to the type discriminator field of the
390 : array descriptor DESC. */
391 :
392 : tree
393 19 : gfc_conv_descriptor_type_set (tree desc, tree value)
394 : {
395 19 : stmtblock_t block;
396 :
397 19 : gfc_init_block (&block);
398 19 : gfc_conv_descriptor_type_set (&block, desc, value);
399 19 : return gfc_finish_block (&block);
400 : }
401 :
402 : /* Return a statement assigning VALUE to the type discriminator field of the
403 : array descriptor DESC. */
404 :
405 : tree
406 114 : gfc_conv_descriptor_type_set (tree desc, int value)
407 : {
408 114 : stmtblock_t block;
409 :
410 114 : gfc_init_block (&block);
411 114 : gfc_conv_descriptor_type_set (&block, desc, value);
412 114 : return gfc_finish_block (&block);
413 : }
414 :
415 :
416 : /* Return a reference to the array of dimension descriptors of the array
417 : descriptor DESC. */
418 :
419 : tree
420 1052021 : gfc_get_descriptor_dimension (tree desc)
421 : {
422 1052021 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
423 1052021 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
424 : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
425 1052021 : return field;
426 : }
427 :
428 :
429 : /* Return a reference to the dimension descriptor for the (zero-based) dimension
430 : DIM of the array descriptor DESC. */
431 :
432 : static tree
433 1047779 : conv_descriptor_dimension (tree desc, tree dim)
434 : {
435 1047779 : tree tmp;
436 :
437 1047779 : tmp = gfc_get_descriptor_dimension (desc);
438 :
439 1047779 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
440 : }
441 :
442 :
443 : /* Return a reference to the coarray token field of the array descriptor
444 : DESC. */
445 :
446 : tree
447 2412 : gfc_conv_descriptor_token (tree desc)
448 : {
449 2412 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
450 2412 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
451 : /* Should be a restricted pointer - except in the finalization wrapper. */
452 2412 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
453 : || TREE_TYPE (field) == pvoid_type_node);
454 2412 : return field;
455 : }
456 :
457 : /* Add code to BLOCK assigning VALUE to the coarray token field of the array
458 : descriptor DESC. */
459 :
460 : void
461 585 : gfc_conv_descriptor_token_set (stmtblock_t *block, tree desc, tree value)
462 : {
463 585 : location_t loc = input_location;
464 585 : tree t = gfc_conv_descriptor_token (desc);
465 585 : gfc_add_modify_loc (loc, block, t,
466 585 : fold_convert_loc (loc, TREE_TYPE (t), value));
467 585 : }
468 :
469 :
470 : /* Return a reference to the FIELD_IDX'th subfield of the dimension descriptor
471 : of the (zero-based) dimension DIM of the array descriptor DESC. */
472 :
473 : static tree
474 1047779 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
475 : {
476 1047779 : tree tmp = conv_descriptor_dimension (desc, dim);
477 1047779 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
478 1047779 : gcc_assert (field != NULL_TREE);
479 :
480 1047779 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
481 1047779 : tmp, field, NULL_TREE);
482 : }
483 :
484 :
485 : /* Return a reference to the stride field of the (zero-based) dimension DIM of
486 : the array descriptor DESC. */
487 :
488 : static tree
489 279602 : conv_descriptor_stride (tree desc, tree dim)
490 : {
491 279602 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
492 279602 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
493 279602 : return field;
494 : }
495 :
496 : /* Return the stride value for the (zero-based) dimension DIM of the array
497 : descriptor DESC. */
498 :
499 : tree
500 172602 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
501 : {
502 172602 : tree type = TREE_TYPE (desc);
503 172602 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
504 172602 : if (integer_zerop (dim)
505 172602 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
506 44731 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
507 43644 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
508 43488 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
509 43338 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
510 43338 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
511 72989 : return gfc_index_one_node;
512 :
513 99613 : return conv_descriptor_stride (desc, dim);
514 : }
515 :
516 : /* Add code to BLOCK assigning VALUE to the stride field of the (zero-based)
517 : dimension DIM of the array descriptor DESC. */
518 :
519 : void
520 179989 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
521 : tree dim, tree value)
522 : {
523 179989 : tree t = conv_descriptor_stride (desc, dim);
524 179989 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
525 179989 : }
526 :
527 :
528 : /* Return a reference to the lower bound field of the (zero-based) dimension DIM
529 : of the array descriptor DESC. */
530 :
531 : static tree
532 398704 : conv_descriptor_lbound (tree desc, tree dim)
533 : {
534 398704 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
535 398704 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
536 398704 : return field;
537 : }
538 :
539 : /* Return the lower bound value for the (zero-based) dimension DIM of the array
540 : descriptor DESC. */
541 :
542 : tree
543 213896 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
544 : {
545 213896 : return conv_descriptor_lbound (desc, dim);
546 : }
547 :
548 : /* Add code to BLOCK assigning VALUE to the lower bound field of the
549 : (zero-based) dimension DIM of the array descriptor DESC. */
550 :
551 : void
552 184808 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
553 : tree dim, tree value)
554 : {
555 184808 : tree t = conv_descriptor_lbound (desc, dim);
556 184808 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
557 184808 : }
558 :
559 :
560 : /* Return a reference to the upper bound field of the (zero-based) dimension DIM
561 : of the array descriptor DESC. */
562 :
563 : static tree
564 369473 : conv_descriptor_ubound (tree desc, tree dim)
565 : {
566 369473 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
567 369473 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
568 369473 : return field;
569 : }
570 :
571 : /* Return the upper bound value for the (zero-based) dimension DIM of the array
572 : descriptor DESC. */
573 :
574 : tree
575 184931 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
576 : {
577 184931 : return conv_descriptor_ubound (desc, dim);
578 : }
579 :
580 : /* Add code to BLOCK assigning VALUE to the upper bound field of the
581 : (zero-based) dimension DIM of the array descriptor DESC. */
582 :
583 : void
584 184542 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
585 : tree dim, tree value)
586 : {
587 184542 : tree t = conv_descriptor_ubound (desc, dim);
588 184542 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
589 184542 : }
590 :
591 :
592 : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
593 :
594 : void
595 277442 : gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
596 : tree *dtype_off, tree *span_off,
597 : tree *dim_off, tree *dim_size,
598 : tree *stride_suboff, tree *lower_suboff,
599 : tree *upper_suboff)
600 : {
601 277442 : tree field;
602 277442 : tree type;
603 :
604 277442 : type = TYPE_MAIN_VARIANT (desc_type);
605 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
606 277442 : *data_off = byte_position (field);
607 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
608 277442 : *dtype_off = byte_position (field);
609 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
610 277442 : *span_off = byte_position (field);
611 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
612 277442 : *dim_off = byte_position (field);
613 277442 : type = TREE_TYPE (TREE_TYPE (field));
614 277442 : *dim_size = TYPE_SIZE_UNIT (type);
615 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
616 277442 : *stride_suboff = byte_position (field);
617 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
618 277442 : *lower_suboff = byte_position (field);
619 277442 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
620 277442 : *upper_suboff = byte_position (field);
621 277442 : }
622 :
623 :
624 : /* Array descriptor higher level routines.
625 : ******************************************************************************/
626 :
627 : /* Build a null array descriptor constructor. */
628 :
629 : tree
630 1088 : gfc_build_null_descriptor (tree type)
631 : {
632 1088 : tree field;
633 1088 : tree tmp;
634 :
635 1088 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
636 1088 : gcc_assert (DATA_FIELD == 0);
637 1088 : field = TYPE_FIELDS (type);
638 :
639 : /* Set a NULL data pointer. */
640 1088 : tmp = build_constructor_single (type, field, null_pointer_node);
641 1088 : TREE_CONSTANT (tmp) = 1;
642 : /* All other fields are ignored. */
643 :
644 1088 : return tmp;
645 : }
646 :
647 :
648 : /* Cleanup those #defines. */
649 :
650 : #undef DATA_FIELD
651 : #undef OFFSET_FIELD
652 : #undef DTYPE_FIELD
653 : #undef SPAN_FIELD
654 : #undef DIMENSION_FIELD
655 : #undef CAF_TOKEN_FIELD
656 : #undef STRIDE_SUBFIELD
657 : #undef LBOUND_SUBFIELD
658 : #undef UBOUND_SUBFIELD
659 :
660 :
661 : /* For an array descriptor, get the total number of elements. This is just
662 : the product of the extents along from_dim to to_dim. */
663 :
664 : static tree
665 1954 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
666 : {
667 1954 : tree res;
668 1954 : int dim;
669 :
670 1954 : res = gfc_index_one_node;
671 :
672 4777 : for (dim = from_dim; dim < to_dim; ++dim)
673 : {
674 2823 : tree lbound;
675 2823 : tree ubound;
676 2823 : tree extent;
677 :
678 2823 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
679 2823 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
680 :
681 2823 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
682 2823 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
683 : res, extent);
684 : }
685 :
686 1954 : return res;
687 : }
688 :
689 :
690 : /* Full size of an array. */
691 :
692 : tree
693 1890 : gfc_conv_descriptor_size (tree desc, int rank)
694 : {
695 1890 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
696 : }
697 :
698 :
699 : /* Size of a coarray for all dimensions but the last. */
700 :
701 : tree
702 64 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
703 : {
704 64 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
705 : }
706 :
707 :
708 : /* Modify a descriptor such that the lbound of a given dimension is the value
709 : specified. This also updates ubound and offset accordingly. */
710 :
711 : void
712 955 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
713 : int dim, tree new_lbound)
714 : {
715 955 : tree offs, ubound, lbound, stride;
716 955 : tree diff, offs_diff;
717 :
718 955 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
719 :
720 955 : offs = gfc_conv_descriptor_offset_get (desc);
721 955 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
722 955 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
723 955 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
724 :
725 : /* Get difference (new - old) by which to shift stuff. */
726 955 : diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
727 : new_lbound, lbound);
728 :
729 : /* Shift ubound and offset accordingly. This has to be done before
730 : updating the lbound, as they depend on the lbound expression! */
731 955 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
732 : ubound, diff);
733 955 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
734 955 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
735 : diff, stride);
736 955 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
737 : offs, offs_diff);
738 955 : gfc_conv_descriptor_offset_set (block, desc, offs);
739 :
740 : /* Finally set lbound to value we want. */
741 955 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
742 955 : }
743 :
744 :
745 : void
746 1750 : gfc_copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
747 : {
748 1750 : int n;
749 1750 : tree dim;
750 1750 : tree tmp;
751 1750 : tree tmp2;
752 1750 : tree size;
753 1750 : tree offset;
754 :
755 1750 : offset = gfc_index_zero_node;
756 :
757 : /* Use memcpy to copy the descriptor. The size is the minimum of
758 : the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
759 1750 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
760 1750 : tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
761 1750 : size = fold_build2_loc (input_location, MIN_EXPR,
762 1750 : TREE_TYPE (tmp), tmp, tmp2);
763 1750 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
764 1750 : tmp = build_call_expr_loc (input_location, tmp, 3,
765 : gfc_build_addr_expr (NULL_TREE, dst),
766 : gfc_build_addr_expr (NULL_TREE, src),
767 : fold_convert (size_type_node, size));
768 1750 : gfc_add_expr_to_block (block, tmp);
769 :
770 : /* Set the offset correctly. */
771 8694 : for (n = 0; n < rank; n++)
772 : {
773 5194 : dim = gfc_rank_cst[n];
774 5194 : tmp = gfc_conv_descriptor_lbound_get (src, dim);
775 5194 : tmp2 = gfc_conv_descriptor_stride_get (src, dim);
776 5194 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
777 : tmp, tmp2);
778 5194 : offset = fold_build2_loc (input_location, MINUS_EXPR,
779 5194 : TREE_TYPE (offset), offset, tmp);
780 5194 : offset = gfc_evaluate_now (offset, block);
781 : }
782 :
783 1750 : gfc_conv_descriptor_offset_set (block, dst, offset);
784 1750 : }
785 :
786 :
787 : /* Extend the data in array DESC by EXTRA elements. */
788 :
789 : void
790 1066 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
791 : {
792 1066 : tree arg0, arg1;
793 1066 : tree tmp;
794 1066 : tree size;
795 1066 : tree ubound;
796 :
797 1066 : if (integer_zerop (extra))
798 : return;
799 :
800 1036 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
801 :
802 : /* Add EXTRA to the upper bound. */
803 1036 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
804 : ubound, extra);
805 1036 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
806 :
807 : /* Get the value of the current data pointer. */
808 1036 : arg0 = gfc_conv_descriptor_data_get (desc);
809 :
810 : /* Calculate the new array size. */
811 1036 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
812 1036 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
813 : ubound, gfc_index_one_node);
814 1036 : arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
815 : fold_convert (size_type_node, tmp),
816 : fold_convert (size_type_node, size));
817 :
818 : /* Call the realloc() function. */
819 1036 : tmp = gfc_call_realloc (pblock, arg0, arg1);
820 1036 : gfc_conv_descriptor_data_set (pblock, desc, tmp);
821 : }
|
