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 : #define GFC_DTYPE_ELEM_LEN 0
65 : #define GFC_DTYPE_VERSION 1
66 : #define GFC_DTYPE_RANK 2
67 : #define GFC_DTYPE_TYPE 3
68 : #define GFC_DTYPE_ATTRIBUTE 4
69 :
70 :
71 : /* Get FIELD_IDX'th field in struct TYPE. */
72 :
73 : static tree
74 2081461 : get_type_field (tree type, unsigned field_idx)
75 : {
76 2081461 : tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
77 2081461 : gcc_assert (field != NULL_TREE);
78 :
79 2081461 : return field;
80 : }
81 :
82 :
83 : /* Return a reference to the FIELD_IDX-th field of the descriptor DESC. */
84 :
85 : static tree
86 2081233 : gfc_get_descriptor_field (tree desc, unsigned field_idx)
87 : {
88 2081233 : tree type = TREE_TYPE (desc);
89 2081233 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
90 :
91 2081233 : tree field = get_type_field (type, field_idx);
92 :
93 2081233 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
94 2081233 : desc, field, NULL_TREE);
95 : }
96 :
97 :
98 : /* Return a reference to the data field of the array descriptor DESC. */
99 :
100 : static tree
101 459204 : conv_descriptor_data (tree desc)
102 : {
103 0 : return gfc_get_descriptor_field (desc, DATA_FIELD);
104 : }
105 :
106 : /* This provides READ-ONLY access to the data field. The field itself
107 : doesn't have the proper type. */
108 :
109 : tree
110 295236 : gfc_conv_descriptor_data_get (tree desc)
111 : {
112 295236 : tree type = TREE_TYPE (desc);
113 295236 : if (TREE_CODE (type) == REFERENCE_TYPE)
114 0 : gcc_unreachable ();
115 :
116 295236 : tree data = conv_descriptor_data (desc);
117 295236 : return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), data);
118 : }
119 :
120 : /* This provides WRITE access to the data field. */
121 :
122 : void
123 163968 : gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
124 : {
125 163968 : tree data = conv_descriptor_data (desc);
126 163968 : gfc_add_modify (block, data, fold_convert (TREE_TYPE (data), value));
127 163968 : }
128 :
129 :
130 : /* Return a reference to the offset field of the array descriptor DESC. */
131 :
132 : static tree
133 213037 : conv_descriptor_offset (tree desc)
134 : {
135 213037 : tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
136 213037 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
137 213037 : return field;
138 : }
139 :
140 : /* Return the offset value of the array descriptor DESC. */
141 :
142 : tree
143 79431 : gfc_conv_descriptor_offset_get (tree desc)
144 : {
145 79431 : return conv_descriptor_offset (desc);
146 : }
147 :
148 : /* Add code to BLOCK assigning VALUE to the offset field of the array descriptor
149 : DESC. */
150 :
151 : void
152 133606 : gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, tree value)
153 : {
154 133606 : tree t = conv_descriptor_offset (desc);
155 133606 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
156 133606 : }
157 :
158 :
159 : /* Return a reference to the dtype field of the array descriptor DESC. */
160 :
161 : static tree
162 181230 : conv_descriptor_dtype (tree desc)
163 : {
164 181230 : tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
165 181230 : gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
166 181230 : return field;
167 : }
168 :
169 : /* Return the dtype value of the array descriptor DESC. */
170 :
171 : tree
172 3398 : gfc_conv_descriptor_dtype_get (tree desc)
173 : {
174 3398 : return conv_descriptor_dtype (desc);
175 : }
176 :
177 : /* Add code to BLOCK assigning VALUE to the dtype field of the array descriptor
178 : DESC. */
179 :
180 : void
181 144337 : gfc_conv_descriptor_dtype_set (stmtblock_t *block, tree desc, tree value)
182 : {
183 144337 : location_t loc = input_location;
184 144337 : tree t = conv_descriptor_dtype (desc);
185 144337 : gfc_add_modify_loc (loc, block, t,
186 144337 : fold_convert_loc (loc, TREE_TYPE (t), value));
187 144337 : }
188 :
189 :
190 : /* Return a reference to the span field of the array descriptor DESC. */
191 :
192 : static tree
193 163377 : conv_descriptor_span (tree desc)
194 : {
195 163377 : tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
196 163377 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
197 163377 : return field;
198 : }
199 :
200 : /* Return the span value of the array descriptor DESC. */
201 :
202 : tree
203 37720 : gfc_conv_descriptor_span_get (tree desc)
204 : {
205 37720 : return conv_descriptor_span (desc);
206 : }
207 :
208 : /* Add code to BLOCK assigning VALUE to the span field of the array descriptor
209 : DESC. */
210 :
211 : void
212 125657 : gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, tree value)
213 : {
214 125657 : tree t = conv_descriptor_span (desc);
215 125657 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
216 125657 : }
217 :
218 :
219 : /* Return a reference to the rank field of the array descriptor DESC. */
220 :
221 : static tree
222 22713 : conv_descriptor_rank (tree desc)
223 : {
224 22713 : tree tmp;
225 22713 : tree dtype;
226 :
227 22713 : dtype = conv_descriptor_dtype (desc);
228 22713 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
229 22713 : gcc_assert (tmp != NULL_TREE
230 : && TREE_TYPE (tmp) == gfc_array_dim_rank_type);
231 22713 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
232 22713 : dtype, tmp, NULL_TREE);
233 : }
234 :
235 : /* Return the rank value of the array descriptor DESC. */
236 :
237 : tree
238 21849 : gfc_conv_descriptor_rank_get (tree desc)
239 : {
240 21849 : return conv_descriptor_rank (desc);
241 : }
242 :
243 : /* Add code to BLOCK assigning VALUE to the rank field of the array descriptor
244 : DESC. */
245 :
246 : void
247 864 : gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, tree value)
248 : {
249 864 : location_t loc = input_location;
250 864 : tree t = conv_descriptor_rank (desc);
251 864 : gfc_add_modify_loc (loc, block, t,
252 864 : fold_convert_loc (loc, TREE_TYPE (t), value));
253 864 : }
254 :
255 : /* Add code to BLOCK assigning VALUE to the rank field of the array descriptor
256 : DESC. */
257 :
258 : void
259 277 : gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int value)
260 : {
261 277 : gfc_conv_descriptor_rank_set (block, desc, gfc_rank_cst[value]);
262 277 : }
263 :
264 :
265 : /* Return a reference to the format version field of the array descriptor
266 : DESC. */
267 :
268 : static tree
269 127 : conv_descriptor_version (tree desc)
270 : {
271 127 : tree tmp;
272 127 : tree dtype;
273 :
274 127 : dtype = conv_descriptor_dtype (desc);
275 127 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION);
276 127 : gcc_assert (tmp != NULL_TREE
277 : && TREE_TYPE (tmp) == integer_type_node);
278 127 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
279 127 : dtype, tmp, NULL_TREE);
280 : }
281 :
282 : /* Return the format version value of the array descriptor DESC. */
283 :
284 : tree
285 48 : gfc_conv_descriptor_version_get (tree desc)
286 : {
287 48 : return conv_descriptor_version (desc);
288 : }
289 :
290 : /* Add code to BLOCK assigning VALUE to the format version field of the array
291 : descriptor DESC. */
292 :
293 : void
294 79 : gfc_conv_descriptor_version_set (stmtblock_t *block, tree desc, tree value)
295 : {
296 79 : location_t loc = input_location;
297 79 : tree t = conv_descriptor_version (desc);
298 79 : gfc_add_modify_loc (loc, block, t,
299 79 : fold_convert_loc (loc, TREE_TYPE (t), value));
300 79 : }
301 :
302 :
303 : /* Return a reference to the element length field of the array descriptor
304 : DESC. */
305 :
306 : static tree
307 10468 : conv_descriptor_elem_len (tree desc)
308 : {
309 10468 : tree tmp;
310 10468 : tree dtype;
311 :
312 10468 : dtype = conv_descriptor_dtype (desc);
313 10468 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
314 : GFC_DTYPE_ELEM_LEN);
315 10468 : gcc_assert (tmp != NULL_TREE
316 : && TREE_TYPE (tmp) == size_type_node);
317 10468 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
318 10468 : dtype, tmp, NULL_TREE);
319 : }
320 :
321 : /* Return the element length value of the array descriptor DESC. */
322 :
323 : tree
324 10034 : gfc_conv_descriptor_elem_len_get (tree desc)
325 : {
326 10034 : return conv_descriptor_elem_len (desc);
327 : }
328 :
329 : /* Add code to BLOCK assigning VALUE to the element length field of the array
330 : descriptor DESC. */
331 :
332 : void
333 434 : gfc_conv_descriptor_elem_len_set (stmtblock_t *block, tree desc, tree value)
334 : {
335 434 : location_t loc = input_location;
336 434 : tree t = conv_descriptor_elem_len (desc);
337 434 : gfc_add_modify_loc (loc, block, t,
338 434 : fold_convert_loc (loc, TREE_TYPE (t), value));
339 434 : }
340 :
341 :
342 : /* Return a reference to the type discriminator field of the array descriptor
343 : DESC. */
344 :
345 : static tree
346 187 : conv_descriptor_type (tree desc)
347 : {
348 187 : tree tmp;
349 187 : tree dtype;
350 :
351 187 : dtype = conv_descriptor_dtype (desc);
352 187 : tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
353 187 : gcc_assert (tmp!= NULL_TREE
354 : && TREE_TYPE (tmp) == signed_char_type_node);
355 187 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
356 187 : dtype, tmp, NULL_TREE);
357 : }
358 :
359 : /* Return the type discriminator value of the array descriptor DESC. */
360 :
361 : tree
362 54 : gfc_conv_descriptor_type_get (tree desc)
363 : {
364 54 : return conv_descriptor_type (desc);
365 : }
366 :
367 : /* Add code to BLOCK assigning VALUE to the type discriminator field of the
368 : array descriptor DESC. */
369 :
370 : void
371 133 : gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, tree value)
372 : {
373 133 : location_t loc = input_location;
374 133 : tree t = conv_descriptor_type (desc);
375 133 : gfc_add_modify_loc (loc, block, t,
376 133 : fold_convert_loc (loc, TREE_TYPE (t), value));
377 133 : }
378 :
379 : /* Add code to BLOCK assigning VALUE to the type discriminator field of the
380 : array descriptor DESC. */
381 :
382 : void
383 114 : gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, int value)
384 : {
385 114 : tree type = TREE_TYPE (desc);
386 114 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
387 :
388 114 : tree dtype = get_type_field (type, DTYPE_FIELD);
389 114 : tree field = get_type_field (TREE_TYPE (dtype), GFC_DTYPE_TYPE);
390 114 : tree type_value = build_int_cst (TREE_TYPE (field), value);
391 :
392 114 : gfc_conv_descriptor_type_set (block, desc, type_value);
393 114 : }
394 :
395 : /* Return a statement assigning VALUE to the type discriminator field of the
396 : array descriptor DESC. */
397 :
398 : tree
399 19 : gfc_conv_descriptor_type_set (tree desc, tree value)
400 : {
401 19 : stmtblock_t block;
402 :
403 19 : gfc_init_block (&block);
404 19 : gfc_conv_descriptor_type_set (&block, desc, value);
405 19 : return gfc_finish_block (&block);
406 : }
407 :
408 : /* Return a statement assigning VALUE to the type discriminator field of the
409 : array descriptor DESC. */
410 :
411 : tree
412 114 : gfc_conv_descriptor_type_set (tree desc, int value)
413 : {
414 114 : stmtblock_t block;
415 :
416 114 : gfc_init_block (&block);
417 114 : gfc_conv_descriptor_type_set (&block, desc, value);
418 114 : return gfc_finish_block (&block);
419 : }
420 :
421 :
422 : /* Return a reference to the array of dimension descriptors of the array
423 : descriptor DESC. */
424 :
425 : tree
426 1061957 : gfc_get_descriptor_dimension (tree desc)
427 : {
428 1061957 : tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
429 1061957 : gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
430 : && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
431 1061957 : return field;
432 : }
433 :
434 :
435 : /* Return a reference to the dimension descriptor for the (zero-based) dimension
436 : DIM of the array descriptor DESC. */
437 :
438 : static tree
439 1057703 : conv_descriptor_dimension (tree desc, tree dim)
440 : {
441 1057703 : tree tmp;
442 :
443 1057703 : tmp = gfc_get_descriptor_dimension (desc);
444 :
445 1057703 : return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
446 : }
447 :
448 :
449 : /* Return a reference to the coarray token field of the array descriptor
450 : DESC. */
451 :
452 : tree
453 2428 : gfc_conv_descriptor_token (tree desc)
454 : {
455 2428 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
456 2428 : tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
457 : /* Should be a restricted pointer - except in the finalization wrapper. */
458 2428 : gcc_assert (TREE_TYPE (field) == prvoid_type_node
459 : || TREE_TYPE (field) == pvoid_type_node);
460 2428 : return field;
461 : }
462 :
463 : /* Add code to BLOCK assigning VALUE to the coarray token field of the array
464 : descriptor DESC. */
465 :
466 : void
467 597 : gfc_conv_descriptor_token_set (stmtblock_t *block, tree desc, tree value)
468 : {
469 597 : location_t loc = input_location;
470 597 : tree t = gfc_conv_descriptor_token (desc);
471 597 : gfc_add_modify_loc (loc, block, t,
472 597 : fold_convert_loc (loc, TREE_TYPE (t), value));
473 597 : }
474 :
475 :
476 : /* Return a reference to the FIELD_IDX'th subfield of the dimension descriptor
477 : of the (zero-based) dimension DIM of the array descriptor DESC. */
478 :
479 : static tree
480 1057703 : gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
481 : {
482 1057703 : tree tmp = conv_descriptor_dimension (desc, dim);
483 1057703 : tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
484 1057703 : gcc_assert (field != NULL_TREE);
485 :
486 1057703 : return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
487 1057703 : tmp, field, NULL_TREE);
488 : }
489 :
490 :
491 : /* Return a reference to the stride field of the (zero-based) dimension DIM of
492 : the array descriptor DESC. */
493 :
494 : static tree
495 282374 : conv_descriptor_stride (tree desc, tree dim)
496 : {
497 282374 : tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
498 282374 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
499 282374 : return field;
500 : }
501 :
502 : /* Return the stride value for the (zero-based) dimension DIM of the array
503 : descriptor DESC. */
504 :
505 : tree
506 174899 : gfc_conv_descriptor_stride_get (tree desc, tree dim)
507 : {
508 174899 : tree type = TREE_TYPE (desc);
509 174899 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
510 174899 : if (integer_zerop (dim)
511 174899 : && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
512 45314 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
513 44227 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
514 44071 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
515 43921 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
516 43921 : || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
517 74065 : return gfc_index_one_node;
518 :
519 100834 : return conv_descriptor_stride (desc, dim);
520 : }
521 :
522 : /* Add code to BLOCK assigning VALUE to the stride field of the (zero-based)
523 : dimension DIM of the array descriptor DESC. */
524 :
525 : void
526 181540 : gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
527 : tree dim, tree value)
528 : {
529 181540 : tree t = conv_descriptor_stride (desc, dim);
530 181540 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
531 181540 : }
532 :
533 :
534 : /* Return a reference to the lower bound field of the (zero-based) dimension DIM
535 : of the array descriptor DESC. */
536 :
537 : static tree
538 402433 : conv_descriptor_lbound (tree desc, tree dim)
539 : {
540 402433 : tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
541 402433 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
542 402433 : return field;
543 : }
544 :
545 : /* Return the lower bound value for the (zero-based) dimension DIM of the array
546 : descriptor DESC. */
547 :
548 : tree
549 215984 : gfc_conv_descriptor_lbound_get (tree desc, tree dim)
550 : {
551 215984 : return conv_descriptor_lbound (desc, dim);
552 : }
553 :
554 : /* Add code to BLOCK assigning VALUE to the lower bound field of the
555 : (zero-based) dimension DIM of the array descriptor DESC. */
556 :
557 : void
558 186449 : gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
559 : tree dim, tree value)
560 : {
561 186449 : tree t = conv_descriptor_lbound (desc, dim);
562 186449 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
563 186449 : }
564 :
565 :
566 : /* Return a reference to the upper bound field of the (zero-based) dimension DIM
567 : of the array descriptor DESC. */
568 :
569 : static tree
570 372896 : conv_descriptor_ubound (tree desc, tree dim)
571 : {
572 372896 : tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
573 372896 : gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
574 372896 : return field;
575 : }
576 :
577 : /* Return the upper bound value for the (zero-based) dimension DIM of the array
578 : descriptor DESC. */
579 :
580 : tree
581 186731 : gfc_conv_descriptor_ubound_get (tree desc, tree dim)
582 : {
583 186731 : return conv_descriptor_ubound (desc, dim);
584 : }
585 :
586 : /* Add code to BLOCK assigning VALUE to the upper bound field of the
587 : (zero-based) dimension DIM of the array descriptor DESC. */
588 :
589 : void
590 186165 : gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
591 : tree dim, tree value)
592 : {
593 186165 : tree t = conv_descriptor_ubound (desc, dim);
594 186165 : gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
595 186165 : }
596 :
597 :
598 : /* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
599 :
600 : void
601 280856 : gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
602 : tree *rank_off, tree *span_off,
603 : tree *dim_off, tree *dim_size,
604 : tree *stride_suboff, tree *lower_suboff,
605 : tree *upper_suboff)
606 : {
607 280856 : tree field;
608 280856 : tree type;
609 :
610 280856 : type = TYPE_MAIN_VARIANT (desc_type);
611 280856 : tree fields = TYPE_FIELDS (type);
612 280856 : field = gfc_advance_chain (fields, DATA_FIELD);
613 280856 : *data_off = byte_position (field);
614 280856 : field = gfc_advance_chain (fields, DTYPE_FIELD);
615 280856 : tree dtype_off = byte_position (field);
616 280856 : type = TREE_TYPE (field);
617 280856 : field = gfc_advance_chain (TYPE_FIELDS (type), GFC_DTYPE_RANK);
618 280856 : tree rank_suboff = byte_position (field);
619 280856 : *rank_off = fold_build2 (PLUS_EXPR, TREE_TYPE (dtype_off), dtype_off,
620 : rank_suboff);
621 280856 : field = gfc_advance_chain (fields, SPAN_FIELD);
622 280856 : *span_off = byte_position (field);
623 280856 : field = gfc_advance_chain (fields, DIMENSION_FIELD);
624 280856 : *dim_off = byte_position (field);
625 280856 : type = TREE_TYPE (TREE_TYPE (field));
626 280856 : *dim_size = TYPE_SIZE_UNIT (type);
627 280856 : field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
628 280856 : *stride_suboff = byte_position (field);
629 280856 : field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
630 280856 : *lower_suboff = byte_position (field);
631 280856 : field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
632 280856 : *upper_suboff = byte_position (field);
633 280856 : }
634 :
635 :
636 : /* Array descriptor higher level routines.
637 : ******************************************************************************/
638 :
639 : /* Return a constructor for a descriptor dtype with the caracteristics given by
640 : the arguments. */
641 :
642 : tree
643 145806 : gfc_build_dtype_constructor (tree size, int type, int rank)
644 : {
645 145806 : tree field;
646 145806 : vec<constructor_elt, va_gc> *v = NULL;
647 :
648 145806 : gcc_assert (size);
649 :
650 145806 : STRIP_NOPS (size);
651 145806 : size = fold_convert (size_type_node, size);
652 145806 : tree dtype_type_node = get_dtype_type_node ();
653 145806 : field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
654 : GFC_DTYPE_ELEM_LEN);
655 145806 : CONSTRUCTOR_APPEND_ELT (v, field,
656 : fold_convert (TREE_TYPE (field), size));
657 145806 : field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
658 : GFC_DTYPE_VERSION);
659 145806 : CONSTRUCTOR_APPEND_ELT (v, field,
660 : build_zero_cst (TREE_TYPE (field)));
661 :
662 145806 : field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
663 : GFC_DTYPE_RANK);
664 145806 : if (rank >= 0)
665 145219 : CONSTRUCTOR_APPEND_ELT (v, field,
666 : build_int_cst (TREE_TYPE (field), rank));
667 :
668 145806 : field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
669 : GFC_DTYPE_TYPE);
670 145806 : CONSTRUCTOR_APPEND_ELT (v, field,
671 : build_int_cst (TREE_TYPE (field), type));
672 :
673 145806 : return build_constructor (dtype_type_node, v);
674 : }
675 :
676 :
677 : /* Build a null array descriptor constructor. */
678 :
679 : tree
680 1124 : gfc_build_null_descriptor (tree type)
681 : {
682 1124 : tree field;
683 1124 : tree tmp;
684 :
685 1124 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
686 1124 : gcc_assert (DATA_FIELD == 0);
687 1124 : field = TYPE_FIELDS (type);
688 :
689 : /* Set a NULL data pointer. */
690 1124 : tmp = build_constructor_single (type, field, null_pointer_node);
691 1124 : TREE_CONSTANT (tmp) = 1;
692 : /* All other fields are ignored. */
693 :
694 1124 : return tmp;
695 : }
696 :
697 :
698 : /* Cleanup those #defines. */
699 :
700 : #undef DATA_FIELD
701 : #undef OFFSET_FIELD
702 : #undef DTYPE_FIELD
703 : #undef SPAN_FIELD
704 : #undef DIMENSION_FIELD
705 : #undef CAF_TOKEN_FIELD
706 :
707 : #undef STRIDE_SUBFIELD
708 : #undef LBOUND_SUBFIELD
709 : #undef UBOUND_SUBFIELD
710 :
711 : #undef GFC_DTYPE_ELEM_LEN
712 : #undef GFC_DTYPE_VERSION
713 : #undef GFC_DTYPE_RANK
714 : #undef GFC_DTYPE_TYPE
715 : #undef GFC_DTYPE_ATTRIBUTE
716 :
717 :
718 : /* Add code to BLOCK implementing the pointer assigment from NULL() to the
719 : pointer represented by the array descriptor DESCR. */
720 :
721 : void
722 692 : gfc_nullify_descriptor (stmtblock_t *block, tree descr)
723 : {
724 692 : gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
725 692 : }
726 :
727 :
728 : /* Add code to BLOCK default-initializing array function result descriptor
729 : DESCR. This is used for the initialization of polymorphic allocatable
730 : function results. */
731 :
732 : void
733 34 : gfc_init_result_descriptor (stmtblock_t *block, tree descr)
734 : {
735 34 : gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
736 34 : }
737 :
738 :
739 : /* Add code to BLOCK initializing array descriptor DESCR so that it represents
740 : an absent actual argument associated with an optional dummy. */
741 :
742 : void
743 696 : gfc_init_absent_descriptor (stmtblock_t *block, tree descr)
744 : {
745 696 : gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
746 696 : }
747 :
748 :
749 : /* Add code to BLOCK initializing the array descriptor DESCR corresponding to
750 : the array variable SYM. This is only used for variables needing a default
751 : initialization of their descriptor. Typically allocatable (array) variables,
752 : that have an initial status of unallocated, are among them; they need their
753 : data pointer set to nullptr. */
754 :
755 : void
756 12029 : gfc_init_descriptor_variable (stmtblock_t *block, gfc_symbol *sym, tree descr)
757 : {
758 : /* NULLIFY the data pointer for non-saved allocatables, or for non-saved
759 : pointers when -fcheck=pointer is specified. */
760 12029 : if (!sym->attr.save
761 12016 : && (sym->attr.allocatable
762 3285 : || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
763 : {
764 8774 : gfc_conv_descriptor_data_set (block, descr, null_pointer_node);
765 8774 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
766 171 : gfc_conv_descriptor_token_set (block, descr, null_pointer_node);
767 : }
768 :
769 12029 : gcc_assert (sym->as && sym->as->rank>=0);
770 12029 : tree etype = gfc_get_element_type (TREE_TYPE (descr));
771 12029 : gfc_conv_descriptor_dtype_set (block, descr,
772 12029 : gfc_get_dtype_rank_type (sym->as->rank,
773 : etype));
774 12029 : }
775 :
776 :
777 : /* Create a fresh array descriptor copied from SOURCE_DESCR, with a cleared data
778 : pointer and a possibly different dtype value. Set the dtype field to DTYPE
779 : if different from NULL_TREE; otherwise set it with a default value built
780 : using SOURCE_DESCR's type. Add the copying code and any other initialization
781 : to BLOCK and return the descriptor declaration.
782 :
783 : The descriptor created by this function is used to pass to intrinsic
784 : functions from the library, when the result is assigned to a reallocatable
785 : variable. The left hand side variable descriptor is not passed directly to
786 : the library, and the unallocated descriptor this function creates is passed
787 : instead. Allocation happens in the library; deallocation of the left hand
788 : side variable data, if any, and correct bounds mapping happen outside the
789 : library, after the function returns. */
790 :
791 : tree
792 2137 : gfc_create_unallocated_library_result_descriptor (stmtblock_t *block,
793 : tree source_descr, tree dtype)
794 : {
795 : /* Unallocated, the descriptor does not have a dtype. */
796 2137 : if (dtype == NULL_TREE)
797 2124 : dtype = gfc_get_dtype (TREE_TYPE (source_descr));
798 :
799 2137 : gfc_conv_descriptor_dtype_set (block, source_descr, dtype);
800 :
801 2137 : tree res_desc = gfc_evaluate_now (source_descr, block);
802 2137 : gfc_conv_descriptor_data_set (block, res_desc, null_pointer_node);
803 :
804 2137 : return res_desc;
805 : }
806 :
807 :
808 : /* Create a new descriptor to represent a null actual argument of type TS and
809 : rank RANK passed to a dummy argument having attributes ATTR. Add
810 : initialization code to BLOCK and return the descriptor declaration. */
811 :
812 : tree
813 264 : gfc_create_null_actual_descriptor (stmtblock_t *block, gfc_typespec *ts,
814 : symbol_attribute attr, int rank)
815 : {
816 264 : tree etype = gfc_typenode_for_spec (ts);
817 :
818 264 : enum gfc_array_kind akind;
819 :
820 264 : if (attr.pointer)
821 : akind = GFC_ARRAY_POINTER_CONT;
822 96 : else if (attr.allocatable)
823 : akind = GFC_ARRAY_ALLOCATABLE;
824 : else
825 0 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
826 :
827 264 : tree lower[GFC_MAX_DIMENSIONS];
828 264 : tree upper[GFC_MAX_DIMENSIONS];
829 264 : memset (&lower, 0, rank * sizeof (lower[0]));
830 264 : memset (&upper, 0, rank * sizeof (upper[0]));
831 :
832 432 : tree type = gfc_get_array_type_bounds (etype, rank, 0, lower, upper, 1,
833 : akind, !(attr.pointer || attr.target));
834 264 : tree desc = gfc_create_var (type, "desc");
835 264 : DECL_ARTIFICIAL (desc) = 1;
836 :
837 264 : gfc_conv_descriptor_dtype_set (block, desc,
838 : gfc_get_dtype_rank_type (rank, etype));
839 264 : gfc_conv_descriptor_data_set (block, desc, null_pointer_node);
840 264 : gfc_conv_descriptor_span_set (block, desc,
841 : gfc_conv_descriptor_elem_len_get (desc));
842 :
843 264 : return desc;
844 : }
845 :
846 :
847 : /* For an array descriptor, get the total number of elements. This is just
848 : the product of the extents along from_dim to to_dim. */
849 :
850 : static tree
851 1973 : gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
852 : {
853 1973 : tree res;
854 1973 : int dim;
855 :
856 1973 : res = gfc_index_one_node;
857 :
858 4815 : for (dim = from_dim; dim < to_dim; ++dim)
859 : {
860 2842 : tree lbound;
861 2842 : tree ubound;
862 2842 : tree extent;
863 :
864 2842 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
865 2842 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
866 :
867 2842 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
868 2842 : res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
869 : res, extent);
870 : }
871 :
872 1973 : return res;
873 : }
874 :
875 :
876 : /* Full size of an array. */
877 :
878 : tree
879 1909 : gfc_conv_descriptor_size (tree desc, int rank)
880 : {
881 1909 : return gfc_conv_descriptor_size_1 (desc, 0, rank);
882 : }
883 :
884 :
885 : /* Size of a coarray for all dimensions but the last. */
886 :
887 : tree
888 64 : gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
889 : {
890 64 : return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
891 : }
892 :
893 :
894 : /* Modify a descriptor such that the lbound of a given dimension is the value
895 : specified. This also updates ubound and offset accordingly. */
896 :
897 : void
898 1009 : gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
899 : int dim, tree new_lbound)
900 : {
901 1009 : tree offs, ubound, lbound, stride;
902 1009 : tree diff, offs_diff;
903 :
904 1009 : new_lbound = fold_convert (gfc_array_index_type, new_lbound);
905 :
906 1009 : offs = gfc_conv_descriptor_offset_get (desc);
907 1009 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
908 1009 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
909 1009 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
910 :
911 : /* Get difference (new - old) by which to shift stuff. */
912 1009 : diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
913 : new_lbound, lbound);
914 :
915 : /* Shift ubound and offset accordingly. This has to be done before
916 : updating the lbound, as they depend on the lbound expression! */
917 1009 : ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
918 : ubound, diff);
919 1009 : gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
920 1009 : offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
921 : diff, stride);
922 1009 : offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
923 : offs, offs_diff);
924 1009 : gfc_conv_descriptor_offset_set (block, desc, offs);
925 :
926 : /* Finally set lbound to value we want. */
927 1009 : gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
928 1009 : }
929 :
930 :
931 : void
932 1778 : gfc_copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
933 : {
934 1778 : int n;
935 1778 : tree dim;
936 1778 : tree tmp;
937 1778 : tree tmp2;
938 1778 : tree size;
939 1778 : tree offset;
940 :
941 1778 : offset = gfc_index_zero_node;
942 :
943 : /* Use memcpy to copy the descriptor. The size is the minimum of
944 : the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
945 1778 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
946 1778 : tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
947 1778 : size = fold_build2_loc (input_location, MIN_EXPR,
948 1778 : TREE_TYPE (tmp), tmp, tmp2);
949 1778 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
950 1778 : tmp = build_call_expr_loc (input_location, tmp, 3,
951 : gfc_build_addr_expr (NULL_TREE, dst),
952 : gfc_build_addr_expr (NULL_TREE, src),
953 : fold_convert (size_type_node, size));
954 1778 : gfc_add_expr_to_block (block, tmp);
955 :
956 : /* Set the offset correctly. */
957 8792 : for (n = 0; n < rank; n++)
958 : {
959 5236 : dim = gfc_rank_cst[n];
960 5236 : tmp = gfc_conv_descriptor_lbound_get (src, dim);
961 5236 : tmp2 = gfc_conv_descriptor_stride_get (src, dim);
962 5236 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
963 : tmp, tmp2);
964 5236 : offset = fold_build2_loc (input_location, MINUS_EXPR,
965 5236 : TREE_TYPE (offset), offset, tmp);
966 5236 : offset = gfc_evaluate_now (offset, block);
967 : }
968 :
969 1778 : gfc_conv_descriptor_offset_set (block, dst, offset);
970 1778 : }
971 :
972 :
973 : /* Extend the data in array DESC by EXTRA elements. */
974 :
975 : void
976 1066 : gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
977 : {
978 1066 : tree arg0, arg1;
979 1066 : tree tmp;
980 1066 : tree size;
981 1066 : tree ubound;
982 :
983 1066 : if (integer_zerop (extra))
984 : return;
985 :
986 1036 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
987 :
988 : /* Add EXTRA to the upper bound. */
989 1036 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
990 : ubound, extra);
991 1036 : gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
992 :
993 : /* Get the value of the current data pointer. */
994 1036 : arg0 = gfc_conv_descriptor_data_get (desc);
995 :
996 : /* Calculate the new array size. */
997 1036 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
998 1036 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
999 : ubound, gfc_index_one_node);
1000 1036 : arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1001 : fold_convert (size_type_node, tmp),
1002 : fold_convert (size_type_node, size));
1003 :
1004 : /* Call the realloc() function. */
1005 1036 : tmp = gfc_call_realloc (pblock, arg0, arg1);
1006 1036 : gfc_conv_descriptor_data_set (pblock, desc, tmp);
1007 : }
|
