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