1 /* Array translation routines
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 /* trans-array.c-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
24
25 /* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
27 expressions.
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
31
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
36
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
42
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
47
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
53 term is calculated.
54
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
59
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
64
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
70
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
74
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
77
78 #include "config.h"
79 #include "system.h"
80 #include "coretypes.h"
81 #include "tree.h"
82 #include "gimple-expr.h"
83 #include "diagnostic-core.h" /* For internal_error/fatal_error. */
84 #include "flags.h"
85 #include "gfortran.h"
86 #include "constructor.h"
87 #include "trans.h"
88 #include "trans-stmt.h"
89 #include "trans-types.h"
90 #include "trans-array.h"
91 #include "trans-const.h"
92 #include "dependency.h"
93
94 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
95
96 /* The contents of this structure aren't actually used, just the address. */
97 static gfc_ss gfc_ss_terminator_var;
98 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
99
100
101 static tree
gfc_array_dataptr_type(tree desc)102 gfc_array_dataptr_type (tree desc)
103 {
104 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
105 }
106
107
108 /* Build expressions to access the members of an array descriptor.
109 It's surprisingly easy to mess up here, so never access
110 an array descriptor by "brute force", always use these
111 functions. This also avoids problems if we change the format
112 of an array descriptor.
113
114 To understand these magic numbers, look at the comments
115 before gfc_build_array_type() in trans-types.c.
116
117 The code within these defines should be the only code which knows the format
118 of an array descriptor.
119
120 Any code just needing to read obtain the bounds of an array should use
121 gfc_conv_array_* rather than the following functions as these will return
122 know constant values, and work with arrays which do not have descriptors.
123
124 Don't forget to #undef these! */
125
126 #define DATA_FIELD 0
127 #define OFFSET_FIELD 1
128 #define DTYPE_FIELD 2
129 #define DIMENSION_FIELD 3
130 #define CAF_TOKEN_FIELD 4
131
132 #define STRIDE_SUBFIELD 0
133 #define LBOUND_SUBFIELD 1
134 #define UBOUND_SUBFIELD 2
135
136 /* This provides READ-ONLY access to the data field. The field itself
137 doesn't have the proper type. */
138
139 tree
gfc_conv_descriptor_data_get(tree desc)140 gfc_conv_descriptor_data_get (tree desc)
141 {
142 tree field, type, t;
143
144 type = TREE_TYPE (desc);
145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
146
147 field = TYPE_FIELDS (type);
148 gcc_assert (DATA_FIELD == 0);
149
150 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
151 field, NULL_TREE);
152 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
153
154 return t;
155 }
156
157 /* This provides WRITE access to the data field.
158
159 TUPLES_P is true if we are generating tuples.
160
161 This function gets called through the following macros:
162 gfc_conv_descriptor_data_set
163 gfc_conv_descriptor_data_set. */
164
165 void
gfc_conv_descriptor_data_set(stmtblock_t * block,tree desc,tree value)166 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
167 {
168 tree field, type, t;
169
170 type = TREE_TYPE (desc);
171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
172
173 field = TYPE_FIELDS (type);
174 gcc_assert (DATA_FIELD == 0);
175
176 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
177 field, NULL_TREE);
178 gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
179 }
180
181
182 /* This provides address access to the data field. This should only be
183 used by array allocation, passing this on to the runtime. */
184
185 tree
gfc_conv_descriptor_data_addr(tree desc)186 gfc_conv_descriptor_data_addr (tree desc)
187 {
188 tree field, type, t;
189
190 type = TREE_TYPE (desc);
191 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
192
193 field = TYPE_FIELDS (type);
194 gcc_assert (DATA_FIELD == 0);
195
196 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
197 field, NULL_TREE);
198 return gfc_build_addr_expr (NULL_TREE, t);
199 }
200
201 static tree
gfc_conv_descriptor_offset(tree desc)202 gfc_conv_descriptor_offset (tree desc)
203 {
204 tree type;
205 tree field;
206
207 type = TREE_TYPE (desc);
208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
209
210 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
211 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
212
213 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
214 desc, field, NULL_TREE);
215 }
216
217 tree
gfc_conv_descriptor_offset_get(tree desc)218 gfc_conv_descriptor_offset_get (tree desc)
219 {
220 return gfc_conv_descriptor_offset (desc);
221 }
222
223 void
gfc_conv_descriptor_offset_set(stmtblock_t * block,tree desc,tree value)224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
225 tree value)
226 {
227 tree t = gfc_conv_descriptor_offset (desc);
228 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
229 }
230
231
232 tree
gfc_conv_descriptor_dtype(tree desc)233 gfc_conv_descriptor_dtype (tree desc)
234 {
235 tree field;
236 tree type;
237
238 type = TREE_TYPE (desc);
239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
240
241 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
242 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
243
244 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
245 desc, field, NULL_TREE);
246 }
247
248
249 tree
gfc_conv_descriptor_rank(tree desc)250 gfc_conv_descriptor_rank (tree desc)
251 {
252 tree tmp;
253 tree dtype;
254
255 dtype = gfc_conv_descriptor_dtype (desc);
256 tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
257 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
258 dtype, tmp);
259 return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
260 }
261
262
263 tree
gfc_get_descriptor_dimension(tree desc)264 gfc_get_descriptor_dimension (tree desc)
265 {
266 tree type, field;
267
268 type = TREE_TYPE (desc);
269 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
270
271 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
272 gcc_assert (field != NULL_TREE
273 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
274 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
275
276 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
277 desc, field, NULL_TREE);
278 }
279
280
281 static tree
gfc_conv_descriptor_dimension(tree desc,tree dim)282 gfc_conv_descriptor_dimension (tree desc, tree dim)
283 {
284 tree tmp;
285
286 tmp = gfc_get_descriptor_dimension (desc);
287
288 return gfc_build_array_ref (tmp, dim, NULL);
289 }
290
291
292 tree
gfc_conv_descriptor_token(tree desc)293 gfc_conv_descriptor_token (tree desc)
294 {
295 tree type;
296 tree field;
297
298 type = TREE_TYPE (desc);
299 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
300 gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
301 gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
302 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
303
304 /* Should be a restricted pointer - except in the finalization wrapper. */
305 gcc_assert (field != NULL_TREE
306 && (TREE_TYPE (field) == prvoid_type_node
307 || TREE_TYPE (field) == pvoid_type_node));
308
309 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
310 desc, field, NULL_TREE);
311 }
312
313
314 static tree
gfc_conv_descriptor_stride(tree desc,tree dim)315 gfc_conv_descriptor_stride (tree desc, tree dim)
316 {
317 tree tmp;
318 tree field;
319
320 tmp = gfc_conv_descriptor_dimension (desc, dim);
321 field = TYPE_FIELDS (TREE_TYPE (tmp));
322 field = gfc_advance_chain (field, STRIDE_SUBFIELD);
323 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
324
325 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
326 tmp, field, NULL_TREE);
327 return tmp;
328 }
329
330 tree
gfc_conv_descriptor_stride_get(tree desc,tree dim)331 gfc_conv_descriptor_stride_get (tree desc, tree dim)
332 {
333 tree type = TREE_TYPE (desc);
334 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
335 if (integer_zerop (dim)
336 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
337 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
338 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
339 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
340 return gfc_index_one_node;
341
342 return gfc_conv_descriptor_stride (desc, dim);
343 }
344
345 void
gfc_conv_descriptor_stride_set(stmtblock_t * block,tree desc,tree dim,tree value)346 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
347 tree dim, tree value)
348 {
349 tree t = gfc_conv_descriptor_stride (desc, dim);
350 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
351 }
352
353 static tree
gfc_conv_descriptor_lbound(tree desc,tree dim)354 gfc_conv_descriptor_lbound (tree desc, tree dim)
355 {
356 tree tmp;
357 tree field;
358
359 tmp = gfc_conv_descriptor_dimension (desc, dim);
360 field = TYPE_FIELDS (TREE_TYPE (tmp));
361 field = gfc_advance_chain (field, LBOUND_SUBFIELD);
362 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
363
364 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
365 tmp, field, NULL_TREE);
366 return tmp;
367 }
368
369 tree
gfc_conv_descriptor_lbound_get(tree desc,tree dim)370 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
371 {
372 return gfc_conv_descriptor_lbound (desc, dim);
373 }
374
375 void
gfc_conv_descriptor_lbound_set(stmtblock_t * block,tree desc,tree dim,tree value)376 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
377 tree dim, tree value)
378 {
379 tree t = gfc_conv_descriptor_lbound (desc, dim);
380 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
381 }
382
383 static tree
gfc_conv_descriptor_ubound(tree desc,tree dim)384 gfc_conv_descriptor_ubound (tree desc, tree dim)
385 {
386 tree tmp;
387 tree field;
388
389 tmp = gfc_conv_descriptor_dimension (desc, dim);
390 field = TYPE_FIELDS (TREE_TYPE (tmp));
391 field = gfc_advance_chain (field, UBOUND_SUBFIELD);
392 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
393
394 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
395 tmp, field, NULL_TREE);
396 return tmp;
397 }
398
399 tree
gfc_conv_descriptor_ubound_get(tree desc,tree dim)400 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
401 {
402 return gfc_conv_descriptor_ubound (desc, dim);
403 }
404
405 void
gfc_conv_descriptor_ubound_set(stmtblock_t * block,tree desc,tree dim,tree value)406 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
407 tree dim, tree value)
408 {
409 tree t = gfc_conv_descriptor_ubound (desc, dim);
410 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
411 }
412
413 /* Build a null array descriptor constructor. */
414
415 tree
gfc_build_null_descriptor(tree type)416 gfc_build_null_descriptor (tree type)
417 {
418 tree field;
419 tree tmp;
420
421 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
422 gcc_assert (DATA_FIELD == 0);
423 field = TYPE_FIELDS (type);
424
425 /* Set a NULL data pointer. */
426 tmp = build_constructor_single (type, field, null_pointer_node);
427 TREE_CONSTANT (tmp) = 1;
428 /* All other fields are ignored. */
429
430 return tmp;
431 }
432
433
434 /* Modify a descriptor such that the lbound of a given dimension is the value
435 specified. This also updates ubound and offset accordingly. */
436
437 void
gfc_conv_shift_descriptor_lbound(stmtblock_t * block,tree desc,int dim,tree new_lbound)438 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
439 int dim, tree new_lbound)
440 {
441 tree offs, ubound, lbound, stride;
442 tree diff, offs_diff;
443
444 new_lbound = fold_convert (gfc_array_index_type, new_lbound);
445
446 offs = gfc_conv_descriptor_offset_get (desc);
447 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
448 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
449 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
450
451 /* Get difference (new - old) by which to shift stuff. */
452 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
453 new_lbound, lbound);
454
455 /* Shift ubound and offset accordingly. This has to be done before
456 updating the lbound, as they depend on the lbound expression! */
457 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
458 ubound, diff);
459 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
460 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
461 diff, stride);
462 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
463 offs, offs_diff);
464 gfc_conv_descriptor_offset_set (block, desc, offs);
465
466 /* Finally set lbound to value we want. */
467 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
468 }
469
470
471 /* Cleanup those #defines. */
472
473 #undef DATA_FIELD
474 #undef OFFSET_FIELD
475 #undef DTYPE_FIELD
476 #undef DIMENSION_FIELD
477 #undef CAF_TOKEN_FIELD
478 #undef STRIDE_SUBFIELD
479 #undef LBOUND_SUBFIELD
480 #undef UBOUND_SUBFIELD
481
482
483 /* Mark a SS chain as used. Flags specifies in which loops the SS is used.
484 flags & 1 = Main loop body.
485 flags & 2 = temp copy loop. */
486
487 void
gfc_mark_ss_chain_used(gfc_ss * ss,unsigned flags)488 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
489 {
490 for (; ss != gfc_ss_terminator; ss = ss->next)
491 ss->info->useflags = flags;
492 }
493
494
495 /* Free a gfc_ss chain. */
496
497 void
gfc_free_ss_chain(gfc_ss * ss)498 gfc_free_ss_chain (gfc_ss * ss)
499 {
500 gfc_ss *next;
501
502 while (ss != gfc_ss_terminator)
503 {
504 gcc_assert (ss != NULL);
505 next = ss->next;
506 gfc_free_ss (ss);
507 ss = next;
508 }
509 }
510
511
512 static void
free_ss_info(gfc_ss_info * ss_info)513 free_ss_info (gfc_ss_info *ss_info)
514 {
515 int n;
516
517 ss_info->refcount--;
518 if (ss_info->refcount > 0)
519 return;
520
521 gcc_assert (ss_info->refcount == 0);
522
523 switch (ss_info->type)
524 {
525 case GFC_SS_SECTION:
526 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
527 if (ss_info->data.array.subscript[n])
528 gfc_free_ss_chain (ss_info->data.array.subscript[n]);
529 break;
530
531 default:
532 break;
533 }
534
535 free (ss_info);
536 }
537
538
539 /* Free a SS. */
540
541 void
gfc_free_ss(gfc_ss * ss)542 gfc_free_ss (gfc_ss * ss)
543 {
544 free_ss_info (ss->info);
545 free (ss);
546 }
547
548
549 /* Creates and initializes an array type gfc_ss struct. */
550
551 gfc_ss *
gfc_get_array_ss(gfc_ss * next,gfc_expr * expr,int dimen,gfc_ss_type type)552 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
553 {
554 gfc_ss *ss;
555 gfc_ss_info *ss_info;
556 int i;
557
558 ss_info = gfc_get_ss_info ();
559 ss_info->refcount++;
560 ss_info->type = type;
561 ss_info->expr = expr;
562
563 ss = gfc_get_ss ();
564 ss->info = ss_info;
565 ss->next = next;
566 ss->dimen = dimen;
567 for (i = 0; i < ss->dimen; i++)
568 ss->dim[i] = i;
569
570 return ss;
571 }
572
573
574 /* Creates and initializes a temporary type gfc_ss struct. */
575
576 gfc_ss *
gfc_get_temp_ss(tree type,tree string_length,int dimen)577 gfc_get_temp_ss (tree type, tree string_length, int dimen)
578 {
579 gfc_ss *ss;
580 gfc_ss_info *ss_info;
581 int i;
582
583 ss_info = gfc_get_ss_info ();
584 ss_info->refcount++;
585 ss_info->type = GFC_SS_TEMP;
586 ss_info->string_length = string_length;
587 ss_info->data.temp.type = type;
588
589 ss = gfc_get_ss ();
590 ss->info = ss_info;
591 ss->next = gfc_ss_terminator;
592 ss->dimen = dimen;
593 for (i = 0; i < ss->dimen; i++)
594 ss->dim[i] = i;
595
596 return ss;
597 }
598
599
600 /* Creates and initializes a scalar type gfc_ss struct. */
601
602 gfc_ss *
gfc_get_scalar_ss(gfc_ss * next,gfc_expr * expr)603 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
604 {
605 gfc_ss *ss;
606 gfc_ss_info *ss_info;
607
608 ss_info = gfc_get_ss_info ();
609 ss_info->refcount++;
610 ss_info->type = GFC_SS_SCALAR;
611 ss_info->expr = expr;
612
613 ss = gfc_get_ss ();
614 ss->info = ss_info;
615 ss->next = next;
616
617 return ss;
618 }
619
620
621 /* Free all the SS associated with a loop. */
622
623 void
gfc_cleanup_loop(gfc_loopinfo * loop)624 gfc_cleanup_loop (gfc_loopinfo * loop)
625 {
626 gfc_loopinfo *loop_next, **ploop;
627 gfc_ss *ss;
628 gfc_ss *next;
629
630 ss = loop->ss;
631 while (ss != gfc_ss_terminator)
632 {
633 gcc_assert (ss != NULL);
634 next = ss->loop_chain;
635 gfc_free_ss (ss);
636 ss = next;
637 }
638
639 /* Remove reference to self in the parent loop. */
640 if (loop->parent)
641 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
642 if (*ploop == loop)
643 {
644 *ploop = loop->next;
645 break;
646 }
647
648 /* Free non-freed nested loops. */
649 for (loop = loop->nested; loop; loop = loop_next)
650 {
651 loop_next = loop->next;
652 gfc_cleanup_loop (loop);
653 free (loop);
654 }
655 }
656
657
658 static void
set_ss_loop(gfc_ss * ss,gfc_loopinfo * loop)659 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
660 {
661 int n;
662
663 for (; ss != gfc_ss_terminator; ss = ss->next)
664 {
665 ss->loop = loop;
666
667 if (ss->info->type == GFC_SS_SCALAR
668 || ss->info->type == GFC_SS_REFERENCE
669 || ss->info->type == GFC_SS_TEMP)
670 continue;
671
672 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
673 if (ss->info->data.array.subscript[n] != NULL)
674 set_ss_loop (ss->info->data.array.subscript[n], loop);
675 }
676 }
677
678
679 /* Associate a SS chain with a loop. */
680
681 void
gfc_add_ss_to_loop(gfc_loopinfo * loop,gfc_ss * head)682 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
683 {
684 gfc_ss *ss;
685 gfc_loopinfo *nested_loop;
686
687 if (head == gfc_ss_terminator)
688 return;
689
690 set_ss_loop (head, loop);
691
692 ss = head;
693 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
694 {
695 if (ss->nested_ss)
696 {
697 nested_loop = ss->nested_ss->loop;
698
699 /* More than one ss can belong to the same loop. Hence, we add the
700 loop to the chain only if it is different from the previously
701 added one, to avoid duplicate nested loops. */
702 if (nested_loop != loop->nested)
703 {
704 gcc_assert (nested_loop->parent == NULL);
705 nested_loop->parent = loop;
706
707 gcc_assert (nested_loop->next == NULL);
708 nested_loop->next = loop->nested;
709 loop->nested = nested_loop;
710 }
711 else
712 gcc_assert (nested_loop->parent == loop);
713 }
714
715 if (ss->next == gfc_ss_terminator)
716 ss->loop_chain = loop->ss;
717 else
718 ss->loop_chain = ss->next;
719 }
720 gcc_assert (ss == gfc_ss_terminator);
721 loop->ss = head;
722 }
723
724
725 /* Generate an initializer for a static pointer or allocatable array. */
726
727 void
gfc_trans_static_array_pointer(gfc_symbol * sym)728 gfc_trans_static_array_pointer (gfc_symbol * sym)
729 {
730 tree type;
731
732 gcc_assert (TREE_STATIC (sym->backend_decl));
733 /* Just zero the data member. */
734 type = TREE_TYPE (sym->backend_decl);
735 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
736 }
737
738
739 /* If the bounds of SE's loop have not yet been set, see if they can be
740 determined from array spec AS, which is the array spec of a called
741 function. MAPPING maps the callee's dummy arguments to the values
742 that the caller is passing. Add any initialization and finalization
743 code to SE. */
744
745 void
gfc_set_loop_bounds_from_array_spec(gfc_interface_mapping * mapping,gfc_se * se,gfc_array_spec * as)746 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
747 gfc_se * se, gfc_array_spec * as)
748 {
749 int n, dim, total_dim;
750 gfc_se tmpse;
751 gfc_ss *ss;
752 tree lower;
753 tree upper;
754 tree tmp;
755
756 total_dim = 0;
757
758 if (!as || as->type != AS_EXPLICIT)
759 return;
760
761 for (ss = se->ss; ss; ss = ss->parent)
762 {
763 total_dim += ss->loop->dimen;
764 for (n = 0; n < ss->loop->dimen; n++)
765 {
766 /* The bound is known, nothing to do. */
767 if (ss->loop->to[n] != NULL_TREE)
768 continue;
769
770 dim = ss->dim[n];
771 gcc_assert (dim < as->rank);
772 gcc_assert (ss->loop->dimen <= as->rank);
773
774 /* Evaluate the lower bound. */
775 gfc_init_se (&tmpse, NULL);
776 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
777 gfc_add_block_to_block (&se->pre, &tmpse.pre);
778 gfc_add_block_to_block (&se->post, &tmpse.post);
779 lower = fold_convert (gfc_array_index_type, tmpse.expr);
780
781 /* ...and the upper bound. */
782 gfc_init_se (&tmpse, NULL);
783 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
784 gfc_add_block_to_block (&se->pre, &tmpse.pre);
785 gfc_add_block_to_block (&se->post, &tmpse.post);
786 upper = fold_convert (gfc_array_index_type, tmpse.expr);
787
788 /* Set the upper bound of the loop to UPPER - LOWER. */
789 tmp = fold_build2_loc (input_location, MINUS_EXPR,
790 gfc_array_index_type, upper, lower);
791 tmp = gfc_evaluate_now (tmp, &se->pre);
792 ss->loop->to[n] = tmp;
793 }
794 }
795
796 gcc_assert (total_dim == as->rank);
797 }
798
799
800 /* Generate code to allocate an array temporary, or create a variable to
801 hold the data. If size is NULL, zero the descriptor so that the
802 callee will allocate the array. If DEALLOC is true, also generate code to
803 free the array afterwards.
804
805 If INITIAL is not NULL, it is packed using internal_pack and the result used
806 as data instead of allocating a fresh, unitialized area of memory.
807
808 Initialization code is added to PRE and finalization code to POST.
809 DYNAMIC is true if the caller may want to extend the array later
810 using realloc. This prevents us from putting the array on the stack. */
811
812 static void
gfc_trans_allocate_array_storage(stmtblock_t * pre,stmtblock_t * post,gfc_array_info * info,tree size,tree nelem,tree initial,bool dynamic,bool dealloc)813 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
814 gfc_array_info * info, tree size, tree nelem,
815 tree initial, bool dynamic, bool dealloc)
816 {
817 tree tmp;
818 tree desc;
819 bool onstack;
820
821 desc = info->descriptor;
822 info->offset = gfc_index_zero_node;
823 if (size == NULL_TREE || integer_zerop (size))
824 {
825 /* A callee allocated array. */
826 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
827 onstack = FALSE;
828 }
829 else
830 {
831 /* Allocate the temporary. */
832 onstack = !dynamic && initial == NULL_TREE
833 && (gfc_option.flag_stack_arrays
834 || gfc_can_put_var_on_stack (size));
835
836 if (onstack)
837 {
838 /* Make a temporary variable to hold the data. */
839 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
840 nelem, gfc_index_one_node);
841 tmp = gfc_evaluate_now (tmp, pre);
842 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
843 tmp);
844 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
845 tmp);
846 tmp = gfc_create_var (tmp, "A");
847 /* If we're here only because of -fstack-arrays we have to
848 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
849 if (!gfc_can_put_var_on_stack (size))
850 gfc_add_expr_to_block (pre,
851 fold_build1_loc (input_location,
852 DECL_EXPR, TREE_TYPE (tmp),
853 tmp));
854 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
855 gfc_conv_descriptor_data_set (pre, desc, tmp);
856 }
857 else
858 {
859 /* Allocate memory to hold the data or call internal_pack. */
860 if (initial == NULL_TREE)
861 {
862 tmp = gfc_call_malloc (pre, NULL, size);
863 tmp = gfc_evaluate_now (tmp, pre);
864 }
865 else
866 {
867 tree packed;
868 tree source_data;
869 tree was_packed;
870 stmtblock_t do_copying;
871
872 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
873 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
874 tmp = TREE_TYPE (tmp); /* The descriptor itself. */
875 tmp = gfc_get_element_type (tmp);
876 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
877 packed = gfc_create_var (build_pointer_type (tmp), "data");
878
879 tmp = build_call_expr_loc (input_location,
880 gfor_fndecl_in_pack, 1, initial);
881 tmp = fold_convert (TREE_TYPE (packed), tmp);
882 gfc_add_modify (pre, packed, tmp);
883
884 tmp = build_fold_indirect_ref_loc (input_location,
885 initial);
886 source_data = gfc_conv_descriptor_data_get (tmp);
887
888 /* internal_pack may return source->data without any allocation
889 or copying if it is already packed. If that's the case, we
890 need to allocate and copy manually. */
891
892 gfc_start_block (&do_copying);
893 tmp = gfc_call_malloc (&do_copying, NULL, size);
894 tmp = fold_convert (TREE_TYPE (packed), tmp);
895 gfc_add_modify (&do_copying, packed, tmp);
896 tmp = gfc_build_memcpy_call (packed, source_data, size);
897 gfc_add_expr_to_block (&do_copying, tmp);
898
899 was_packed = fold_build2_loc (input_location, EQ_EXPR,
900 boolean_type_node, packed,
901 source_data);
902 tmp = gfc_finish_block (&do_copying);
903 tmp = build3_v (COND_EXPR, was_packed, tmp,
904 build_empty_stmt (input_location));
905 gfc_add_expr_to_block (pre, tmp);
906
907 tmp = fold_convert (pvoid_type_node, packed);
908 }
909
910 gfc_conv_descriptor_data_set (pre, desc, tmp);
911 }
912 }
913 info->data = gfc_conv_descriptor_data_get (desc);
914
915 /* The offset is zero because we create temporaries with a zero
916 lower bound. */
917 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
918
919 if (dealloc && !onstack)
920 {
921 /* Free the temporary. */
922 tmp = gfc_conv_descriptor_data_get (desc);
923 tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
924 gfc_add_expr_to_block (post, tmp);
925 }
926 }
927
928
929 /* Get the scalarizer array dimension corresponding to actual array dimension
930 given by ARRAY_DIM.
931
932 For example, if SS represents the array ref a(1,:,:,1), it is a
933 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
934 and 1 for ARRAY_DIM=2.
935 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
936 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
937 ARRAY_DIM=3.
938 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
939 array. If called on the inner ss, the result would be respectively 0,1,2 for
940 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
941 for ARRAY_DIM=1,2. */
942
943 static int
get_scalarizer_dim_for_array_dim(gfc_ss * ss,int array_dim)944 get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
945 {
946 int array_ref_dim;
947 int n;
948
949 array_ref_dim = 0;
950
951 for (; ss; ss = ss->parent)
952 for (n = 0; n < ss->dimen; n++)
953 if (ss->dim[n] < array_dim)
954 array_ref_dim++;
955
956 return array_ref_dim;
957 }
958
959
960 static gfc_ss *
innermost_ss(gfc_ss * ss)961 innermost_ss (gfc_ss *ss)
962 {
963 while (ss->nested_ss != NULL)
964 ss = ss->nested_ss;
965
966 return ss;
967 }
968
969
970
971 /* Get the array reference dimension corresponding to the given loop dimension.
972 It is different from the true array dimension given by the dim array in
973 the case of a partial array reference (i.e. a(:,:,1,:) for example)
974 It is different from the loop dimension in the case of a transposed array.
975 */
976
977 static int
get_array_ref_dim_for_loop_dim(gfc_ss * ss,int loop_dim)978 get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
979 {
980 return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
981 ss->dim[loop_dim]);
982 }
983
984
985 /* Generate code to create and initialize the descriptor for a temporary
986 array. This is used for both temporaries needed by the scalarizer, and
987 functions returning arrays. Adjusts the loop variables to be
988 zero-based, and calculates the loop bounds for callee allocated arrays.
989 Allocate the array unless it's callee allocated (we have a callee
990 allocated array if 'callee_alloc' is true, or if loop->to[n] is
991 NULL_TREE for any n). Also fills in the descriptor, data and offset
992 fields of info if known. Returns the size of the array, or NULL for a
993 callee allocated array.
994
995 'eltype' == NULL signals that the temporary should be a class object.
996 The 'initial' expression is used to obtain the size of the dynamic
997 type; otherwise the allocation and initialization proceeds as for any
998 other expression
999
1000 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1001 gfc_trans_allocate_array_storage. */
1002
1003 tree
gfc_trans_create_temp_array(stmtblock_t * pre,stmtblock_t * post,gfc_ss * ss,tree eltype,tree initial,bool dynamic,bool dealloc,bool callee_alloc,locus * where)1004 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1005 tree eltype, tree initial, bool dynamic,
1006 bool dealloc, bool callee_alloc, locus * where)
1007 {
1008 gfc_loopinfo *loop;
1009 gfc_ss *s;
1010 gfc_array_info *info;
1011 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1012 tree type;
1013 tree desc;
1014 tree tmp;
1015 tree size;
1016 tree nelem;
1017 tree cond;
1018 tree or_expr;
1019 tree class_expr = NULL_TREE;
1020 int n, dim, tmp_dim;
1021 int total_dim = 0;
1022
1023 /* This signals a class array for which we need the size of the
1024 dynamic type. Generate an eltype and then the class expression. */
1025 if (eltype == NULL_TREE && initial)
1026 {
1027 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1028 class_expr = build_fold_indirect_ref_loc (input_location, initial);
1029 eltype = TREE_TYPE (class_expr);
1030 eltype = gfc_get_element_type (eltype);
1031 /* Obtain the structure (class) expression. */
1032 class_expr = TREE_OPERAND (class_expr, 0);
1033 gcc_assert (class_expr);
1034 }
1035
1036 memset (from, 0, sizeof (from));
1037 memset (to, 0, sizeof (to));
1038
1039 info = &ss->info->data.array;
1040
1041 gcc_assert (ss->dimen > 0);
1042 gcc_assert (ss->loop->dimen == ss->dimen);
1043
1044 if (gfc_option.warn_array_temp && where)
1045 gfc_warning ("Creating array temporary at %L", where);
1046
1047 /* Set the lower bound to zero. */
1048 for (s = ss; s; s = s->parent)
1049 {
1050 loop = s->loop;
1051
1052 total_dim += loop->dimen;
1053 for (n = 0; n < loop->dimen; n++)
1054 {
1055 dim = s->dim[n];
1056
1057 /* Callee allocated arrays may not have a known bound yet. */
1058 if (loop->to[n])
1059 loop->to[n] = gfc_evaluate_now (
1060 fold_build2_loc (input_location, MINUS_EXPR,
1061 gfc_array_index_type,
1062 loop->to[n], loop->from[n]),
1063 pre);
1064 loop->from[n] = gfc_index_zero_node;
1065
1066 /* We have just changed the loop bounds, we must clear the
1067 corresponding specloop, so that delta calculation is not skipped
1068 later in gfc_set_delta. */
1069 loop->specloop[n] = NULL;
1070
1071 /* We are constructing the temporary's descriptor based on the loop
1072 dimensions. As the dimensions may be accessed in arbitrary order
1073 (think of transpose) the size taken from the n'th loop may not map
1074 to the n'th dimension of the array. We need to reconstruct loop
1075 infos in the right order before using it to set the descriptor
1076 bounds. */
1077 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1078 from[tmp_dim] = loop->from[n];
1079 to[tmp_dim] = loop->to[n];
1080
1081 info->delta[dim] = gfc_index_zero_node;
1082 info->start[dim] = gfc_index_zero_node;
1083 info->end[dim] = gfc_index_zero_node;
1084 info->stride[dim] = gfc_index_one_node;
1085 }
1086 }
1087
1088 /* Initialize the descriptor. */
1089 type =
1090 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1091 GFC_ARRAY_UNKNOWN, true);
1092 desc = gfc_create_var (type, "atmp");
1093 GFC_DECL_PACKED_ARRAY (desc) = 1;
1094
1095 info->descriptor = desc;
1096 size = gfc_index_one_node;
1097
1098 /* Fill in the array dtype. */
1099 tmp = gfc_conv_descriptor_dtype (desc);
1100 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1101
1102 /*
1103 Fill in the bounds and stride. This is a packed array, so:
1104
1105 size = 1;
1106 for (n = 0; n < rank; n++)
1107 {
1108 stride[n] = size
1109 delta = ubound[n] + 1 - lbound[n];
1110 size = size * delta;
1111 }
1112 size = size * sizeof(element);
1113 */
1114
1115 or_expr = NULL_TREE;
1116
1117 /* If there is at least one null loop->to[n], it is a callee allocated
1118 array. */
1119 for (n = 0; n < total_dim; n++)
1120 if (to[n] == NULL_TREE)
1121 {
1122 size = NULL_TREE;
1123 break;
1124 }
1125
1126 if (size == NULL_TREE)
1127 for (s = ss; s; s = s->parent)
1128 for (n = 0; n < s->loop->dimen; n++)
1129 {
1130 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1131
1132 /* For a callee allocated array express the loop bounds in terms
1133 of the descriptor fields. */
1134 tmp = fold_build2_loc (input_location,
1135 MINUS_EXPR, gfc_array_index_type,
1136 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1137 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1138 s->loop->to[n] = tmp;
1139 }
1140 else
1141 {
1142 for (n = 0; n < total_dim; n++)
1143 {
1144 /* Store the stride and bound components in the descriptor. */
1145 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1146
1147 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1148 gfc_index_zero_node);
1149
1150 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1151
1152 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1153 gfc_array_index_type,
1154 to[n], gfc_index_one_node);
1155
1156 /* Check whether the size for this dimension is negative. */
1157 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1158 tmp, gfc_index_zero_node);
1159 cond = gfc_evaluate_now (cond, pre);
1160
1161 if (n == 0)
1162 or_expr = cond;
1163 else
1164 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1165 boolean_type_node, or_expr, cond);
1166
1167 size = fold_build2_loc (input_location, MULT_EXPR,
1168 gfc_array_index_type, size, tmp);
1169 size = gfc_evaluate_now (size, pre);
1170 }
1171 }
1172
1173 /* Get the size of the array. */
1174 if (size && !callee_alloc)
1175 {
1176 tree elemsize;
1177 /* If or_expr is true, then the extent in at least one
1178 dimension is zero and the size is set to zero. */
1179 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1180 or_expr, gfc_index_zero_node, size);
1181
1182 nelem = size;
1183 if (class_expr == NULL_TREE)
1184 elemsize = fold_convert (gfc_array_index_type,
1185 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
1186 else
1187 elemsize = gfc_vtable_size_get (class_expr);
1188
1189 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1190 size, elemsize);
1191 }
1192 else
1193 {
1194 nelem = size;
1195 size = NULL_TREE;
1196 }
1197
1198 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1199 dynamic, dealloc);
1200
1201 while (ss->parent)
1202 ss = ss->parent;
1203
1204 if (ss->dimen > ss->loop->temp_dim)
1205 ss->loop->temp_dim = ss->dimen;
1206
1207 return size;
1208 }
1209
1210
1211 /* Return the number of iterations in a loop that starts at START,
1212 ends at END, and has step STEP. */
1213
1214 static tree
gfc_get_iteration_count(tree start,tree end,tree step)1215 gfc_get_iteration_count (tree start, tree end, tree step)
1216 {
1217 tree tmp;
1218 tree type;
1219
1220 type = TREE_TYPE (step);
1221 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1222 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1223 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1224 build_int_cst (type, 1));
1225 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1226 build_int_cst (type, 0));
1227 return fold_convert (gfc_array_index_type, tmp);
1228 }
1229
1230
1231 /* Extend the data in array DESC by EXTRA elements. */
1232
1233 static void
gfc_grow_array(stmtblock_t * pblock,tree desc,tree extra)1234 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1235 {
1236 tree arg0, arg1;
1237 tree tmp;
1238 tree size;
1239 tree ubound;
1240
1241 if (integer_zerop (extra))
1242 return;
1243
1244 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1245
1246 /* Add EXTRA to the upper bound. */
1247 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1248 ubound, extra);
1249 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1250
1251 /* Get the value of the current data pointer. */
1252 arg0 = gfc_conv_descriptor_data_get (desc);
1253
1254 /* Calculate the new array size. */
1255 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1256 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1257 ubound, gfc_index_one_node);
1258 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1259 fold_convert (size_type_node, tmp),
1260 fold_convert (size_type_node, size));
1261
1262 /* Call the realloc() function. */
1263 tmp = gfc_call_realloc (pblock, arg0, arg1);
1264 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1265 }
1266
1267
1268 /* Return true if the bounds of iterator I can only be determined
1269 at run time. */
1270
1271 static inline bool
gfc_iterator_has_dynamic_bounds(gfc_iterator * i)1272 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1273 {
1274 return (i->start->expr_type != EXPR_CONSTANT
1275 || i->end->expr_type != EXPR_CONSTANT
1276 || i->step->expr_type != EXPR_CONSTANT);
1277 }
1278
1279
1280 /* Split the size of constructor element EXPR into the sum of two terms,
1281 one of which can be determined at compile time and one of which must
1282 be calculated at run time. Set *SIZE to the former and return true
1283 if the latter might be nonzero. */
1284
1285 static bool
gfc_get_array_constructor_element_size(mpz_t * size,gfc_expr * expr)1286 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1287 {
1288 if (expr->expr_type == EXPR_ARRAY)
1289 return gfc_get_array_constructor_size (size, expr->value.constructor);
1290 else if (expr->rank > 0)
1291 {
1292 /* Calculate everything at run time. */
1293 mpz_set_ui (*size, 0);
1294 return true;
1295 }
1296 else
1297 {
1298 /* A single element. */
1299 mpz_set_ui (*size, 1);
1300 return false;
1301 }
1302 }
1303
1304
1305 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1306 of array constructor C. */
1307
1308 static bool
gfc_get_array_constructor_size(mpz_t * size,gfc_constructor_base base)1309 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1310 {
1311 gfc_constructor *c;
1312 gfc_iterator *i;
1313 mpz_t val;
1314 mpz_t len;
1315 bool dynamic;
1316
1317 mpz_set_ui (*size, 0);
1318 mpz_init (len);
1319 mpz_init (val);
1320
1321 dynamic = false;
1322 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1323 {
1324 i = c->iterator;
1325 if (i && gfc_iterator_has_dynamic_bounds (i))
1326 dynamic = true;
1327 else
1328 {
1329 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1330 if (i)
1331 {
1332 /* Multiply the static part of the element size by the
1333 number of iterations. */
1334 mpz_sub (val, i->end->value.integer, i->start->value.integer);
1335 mpz_fdiv_q (val, val, i->step->value.integer);
1336 mpz_add_ui (val, val, 1);
1337 if (mpz_sgn (val) > 0)
1338 mpz_mul (len, len, val);
1339 else
1340 mpz_set_ui (len, 0);
1341 }
1342 mpz_add (*size, *size, len);
1343 }
1344 }
1345 mpz_clear (len);
1346 mpz_clear (val);
1347 return dynamic;
1348 }
1349
1350
1351 /* Make sure offset is a variable. */
1352
1353 static void
gfc_put_offset_into_var(stmtblock_t * pblock,tree * poffset,tree * offsetvar)1354 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1355 tree * offsetvar)
1356 {
1357 /* We should have already created the offset variable. We cannot
1358 create it here because we may be in an inner scope. */
1359 gcc_assert (*offsetvar != NULL_TREE);
1360 gfc_add_modify (pblock, *offsetvar, *poffset);
1361 *poffset = *offsetvar;
1362 TREE_USED (*offsetvar) = 1;
1363 }
1364
1365
1366 /* Variables needed for bounds-checking. */
1367 static bool first_len;
1368 static tree first_len_val;
1369 static bool typespec_chararray_ctor;
1370
1371 static void
gfc_trans_array_ctor_element(stmtblock_t * pblock,tree desc,tree offset,gfc_se * se,gfc_expr * expr)1372 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1373 tree offset, gfc_se * se, gfc_expr * expr)
1374 {
1375 tree tmp;
1376
1377 gfc_conv_expr (se, expr);
1378
1379 /* Store the value. */
1380 tmp = build_fold_indirect_ref_loc (input_location,
1381 gfc_conv_descriptor_data_get (desc));
1382 tmp = gfc_build_array_ref (tmp, offset, NULL);
1383
1384 if (expr->ts.type == BT_CHARACTER)
1385 {
1386 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1387 tree esize;
1388
1389 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1390 esize = fold_convert (gfc_charlen_type_node, esize);
1391 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1392 gfc_charlen_type_node, esize,
1393 build_int_cst (gfc_charlen_type_node,
1394 gfc_character_kinds[i].bit_size / 8));
1395
1396 gfc_conv_string_parameter (se);
1397 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1398 {
1399 /* The temporary is an array of pointers. */
1400 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1401 gfc_add_modify (&se->pre, tmp, se->expr);
1402 }
1403 else
1404 {
1405 /* The temporary is an array of string values. */
1406 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1407 /* We know the temporary and the value will be the same length,
1408 so can use memcpy. */
1409 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1410 se->string_length, se->expr, expr->ts.kind);
1411 }
1412 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1413 {
1414 if (first_len)
1415 {
1416 gfc_add_modify (&se->pre, first_len_val,
1417 se->string_length);
1418 first_len = false;
1419 }
1420 else
1421 {
1422 /* Verify that all constructor elements are of the same
1423 length. */
1424 tree cond = fold_build2_loc (input_location, NE_EXPR,
1425 boolean_type_node, first_len_val,
1426 se->string_length);
1427 gfc_trans_runtime_check
1428 (true, false, cond, &se->pre, &expr->where,
1429 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1430 fold_convert (long_integer_type_node, first_len_val),
1431 fold_convert (long_integer_type_node, se->string_length));
1432 }
1433 }
1434 }
1435 else
1436 {
1437 /* TODO: Should the frontend already have done this conversion? */
1438 se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1439 gfc_add_modify (&se->pre, tmp, se->expr);
1440 }
1441
1442 gfc_add_block_to_block (pblock, &se->pre);
1443 gfc_add_block_to_block (pblock, &se->post);
1444 }
1445
1446
1447 /* Add the contents of an array to the constructor. DYNAMIC is as for
1448 gfc_trans_array_constructor_value. */
1449
1450 static void
gfc_trans_array_constructor_subarray(stmtblock_t * pblock,tree type ATTRIBUTE_UNUSED,tree desc,gfc_expr * expr,tree * poffset,tree * offsetvar,bool dynamic)1451 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1452 tree type ATTRIBUTE_UNUSED,
1453 tree desc, gfc_expr * expr,
1454 tree * poffset, tree * offsetvar,
1455 bool dynamic)
1456 {
1457 gfc_se se;
1458 gfc_ss *ss;
1459 gfc_loopinfo loop;
1460 stmtblock_t body;
1461 tree tmp;
1462 tree size;
1463 int n;
1464
1465 /* We need this to be a variable so we can increment it. */
1466 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1467
1468 gfc_init_se (&se, NULL);
1469
1470 /* Walk the array expression. */
1471 ss = gfc_walk_expr (expr);
1472 gcc_assert (ss != gfc_ss_terminator);
1473
1474 /* Initialize the scalarizer. */
1475 gfc_init_loopinfo (&loop);
1476 gfc_add_ss_to_loop (&loop, ss);
1477
1478 /* Initialize the loop. */
1479 gfc_conv_ss_startstride (&loop);
1480 gfc_conv_loop_setup (&loop, &expr->where);
1481
1482 /* Make sure the constructed array has room for the new data. */
1483 if (dynamic)
1484 {
1485 /* Set SIZE to the total number of elements in the subarray. */
1486 size = gfc_index_one_node;
1487 for (n = 0; n < loop.dimen; n++)
1488 {
1489 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1490 gfc_index_one_node);
1491 size = fold_build2_loc (input_location, MULT_EXPR,
1492 gfc_array_index_type, size, tmp);
1493 }
1494
1495 /* Grow the constructed array by SIZE elements. */
1496 gfc_grow_array (&loop.pre, desc, size);
1497 }
1498
1499 /* Make the loop body. */
1500 gfc_mark_ss_chain_used (ss, 1);
1501 gfc_start_scalarized_body (&loop, &body);
1502 gfc_copy_loopinfo_to_se (&se, &loop);
1503 se.ss = ss;
1504
1505 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1506 gcc_assert (se.ss == gfc_ss_terminator);
1507
1508 /* Increment the offset. */
1509 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1510 *poffset, gfc_index_one_node);
1511 gfc_add_modify (&body, *poffset, tmp);
1512
1513 /* Finish the loop. */
1514 gfc_trans_scalarizing_loops (&loop, &body);
1515 gfc_add_block_to_block (&loop.pre, &loop.post);
1516 tmp = gfc_finish_block (&loop.pre);
1517 gfc_add_expr_to_block (pblock, tmp);
1518
1519 gfc_cleanup_loop (&loop);
1520 }
1521
1522
1523 /* Assign the values to the elements of an array constructor. DYNAMIC
1524 is true if descriptor DESC only contains enough data for the static
1525 size calculated by gfc_get_array_constructor_size. When true, memory
1526 for the dynamic parts must be allocated using realloc. */
1527
1528 static void
gfc_trans_array_constructor_value(stmtblock_t * pblock,tree type,tree desc,gfc_constructor_base base,tree * poffset,tree * offsetvar,bool dynamic)1529 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1530 tree desc, gfc_constructor_base base,
1531 tree * poffset, tree * offsetvar,
1532 bool dynamic)
1533 {
1534 tree tmp;
1535 tree start = NULL_TREE;
1536 tree end = NULL_TREE;
1537 tree step = NULL_TREE;
1538 stmtblock_t body;
1539 gfc_se se;
1540 mpz_t size;
1541 gfc_constructor *c;
1542
1543 tree shadow_loopvar = NULL_TREE;
1544 gfc_saved_var saved_loopvar;
1545
1546 mpz_init (size);
1547 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1548 {
1549 /* If this is an iterator or an array, the offset must be a variable. */
1550 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1551 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1552
1553 /* Shadowing the iterator avoids changing its value and saves us from
1554 keeping track of it. Further, it makes sure that there's always a
1555 backend-decl for the symbol, even if there wasn't one before,
1556 e.g. in the case of an iterator that appears in a specification
1557 expression in an interface mapping. */
1558 if (c->iterator)
1559 {
1560 gfc_symbol *sym;
1561 tree type;
1562
1563 /* Evaluate loop bounds before substituting the loop variable
1564 in case they depend on it. Such a case is invalid, but it is
1565 not more expensive to do the right thing here.
1566 See PR 44354. */
1567 gfc_init_se (&se, NULL);
1568 gfc_conv_expr_val (&se, c->iterator->start);
1569 gfc_add_block_to_block (pblock, &se.pre);
1570 start = gfc_evaluate_now (se.expr, pblock);
1571
1572 gfc_init_se (&se, NULL);
1573 gfc_conv_expr_val (&se, c->iterator->end);
1574 gfc_add_block_to_block (pblock, &se.pre);
1575 end = gfc_evaluate_now (se.expr, pblock);
1576
1577 gfc_init_se (&se, NULL);
1578 gfc_conv_expr_val (&se, c->iterator->step);
1579 gfc_add_block_to_block (pblock, &se.pre);
1580 step = gfc_evaluate_now (se.expr, pblock);
1581
1582 sym = c->iterator->var->symtree->n.sym;
1583 type = gfc_typenode_for_spec (&sym->ts);
1584
1585 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1586 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1587 }
1588
1589 gfc_start_block (&body);
1590
1591 if (c->expr->expr_type == EXPR_ARRAY)
1592 {
1593 /* Array constructors can be nested. */
1594 gfc_trans_array_constructor_value (&body, type, desc,
1595 c->expr->value.constructor,
1596 poffset, offsetvar, dynamic);
1597 }
1598 else if (c->expr->rank > 0)
1599 {
1600 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1601 poffset, offsetvar, dynamic);
1602 }
1603 else
1604 {
1605 /* This code really upsets the gimplifier so don't bother for now. */
1606 gfc_constructor *p;
1607 HOST_WIDE_INT n;
1608 HOST_WIDE_INT size;
1609
1610 p = c;
1611 n = 0;
1612 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1613 {
1614 p = gfc_constructor_next (p);
1615 n++;
1616 }
1617 if (n < 4)
1618 {
1619 /* Scalar values. */
1620 gfc_init_se (&se, NULL);
1621 gfc_trans_array_ctor_element (&body, desc, *poffset,
1622 &se, c->expr);
1623
1624 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1625 gfc_array_index_type,
1626 *poffset, gfc_index_one_node);
1627 }
1628 else
1629 {
1630 /* Collect multiple scalar constants into a constructor. */
1631 vec<constructor_elt, va_gc> *v = NULL;
1632 tree init;
1633 tree bound;
1634 tree tmptype;
1635 HOST_WIDE_INT idx = 0;
1636
1637 p = c;
1638 /* Count the number of consecutive scalar constants. */
1639 while (p && !(p->iterator
1640 || p->expr->expr_type != EXPR_CONSTANT))
1641 {
1642 gfc_init_se (&se, NULL);
1643 gfc_conv_constant (&se, p->expr);
1644
1645 if (c->expr->ts.type != BT_CHARACTER)
1646 se.expr = fold_convert (type, se.expr);
1647 /* For constant character array constructors we build
1648 an array of pointers. */
1649 else if (POINTER_TYPE_P (type))
1650 se.expr = gfc_build_addr_expr
1651 (gfc_get_pchar_type (p->expr->ts.kind),
1652 se.expr);
1653
1654 CONSTRUCTOR_APPEND_ELT (v,
1655 build_int_cst (gfc_array_index_type,
1656 idx++),
1657 se.expr);
1658 c = p;
1659 p = gfc_constructor_next (p);
1660 }
1661
1662 bound = size_int (n - 1);
1663 /* Create an array type to hold them. */
1664 tmptype = build_range_type (gfc_array_index_type,
1665 gfc_index_zero_node, bound);
1666 tmptype = build_array_type (type, tmptype);
1667
1668 init = build_constructor (tmptype, v);
1669 TREE_CONSTANT (init) = 1;
1670 TREE_STATIC (init) = 1;
1671 /* Create a static variable to hold the data. */
1672 tmp = gfc_create_var (tmptype, "data");
1673 TREE_STATIC (tmp) = 1;
1674 TREE_CONSTANT (tmp) = 1;
1675 TREE_READONLY (tmp) = 1;
1676 DECL_INITIAL (tmp) = init;
1677 init = tmp;
1678
1679 /* Use BUILTIN_MEMCPY to assign the values. */
1680 tmp = gfc_conv_descriptor_data_get (desc);
1681 tmp = build_fold_indirect_ref_loc (input_location,
1682 tmp);
1683 tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1684 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1685 init = gfc_build_addr_expr (NULL_TREE, init);
1686
1687 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1688 bound = build_int_cst (size_type_node, n * size);
1689 tmp = build_call_expr_loc (input_location,
1690 builtin_decl_explicit (BUILT_IN_MEMCPY),
1691 3, tmp, init, bound);
1692 gfc_add_expr_to_block (&body, tmp);
1693
1694 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
1695 gfc_array_index_type, *poffset,
1696 build_int_cst (gfc_array_index_type, n));
1697 }
1698 if (!INTEGER_CST_P (*poffset))
1699 {
1700 gfc_add_modify (&body, *offsetvar, *poffset);
1701 *poffset = *offsetvar;
1702 }
1703 }
1704
1705 /* The frontend should already have done any expansions
1706 at compile-time. */
1707 if (!c->iterator)
1708 {
1709 /* Pass the code as is. */
1710 tmp = gfc_finish_block (&body);
1711 gfc_add_expr_to_block (pblock, tmp);
1712 }
1713 else
1714 {
1715 /* Build the implied do-loop. */
1716 stmtblock_t implied_do_block;
1717 tree cond;
1718 tree exit_label;
1719 tree loopbody;
1720 tree tmp2;
1721
1722 loopbody = gfc_finish_block (&body);
1723
1724 /* Create a new block that holds the implied-do loop. A temporary
1725 loop-variable is used. */
1726 gfc_start_block(&implied_do_block);
1727
1728 /* Initialize the loop. */
1729 gfc_add_modify (&implied_do_block, shadow_loopvar, start);
1730
1731 /* If this array expands dynamically, and the number of iterations
1732 is not constant, we won't have allocated space for the static
1733 part of C->EXPR's size. Do that now. */
1734 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1735 {
1736 /* Get the number of iterations. */
1737 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1738
1739 /* Get the static part of C->EXPR's size. */
1740 gfc_get_array_constructor_element_size (&size, c->expr);
1741 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1742
1743 /* Grow the array by TMP * TMP2 elements. */
1744 tmp = fold_build2_loc (input_location, MULT_EXPR,
1745 gfc_array_index_type, tmp, tmp2);
1746 gfc_grow_array (&implied_do_block, desc, tmp);
1747 }
1748
1749 /* Generate the loop body. */
1750 exit_label = gfc_build_label_decl (NULL_TREE);
1751 gfc_start_block (&body);
1752
1753 /* Generate the exit condition. Depending on the sign of
1754 the step variable we have to generate the correct
1755 comparison. */
1756 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1757 step, build_int_cst (TREE_TYPE (step), 0));
1758 cond = fold_build3_loc (input_location, COND_EXPR,
1759 boolean_type_node, tmp,
1760 fold_build2_loc (input_location, GT_EXPR,
1761 boolean_type_node, shadow_loopvar, end),
1762 fold_build2_loc (input_location, LT_EXPR,
1763 boolean_type_node, shadow_loopvar, end));
1764 tmp = build1_v (GOTO_EXPR, exit_label);
1765 TREE_USED (exit_label) = 1;
1766 tmp = build3_v (COND_EXPR, cond, tmp,
1767 build_empty_stmt (input_location));
1768 gfc_add_expr_to_block (&body, tmp);
1769
1770 /* The main loop body. */
1771 gfc_add_expr_to_block (&body, loopbody);
1772
1773 /* Increase loop variable by step. */
1774 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1775 TREE_TYPE (shadow_loopvar), shadow_loopvar,
1776 step);
1777 gfc_add_modify (&body, shadow_loopvar, tmp);
1778
1779 /* Finish the loop. */
1780 tmp = gfc_finish_block (&body);
1781 tmp = build1_v (LOOP_EXPR, tmp);
1782 gfc_add_expr_to_block (&implied_do_block, tmp);
1783
1784 /* Add the exit label. */
1785 tmp = build1_v (LABEL_EXPR, exit_label);
1786 gfc_add_expr_to_block (&implied_do_block, tmp);
1787
1788 /* Finish the implied-do loop. */
1789 tmp = gfc_finish_block(&implied_do_block);
1790 gfc_add_expr_to_block(pblock, tmp);
1791
1792 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1793 }
1794 }
1795 mpz_clear (size);
1796 }
1797
1798
1799 /* A catch-all to obtain the string length for anything that is not
1800 a substring of non-constant length, a constant, array or variable. */
1801
1802 static void
get_array_ctor_all_strlen(stmtblock_t * block,gfc_expr * e,tree * len)1803 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1804 {
1805 gfc_se se;
1806
1807 /* Don't bother if we already know the length is a constant. */
1808 if (*len && INTEGER_CST_P (*len))
1809 return;
1810
1811 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1812 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1813 {
1814 /* This is easy. */
1815 gfc_conv_const_charlen (e->ts.u.cl);
1816 *len = e->ts.u.cl->backend_decl;
1817 }
1818 else
1819 {
1820 /* Otherwise, be brutal even if inefficient. */
1821 gfc_init_se (&se, NULL);
1822
1823 /* No function call, in case of side effects. */
1824 se.no_function_call = 1;
1825 if (e->rank == 0)
1826 gfc_conv_expr (&se, e);
1827 else
1828 gfc_conv_expr_descriptor (&se, e);
1829
1830 /* Fix the value. */
1831 *len = gfc_evaluate_now (se.string_length, &se.pre);
1832
1833 gfc_add_block_to_block (block, &se.pre);
1834 gfc_add_block_to_block (block, &se.post);
1835
1836 e->ts.u.cl->backend_decl = *len;
1837 }
1838 }
1839
1840
1841 /* Figure out the string length of a variable reference expression.
1842 Used by get_array_ctor_strlen. */
1843
1844 static void
get_array_ctor_var_strlen(stmtblock_t * block,gfc_expr * expr,tree * len)1845 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
1846 {
1847 gfc_ref *ref;
1848 gfc_typespec *ts;
1849 mpz_t char_len;
1850
1851 /* Don't bother if we already know the length is a constant. */
1852 if (*len && INTEGER_CST_P (*len))
1853 return;
1854
1855 ts = &expr->symtree->n.sym->ts;
1856 for (ref = expr->ref; ref; ref = ref->next)
1857 {
1858 switch (ref->type)
1859 {
1860 case REF_ARRAY:
1861 /* Array references don't change the string length. */
1862 break;
1863
1864 case REF_COMPONENT:
1865 /* Use the length of the component. */
1866 ts = &ref->u.c.component->ts;
1867 break;
1868
1869 case REF_SUBSTRING:
1870 if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1871 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1872 {
1873 /* Note that this might evaluate expr. */
1874 get_array_ctor_all_strlen (block, expr, len);
1875 return;
1876 }
1877 mpz_init_set_ui (char_len, 1);
1878 mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1879 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1880 *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1881 *len = convert (gfc_charlen_type_node, *len);
1882 mpz_clear (char_len);
1883 return;
1884
1885 default:
1886 gcc_unreachable ();
1887 }
1888 }
1889
1890 *len = ts->u.cl->backend_decl;
1891 }
1892
1893
1894 /* Figure out the string length of a character array constructor.
1895 If len is NULL, don't calculate the length; this happens for recursive calls
1896 when a sub-array-constructor is an element but not at the first position,
1897 so when we're not interested in the length.
1898 Returns TRUE if all elements are character constants. */
1899
1900 bool
get_array_ctor_strlen(stmtblock_t * block,gfc_constructor_base base,tree * len)1901 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
1902 {
1903 gfc_constructor *c;
1904 bool is_const;
1905
1906 is_const = TRUE;
1907
1908 if (gfc_constructor_first (base) == NULL)
1909 {
1910 if (len)
1911 *len = build_int_cstu (gfc_charlen_type_node, 0);
1912 return is_const;
1913 }
1914
1915 /* Loop over all constructor elements to find out is_const, but in len we
1916 want to store the length of the first, not the last, element. We can
1917 of course exit the loop as soon as is_const is found to be false. */
1918 for (c = gfc_constructor_first (base);
1919 c && is_const; c = gfc_constructor_next (c))
1920 {
1921 switch (c->expr->expr_type)
1922 {
1923 case EXPR_CONSTANT:
1924 if (len && !(*len && INTEGER_CST_P (*len)))
1925 *len = build_int_cstu (gfc_charlen_type_node,
1926 c->expr->value.character.length);
1927 break;
1928
1929 case EXPR_ARRAY:
1930 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1931 is_const = false;
1932 break;
1933
1934 case EXPR_VARIABLE:
1935 is_const = false;
1936 if (len)
1937 get_array_ctor_var_strlen (block, c->expr, len);
1938 break;
1939
1940 default:
1941 is_const = false;
1942 if (len)
1943 get_array_ctor_all_strlen (block, c->expr, len);
1944 break;
1945 }
1946
1947 /* After the first iteration, we don't want the length modified. */
1948 len = NULL;
1949 }
1950
1951 return is_const;
1952 }
1953
1954 /* Check whether the array constructor C consists entirely of constant
1955 elements, and if so returns the number of those elements, otherwise
1956 return zero. Note, an empty or NULL array constructor returns zero. */
1957
1958 unsigned HOST_WIDE_INT
gfc_constant_array_constructor_p(gfc_constructor_base base)1959 gfc_constant_array_constructor_p (gfc_constructor_base base)
1960 {
1961 unsigned HOST_WIDE_INT nelem = 0;
1962
1963 gfc_constructor *c = gfc_constructor_first (base);
1964 while (c)
1965 {
1966 if (c->iterator
1967 || c->expr->rank > 0
1968 || c->expr->expr_type != EXPR_CONSTANT)
1969 return 0;
1970 c = gfc_constructor_next (c);
1971 nelem++;
1972 }
1973 return nelem;
1974 }
1975
1976
1977 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1978 and the tree type of it's elements, TYPE, return a static constant
1979 variable that is compile-time initialized. */
1980
1981 tree
gfc_build_constant_array_constructor(gfc_expr * expr,tree type)1982 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1983 {
1984 tree tmptype, init, tmp;
1985 HOST_WIDE_INT nelem;
1986 gfc_constructor *c;
1987 gfc_array_spec as;
1988 gfc_se se;
1989 int i;
1990 vec<constructor_elt, va_gc> *v = NULL;
1991
1992 /* First traverse the constructor list, converting the constants
1993 to tree to build an initializer. */
1994 nelem = 0;
1995 c = gfc_constructor_first (expr->value.constructor);
1996 while (c)
1997 {
1998 gfc_init_se (&se, NULL);
1999 gfc_conv_constant (&se, c->expr);
2000 if (c->expr->ts.type != BT_CHARACTER)
2001 se.expr = fold_convert (type, se.expr);
2002 else if (POINTER_TYPE_P (type))
2003 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2004 se.expr);
2005 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2006 se.expr);
2007 c = gfc_constructor_next (c);
2008 nelem++;
2009 }
2010
2011 /* Next determine the tree type for the array. We use the gfortran
2012 front-end's gfc_get_nodesc_array_type in order to create a suitable
2013 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2014
2015 memset (&as, 0, sizeof (gfc_array_spec));
2016
2017 as.rank = expr->rank;
2018 as.type = AS_EXPLICIT;
2019 if (!expr->shape)
2020 {
2021 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2022 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2023 NULL, nelem - 1);
2024 }
2025 else
2026 for (i = 0; i < expr->rank; i++)
2027 {
2028 int tmp = (int) mpz_get_si (expr->shape[i]);
2029 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2030 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2031 NULL, tmp - 1);
2032 }
2033
2034 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2035
2036 /* as is not needed anymore. */
2037 for (i = 0; i < as.rank + as.corank; i++)
2038 {
2039 gfc_free_expr (as.lower[i]);
2040 gfc_free_expr (as.upper[i]);
2041 }
2042
2043 init = build_constructor (tmptype, v);
2044
2045 TREE_CONSTANT (init) = 1;
2046 TREE_STATIC (init) = 1;
2047
2048 tmp = gfc_create_var (tmptype, "A");
2049 TREE_STATIC (tmp) = 1;
2050 TREE_CONSTANT (tmp) = 1;
2051 TREE_READONLY (tmp) = 1;
2052 DECL_INITIAL (tmp) = init;
2053
2054 return tmp;
2055 }
2056
2057
2058 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2059 This mostly initializes the scalarizer state info structure with the
2060 appropriate values to directly use the array created by the function
2061 gfc_build_constant_array_constructor. */
2062
2063 static void
trans_constant_array_constructor(gfc_ss * ss,tree type)2064 trans_constant_array_constructor (gfc_ss * ss, tree type)
2065 {
2066 gfc_array_info *info;
2067 tree tmp;
2068 int i;
2069
2070 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2071
2072 info = &ss->info->data.array;
2073
2074 info->descriptor = tmp;
2075 info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2076 info->offset = gfc_index_zero_node;
2077
2078 for (i = 0; i < ss->dimen; i++)
2079 {
2080 info->delta[i] = gfc_index_zero_node;
2081 info->start[i] = gfc_index_zero_node;
2082 info->end[i] = gfc_index_zero_node;
2083 info->stride[i] = gfc_index_one_node;
2084 }
2085 }
2086
2087
2088 static int
get_rank(gfc_loopinfo * loop)2089 get_rank (gfc_loopinfo *loop)
2090 {
2091 int rank;
2092
2093 rank = 0;
2094 for (; loop; loop = loop->parent)
2095 rank += loop->dimen;
2096
2097 return rank;
2098 }
2099
2100
2101 /* Helper routine of gfc_trans_array_constructor to determine if the
2102 bounds of the loop specified by LOOP are constant and simple enough
2103 to use with trans_constant_array_constructor. Returns the
2104 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2105
2106 static tree
constant_array_constructor_loop_size(gfc_loopinfo * l)2107 constant_array_constructor_loop_size (gfc_loopinfo * l)
2108 {
2109 gfc_loopinfo *loop;
2110 tree size = gfc_index_one_node;
2111 tree tmp;
2112 int i, total_dim;
2113
2114 total_dim = get_rank (l);
2115
2116 for (loop = l; loop; loop = loop->parent)
2117 {
2118 for (i = 0; i < loop->dimen; i++)
2119 {
2120 /* If the bounds aren't constant, return NULL_TREE. */
2121 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
2122 return NULL_TREE;
2123 if (!integer_zerop (loop->from[i]))
2124 {
2125 /* Only allow nonzero "from" in one-dimensional arrays. */
2126 if (total_dim != 1)
2127 return NULL_TREE;
2128 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2129 gfc_array_index_type,
2130 loop->to[i], loop->from[i]);
2131 }
2132 else
2133 tmp = loop->to[i];
2134 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2135 gfc_array_index_type, tmp, gfc_index_one_node);
2136 size = fold_build2_loc (input_location, MULT_EXPR,
2137 gfc_array_index_type, size, tmp);
2138 }
2139 }
2140
2141 return size;
2142 }
2143
2144
2145 static tree *
get_loop_upper_bound_for_array(gfc_ss * array,int array_dim)2146 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2147 {
2148 gfc_ss *ss;
2149 int n;
2150
2151 gcc_assert (array->nested_ss == NULL);
2152
2153 for (ss = array; ss; ss = ss->parent)
2154 for (n = 0; n < ss->loop->dimen; n++)
2155 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2156 return &(ss->loop->to[n]);
2157
2158 gcc_unreachable ();
2159 }
2160
2161
2162 static gfc_loopinfo *
outermost_loop(gfc_loopinfo * loop)2163 outermost_loop (gfc_loopinfo * loop)
2164 {
2165 while (loop->parent != NULL)
2166 loop = loop->parent;
2167
2168 return loop;
2169 }
2170
2171
2172 /* Array constructors are handled by constructing a temporary, then using that
2173 within the scalarization loop. This is not optimal, but seems by far the
2174 simplest method. */
2175
2176 static void
trans_array_constructor(gfc_ss * ss,locus * where)2177 trans_array_constructor (gfc_ss * ss, locus * where)
2178 {
2179 gfc_constructor_base c;
2180 tree offset;
2181 tree offsetvar;
2182 tree desc;
2183 tree type;
2184 tree tmp;
2185 tree *loop_ubound0;
2186 bool dynamic;
2187 bool old_first_len, old_typespec_chararray_ctor;
2188 tree old_first_len_val;
2189 gfc_loopinfo *loop, *outer_loop;
2190 gfc_ss_info *ss_info;
2191 gfc_expr *expr;
2192 gfc_ss *s;
2193
2194 /* Save the old values for nested checking. */
2195 old_first_len = first_len;
2196 old_first_len_val = first_len_val;
2197 old_typespec_chararray_ctor = typespec_chararray_ctor;
2198
2199 loop = ss->loop;
2200 outer_loop = outermost_loop (loop);
2201 ss_info = ss->info;
2202 expr = ss_info->expr;
2203
2204 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2205 typespec was given for the array constructor. */
2206 typespec_chararray_ctor = (expr->ts.u.cl
2207 && expr->ts.u.cl->length_from_typespec);
2208
2209 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2210 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2211 {
2212 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2213 first_len = true;
2214 }
2215
2216 gcc_assert (ss->dimen == ss->loop->dimen);
2217
2218 c = expr->value.constructor;
2219 if (expr->ts.type == BT_CHARACTER)
2220 {
2221 bool const_string;
2222
2223 /* get_array_ctor_strlen walks the elements of the constructor, if a
2224 typespec was given, we already know the string length and want the one
2225 specified there. */
2226 if (typespec_chararray_ctor && expr->ts.u.cl->length
2227 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2228 {
2229 gfc_se length_se;
2230
2231 const_string = false;
2232 gfc_init_se (&length_se, NULL);
2233 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2234 gfc_charlen_type_node);
2235 ss_info->string_length = length_se.expr;
2236 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2237 gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2238 }
2239 else
2240 const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2241 &ss_info->string_length);
2242
2243 /* Complex character array constructors should have been taken care of
2244 and not end up here. */
2245 gcc_assert (ss_info->string_length);
2246
2247 expr->ts.u.cl->backend_decl = ss_info->string_length;
2248
2249 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2250 if (const_string)
2251 type = build_pointer_type (type);
2252 }
2253 else
2254 type = gfc_typenode_for_spec (&expr->ts);
2255
2256 /* See if the constructor determines the loop bounds. */
2257 dynamic = false;
2258
2259 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2260
2261 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
2262 {
2263 /* We have a multidimensional parameter. */
2264 for (s = ss; s; s = s->parent)
2265 {
2266 int n;
2267 for (n = 0; n < s->loop->dimen; n++)
2268 {
2269 s->loop->from[n] = gfc_index_zero_node;
2270 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2271 gfc_index_integer_kind);
2272 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2273 gfc_array_index_type,
2274 s->loop->to[n],
2275 gfc_index_one_node);
2276 }
2277 }
2278 }
2279
2280 if (*loop_ubound0 == NULL_TREE)
2281 {
2282 mpz_t size;
2283
2284 /* We should have a 1-dimensional, zero-based loop. */
2285 gcc_assert (loop->parent == NULL && loop->nested == NULL);
2286 gcc_assert (loop->dimen == 1);
2287 gcc_assert (integer_zerop (loop->from[0]));
2288
2289 /* Split the constructor size into a static part and a dynamic part.
2290 Allocate the static size up-front and record whether the dynamic
2291 size might be nonzero. */
2292 mpz_init (size);
2293 dynamic = gfc_get_array_constructor_size (&size, c);
2294 mpz_sub_ui (size, size, 1);
2295 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2296 mpz_clear (size);
2297 }
2298
2299 /* Special case constant array constructors. */
2300 if (!dynamic)
2301 {
2302 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
2303 if (nelem > 0)
2304 {
2305 tree size = constant_array_constructor_loop_size (loop);
2306 if (size && compare_tree_int (size, nelem) == 0)
2307 {
2308 trans_constant_array_constructor (ss, type);
2309 goto finish;
2310 }
2311 }
2312 }
2313
2314 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2315 NULL_TREE, dynamic, true, false, where);
2316
2317 desc = ss_info->data.array.descriptor;
2318 offset = gfc_index_zero_node;
2319 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2320 TREE_NO_WARNING (offsetvar) = 1;
2321 TREE_USED (offsetvar) = 0;
2322 gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
2323 &offset, &offsetvar, dynamic);
2324
2325 /* If the array grows dynamically, the upper bound of the loop variable
2326 is determined by the array's final upper bound. */
2327 if (dynamic)
2328 {
2329 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2330 gfc_array_index_type,
2331 offsetvar, gfc_index_one_node);
2332 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2333 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2334 if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL)
2335 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2336 else
2337 *loop_ubound0 = tmp;
2338 }
2339
2340 if (TREE_USED (offsetvar))
2341 pushdecl (offsetvar);
2342 else
2343 gcc_assert (INTEGER_CST_P (offset));
2344
2345 #if 0
2346 /* Disable bound checking for now because it's probably broken. */
2347 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2348 {
2349 gcc_unreachable ();
2350 }
2351 #endif
2352
2353 finish:
2354 /* Restore old values of globals. */
2355 first_len = old_first_len;
2356 first_len_val = old_first_len_val;
2357 typespec_chararray_ctor = old_typespec_chararray_ctor;
2358 }
2359
2360
2361 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2362 called after evaluating all of INFO's vector dimensions. Go through
2363 each such vector dimension and see if we can now fill in any missing
2364 loop bounds. */
2365
2366 static void
set_vector_loop_bounds(gfc_ss * ss)2367 set_vector_loop_bounds (gfc_ss * ss)
2368 {
2369 gfc_loopinfo *loop, *outer_loop;
2370 gfc_array_info *info;
2371 gfc_se se;
2372 tree tmp;
2373 tree desc;
2374 tree zero;
2375 int n;
2376 int dim;
2377
2378 outer_loop = outermost_loop (ss->loop);
2379
2380 info = &ss->info->data.array;
2381
2382 for (; ss; ss = ss->parent)
2383 {
2384 loop = ss->loop;
2385
2386 for (n = 0; n < loop->dimen; n++)
2387 {
2388 dim = ss->dim[n];
2389 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
2390 || loop->to[n] != NULL)
2391 continue;
2392
2393 /* Loop variable N indexes vector dimension DIM, and we don't
2394 yet know the upper bound of loop variable N. Set it to the
2395 difference between the vector's upper and lower bounds. */
2396 gcc_assert (loop->from[n] == gfc_index_zero_node);
2397 gcc_assert (info->subscript[dim]
2398 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2399
2400 gfc_init_se (&se, NULL);
2401 desc = info->subscript[dim]->info->data.array.descriptor;
2402 zero = gfc_rank_cst[0];
2403 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2404 gfc_array_index_type,
2405 gfc_conv_descriptor_ubound_get (desc, zero),
2406 gfc_conv_descriptor_lbound_get (desc, zero));
2407 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2408 loop->to[n] = tmp;
2409 }
2410 }
2411 }
2412
2413
2414 /* Add the pre and post chains for all the scalar expressions in a SS chain
2415 to loop. This is called after the loop parameters have been calculated,
2416 but before the actual scalarizing loops. */
2417
2418 static void
gfc_add_loop_ss_code(gfc_loopinfo * loop,gfc_ss * ss,bool subscript,locus * where)2419 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2420 locus * where)
2421 {
2422 gfc_loopinfo *nested_loop, *outer_loop;
2423 gfc_se se;
2424 gfc_ss_info *ss_info;
2425 gfc_array_info *info;
2426 gfc_expr *expr;
2427 int n;
2428
2429 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
2430 arguments could get evaluated multiple times. */
2431 if (ss->is_alloc_lhs)
2432 return;
2433
2434 outer_loop = outermost_loop (loop);
2435
2436 /* TODO: This can generate bad code if there are ordering dependencies,
2437 e.g., a callee allocated function and an unknown size constructor. */
2438 gcc_assert (ss != NULL);
2439
2440 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2441 {
2442 gcc_assert (ss);
2443
2444 /* Cross loop arrays are handled from within the most nested loop. */
2445 if (ss->nested_ss != NULL)
2446 continue;
2447
2448 ss_info = ss->info;
2449 expr = ss_info->expr;
2450 info = &ss_info->data.array;
2451
2452 switch (ss_info->type)
2453 {
2454 case GFC_SS_SCALAR:
2455 /* Scalar expression. Evaluate this now. This includes elemental
2456 dimension indices, but not array section bounds. */
2457 gfc_init_se (&se, NULL);
2458 gfc_conv_expr (&se, expr);
2459 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2460
2461 if (expr->ts.type != BT_CHARACTER)
2462 {
2463 /* Move the evaluation of scalar expressions outside the
2464 scalarization loop, except for WHERE assignments. */
2465 if (subscript)
2466 se.expr = convert(gfc_array_index_type, se.expr);
2467 if (!ss_info->where)
2468 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
2469 gfc_add_block_to_block (&outer_loop->pre, &se.post);
2470 }
2471 else
2472 gfc_add_block_to_block (&outer_loop->post, &se.post);
2473
2474 ss_info->data.scalar.value = se.expr;
2475 ss_info->string_length = se.string_length;
2476 break;
2477
2478 case GFC_SS_REFERENCE:
2479 /* Scalar argument to elemental procedure. */
2480 gfc_init_se (&se, NULL);
2481 if (ss_info->can_be_null_ref)
2482 {
2483 /* If the actual argument can be absent (in other words, it can
2484 be a NULL reference), don't try to evaluate it; pass instead
2485 the reference directly. */
2486 gfc_conv_expr_reference (&se, expr);
2487 }
2488 else
2489 {
2490 /* Otherwise, evaluate the argument outside the loop and pass
2491 a reference to the value. */
2492 gfc_conv_expr (&se, expr);
2493 }
2494
2495 /* Ensure that a pointer to the string is stored. */
2496 if (expr->ts.type == BT_CHARACTER)
2497 gfc_conv_string_parameter (&se);
2498
2499 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2500 gfc_add_block_to_block (&outer_loop->post, &se.post);
2501 if (gfc_is_class_scalar_expr (expr))
2502 /* This is necessary because the dynamic type will always be
2503 large than the declared type. In consequence, assigning
2504 the value to a temporary could segfault.
2505 OOP-TODO: see if this is generally correct or is the value
2506 has to be written to an allocated temporary, whose address
2507 is passed via ss_info. */
2508 ss_info->data.scalar.value = se.expr;
2509 else
2510 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
2511 &outer_loop->pre);
2512
2513 ss_info->string_length = se.string_length;
2514 break;
2515
2516 case GFC_SS_SECTION:
2517 /* Add the expressions for scalar and vector subscripts. */
2518 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2519 if (info->subscript[n])
2520 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
2521
2522 set_vector_loop_bounds (ss);
2523 break;
2524
2525 case GFC_SS_VECTOR:
2526 /* Get the vector's descriptor and store it in SS. */
2527 gfc_init_se (&se, NULL);
2528 gfc_conv_expr_descriptor (&se, expr);
2529 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2530 gfc_add_block_to_block (&outer_loop->post, &se.post);
2531 info->descriptor = se.expr;
2532 break;
2533
2534 case GFC_SS_INTRINSIC:
2535 gfc_add_intrinsic_ss_code (loop, ss);
2536 break;
2537
2538 case GFC_SS_FUNCTION:
2539 /* Array function return value. We call the function and save its
2540 result in a temporary for use inside the loop. */
2541 gfc_init_se (&se, NULL);
2542 se.loop = loop;
2543 se.ss = ss;
2544 gfc_conv_expr (&se, expr);
2545 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2546 gfc_add_block_to_block (&outer_loop->post, &se.post);
2547 ss_info->string_length = se.string_length;
2548 break;
2549
2550 case GFC_SS_CONSTRUCTOR:
2551 if (expr->ts.type == BT_CHARACTER
2552 && ss_info->string_length == NULL
2553 && expr->ts.u.cl
2554 && expr->ts.u.cl->length)
2555 {
2556 gfc_init_se (&se, NULL);
2557 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
2558 gfc_charlen_type_node);
2559 ss_info->string_length = se.expr;
2560 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
2561 gfc_add_block_to_block (&outer_loop->post, &se.post);
2562 }
2563 trans_array_constructor (ss, where);
2564 break;
2565
2566 case GFC_SS_TEMP:
2567 case GFC_SS_COMPONENT:
2568 /* Do nothing. These are handled elsewhere. */
2569 break;
2570
2571 default:
2572 gcc_unreachable ();
2573 }
2574 }
2575
2576 if (!subscript)
2577 for (nested_loop = loop->nested; nested_loop;
2578 nested_loop = nested_loop->next)
2579 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
2580 }
2581
2582
2583 /* Translate expressions for the descriptor and data pointer of a SS. */
2584 /*GCC ARRAYS*/
2585
2586 static void
gfc_conv_ss_descriptor(stmtblock_t * block,gfc_ss * ss,int base)2587 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2588 {
2589 gfc_se se;
2590 gfc_ss_info *ss_info;
2591 gfc_array_info *info;
2592 tree tmp;
2593
2594 ss_info = ss->info;
2595 info = &ss_info->data.array;
2596
2597 /* Get the descriptor for the array to be scalarized. */
2598 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
2599 gfc_init_se (&se, NULL);
2600 se.descriptor_only = 1;
2601 gfc_conv_expr_lhs (&se, ss_info->expr);
2602 gfc_add_block_to_block (block, &se.pre);
2603 info->descriptor = se.expr;
2604 ss_info->string_length = se.string_length;
2605
2606 if (base)
2607 {
2608 /* Also the data pointer. */
2609 tmp = gfc_conv_array_data (se.expr);
2610 /* If this is a variable or address of a variable we use it directly.
2611 Otherwise we must evaluate it now to avoid breaking dependency
2612 analysis by pulling the expressions for elemental array indices
2613 inside the loop. */
2614 if (!(DECL_P (tmp)
2615 || (TREE_CODE (tmp) == ADDR_EXPR
2616 && DECL_P (TREE_OPERAND (tmp, 0)))))
2617 tmp = gfc_evaluate_now (tmp, block);
2618 info->data = tmp;
2619
2620 tmp = gfc_conv_array_offset (se.expr);
2621 info->offset = gfc_evaluate_now (tmp, block);
2622
2623 /* Make absolutely sure that the saved_offset is indeed saved
2624 so that the variable is still accessible after the loops
2625 are translated. */
2626 info->saved_offset = info->offset;
2627 }
2628 }
2629
2630
2631 /* Initialize a gfc_loopinfo structure. */
2632
2633 void
gfc_init_loopinfo(gfc_loopinfo * loop)2634 gfc_init_loopinfo (gfc_loopinfo * loop)
2635 {
2636 int n;
2637
2638 memset (loop, 0, sizeof (gfc_loopinfo));
2639 gfc_init_block (&loop->pre);
2640 gfc_init_block (&loop->post);
2641
2642 /* Initially scalarize in order and default to no loop reversal. */
2643 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2644 {
2645 loop->order[n] = n;
2646 loop->reverse[n] = GFC_INHIBIT_REVERSE;
2647 }
2648
2649 loop->ss = gfc_ss_terminator;
2650 }
2651
2652
2653 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2654 chain. */
2655
2656 void
gfc_copy_loopinfo_to_se(gfc_se * se,gfc_loopinfo * loop)2657 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2658 {
2659 se->loop = loop;
2660 }
2661
2662
2663 /* Return an expression for the data pointer of an array. */
2664
2665 tree
gfc_conv_array_data(tree descriptor)2666 gfc_conv_array_data (tree descriptor)
2667 {
2668 tree type;
2669
2670 type = TREE_TYPE (descriptor);
2671 if (GFC_ARRAY_TYPE_P (type))
2672 {
2673 if (TREE_CODE (type) == POINTER_TYPE)
2674 return descriptor;
2675 else
2676 {
2677 /* Descriptorless arrays. */
2678 return gfc_build_addr_expr (NULL_TREE, descriptor);
2679 }
2680 }
2681 else
2682 return gfc_conv_descriptor_data_get (descriptor);
2683 }
2684
2685
2686 /* Return an expression for the base offset of an array. */
2687
2688 tree
gfc_conv_array_offset(tree descriptor)2689 gfc_conv_array_offset (tree descriptor)
2690 {
2691 tree type;
2692
2693 type = TREE_TYPE (descriptor);
2694 if (GFC_ARRAY_TYPE_P (type))
2695 return GFC_TYPE_ARRAY_OFFSET (type);
2696 else
2697 return gfc_conv_descriptor_offset_get (descriptor);
2698 }
2699
2700
2701 /* Get an expression for the array stride. */
2702
2703 tree
gfc_conv_array_stride(tree descriptor,int dim)2704 gfc_conv_array_stride (tree descriptor, int dim)
2705 {
2706 tree tmp;
2707 tree type;
2708
2709 type = TREE_TYPE (descriptor);
2710
2711 /* For descriptorless arrays use the array size. */
2712 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2713 if (tmp != NULL_TREE)
2714 return tmp;
2715
2716 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2717 return tmp;
2718 }
2719
2720
2721 /* Like gfc_conv_array_stride, but for the lower bound. */
2722
2723 tree
gfc_conv_array_lbound(tree descriptor,int dim)2724 gfc_conv_array_lbound (tree descriptor, int dim)
2725 {
2726 tree tmp;
2727 tree type;
2728
2729 type = TREE_TYPE (descriptor);
2730
2731 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2732 if (tmp != NULL_TREE)
2733 return tmp;
2734
2735 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2736 return tmp;
2737 }
2738
2739
2740 /* Like gfc_conv_array_stride, but for the upper bound. */
2741
2742 tree
gfc_conv_array_ubound(tree descriptor,int dim)2743 gfc_conv_array_ubound (tree descriptor, int dim)
2744 {
2745 tree tmp;
2746 tree type;
2747
2748 type = TREE_TYPE (descriptor);
2749
2750 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2751 if (tmp != NULL_TREE)
2752 return tmp;
2753
2754 /* This should only ever happen when passing an assumed shape array
2755 as an actual parameter. The value will never be used. */
2756 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2757 return gfc_index_zero_node;
2758
2759 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2760 return tmp;
2761 }
2762
2763
2764 /* Generate code to perform an array index bound check. */
2765
2766 static tree
trans_array_bound_check(gfc_se * se,gfc_ss * ss,tree index,int n,locus * where,bool check_upper)2767 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
2768 locus * where, bool check_upper)
2769 {
2770 tree fault;
2771 tree tmp_lo, tmp_up;
2772 tree descriptor;
2773 char *msg;
2774 const char * name = NULL;
2775
2776 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2777 return index;
2778
2779 descriptor = ss->info->data.array.descriptor;
2780
2781 index = gfc_evaluate_now (index, &se->pre);
2782
2783 /* We find a name for the error message. */
2784 name = ss->info->expr->symtree->n.sym->name;
2785 gcc_assert (name != NULL);
2786
2787 if (TREE_CODE (descriptor) == VAR_DECL)
2788 name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
2789
2790 /* If upper bound is present, include both bounds in the error message. */
2791 if (check_upper)
2792 {
2793 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2794 tmp_up = gfc_conv_array_ubound (descriptor, n);
2795
2796 if (name)
2797 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2798 "outside of expected range (%%ld:%%ld)", n+1, name);
2799 else
2800 asprintf (&msg, "Index '%%ld' of dimension %d "
2801 "outside of expected range (%%ld:%%ld)", n+1);
2802
2803 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2804 index, tmp_lo);
2805 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2806 fold_convert (long_integer_type_node, index),
2807 fold_convert (long_integer_type_node, tmp_lo),
2808 fold_convert (long_integer_type_node, tmp_up));
2809 fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2810 index, tmp_up);
2811 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2812 fold_convert (long_integer_type_node, index),
2813 fold_convert (long_integer_type_node, tmp_lo),
2814 fold_convert (long_integer_type_node, tmp_up));
2815 free (msg);
2816 }
2817 else
2818 {
2819 tmp_lo = gfc_conv_array_lbound (descriptor, n);
2820
2821 if (name)
2822 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2823 "below lower bound of %%ld", n+1, name);
2824 else
2825 asprintf (&msg, "Index '%%ld' of dimension %d "
2826 "below lower bound of %%ld", n+1);
2827
2828 fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2829 index, tmp_lo);
2830 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2831 fold_convert (long_integer_type_node, index),
2832 fold_convert (long_integer_type_node, tmp_lo));
2833 free (msg);
2834 }
2835
2836 return index;
2837 }
2838
2839
2840 /* Return the offset for an index. Performs bound checking for elemental
2841 dimensions. Single element references are processed separately.
2842 DIM is the array dimension, I is the loop dimension. */
2843
2844 static tree
conv_array_index_offset(gfc_se * se,gfc_ss * ss,int dim,int i,gfc_array_ref * ar,tree stride)2845 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
2846 gfc_array_ref * ar, tree stride)
2847 {
2848 gfc_array_info *info;
2849 tree index;
2850 tree desc;
2851 tree data;
2852
2853 info = &ss->info->data.array;
2854
2855 /* Get the index into the array for this dimension. */
2856 if (ar)
2857 {
2858 gcc_assert (ar->type != AR_ELEMENT);
2859 switch (ar->dimen_type[dim])
2860 {
2861 case DIMEN_THIS_IMAGE:
2862 gcc_unreachable ();
2863 break;
2864 case DIMEN_ELEMENT:
2865 /* Elemental dimension. */
2866 gcc_assert (info->subscript[dim]
2867 && info->subscript[dim]->info->type == GFC_SS_SCALAR);
2868 /* We've already translated this value outside the loop. */
2869 index = info->subscript[dim]->info->data.scalar.value;
2870
2871 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2872 ar->as->type != AS_ASSUMED_SIZE
2873 || dim < ar->dimen - 1);
2874 break;
2875
2876 case DIMEN_VECTOR:
2877 gcc_assert (info && se->loop);
2878 gcc_assert (info->subscript[dim]
2879 && info->subscript[dim]->info->type == GFC_SS_VECTOR);
2880 desc = info->subscript[dim]->info->data.array.descriptor;
2881
2882 /* Get a zero-based index into the vector. */
2883 index = fold_build2_loc (input_location, MINUS_EXPR,
2884 gfc_array_index_type,
2885 se->loop->loopvar[i], se->loop->from[i]);
2886
2887 /* Multiply the index by the stride. */
2888 index = fold_build2_loc (input_location, MULT_EXPR,
2889 gfc_array_index_type,
2890 index, gfc_conv_array_stride (desc, 0));
2891
2892 /* Read the vector to get an index into info->descriptor. */
2893 data = build_fold_indirect_ref_loc (input_location,
2894 gfc_conv_array_data (desc));
2895 index = gfc_build_array_ref (data, index, NULL);
2896 index = gfc_evaluate_now (index, &se->pre);
2897 index = fold_convert (gfc_array_index_type, index);
2898
2899 /* Do any bounds checking on the final info->descriptor index. */
2900 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
2901 ar->as->type != AS_ASSUMED_SIZE
2902 || dim < ar->dimen - 1);
2903 break;
2904
2905 case DIMEN_RANGE:
2906 /* Scalarized dimension. */
2907 gcc_assert (info && se->loop);
2908
2909 /* Multiply the loop variable by the stride and delta. */
2910 index = se->loop->loopvar[i];
2911 if (!integer_onep (info->stride[dim]))
2912 index = fold_build2_loc (input_location, MULT_EXPR,
2913 gfc_array_index_type, index,
2914 info->stride[dim]);
2915 if (!integer_zerop (info->delta[dim]))
2916 index = fold_build2_loc (input_location, PLUS_EXPR,
2917 gfc_array_index_type, index,
2918 info->delta[dim]);
2919 break;
2920
2921 default:
2922 gcc_unreachable ();
2923 }
2924 }
2925 else
2926 {
2927 /* Temporary array or derived type component. */
2928 gcc_assert (se->loop);
2929 index = se->loop->loopvar[se->loop->order[i]];
2930
2931 /* Pointer functions can have stride[0] different from unity.
2932 Use the stride returned by the function call and stored in
2933 the descriptor for the temporary. */
2934 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
2935 && se->ss->info->expr
2936 && se->ss->info->expr->symtree
2937 && se->ss->info->expr->symtree->n.sym->result
2938 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
2939 stride = gfc_conv_descriptor_stride_get (info->descriptor,
2940 gfc_rank_cst[dim]);
2941
2942 if (!integer_zerop (info->delta[dim]))
2943 index = fold_build2_loc (input_location, PLUS_EXPR,
2944 gfc_array_index_type, index, info->delta[dim]);
2945 }
2946
2947 /* Multiply by the stride. */
2948 if (!integer_onep (stride))
2949 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
2950 index, stride);
2951
2952 return index;
2953 }
2954
2955
2956 /* Build a scalarized array reference using the vptr 'size'. */
2957
2958 static bool
build_class_array_ref(gfc_se * se,tree base,tree index)2959 build_class_array_ref (gfc_se *se, tree base, tree index)
2960 {
2961 tree type;
2962 tree size;
2963 tree offset;
2964 tree decl;
2965 tree tmp;
2966 gfc_expr *expr = se->ss->info->expr;
2967 gfc_ref *ref;
2968 gfc_ref *class_ref;
2969 gfc_typespec *ts;
2970
2971 if (expr == NULL || expr->ts.type != BT_CLASS)
2972 return false;
2973
2974 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
2975 ts = &expr->symtree->n.sym->ts;
2976 else
2977 ts = NULL;
2978 class_ref = NULL;
2979
2980 for (ref = expr->ref; ref; ref = ref->next)
2981 {
2982 if (ref->type == REF_COMPONENT
2983 && ref->u.c.component->ts.type == BT_CLASS
2984 && ref->next && ref->next->type == REF_COMPONENT
2985 && strcmp (ref->next->u.c.component->name, "_data") == 0
2986 && ref->next->next
2987 && ref->next->next->type == REF_ARRAY
2988 && ref->next->next->u.ar.type != AR_ELEMENT)
2989 {
2990 ts = &ref->u.c.component->ts;
2991 class_ref = ref;
2992 break;
2993 }
2994 }
2995
2996 if (ts == NULL)
2997 return false;
2998
2999 if (class_ref == NULL && expr->symtree->n.sym->attr.function
3000 && expr->symtree->n.sym == expr->symtree->n.sym->result)
3001 {
3002 gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
3003 decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
3004 }
3005 else if (class_ref == NULL)
3006 decl = expr->symtree->n.sym->backend_decl;
3007 else
3008 {
3009 /* Remove everything after the last class reference, convert the
3010 expression and then recover its tailend once more. */
3011 gfc_se tmpse;
3012 ref = class_ref->next;
3013 class_ref->next = NULL;
3014 gfc_init_se (&tmpse, NULL);
3015 gfc_conv_expr (&tmpse, expr);
3016 decl = tmpse.expr;
3017 class_ref->next = ref;
3018 }
3019
3020 size = gfc_vtable_size_get (decl);
3021
3022 /* Build the address of the element. */
3023 type = TREE_TYPE (TREE_TYPE (base));
3024 size = fold_convert (TREE_TYPE (index), size);
3025 offset = fold_build2_loc (input_location, MULT_EXPR,
3026 gfc_array_index_type,
3027 index, size);
3028 tmp = gfc_build_addr_expr (pvoid_type_node, base);
3029 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
3030 tmp = fold_convert (build_pointer_type (type), tmp);
3031
3032 /* Return the element in the se expression. */
3033 se->expr = build_fold_indirect_ref_loc (input_location, tmp);
3034 return true;
3035 }
3036
3037
3038 /* Build a scalarized reference to an array. */
3039
3040 static void
gfc_conv_scalarized_array_ref(gfc_se * se,gfc_array_ref * ar)3041 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
3042 {
3043 gfc_array_info *info;
3044 tree decl = NULL_TREE;
3045 tree index;
3046 tree tmp;
3047 gfc_ss *ss;
3048 gfc_expr *expr;
3049 int n;
3050
3051 ss = se->ss;
3052 expr = ss->info->expr;
3053 info = &ss->info->data.array;
3054 if (ar)
3055 n = se->loop->order[0];
3056 else
3057 n = 0;
3058
3059 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3060 /* Add the offset for this dimension to the stored offset for all other
3061 dimensions. */
3062 if (!integer_zerop (info->offset))
3063 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3064 index, info->offset);
3065
3066 if (expr && is_subref_array (expr))
3067 decl = expr->symtree->n.sym->backend_decl;
3068
3069 tmp = build_fold_indirect_ref_loc (input_location, info->data);
3070
3071 /* Use the vptr 'size' field to access a class the element of a class
3072 array. */
3073 if (build_class_array_ref (se, tmp, index))
3074 return;
3075
3076 se->expr = gfc_build_array_ref (tmp, index, decl);
3077 }
3078
3079
3080 /* Translate access of temporary array. */
3081
3082 void
gfc_conv_tmp_array_ref(gfc_se * se)3083 gfc_conv_tmp_array_ref (gfc_se * se)
3084 {
3085 se->string_length = se->ss->info->string_length;
3086 gfc_conv_scalarized_array_ref (se, NULL);
3087 gfc_advance_se_ss_chain (se);
3088 }
3089
3090 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3091
3092 static void
add_to_offset(tree * cst_offset,tree * offset,tree t)3093 add_to_offset (tree *cst_offset, tree *offset, tree t)
3094 {
3095 if (TREE_CODE (t) == INTEGER_CST)
3096 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3097 else
3098 {
3099 if (!integer_zerop (*offset))
3100 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3101 gfc_array_index_type, *offset, t);
3102 else
3103 *offset = t;
3104 }
3105 }
3106
3107
3108 static tree
build_array_ref(tree desc,tree offset,tree decl)3109 build_array_ref (tree desc, tree offset, tree decl)
3110 {
3111 tree tmp;
3112 tree type;
3113
3114 /* Class container types do not always have the GFC_CLASS_TYPE_P
3115 but the canonical type does. */
3116 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
3117 && TREE_CODE (desc) == COMPONENT_REF)
3118 {
3119 type = TREE_TYPE (TREE_OPERAND (desc, 0));
3120 if (TYPE_CANONICAL (type)
3121 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
3122 type = TYPE_CANONICAL (type);
3123 }
3124 else
3125 type = NULL;
3126
3127 /* Class array references need special treatment because the assigned
3128 type size needs to be used to point to the element. */
3129 if (type && GFC_CLASS_TYPE_P (type))
3130 {
3131 type = gfc_get_element_type (TREE_TYPE (desc));
3132 tmp = TREE_OPERAND (desc, 0);
3133 tmp = gfc_get_class_array_ref (offset, tmp);
3134 tmp = fold_convert (build_pointer_type (type), tmp);
3135 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3136 return tmp;
3137 }
3138
3139 tmp = gfc_conv_array_data (desc);
3140 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3141 tmp = gfc_build_array_ref (tmp, offset, decl);
3142 return tmp;
3143 }
3144
3145
3146 /* Build an array reference. se->expr already holds the array descriptor.
3147 This should be either a variable, indirect variable reference or component
3148 reference. For arrays which do not have a descriptor, se->expr will be
3149 the data pointer.
3150 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3151
3152 void
gfc_conv_array_ref(gfc_se * se,gfc_array_ref * ar,gfc_expr * expr,locus * where)3153 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
3154 locus * where)
3155 {
3156 int n;
3157 tree offset, cst_offset;
3158 tree tmp;
3159 tree stride;
3160 gfc_se indexse;
3161 gfc_se tmpse;
3162 gfc_symbol * sym = expr->symtree->n.sym;
3163 char *var_name = NULL;
3164
3165 if (ar->dimen == 0)
3166 {
3167 gcc_assert (ar->codimen);
3168
3169 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3170 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3171 else
3172 {
3173 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3174 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
3175 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3176
3177 /* Use the actual tree type and not the wrapped coarray. */
3178 if (!se->want_pointer)
3179 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
3180 se->expr);
3181 }
3182
3183 return;
3184 }
3185
3186 /* Handle scalarized references separately. */
3187 if (ar->type != AR_ELEMENT)
3188 {
3189 gfc_conv_scalarized_array_ref (se, ar);
3190 gfc_advance_se_ss_chain (se);
3191 return;
3192 }
3193
3194 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3195 {
3196 size_t len;
3197 gfc_ref *ref;
3198
3199 len = strlen (sym->name) + 1;
3200 for (ref = expr->ref; ref; ref = ref->next)
3201 {
3202 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3203 break;
3204 if (ref->type == REF_COMPONENT)
3205 len += 1 + strlen (ref->u.c.component->name);
3206 }
3207
3208 var_name = XALLOCAVEC (char, len);
3209 strcpy (var_name, sym->name);
3210
3211 for (ref = expr->ref; ref; ref = ref->next)
3212 {
3213 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3214 break;
3215 if (ref->type == REF_COMPONENT)
3216 {
3217 strcat (var_name, "%%");
3218 strcat (var_name, ref->u.c.component->name);
3219 }
3220 }
3221 }
3222
3223 cst_offset = offset = gfc_index_zero_node;
3224 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
3225
3226 /* Calculate the offsets from all the dimensions. Make sure to associate
3227 the final offset so that we form a chain of loop invariant summands. */
3228 for (n = ar->dimen - 1; n >= 0; n--)
3229 {
3230 /* Calculate the index for this dimension. */
3231 gfc_init_se (&indexse, se);
3232 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3233 gfc_add_block_to_block (&se->pre, &indexse.pre);
3234
3235 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3236 {
3237 /* Check array bounds. */
3238 tree cond;
3239 char *msg;
3240
3241 /* Evaluate the indexse.expr only once. */
3242 indexse.expr = save_expr (indexse.expr);
3243
3244 /* Lower bound. */
3245 tmp = gfc_conv_array_lbound (se->expr, n);
3246 if (sym->attr.temporary)
3247 {
3248 gfc_init_se (&tmpse, se);
3249 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3250 gfc_array_index_type);
3251 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3252 tmp = tmpse.expr;
3253 }
3254
3255 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3256 indexse.expr, tmp);
3257 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3258 "below lower bound of %%ld", n+1, var_name);
3259 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3260 fold_convert (long_integer_type_node,
3261 indexse.expr),
3262 fold_convert (long_integer_type_node, tmp));
3263 free (msg);
3264
3265 /* Upper bound, but not for the last dimension of assumed-size
3266 arrays. */
3267 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
3268 {
3269 tmp = gfc_conv_array_ubound (se->expr, n);
3270 if (sym->attr.temporary)
3271 {
3272 gfc_init_se (&tmpse, se);
3273 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
3274 gfc_array_index_type);
3275 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3276 tmp = tmpse.expr;
3277 }
3278
3279 cond = fold_build2_loc (input_location, GT_EXPR,
3280 boolean_type_node, indexse.expr, tmp);
3281 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3282 "above upper bound of %%ld", n+1, var_name);
3283 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
3284 fold_convert (long_integer_type_node,
3285 indexse.expr),
3286 fold_convert (long_integer_type_node, tmp));
3287 free (msg);
3288 }
3289 }
3290
3291 /* Multiply the index by the stride. */
3292 stride = gfc_conv_array_stride (se->expr, n);
3293 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3294 indexse.expr, stride);
3295
3296 /* And add it to the total. */
3297 add_to_offset (&cst_offset, &offset, tmp);
3298 }
3299
3300 if (!integer_zerop (cst_offset))
3301 offset = fold_build2_loc (input_location, PLUS_EXPR,
3302 gfc_array_index_type, offset, cst_offset);
3303
3304 se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
3305 }
3306
3307
3308 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
3309 LOOP_DIM dimension (if any) to array's offset. */
3310
3311 static void
add_array_offset(stmtblock_t * pblock,gfc_loopinfo * loop,gfc_ss * ss,gfc_array_ref * ar,int array_dim,int loop_dim)3312 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
3313 gfc_array_ref *ar, int array_dim, int loop_dim)
3314 {
3315 gfc_se se;
3316 gfc_array_info *info;
3317 tree stride, index;
3318
3319 info = &ss->info->data.array;
3320
3321 gfc_init_se (&se, NULL);
3322 se.loop = loop;
3323 se.expr = info->descriptor;
3324 stride = gfc_conv_array_stride (info->descriptor, array_dim);
3325 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
3326 gfc_add_block_to_block (pblock, &se.pre);
3327
3328 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
3329 gfc_array_index_type,
3330 info->offset, index);
3331 info->offset = gfc_evaluate_now (info->offset, pblock);
3332 }
3333
3334
3335 /* Generate the code to be executed immediately before entering a
3336 scalarization loop. */
3337
3338 static void
gfc_trans_preloop_setup(gfc_loopinfo * loop,int dim,int flag,stmtblock_t * pblock)3339 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
3340 stmtblock_t * pblock)
3341 {
3342 tree stride;
3343 gfc_ss_info *ss_info;
3344 gfc_array_info *info;
3345 gfc_ss_type ss_type;
3346 gfc_ss *ss, *pss;
3347 gfc_loopinfo *ploop;
3348 gfc_array_ref *ar;
3349 int i;
3350
3351 /* This code will be executed before entering the scalarization loop
3352 for this dimension. */
3353 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3354 {
3355 ss_info = ss->info;
3356
3357 if ((ss_info->useflags & flag) == 0)
3358 continue;
3359
3360 ss_type = ss_info->type;
3361 if (ss_type != GFC_SS_SECTION
3362 && ss_type != GFC_SS_FUNCTION
3363 && ss_type != GFC_SS_CONSTRUCTOR
3364 && ss_type != GFC_SS_COMPONENT)
3365 continue;
3366
3367 info = &ss_info->data.array;
3368
3369 gcc_assert (dim < ss->dimen);
3370 gcc_assert (ss->dimen == loop->dimen);
3371
3372 if (info->ref)
3373 ar = &info->ref->u.ar;
3374 else
3375 ar = NULL;
3376
3377 if (dim == loop->dimen - 1 && loop->parent != NULL)
3378 {
3379 /* If we are in the outermost dimension of this loop, the previous
3380 dimension shall be in the parent loop. */
3381 gcc_assert (ss->parent != NULL);
3382
3383 pss = ss->parent;
3384 ploop = loop->parent;
3385
3386 /* ss and ss->parent are about the same array. */
3387 gcc_assert (ss_info == pss->info);
3388 }
3389 else
3390 {
3391 ploop = loop;
3392 pss = ss;
3393 }
3394
3395 if (dim == loop->dimen - 1)
3396 i = 0;
3397 else
3398 i = dim + 1;
3399
3400 /* For the time being, there is no loop reordering. */
3401 gcc_assert (i == ploop->order[i]);
3402 i = ploop->order[i];
3403
3404 if (dim == loop->dimen - 1 && loop->parent == NULL)
3405 {
3406 stride = gfc_conv_array_stride (info->descriptor,
3407 innermost_ss (ss)->dim[i]);
3408
3409 /* Calculate the stride of the innermost loop. Hopefully this will
3410 allow the backend optimizers to do their stuff more effectively.
3411 */
3412 info->stride0 = gfc_evaluate_now (stride, pblock);
3413
3414 /* For the outermost loop calculate the offset due to any
3415 elemental dimensions. It will have been initialized with the
3416 base offset of the array. */
3417 if (info->ref)
3418 {
3419 for (i = 0; i < ar->dimen; i++)
3420 {
3421 if (ar->dimen_type[i] != DIMEN_ELEMENT)
3422 continue;
3423
3424 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
3425 }
3426 }
3427 }
3428 else
3429 /* Add the offset for the previous loop dimension. */
3430 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
3431
3432 /* Remember this offset for the second loop. */
3433 if (dim == loop->temp_dim - 1 && loop->parent == NULL)
3434 info->saved_offset = info->offset;
3435 }
3436 }
3437
3438
3439 /* Start a scalarized expression. Creates a scope and declares loop
3440 variables. */
3441
3442 void
gfc_start_scalarized_body(gfc_loopinfo * loop,stmtblock_t * pbody)3443 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
3444 {
3445 int dim;
3446 int n;
3447 int flags;
3448
3449 gcc_assert (!loop->array_parameter);
3450
3451 for (dim = loop->dimen - 1; dim >= 0; dim--)
3452 {
3453 n = loop->order[dim];
3454
3455 gfc_start_block (&loop->code[n]);
3456
3457 /* Create the loop variable. */
3458 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
3459
3460 if (dim < loop->temp_dim)
3461 flags = 3;
3462 else
3463 flags = 1;
3464 /* Calculate values that will be constant within this loop. */
3465 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
3466 }
3467 gfc_start_block (pbody);
3468 }
3469
3470
3471 /* Generates the actual loop code for a scalarization loop. */
3472
3473 void
gfc_trans_scalarized_loop_end(gfc_loopinfo * loop,int n,stmtblock_t * pbody)3474 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
3475 stmtblock_t * pbody)
3476 {
3477 stmtblock_t block;
3478 tree cond;
3479 tree tmp;
3480 tree loopbody;
3481 tree exit_label;
3482 tree stmt;
3483 tree init;
3484 tree incr;
3485
3486 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
3487 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
3488 && n == loop->dimen - 1)
3489 {
3490 /* We create an OMP_FOR construct for the outermost scalarized loop. */
3491 init = make_tree_vec (1);
3492 cond = make_tree_vec (1);
3493 incr = make_tree_vec (1);
3494
3495 /* Cycle statement is implemented with a goto. Exit statement must not
3496 be present for this loop. */
3497 exit_label = gfc_build_label_decl (NULL_TREE);
3498 TREE_USED (exit_label) = 1;
3499
3500 /* Label for cycle statements (if needed). */
3501 tmp = build1_v (LABEL_EXPR, exit_label);
3502 gfc_add_expr_to_block (pbody, tmp);
3503
3504 stmt = make_node (OMP_FOR);
3505
3506 TREE_TYPE (stmt) = void_type_node;
3507 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
3508
3509 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
3510 OMP_CLAUSE_SCHEDULE);
3511 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
3512 = OMP_CLAUSE_SCHEDULE_STATIC;
3513 if (ompws_flags & OMPWS_NOWAIT)
3514 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
3515 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
3516
3517 /* Initialize the loopvar. */
3518 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
3519 loop->from[n]);
3520 OMP_FOR_INIT (stmt) = init;
3521 /* The exit condition. */
3522 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR,
3523 boolean_type_node,
3524 loop->loopvar[n], loop->to[n]);
3525 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location);
3526 OMP_FOR_COND (stmt) = cond;
3527 /* Increment the loopvar. */
3528 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3529 loop->loopvar[n], gfc_index_one_node);
3530 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR,
3531 void_type_node, loop->loopvar[n], tmp);
3532 OMP_FOR_INCR (stmt) = incr;
3533
3534 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
3535 gfc_add_expr_to_block (&loop->code[n], stmt);
3536 }
3537 else
3538 {
3539 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
3540 && (loop->temp_ss == NULL);
3541
3542 loopbody = gfc_finish_block (pbody);
3543
3544 if (reverse_loop)
3545 {
3546 tmp = loop->from[n];
3547 loop->from[n] = loop->to[n];
3548 loop->to[n] = tmp;
3549 }
3550
3551 /* Initialize the loopvar. */
3552 if (loop->loopvar[n] != loop->from[n])
3553 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
3554
3555 exit_label = gfc_build_label_decl (NULL_TREE);
3556
3557 /* Generate the loop body. */
3558 gfc_init_block (&block);
3559
3560 /* The exit condition. */
3561 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
3562 boolean_type_node, loop->loopvar[n], loop->to[n]);
3563 tmp = build1_v (GOTO_EXPR, exit_label);
3564 TREE_USED (exit_label) = 1;
3565 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3566 gfc_add_expr_to_block (&block, tmp);
3567
3568 /* The main body. */
3569 gfc_add_expr_to_block (&block, loopbody);
3570
3571 /* Increment the loopvar. */
3572 tmp = fold_build2_loc (input_location,
3573 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
3574 gfc_array_index_type, loop->loopvar[n],
3575 gfc_index_one_node);
3576
3577 gfc_add_modify (&block, loop->loopvar[n], tmp);
3578
3579 /* Build the loop. */
3580 tmp = gfc_finish_block (&block);
3581 tmp = build1_v (LOOP_EXPR, tmp);
3582 gfc_add_expr_to_block (&loop->code[n], tmp);
3583
3584 /* Add the exit label. */
3585 tmp = build1_v (LABEL_EXPR, exit_label);
3586 gfc_add_expr_to_block (&loop->code[n], tmp);
3587 }
3588
3589 }
3590
3591
3592 /* Finishes and generates the loops for a scalarized expression. */
3593
3594 void
gfc_trans_scalarizing_loops(gfc_loopinfo * loop,stmtblock_t * body)3595 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
3596 {
3597 int dim;
3598 int n;
3599 gfc_ss *ss;
3600 stmtblock_t *pblock;
3601 tree tmp;
3602
3603 pblock = body;
3604 /* Generate the loops. */
3605 for (dim = 0; dim < loop->dimen; dim++)
3606 {
3607 n = loop->order[dim];
3608 gfc_trans_scalarized_loop_end (loop, n, pblock);
3609 loop->loopvar[n] = NULL_TREE;
3610 pblock = &loop->code[n];
3611 }
3612
3613 tmp = gfc_finish_block (pblock);
3614 gfc_add_expr_to_block (&loop->pre, tmp);
3615
3616 /* Clear all the used flags. */
3617 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3618 if (ss->parent == NULL)
3619 ss->info->useflags = 0;
3620 }
3621
3622
3623 /* Finish the main body of a scalarized expression, and start the secondary
3624 copying body. */
3625
3626 void
gfc_trans_scalarized_loop_boundary(gfc_loopinfo * loop,stmtblock_t * body)3627 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
3628 {
3629 int dim;
3630 int n;
3631 stmtblock_t *pblock;
3632 gfc_ss *ss;
3633
3634 pblock = body;
3635 /* We finish as many loops as are used by the temporary. */
3636 for (dim = 0; dim < loop->temp_dim - 1; dim++)
3637 {
3638 n = loop->order[dim];
3639 gfc_trans_scalarized_loop_end (loop, n, pblock);
3640 loop->loopvar[n] = NULL_TREE;
3641 pblock = &loop->code[n];
3642 }
3643
3644 /* We don't want to finish the outermost loop entirely. */
3645 n = loop->order[loop->temp_dim - 1];
3646 gfc_trans_scalarized_loop_end (loop, n, pblock);
3647
3648 /* Restore the initial offsets. */
3649 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3650 {
3651 gfc_ss_type ss_type;
3652 gfc_ss_info *ss_info;
3653
3654 ss_info = ss->info;
3655
3656 if ((ss_info->useflags & 2) == 0)
3657 continue;
3658
3659 ss_type = ss_info->type;
3660 if (ss_type != GFC_SS_SECTION
3661 && ss_type != GFC_SS_FUNCTION
3662 && ss_type != GFC_SS_CONSTRUCTOR
3663 && ss_type != GFC_SS_COMPONENT)
3664 continue;
3665
3666 ss_info->data.array.offset = ss_info->data.array.saved_offset;
3667 }
3668
3669 /* Restart all the inner loops we just finished. */
3670 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
3671 {
3672 n = loop->order[dim];
3673
3674 gfc_start_block (&loop->code[n]);
3675
3676 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
3677
3678 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
3679 }
3680
3681 /* Start a block for the secondary copying code. */
3682 gfc_start_block (body);
3683 }
3684
3685
3686 /* Precalculate (either lower or upper) bound of an array section.
3687 BLOCK: Block in which the (pre)calculation code will go.
3688 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
3689 VALUES[DIM]: Specified bound (NULL <=> unspecified).
3690 DESC: Array descriptor from which the bound will be picked if unspecified
3691 (either lower or upper bound according to LBOUND). */
3692
3693 static void
evaluate_bound(stmtblock_t * block,tree * bounds,gfc_expr ** values,tree desc,int dim,bool lbound)3694 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
3695 tree desc, int dim, bool lbound)
3696 {
3697 gfc_se se;
3698 gfc_expr * input_val = values[dim];
3699 tree *output = &bounds[dim];
3700
3701
3702 if (input_val)
3703 {
3704 /* Specified section bound. */
3705 gfc_init_se (&se, NULL);
3706 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
3707 gfc_add_block_to_block (block, &se.pre);
3708 *output = se.expr;
3709 }
3710 else
3711 {
3712 /* No specific bound specified so use the bound of the array. */
3713 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
3714 gfc_conv_array_ubound (desc, dim);
3715 }
3716 *output = gfc_evaluate_now (*output, block);
3717 }
3718
3719
3720 /* Calculate the lower bound of an array section. */
3721
3722 static void
gfc_conv_section_startstride(stmtblock_t * block,gfc_ss * ss,int dim)3723 gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
3724 {
3725 gfc_expr *stride = NULL;
3726 tree desc;
3727 gfc_se se;
3728 gfc_array_info *info;
3729 gfc_array_ref *ar;
3730
3731 gcc_assert (ss->info->type == GFC_SS_SECTION);
3732
3733 info = &ss->info->data.array;
3734 ar = &info->ref->u.ar;
3735
3736 if (ar->dimen_type[dim] == DIMEN_VECTOR)
3737 {
3738 /* We use a zero-based index to access the vector. */
3739 info->start[dim] = gfc_index_zero_node;
3740 info->end[dim] = NULL;
3741 info->stride[dim] = gfc_index_one_node;
3742 return;
3743 }
3744
3745 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
3746 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
3747 desc = info->descriptor;
3748 stride = ar->stride[dim];
3749
3750 /* Calculate the start of the range. For vector subscripts this will
3751 be the range of the vector. */
3752 evaluate_bound (block, info->start, ar->start, desc, dim, true);
3753
3754 /* Similarly calculate the end. Although this is not used in the
3755 scalarizer, it is needed when checking bounds and where the end
3756 is an expression with side-effects. */
3757 evaluate_bound (block, info->end, ar->end, desc, dim, false);
3758
3759 /* Calculate the stride. */
3760 if (stride == NULL)
3761 info->stride[dim] = gfc_index_one_node;
3762 else
3763 {
3764 gfc_init_se (&se, NULL);
3765 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3766 gfc_add_block_to_block (block, &se.pre);
3767 info->stride[dim] = gfc_evaluate_now (se.expr, block);
3768 }
3769 }
3770
3771
3772 /* Calculates the range start and stride for a SS chain. Also gets the
3773 descriptor and data pointer. The range of vector subscripts is the size
3774 of the vector. Array bounds are also checked. */
3775
3776 void
gfc_conv_ss_startstride(gfc_loopinfo * loop)3777 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3778 {
3779 int n;
3780 tree tmp;
3781 gfc_ss *ss;
3782 tree desc;
3783
3784 gfc_loopinfo * const outer_loop = outermost_loop (loop);
3785
3786 loop->dimen = 0;
3787 /* Determine the rank of the loop. */
3788 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3789 {
3790 switch (ss->info->type)
3791 {
3792 case GFC_SS_SECTION:
3793 case GFC_SS_CONSTRUCTOR:
3794 case GFC_SS_FUNCTION:
3795 case GFC_SS_COMPONENT:
3796 loop->dimen = ss->dimen;
3797 goto done;
3798
3799 /* As usual, lbound and ubound are exceptions!. */
3800 case GFC_SS_INTRINSIC:
3801 switch (ss->info->expr->value.function.isym->id)
3802 {
3803 case GFC_ISYM_LBOUND:
3804 case GFC_ISYM_UBOUND:
3805 case GFC_ISYM_LCOBOUND:
3806 case GFC_ISYM_UCOBOUND:
3807 case GFC_ISYM_THIS_IMAGE:
3808 loop->dimen = ss->dimen;
3809 goto done;
3810
3811 default:
3812 break;
3813 }
3814
3815 default:
3816 break;
3817 }
3818 }
3819
3820 /* We should have determined the rank of the expression by now. If
3821 not, that's bad news. */
3822 gcc_unreachable ();
3823
3824 done:
3825 /* Loop over all the SS in the chain. */
3826 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3827 {
3828 gfc_ss_info *ss_info;
3829 gfc_array_info *info;
3830 gfc_expr *expr;
3831
3832 ss_info = ss->info;
3833 expr = ss_info->expr;
3834 info = &ss_info->data.array;
3835
3836 if (expr && expr->shape && !info->shape)
3837 info->shape = expr->shape;
3838
3839 switch (ss_info->type)
3840 {
3841 case GFC_SS_SECTION:
3842 /* Get the descriptor for the array. If it is a cross loops array,
3843 we got the descriptor already in the outermost loop. */
3844 if (ss->parent == NULL)
3845 gfc_conv_ss_descriptor (&outer_loop->pre, ss,
3846 !loop->array_parameter);
3847
3848 for (n = 0; n < ss->dimen; n++)
3849 gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
3850 break;
3851
3852 case GFC_SS_INTRINSIC:
3853 switch (expr->value.function.isym->id)
3854 {
3855 /* Fall through to supply start and stride. */
3856 case GFC_ISYM_LBOUND:
3857 case GFC_ISYM_UBOUND:
3858 {
3859 gfc_expr *arg;
3860
3861 /* This is the variant without DIM=... */
3862 gcc_assert (expr->value.function.actual->next->expr == NULL);
3863
3864 arg = expr->value.function.actual->expr;
3865 if (arg->rank == -1)
3866 {
3867 gfc_se se;
3868 tree rank, tmp;
3869
3870 /* The rank (hence the return value's shape) is unknown,
3871 we have to retrieve it. */
3872 gfc_init_se (&se, NULL);
3873 se.descriptor_only = 1;
3874 gfc_conv_expr (&se, arg);
3875 /* This is a bare variable, so there is no preliminary
3876 or cleanup code. */
3877 gcc_assert (se.pre.head == NULL_TREE
3878 && se.post.head == NULL_TREE);
3879 rank = gfc_conv_descriptor_rank (se.expr);
3880 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3881 gfc_array_index_type,
3882 fold_convert (gfc_array_index_type,
3883 rank),
3884 gfc_index_one_node);
3885 info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
3886 info->start[0] = gfc_index_zero_node;
3887 info->stride[0] = gfc_index_one_node;
3888 continue;
3889 }
3890 /* Otherwise fall through GFC_SS_FUNCTION. */
3891 }
3892 case GFC_ISYM_LCOBOUND:
3893 case GFC_ISYM_UCOBOUND:
3894 case GFC_ISYM_THIS_IMAGE:
3895 break;
3896
3897 default:
3898 continue;
3899 }
3900
3901 case GFC_SS_CONSTRUCTOR:
3902 case GFC_SS_FUNCTION:
3903 for (n = 0; n < ss->dimen; n++)
3904 {
3905 int dim = ss->dim[n];
3906
3907 info->start[dim] = gfc_index_zero_node;
3908 info->end[dim] = gfc_index_zero_node;
3909 info->stride[dim] = gfc_index_one_node;
3910 }
3911 break;
3912
3913 default:
3914 break;
3915 }
3916 }
3917
3918 /* The rest is just runtime bound checking. */
3919 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3920 {
3921 stmtblock_t block;
3922 tree lbound, ubound;
3923 tree end;
3924 tree size[GFC_MAX_DIMENSIONS];
3925 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3926 gfc_array_info *info;
3927 char *msg;
3928 int dim;
3929
3930 gfc_start_block (&block);
3931
3932 for (n = 0; n < loop->dimen; n++)
3933 size[n] = NULL_TREE;
3934
3935 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3936 {
3937 stmtblock_t inner;
3938 gfc_ss_info *ss_info;
3939 gfc_expr *expr;
3940 locus *expr_loc;
3941 const char *expr_name;
3942
3943 ss_info = ss->info;
3944 if (ss_info->type != GFC_SS_SECTION)
3945 continue;
3946
3947 /* Catch allocatable lhs in f2003. */
3948 if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
3949 continue;
3950
3951 expr = ss_info->expr;
3952 expr_loc = &expr->where;
3953 expr_name = expr->symtree->name;
3954
3955 gfc_start_block (&inner);
3956
3957 /* TODO: range checking for mapped dimensions. */
3958 info = &ss_info->data.array;
3959
3960 /* This code only checks ranges. Elemental and vector
3961 dimensions are checked later. */
3962 for (n = 0; n < loop->dimen; n++)
3963 {
3964 bool check_upper;
3965
3966 dim = ss->dim[n];
3967 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3968 continue;
3969
3970 if (dim == info->ref->u.ar.dimen - 1
3971 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
3972 check_upper = false;
3973 else
3974 check_upper = true;
3975
3976 /* Zero stride is not allowed. */
3977 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3978 info->stride[dim], gfc_index_zero_node);
3979 asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3980 "of array '%s'", dim + 1, expr_name);
3981 gfc_trans_runtime_check (true, false, tmp, &inner,
3982 expr_loc, msg);
3983 free (msg);
3984
3985 desc = info->descriptor;
3986
3987 /* This is the run-time equivalent of resolve.c's
3988 check_dimension(). The logical is more readable there
3989 than it is here, with all the trees. */
3990 lbound = gfc_conv_array_lbound (desc, dim);
3991 end = info->end[dim];
3992 if (check_upper)
3993 ubound = gfc_conv_array_ubound (desc, dim);
3994 else
3995 ubound = NULL;
3996
3997 /* non_zerosized is true when the selected range is not
3998 empty. */
3999 stride_pos = fold_build2_loc (input_location, GT_EXPR,
4000 boolean_type_node, info->stride[dim],
4001 gfc_index_zero_node);
4002 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
4003 info->start[dim], end);
4004 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4005 boolean_type_node, stride_pos, tmp);
4006
4007 stride_neg = fold_build2_loc (input_location, LT_EXPR,
4008 boolean_type_node,
4009 info->stride[dim], gfc_index_zero_node);
4010 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4011 info->start[dim], end);
4012 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4013 boolean_type_node,
4014 stride_neg, tmp);
4015 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4016 boolean_type_node,
4017 stride_pos, stride_neg);
4018
4019 /* Check the start of the range against the lower and upper
4020 bounds of the array, if the range is not empty.
4021 If upper bound is present, include both bounds in the
4022 error message. */
4023 if (check_upper)
4024 {
4025 tmp = fold_build2_loc (input_location, LT_EXPR,
4026 boolean_type_node,
4027 info->start[dim], lbound);
4028 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4029 boolean_type_node,
4030 non_zerosized, tmp);
4031 tmp2 = fold_build2_loc (input_location, GT_EXPR,
4032 boolean_type_node,
4033 info->start[dim], ubound);
4034 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4035 boolean_type_node,
4036 non_zerosized, tmp2);
4037 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4038 "outside of expected range (%%ld:%%ld)",
4039 dim + 1, expr_name);
4040 gfc_trans_runtime_check (true, false, tmp, &inner,
4041 expr_loc, msg,
4042 fold_convert (long_integer_type_node, info->start[dim]),
4043 fold_convert (long_integer_type_node, lbound),
4044 fold_convert (long_integer_type_node, ubound));
4045 gfc_trans_runtime_check (true, false, tmp2, &inner,
4046 expr_loc, msg,
4047 fold_convert (long_integer_type_node, info->start[dim]),
4048 fold_convert (long_integer_type_node, lbound),
4049 fold_convert (long_integer_type_node, ubound));
4050 free (msg);
4051 }
4052 else
4053 {
4054 tmp = fold_build2_loc (input_location, LT_EXPR,
4055 boolean_type_node,
4056 info->start[dim], lbound);
4057 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4058 boolean_type_node, non_zerosized, tmp);
4059 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4060 "below lower bound of %%ld",
4061 dim + 1, expr_name);
4062 gfc_trans_runtime_check (true, false, tmp, &inner,
4063 expr_loc, msg,
4064 fold_convert (long_integer_type_node, info->start[dim]),
4065 fold_convert (long_integer_type_node, lbound));
4066 free (msg);
4067 }
4068
4069 /* Compute the last element of the range, which is not
4070 necessarily "end" (think 0:5:3, which doesn't contain 5)
4071 and check it against both lower and upper bounds. */
4072
4073 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4074 gfc_array_index_type, end,
4075 info->start[dim]);
4076 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
4077 gfc_array_index_type, tmp,
4078 info->stride[dim]);
4079 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4080 gfc_array_index_type, end, tmp);
4081 tmp2 = fold_build2_loc (input_location, LT_EXPR,
4082 boolean_type_node, tmp, lbound);
4083 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4084 boolean_type_node, non_zerosized, tmp2);
4085 if (check_upper)
4086 {
4087 tmp3 = fold_build2_loc (input_location, GT_EXPR,
4088 boolean_type_node, tmp, ubound);
4089 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4090 boolean_type_node, non_zerosized, tmp3);
4091 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4092 "outside of expected range (%%ld:%%ld)",
4093 dim + 1, expr_name);
4094 gfc_trans_runtime_check (true, false, tmp2, &inner,
4095 expr_loc, msg,
4096 fold_convert (long_integer_type_node, tmp),
4097 fold_convert (long_integer_type_node, ubound),
4098 fold_convert (long_integer_type_node, lbound));
4099 gfc_trans_runtime_check (true, false, tmp3, &inner,
4100 expr_loc, msg,
4101 fold_convert (long_integer_type_node, tmp),
4102 fold_convert (long_integer_type_node, ubound),
4103 fold_convert (long_integer_type_node, lbound));
4104 free (msg);
4105 }
4106 else
4107 {
4108 asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
4109 "below lower bound of %%ld",
4110 dim + 1, expr_name);
4111 gfc_trans_runtime_check (true, false, tmp2, &inner,
4112 expr_loc, msg,
4113 fold_convert (long_integer_type_node, tmp),
4114 fold_convert (long_integer_type_node, lbound));
4115 free (msg);
4116 }
4117
4118 /* Check the section sizes match. */
4119 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4120 gfc_array_index_type, end,
4121 info->start[dim]);
4122 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4123 gfc_array_index_type, tmp,
4124 info->stride[dim]);
4125 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4126 gfc_array_index_type,
4127 gfc_index_one_node, tmp);
4128 tmp = fold_build2_loc (input_location, MAX_EXPR,
4129 gfc_array_index_type, tmp,
4130 build_int_cst (gfc_array_index_type, 0));
4131 /* We remember the size of the first section, and check all the
4132 others against this. */
4133 if (size[n])
4134 {
4135 tmp3 = fold_build2_loc (input_location, NE_EXPR,
4136 boolean_type_node, tmp, size[n]);
4137 asprintf (&msg, "Array bound mismatch for dimension %d "
4138 "of array '%s' (%%ld/%%ld)",
4139 dim + 1, expr_name);
4140
4141 gfc_trans_runtime_check (true, false, tmp3, &inner,
4142 expr_loc, msg,
4143 fold_convert (long_integer_type_node, tmp),
4144 fold_convert (long_integer_type_node, size[n]));
4145
4146 free (msg);
4147 }
4148 else
4149 size[n] = gfc_evaluate_now (tmp, &inner);
4150 }
4151
4152 tmp = gfc_finish_block (&inner);
4153
4154 /* For optional arguments, only check bounds if the argument is
4155 present. */
4156 if (expr->symtree->n.sym->attr.optional
4157 || expr->symtree->n.sym->attr.not_always_present)
4158 tmp = build3_v (COND_EXPR,
4159 gfc_conv_expr_present (expr->symtree->n.sym),
4160 tmp, build_empty_stmt (input_location));
4161
4162 gfc_add_expr_to_block (&block, tmp);
4163
4164 }
4165
4166 tmp = gfc_finish_block (&block);
4167 gfc_add_expr_to_block (&outer_loop->pre, tmp);
4168 }
4169
4170 for (loop = loop->nested; loop; loop = loop->next)
4171 gfc_conv_ss_startstride (loop);
4172 }
4173
4174 /* Return true if both symbols could refer to the same data object. Does
4175 not take account of aliasing due to equivalence statements. */
4176
4177 static int
symbols_could_alias(gfc_symbol * lsym,gfc_symbol * rsym,bool lsym_pointer,bool lsym_target,bool rsym_pointer,bool rsym_target)4178 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4179 bool lsym_target, bool rsym_pointer, bool rsym_target)
4180 {
4181 /* Aliasing isn't possible if the symbols have different base types. */
4182 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4183 return 0;
4184
4185 /* Pointers can point to other pointers and target objects. */
4186
4187 if ((lsym_pointer && (rsym_pointer || rsym_target))
4188 || (rsym_pointer && (lsym_pointer || lsym_target)))
4189 return 1;
4190
4191 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
4192 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
4193 checked above. */
4194 if (lsym_target && rsym_target
4195 && ((lsym->attr.dummy && !lsym->attr.contiguous
4196 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
4197 || (rsym->attr.dummy && !rsym->attr.contiguous
4198 && (!rsym->attr.dimension
4199 || rsym->as->type == AS_ASSUMED_SHAPE))))
4200 return 1;
4201
4202 return 0;
4203 }
4204
4205
4206 /* Return true if the two SS could be aliased, i.e. both point to the same data
4207 object. */
4208 /* TODO: resolve aliases based on frontend expressions. */
4209
4210 static int
gfc_could_be_alias(gfc_ss * lss,gfc_ss * rss)4211 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
4212 {
4213 gfc_ref *lref;
4214 gfc_ref *rref;
4215 gfc_expr *lexpr, *rexpr;
4216 gfc_symbol *lsym;
4217 gfc_symbol *rsym;
4218 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
4219
4220 lexpr = lss->info->expr;
4221 rexpr = rss->info->expr;
4222
4223 lsym = lexpr->symtree->n.sym;
4224 rsym = rexpr->symtree->n.sym;
4225
4226 lsym_pointer = lsym->attr.pointer;
4227 lsym_target = lsym->attr.target;
4228 rsym_pointer = rsym->attr.pointer;
4229 rsym_target = rsym->attr.target;
4230
4231 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
4232 rsym_pointer, rsym_target))
4233 return 1;
4234
4235 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
4236 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
4237 return 0;
4238
4239 /* For derived types we must check all the component types. We can ignore
4240 array references as these will have the same base type as the previous
4241 component ref. */
4242 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
4243 {
4244 if (lref->type != REF_COMPONENT)
4245 continue;
4246
4247 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
4248 lsym_target = lsym_target || lref->u.c.sym->attr.target;
4249
4250 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
4251 rsym_pointer, rsym_target))
4252 return 1;
4253
4254 if ((lsym_pointer && (rsym_pointer || rsym_target))
4255 || (rsym_pointer && (lsym_pointer || lsym_target)))
4256 {
4257 if (gfc_compare_types (&lref->u.c.component->ts,
4258 &rsym->ts))
4259 return 1;
4260 }
4261
4262 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
4263 rref = rref->next)
4264 {
4265 if (rref->type != REF_COMPONENT)
4266 continue;
4267
4268 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4269 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4270
4271 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
4272 lsym_pointer, lsym_target,
4273 rsym_pointer, rsym_target))
4274 return 1;
4275
4276 if ((lsym_pointer && (rsym_pointer || rsym_target))
4277 || (rsym_pointer && (lsym_pointer || lsym_target)))
4278 {
4279 if (gfc_compare_types (&lref->u.c.component->ts,
4280 &rref->u.c.sym->ts))
4281 return 1;
4282 if (gfc_compare_types (&lref->u.c.sym->ts,
4283 &rref->u.c.component->ts))
4284 return 1;
4285 if (gfc_compare_types (&lref->u.c.component->ts,
4286 &rref->u.c.component->ts))
4287 return 1;
4288 }
4289 }
4290 }
4291
4292 lsym_pointer = lsym->attr.pointer;
4293 lsym_target = lsym->attr.target;
4294 lsym_pointer = lsym->attr.pointer;
4295 lsym_target = lsym->attr.target;
4296
4297 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
4298 {
4299 if (rref->type != REF_COMPONENT)
4300 break;
4301
4302 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
4303 rsym_target = lsym_target || rref->u.c.sym->attr.target;
4304
4305 if (symbols_could_alias (rref->u.c.sym, lsym,
4306 lsym_pointer, lsym_target,
4307 rsym_pointer, rsym_target))
4308 return 1;
4309
4310 if ((lsym_pointer && (rsym_pointer || rsym_target))
4311 || (rsym_pointer && (lsym_pointer || lsym_target)))
4312 {
4313 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
4314 return 1;
4315 }
4316 }
4317
4318 return 0;
4319 }
4320
4321
4322 /* Resolve array data dependencies. Creates a temporary if required. */
4323 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
4324 dependency.c. */
4325
4326 void
gfc_conv_resolve_dependencies(gfc_loopinfo * loop,gfc_ss * dest,gfc_ss * rss)4327 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
4328 gfc_ss * rss)
4329 {
4330 gfc_ss *ss;
4331 gfc_ref *lref;
4332 gfc_ref *rref;
4333 gfc_expr *dest_expr;
4334 gfc_expr *ss_expr;
4335 int nDepend = 0;
4336 int i, j;
4337
4338 loop->temp_ss = NULL;
4339 dest_expr = dest->info->expr;
4340
4341 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
4342 {
4343 ss_expr = ss->info->expr;
4344
4345 if (ss->info->type != GFC_SS_SECTION)
4346 {
4347 if (gfc_option.flag_realloc_lhs
4348 && dest_expr != ss_expr
4349 && gfc_is_reallocatable_lhs (dest_expr)
4350 && ss_expr->rank)
4351 nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
4352
4353 continue;
4354 }
4355
4356 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
4357 {
4358 if (gfc_could_be_alias (dest, ss)
4359 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
4360 {
4361 nDepend = 1;
4362 break;
4363 }
4364 }
4365 else
4366 {
4367 lref = dest_expr->ref;
4368 rref = ss_expr->ref;
4369
4370 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
4371
4372 if (nDepend == 1)
4373 break;
4374
4375 for (i = 0; i < dest->dimen; i++)
4376 for (j = 0; j < ss->dimen; j++)
4377 if (i != j
4378 && dest->dim[i] == ss->dim[j])
4379 {
4380 /* If we don't access array elements in the same order,
4381 there is a dependency. */
4382 nDepend = 1;
4383 goto temporary;
4384 }
4385 #if 0
4386 /* TODO : loop shifting. */
4387 if (nDepend == 1)
4388 {
4389 /* Mark the dimensions for LOOP SHIFTING */
4390 for (n = 0; n < loop->dimen; n++)
4391 {
4392 int dim = dest->data.info.dim[n];
4393
4394 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
4395 depends[n] = 2;
4396 else if (! gfc_is_same_range (&lref->u.ar,
4397 &rref->u.ar, dim, 0))
4398 depends[n] = 1;
4399 }
4400
4401 /* Put all the dimensions with dependencies in the
4402 innermost loops. */
4403 dim = 0;
4404 for (n = 0; n < loop->dimen; n++)
4405 {
4406 gcc_assert (loop->order[n] == n);
4407 if (depends[n])
4408 loop->order[dim++] = n;
4409 }
4410 for (n = 0; n < loop->dimen; n++)
4411 {
4412 if (! depends[n])
4413 loop->order[dim++] = n;
4414 }
4415
4416 gcc_assert (dim == loop->dimen);
4417 break;
4418 }
4419 #endif
4420 }
4421 }
4422
4423 temporary:
4424
4425 if (nDepend == 1)
4426 {
4427 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
4428 if (GFC_ARRAY_TYPE_P (base_type)
4429 || GFC_DESCRIPTOR_TYPE_P (base_type))
4430 base_type = gfc_get_element_type (base_type);
4431 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
4432 loop->dimen);
4433 gfc_add_ss_to_loop (loop, loop->temp_ss);
4434 }
4435 else
4436 loop->temp_ss = NULL;
4437 }
4438
4439
4440 /* Browse through each array's information from the scalarizer and set the loop
4441 bounds according to the "best" one (per dimension), i.e. the one which
4442 provides the most information (constant bounds, shape, etc.). */
4443
4444 static void
set_loop_bounds(gfc_loopinfo * loop)4445 set_loop_bounds (gfc_loopinfo *loop)
4446 {
4447 int n, dim, spec_dim;
4448 gfc_array_info *info;
4449 gfc_array_info *specinfo;
4450 gfc_ss *ss;
4451 tree tmp;
4452 gfc_ss **loopspec;
4453 bool dynamic[GFC_MAX_DIMENSIONS];
4454 mpz_t *cshape;
4455 mpz_t i;
4456 bool nonoptional_arr;
4457
4458 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4459
4460 loopspec = loop->specloop;
4461
4462 mpz_init (i);
4463 for (n = 0; n < loop->dimen; n++)
4464 {
4465 loopspec[n] = NULL;
4466 dynamic[n] = false;
4467
4468 /* If there are both optional and nonoptional array arguments, scalarize
4469 over the nonoptional; otherwise, it does not matter as then all
4470 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
4471
4472 nonoptional_arr = false;
4473
4474 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4475 if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
4476 && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
4477 {
4478 nonoptional_arr = true;
4479 break;
4480 }
4481
4482 /* We use one SS term, and use that to determine the bounds of the
4483 loop for this dimension. We try to pick the simplest term. */
4484 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4485 {
4486 gfc_ss_type ss_type;
4487
4488 ss_type = ss->info->type;
4489 if (ss_type == GFC_SS_SCALAR
4490 || ss_type == GFC_SS_TEMP
4491 || ss_type == GFC_SS_REFERENCE
4492 || (ss->info->can_be_null_ref && nonoptional_arr))
4493 continue;
4494
4495 info = &ss->info->data.array;
4496 dim = ss->dim[n];
4497
4498 if (loopspec[n] != NULL)
4499 {
4500 specinfo = &loopspec[n]->info->data.array;
4501 spec_dim = loopspec[n]->dim[n];
4502 }
4503 else
4504 {
4505 /* Silence uninitialized warnings. */
4506 specinfo = NULL;
4507 spec_dim = 0;
4508 }
4509
4510 if (info->shape)
4511 {
4512 gcc_assert (info->shape[dim]);
4513 /* The frontend has worked out the size for us. */
4514 if (!loopspec[n]
4515 || !specinfo->shape
4516 || !integer_zerop (specinfo->start[spec_dim]))
4517 /* Prefer zero-based descriptors if possible. */
4518 loopspec[n] = ss;
4519 continue;
4520 }
4521
4522 if (ss_type == GFC_SS_CONSTRUCTOR)
4523 {
4524 gfc_constructor_base base;
4525 /* An unknown size constructor will always be rank one.
4526 Higher rank constructors will either have known shape,
4527 or still be wrapped in a call to reshape. */
4528 gcc_assert (loop->dimen == 1);
4529
4530 /* Always prefer to use the constructor bounds if the size
4531 can be determined at compile time. Prefer not to otherwise,
4532 since the general case involves realloc, and it's better to
4533 avoid that overhead if possible. */
4534 base = ss->info->expr->value.constructor;
4535 dynamic[n] = gfc_get_array_constructor_size (&i, base);
4536 if (!dynamic[n] || !loopspec[n])
4537 loopspec[n] = ss;
4538 continue;
4539 }
4540
4541 /* Avoid using an allocatable lhs in an assignment, since
4542 there might be a reallocation coming. */
4543 if (loopspec[n] && ss->is_alloc_lhs)
4544 continue;
4545
4546 if (!loopspec[n])
4547 loopspec[n] = ss;
4548 /* Criteria for choosing a loop specifier (most important first):
4549 doesn't need realloc
4550 stride of one
4551 known stride
4552 known lower bound
4553 known upper bound
4554 */
4555 else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
4556 loopspec[n] = ss;
4557 else if (integer_onep (info->stride[dim])
4558 && !integer_onep (specinfo->stride[spec_dim]))
4559 loopspec[n] = ss;
4560 else if (INTEGER_CST_P (info->stride[dim])
4561 && !INTEGER_CST_P (specinfo->stride[spec_dim]))
4562 loopspec[n] = ss;
4563 else if (INTEGER_CST_P (info->start[dim])
4564 && !INTEGER_CST_P (specinfo->start[spec_dim])
4565 && integer_onep (info->stride[dim])
4566 == integer_onep (specinfo->stride[spec_dim])
4567 && INTEGER_CST_P (info->stride[dim])
4568 == INTEGER_CST_P (specinfo->stride[spec_dim]))
4569 loopspec[n] = ss;
4570 /* We don't work out the upper bound.
4571 else if (INTEGER_CST_P (info->finish[n])
4572 && ! INTEGER_CST_P (specinfo->finish[n]))
4573 loopspec[n] = ss; */
4574 }
4575
4576 /* We should have found the scalarization loop specifier. If not,
4577 that's bad news. */
4578 gcc_assert (loopspec[n]);
4579
4580 info = &loopspec[n]->info->data.array;
4581 dim = loopspec[n]->dim[n];
4582
4583 /* Set the extents of this range. */
4584 cshape = info->shape;
4585 if (cshape && INTEGER_CST_P (info->start[dim])
4586 && INTEGER_CST_P (info->stride[dim]))
4587 {
4588 loop->from[n] = info->start[dim];
4589 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
4590 mpz_sub_ui (i, i, 1);
4591 /* To = from + (size - 1) * stride. */
4592 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
4593 if (!integer_onep (info->stride[dim]))
4594 tmp = fold_build2_loc (input_location, MULT_EXPR,
4595 gfc_array_index_type, tmp,
4596 info->stride[dim]);
4597 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
4598 gfc_array_index_type,
4599 loop->from[n], tmp);
4600 }
4601 else
4602 {
4603 loop->from[n] = info->start[dim];
4604 switch (loopspec[n]->info->type)
4605 {
4606 case GFC_SS_CONSTRUCTOR:
4607 /* The upper bound is calculated when we expand the
4608 constructor. */
4609 gcc_assert (loop->to[n] == NULL_TREE);
4610 break;
4611
4612 case GFC_SS_SECTION:
4613 /* Use the end expression if it exists and is not constant,
4614 so that it is only evaluated once. */
4615 loop->to[n] = info->end[dim];
4616 break;
4617
4618 case GFC_SS_FUNCTION:
4619 /* The loop bound will be set when we generate the call. */
4620 gcc_assert (loop->to[n] == NULL_TREE);
4621 break;
4622
4623 case GFC_SS_INTRINSIC:
4624 {
4625 gfc_expr *expr = loopspec[n]->info->expr;
4626
4627 /* The {l,u}bound of an assumed rank. */
4628 gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
4629 || expr->value.function.isym->id == GFC_ISYM_UBOUND)
4630 && expr->value.function.actual->next->expr == NULL
4631 && expr->value.function.actual->expr->rank == -1);
4632
4633 loop->to[n] = info->end[dim];
4634 break;
4635 }
4636
4637 default:
4638 gcc_unreachable ();
4639 }
4640 }
4641
4642 /* Transform everything so we have a simple incrementing variable. */
4643 if (integer_onep (info->stride[dim]))
4644 info->delta[dim] = gfc_index_zero_node;
4645 else
4646 {
4647 /* Set the delta for this section. */
4648 info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
4649 /* Number of iterations is (end - start + step) / step.
4650 with start = 0, this simplifies to
4651 last = end / step;
4652 for (i = 0; i<=last; i++){...}; */
4653 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4654 gfc_array_index_type, loop->to[n],
4655 loop->from[n]);
4656 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4657 gfc_array_index_type, tmp, info->stride[dim]);
4658 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
4659 tmp, build_int_cst (gfc_array_index_type, -1));
4660 loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
4661 /* Make the loop variable start at 0. */
4662 loop->from[n] = gfc_index_zero_node;
4663 }
4664 }
4665 mpz_clear (i);
4666
4667 for (loop = loop->nested; loop; loop = loop->next)
4668 set_loop_bounds (loop);
4669 }
4670
4671
4672 /* Initialize the scalarization loop. Creates the loop variables. Determines
4673 the range of the loop variables. Creates a temporary if required.
4674 Also generates code for scalar expressions which have been
4675 moved outside the loop. */
4676
4677 void
gfc_conv_loop_setup(gfc_loopinfo * loop,locus * where)4678 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
4679 {
4680 gfc_ss *tmp_ss;
4681 tree tmp;
4682
4683 set_loop_bounds (loop);
4684
4685 /* Add all the scalar code that can be taken out of the loops.
4686 This may include calculating the loop bounds, so do it before
4687 allocating the temporary. */
4688 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4689
4690 tmp_ss = loop->temp_ss;
4691 /* If we want a temporary then create it. */
4692 if (tmp_ss != NULL)
4693 {
4694 gfc_ss_info *tmp_ss_info;
4695
4696 tmp_ss_info = tmp_ss->info;
4697 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
4698 gcc_assert (loop->parent == NULL);
4699
4700 /* Make absolutely sure that this is a complete type. */
4701 if (tmp_ss_info->string_length)
4702 tmp_ss_info->data.temp.type
4703 = gfc_get_character_type_len_for_eltype
4704 (TREE_TYPE (tmp_ss_info->data.temp.type),
4705 tmp_ss_info->string_length);
4706
4707 tmp = tmp_ss_info->data.temp.type;
4708 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
4709 tmp_ss_info->type = GFC_SS_SECTION;
4710
4711 gcc_assert (tmp_ss->dimen != 0);
4712
4713 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
4714 NULL_TREE, false, true, false, where);
4715 }
4716
4717 /* For array parameters we don't have loop variables, so don't calculate the
4718 translations. */
4719 if (!loop->array_parameter)
4720 gfc_set_delta (loop);
4721 }
4722
4723
4724 /* Calculates how to transform from loop variables to array indices for each
4725 array: once loop bounds are chosen, sets the difference (DELTA field) between
4726 loop bounds and array reference bounds, for each array info. */
4727
4728 void
gfc_set_delta(gfc_loopinfo * loop)4729 gfc_set_delta (gfc_loopinfo *loop)
4730 {
4731 gfc_ss *ss, **loopspec;
4732 gfc_array_info *info;
4733 tree tmp;
4734 int n, dim;
4735
4736 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4737
4738 loopspec = loop->specloop;
4739
4740 /* Calculate the translation from loop variables to array indices. */
4741 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4742 {
4743 gfc_ss_type ss_type;
4744
4745 ss_type = ss->info->type;
4746 if (ss_type != GFC_SS_SECTION
4747 && ss_type != GFC_SS_COMPONENT
4748 && ss_type != GFC_SS_CONSTRUCTOR)
4749 continue;
4750
4751 info = &ss->info->data.array;
4752
4753 for (n = 0; n < ss->dimen; n++)
4754 {
4755 /* If we are specifying the range the delta is already set. */
4756 if (loopspec[n] != ss)
4757 {
4758 dim = ss->dim[n];
4759
4760 /* Calculate the offset relative to the loop variable.
4761 First multiply by the stride. */
4762 tmp = loop->from[n];
4763 if (!integer_onep (info->stride[dim]))
4764 tmp = fold_build2_loc (input_location, MULT_EXPR,
4765 gfc_array_index_type,
4766 tmp, info->stride[dim]);
4767
4768 /* Then subtract this from our starting value. */
4769 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4770 gfc_array_index_type,
4771 info->start[dim], tmp);
4772
4773 info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
4774 }
4775 }
4776 }
4777
4778 for (loop = loop->nested; loop; loop = loop->next)
4779 gfc_set_delta (loop);
4780 }
4781
4782
4783 /* Calculate the size of a given array dimension from the bounds. This
4784 is simply (ubound - lbound + 1) if this expression is positive
4785 or 0 if it is negative (pick either one if it is zero). Optionally
4786 (if or_expr is present) OR the (expression != 0) condition to it. */
4787
4788 tree
gfc_conv_array_extent_dim(tree lbound,tree ubound,tree * or_expr)4789 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
4790 {
4791 tree res;
4792 tree cond;
4793
4794 /* Calculate (ubound - lbound + 1). */
4795 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4796 ubound, lbound);
4797 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
4798 gfc_index_one_node);
4799
4800 /* Check whether the size for this dimension is negative. */
4801 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res,
4802 gfc_index_zero_node);
4803 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
4804 gfc_index_zero_node, res);
4805
4806 /* Build OR expression. */
4807 if (or_expr)
4808 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4809 boolean_type_node, *or_expr, cond);
4810
4811 return res;
4812 }
4813
4814
4815 /* For an array descriptor, get the total number of elements. This is just
4816 the product of the extents along from_dim to to_dim. */
4817
4818 static tree
gfc_conv_descriptor_size_1(tree desc,int from_dim,int to_dim)4819 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
4820 {
4821 tree res;
4822 int dim;
4823
4824 res = gfc_index_one_node;
4825
4826 for (dim = from_dim; dim < to_dim; ++dim)
4827 {
4828 tree lbound;
4829 tree ubound;
4830 tree extent;
4831
4832 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
4833 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
4834
4835 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
4836 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4837 res, extent);
4838 }
4839
4840 return res;
4841 }
4842
4843
4844 /* Full size of an array. */
4845
4846 tree
gfc_conv_descriptor_size(tree desc,int rank)4847 gfc_conv_descriptor_size (tree desc, int rank)
4848 {
4849 return gfc_conv_descriptor_size_1 (desc, 0, rank);
4850 }
4851
4852
4853 /* Size of a coarray for all dimensions but the last. */
4854
4855 tree
gfc_conv_descriptor_cosize(tree desc,int rank,int corank)4856 gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
4857 {
4858 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
4859 }
4860
4861
4862 /* Fills in an array descriptor, and returns the size of the array.
4863 The size will be a simple_val, ie a variable or a constant. Also
4864 calculates the offset of the base. The pointer argument overflow,
4865 which should be of integer type, will increase in value if overflow
4866 occurs during the size calculation. Returns the size of the array.
4867 {
4868 stride = 1;
4869 offset = 0;
4870 for (n = 0; n < rank; n++)
4871 {
4872 a.lbound[n] = specified_lower_bound;
4873 offset = offset + a.lbond[n] * stride;
4874 size = 1 - lbound;
4875 a.ubound[n] = specified_upper_bound;
4876 a.stride[n] = stride;
4877 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
4878 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
4879 stride = stride * size;
4880 }
4881 for (n = rank; n < rank+corank; n++)
4882 (Set lcobound/ucobound as above.)
4883 element_size = sizeof (array element);
4884 if (!rank)
4885 return element_size
4886 stride = (size_t) stride;
4887 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
4888 stride = stride * element_size;
4889 return (stride);
4890 } */
4891 /*GCC ARRAYS*/
4892
4893 static tree
gfc_array_init_size(tree descriptor,int rank,int corank,tree * poffset,gfc_expr ** lower,gfc_expr ** upper,stmtblock_t * pblock,stmtblock_t * descriptor_block,tree * overflow,tree expr3_elem_size,tree * nelems,gfc_expr * expr3,gfc_typespec * ts)4894 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
4895 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
4896 stmtblock_t * descriptor_block, tree * overflow,
4897 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
4898 gfc_typespec *ts)
4899 {
4900 tree type;
4901 tree tmp;
4902 tree size;
4903 tree offset;
4904 tree stride;
4905 tree element_size;
4906 tree or_expr;
4907 tree thencase;
4908 tree elsecase;
4909 tree cond;
4910 tree var;
4911 stmtblock_t thenblock;
4912 stmtblock_t elseblock;
4913 gfc_expr *ubound;
4914 gfc_se se;
4915 int n;
4916
4917 type = TREE_TYPE (descriptor);
4918
4919 stride = gfc_index_one_node;
4920 offset = gfc_index_zero_node;
4921
4922 /* Set the dtype. */
4923 tmp = gfc_conv_descriptor_dtype (descriptor);
4924 gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
4925
4926 or_expr = boolean_false_node;
4927
4928 for (n = 0; n < rank; n++)
4929 {
4930 tree conv_lbound;
4931 tree conv_ubound;
4932
4933 /* We have 3 possibilities for determining the size of the array:
4934 lower == NULL => lbound = 1, ubound = upper[n]
4935 upper[n] = NULL => lbound = 1, ubound = lower[n]
4936 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
4937 ubound = upper[n];
4938
4939 /* Set lower bound. */
4940 gfc_init_se (&se, NULL);
4941 if (lower == NULL)
4942 se.expr = gfc_index_one_node;
4943 else
4944 {
4945 gcc_assert (lower[n]);
4946 if (ubound)
4947 {
4948 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
4949 gfc_add_block_to_block (pblock, &se.pre);
4950 }
4951 else
4952 {
4953 se.expr = gfc_index_one_node;
4954 ubound = lower[n];
4955 }
4956 }
4957 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
4958 gfc_rank_cst[n], se.expr);
4959 conv_lbound = se.expr;
4960
4961 /* Work out the offset for this component. */
4962 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4963 se.expr, stride);
4964 offset = fold_build2_loc (input_location, MINUS_EXPR,
4965 gfc_array_index_type, offset, tmp);
4966
4967 /* Set upper bound. */
4968 gfc_init_se (&se, NULL);
4969 gcc_assert (ubound);
4970 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
4971 gfc_add_block_to_block (pblock, &se.pre);
4972
4973 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
4974 gfc_rank_cst[n], se.expr);
4975 conv_ubound = se.expr;
4976
4977 /* Store the stride. */
4978 gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
4979 gfc_rank_cst[n], stride);
4980
4981 /* Calculate size and check whether extent is negative. */
4982 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
4983 size = gfc_evaluate_now (size, pblock);
4984
4985 /* Check whether multiplying the stride by the number of
4986 elements in this dimension would overflow. We must also check
4987 whether the current dimension has zero size in order to avoid
4988 division by zero.
4989 */
4990 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
4991 gfc_array_index_type,
4992 fold_convert (gfc_array_index_type,
4993 TYPE_MAX_VALUE (gfc_array_index_type)),
4994 size);
4995 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
4996 boolean_type_node, tmp, stride),
4997 PRED_FORTRAN_OVERFLOW);
4998 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
4999 integer_one_node, integer_zero_node);
5000 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5001 boolean_type_node, size,
5002 gfc_index_zero_node),
5003 PRED_FORTRAN_SIZE_ZERO);
5004 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5005 integer_zero_node, tmp);
5006 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5007 *overflow, tmp);
5008 *overflow = gfc_evaluate_now (tmp, pblock);
5009
5010 /* Multiply the stride by the number of elements in this dimension. */
5011 stride = fold_build2_loc (input_location, MULT_EXPR,
5012 gfc_array_index_type, stride, size);
5013 stride = gfc_evaluate_now (stride, pblock);
5014 }
5015
5016 for (n = rank; n < rank + corank; n++)
5017 {
5018 ubound = upper[n];
5019
5020 /* Set lower bound. */
5021 gfc_init_se (&se, NULL);
5022 if (lower == NULL || lower[n] == NULL)
5023 {
5024 gcc_assert (n == rank + corank - 1);
5025 se.expr = gfc_index_one_node;
5026 }
5027 else
5028 {
5029 if (ubound || n == rank + corank - 1)
5030 {
5031 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
5032 gfc_add_block_to_block (pblock, &se.pre);
5033 }
5034 else
5035 {
5036 se.expr = gfc_index_one_node;
5037 ubound = lower[n];
5038 }
5039 }
5040 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
5041 gfc_rank_cst[n], se.expr);
5042
5043 if (n < rank + corank - 1)
5044 {
5045 gfc_init_se (&se, NULL);
5046 gcc_assert (ubound);
5047 gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
5048 gfc_add_block_to_block (pblock, &se.pre);
5049 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
5050 gfc_rank_cst[n], se.expr);
5051 }
5052 }
5053
5054 /* The stride is the number of elements in the array, so multiply by the
5055 size of an element to get the total size. Obviously, if there is a
5056 SOURCE expression (expr3) we must use its element size. */
5057 if (expr3_elem_size != NULL_TREE)
5058 tmp = expr3_elem_size;
5059 else if (expr3 != NULL)
5060 {
5061 if (expr3->ts.type == BT_CLASS)
5062 {
5063 gfc_se se_sz;
5064 gfc_expr *sz = gfc_copy_expr (expr3);
5065 gfc_add_vptr_component (sz);
5066 gfc_add_size_component (sz);
5067 gfc_init_se (&se_sz, NULL);
5068 gfc_conv_expr (&se_sz, sz);
5069 gfc_free_expr (sz);
5070 tmp = se_sz.expr;
5071 }
5072 else
5073 {
5074 tmp = gfc_typenode_for_spec (&expr3->ts);
5075 tmp = TYPE_SIZE_UNIT (tmp);
5076 }
5077 }
5078 else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
5079 /* FIXME: Properly handle characters. See PR 57456. */
5080 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
5081 else
5082 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5083
5084 /* Convert to size_t. */
5085 element_size = fold_convert (size_type_node, tmp);
5086
5087 if (rank == 0)
5088 return element_size;
5089
5090 *nelems = gfc_evaluate_now (stride, pblock);
5091 stride = fold_convert (size_type_node, stride);
5092
5093 /* First check for overflow. Since an array of type character can
5094 have zero element_size, we must check for that before
5095 dividing. */
5096 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
5097 size_type_node,
5098 TYPE_MAX_VALUE (size_type_node), element_size);
5099 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
5100 boolean_type_node, tmp, stride),
5101 PRED_FORTRAN_OVERFLOW);
5102 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5103 integer_one_node, integer_zero_node);
5104 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
5105 boolean_type_node, element_size,
5106 build_int_cst (size_type_node, 0)),
5107 PRED_FORTRAN_SIZE_ZERO);
5108 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
5109 integer_zero_node, tmp);
5110 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
5111 *overflow, tmp);
5112 *overflow = gfc_evaluate_now (tmp, pblock);
5113
5114 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5115 stride, element_size);
5116
5117 if (poffset != NULL)
5118 {
5119 offset = gfc_evaluate_now (offset, pblock);
5120 *poffset = offset;
5121 }
5122
5123 if (integer_zerop (or_expr))
5124 return size;
5125 if (integer_onep (or_expr))
5126 return build_int_cst (size_type_node, 0);
5127
5128 var = gfc_create_var (TREE_TYPE (size), "size");
5129 gfc_start_block (&thenblock);
5130 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0));
5131 thencase = gfc_finish_block (&thenblock);
5132
5133 gfc_start_block (&elseblock);
5134 gfc_add_modify (&elseblock, var, size);
5135 elsecase = gfc_finish_block (&elseblock);
5136
5137 tmp = gfc_evaluate_now (or_expr, pblock);
5138 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
5139 gfc_add_expr_to_block (pblock, tmp);
5140
5141 return var;
5142 }
5143
5144
5145 /* Initializes the descriptor and generates a call to _gfor_allocate. Does
5146 the work for an ALLOCATE statement. */
5147 /*GCC ARRAYS*/
5148
5149 bool
gfc_array_allocate(gfc_se * se,gfc_expr * expr,tree status,tree errmsg,tree errlen,tree label_finish,tree expr3_elem_size,tree * nelems,gfc_expr * expr3,gfc_typespec * ts)5150 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
5151 tree errlen, tree label_finish, tree expr3_elem_size,
5152 tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
5153 {
5154 tree tmp;
5155 tree pointer;
5156 tree offset = NULL_TREE;
5157 tree token = NULL_TREE;
5158 tree size;
5159 tree msg;
5160 tree error = NULL_TREE;
5161 tree overflow; /* Boolean storing whether size calculation overflows. */
5162 tree var_overflow = NULL_TREE;
5163 tree cond;
5164 tree set_descriptor;
5165 stmtblock_t set_descriptor_block;
5166 stmtblock_t elseblock;
5167 gfc_expr **lower;
5168 gfc_expr **upper;
5169 gfc_ref *ref, *prev_ref = NULL;
5170 bool allocatable, coarray, dimension;
5171
5172 ref = expr->ref;
5173
5174 /* Find the last reference in the chain. */
5175 while (ref && ref->next != NULL)
5176 {
5177 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
5178 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
5179 prev_ref = ref;
5180 ref = ref->next;
5181 }
5182
5183 if (ref == NULL || ref->type != REF_ARRAY)
5184 return false;
5185
5186 if (!prev_ref)
5187 {
5188 allocatable = expr->symtree->n.sym->attr.allocatable;
5189 coarray = expr->symtree->n.sym->attr.codimension;
5190 dimension = expr->symtree->n.sym->attr.dimension;
5191 }
5192 else
5193 {
5194 allocatable = prev_ref->u.c.component->attr.allocatable;
5195 coarray = prev_ref->u.c.component->attr.codimension;
5196 dimension = prev_ref->u.c.component->attr.dimension;
5197 }
5198
5199 if (!dimension)
5200 gcc_assert (coarray);
5201
5202 /* Figure out the size of the array. */
5203 switch (ref->u.ar.type)
5204 {
5205 case AR_ELEMENT:
5206 if (!coarray)
5207 {
5208 lower = NULL;
5209 upper = ref->u.ar.start;
5210 break;
5211 }
5212 /* Fall through. */
5213
5214 case AR_SECTION:
5215 lower = ref->u.ar.start;
5216 upper = ref->u.ar.end;
5217 break;
5218
5219 case AR_FULL:
5220 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
5221
5222 lower = ref->u.ar.as->lower;
5223 upper = ref->u.ar.as->upper;
5224 break;
5225
5226 default:
5227 gcc_unreachable ();
5228 break;
5229 }
5230
5231 overflow = integer_zero_node;
5232
5233 gfc_init_block (&set_descriptor_block);
5234 size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
5235 ref->u.ar.as->corank, &offset, lower, upper,
5236 &se->pre, &set_descriptor_block, &overflow,
5237 expr3_elem_size, nelems, expr3, ts);
5238
5239 if (dimension)
5240 {
5241 var_overflow = gfc_create_var (integer_type_node, "overflow");
5242 gfc_add_modify (&se->pre, var_overflow, overflow);
5243
5244 if (status == NULL_TREE)
5245 {
5246 /* Generate the block of code handling overflow. */
5247 msg = gfc_build_addr_expr (pchar_type_node,
5248 gfc_build_localized_cstring_const
5249 ("Integer overflow when calculating the amount of "
5250 "memory to allocate"));
5251 error = build_call_expr_loc (input_location,
5252 gfor_fndecl_runtime_error, 1, msg);
5253 }
5254 else
5255 {
5256 tree status_type = TREE_TYPE (status);
5257 stmtblock_t set_status_block;
5258
5259 gfc_start_block (&set_status_block);
5260 gfc_add_modify (&set_status_block, status,
5261 build_int_cst (status_type, LIBERROR_ALLOCATION));
5262 error = gfc_finish_block (&set_status_block);
5263 }
5264 }
5265
5266 gfc_start_block (&elseblock);
5267
5268 /* Allocate memory to store the data. */
5269 if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
5270 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
5271
5272 pointer = gfc_conv_descriptor_data_get (se->expr);
5273 STRIP_NOPS (pointer);
5274
5275 if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5276 token = gfc_build_addr_expr (NULL_TREE,
5277 gfc_conv_descriptor_token (se->expr));
5278
5279 /* The allocatable variant takes the old pointer as first argument. */
5280 if (allocatable)
5281 gfc_allocate_allocatable (&elseblock, pointer, size, token,
5282 status, errmsg, errlen, label_finish, expr);
5283 else
5284 gfc_allocate_using_malloc (&elseblock, pointer, size, status);
5285
5286 if (dimension)
5287 {
5288 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
5289 boolean_type_node, var_overflow, integer_zero_node),
5290 PRED_FORTRAN_OVERFLOW);
5291 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5292 error, gfc_finish_block (&elseblock));
5293 }
5294 else
5295 tmp = gfc_finish_block (&elseblock);
5296
5297 gfc_add_expr_to_block (&se->pre, tmp);
5298
5299 /* Update the array descriptors. */
5300 if (dimension)
5301 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
5302
5303 set_descriptor = gfc_finish_block (&set_descriptor_block);
5304 if (status != NULL_TREE)
5305 {
5306 cond = fold_build2_loc (input_location, EQ_EXPR,
5307 boolean_type_node, status,
5308 build_int_cst (TREE_TYPE (status), 0));
5309 gfc_add_expr_to_block (&se->pre,
5310 fold_build3_loc (input_location, COND_EXPR, void_type_node,
5311 gfc_likely (cond, PRED_FORTRAN_FAIL_ALLOC),
5312 set_descriptor,
5313 build_empty_stmt (input_location)));
5314 }
5315 else
5316 gfc_add_expr_to_block (&se->pre, set_descriptor);
5317
5318 if ((expr->ts.type == BT_DERIVED)
5319 && expr->ts.u.derived->attr.alloc_comp)
5320 {
5321 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
5322 ref->u.ar.as->rank);
5323 gfc_add_expr_to_block (&se->pre, tmp);
5324 }
5325
5326 return true;
5327 }
5328
5329
5330 /* Deallocate an array variable. Also used when an allocated variable goes
5331 out of scope. */
5332 /*GCC ARRAYS*/
5333
5334 tree
gfc_array_deallocate(tree descriptor,tree pstat,tree errmsg,tree errlen,tree label_finish,gfc_expr * expr)5335 gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
5336 tree label_finish, gfc_expr* expr)
5337 {
5338 tree var;
5339 tree tmp;
5340 stmtblock_t block;
5341 bool coarray = gfc_is_coarray (expr);
5342
5343 gfc_start_block (&block);
5344
5345 /* Get a pointer to the data. */
5346 var = gfc_conv_descriptor_data_get (descriptor);
5347 STRIP_NOPS (var);
5348
5349 /* Parameter is the address of the data component. */
5350 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
5351 errlen, label_finish, false, expr, coarray);
5352 gfc_add_expr_to_block (&block, tmp);
5353
5354 /* Zero the data pointer; only for coarrays an error can occur and then
5355 the allocation status may not be changed. */
5356 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5357 var, build_int_cst (TREE_TYPE (var), 0));
5358 if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
5359 {
5360 tree cond;
5361 tree stat = build_fold_indirect_ref_loc (input_location, pstat);
5362
5363 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5364 stat, build_int_cst (TREE_TYPE (stat), 0));
5365 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5366 cond, tmp, build_empty_stmt (input_location));
5367 }
5368
5369 gfc_add_expr_to_block (&block, tmp);
5370
5371 return gfc_finish_block (&block);
5372 }
5373
5374
5375 /* Create an array constructor from an initialization expression.
5376 We assume the frontend already did any expansions and conversions. */
5377
5378 tree
gfc_conv_array_initializer(tree type,gfc_expr * expr)5379 gfc_conv_array_initializer (tree type, gfc_expr * expr)
5380 {
5381 gfc_constructor *c;
5382 tree tmp;
5383 gfc_se se;
5384 HOST_WIDE_INT hi;
5385 unsigned HOST_WIDE_INT lo;
5386 tree index, range;
5387 vec<constructor_elt, va_gc> *v = NULL;
5388
5389 if (expr->expr_type == EXPR_VARIABLE
5390 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
5391 && expr->symtree->n.sym->value)
5392 expr = expr->symtree->n.sym->value;
5393
5394 switch (expr->expr_type)
5395 {
5396 case EXPR_CONSTANT:
5397 case EXPR_STRUCTURE:
5398 /* A single scalar or derived type value. Create an array with all
5399 elements equal to that value. */
5400 gfc_init_se (&se, NULL);
5401
5402 if (expr->expr_type == EXPR_CONSTANT)
5403 gfc_conv_constant (&se, expr);
5404 else
5405 gfc_conv_structure (&se, expr, 1);
5406
5407 tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
5408 gcc_assert (tmp && INTEGER_CST_P (tmp));
5409 hi = TREE_INT_CST_HIGH (tmp);
5410 lo = TREE_INT_CST_LOW (tmp);
5411 lo++;
5412 if (lo == 0)
5413 hi++;
5414 /* This will probably eat buckets of memory for large arrays. */
5415 while (hi != 0 || lo != 0)
5416 {
5417 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, se.expr);
5418 if (lo == 0)
5419 hi--;
5420 lo--;
5421 }
5422 break;
5423
5424 case EXPR_ARRAY:
5425 /* Create a vector of all the elements. */
5426 for (c = gfc_constructor_first (expr->value.constructor);
5427 c; c = gfc_constructor_next (c))
5428 {
5429 if (c->iterator)
5430 {
5431 /* Problems occur when we get something like
5432 integer :: a(lots) = (/(i, i=1, lots)/) */
5433 gfc_fatal_error ("The number of elements in the array constructor "
5434 "at %L requires an increase of the allowed %d "
5435 "upper limit. See -fmax-array-constructor "
5436 "option", &expr->where,
5437 gfc_option.flag_max_array_constructor);
5438 return NULL_TREE;
5439 }
5440 if (mpz_cmp_si (c->offset, 0) != 0)
5441 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5442 else
5443 index = NULL_TREE;
5444
5445 if (mpz_cmp_si (c->repeat, 1) > 0)
5446 {
5447 tree tmp1, tmp2;
5448 mpz_t maxval;
5449
5450 mpz_init (maxval);
5451 mpz_add (maxval, c->offset, c->repeat);
5452 mpz_sub_ui (maxval, maxval, 1);
5453 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5454 if (mpz_cmp_si (c->offset, 0) != 0)
5455 {
5456 mpz_add_ui (maxval, c->offset, 1);
5457 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
5458 }
5459 else
5460 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
5461
5462 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
5463 mpz_clear (maxval);
5464 }
5465 else
5466 range = NULL;
5467
5468 gfc_init_se (&se, NULL);
5469 switch (c->expr->expr_type)
5470 {
5471 case EXPR_CONSTANT:
5472 gfc_conv_constant (&se, c->expr);
5473 break;
5474
5475 case EXPR_STRUCTURE:
5476 gfc_conv_structure (&se, c->expr, 1);
5477 break;
5478
5479 default:
5480 /* Catch those occasional beasts that do not simplify
5481 for one reason or another, assuming that if they are
5482 standard defying the frontend will catch them. */
5483 gfc_conv_expr (&se, c->expr);
5484 break;
5485 }
5486
5487 if (range == NULL_TREE)
5488 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5489 else
5490 {
5491 if (index != NULL_TREE)
5492 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
5493 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
5494 }
5495 }
5496 break;
5497
5498 case EXPR_NULL:
5499 return gfc_build_null_descriptor (type);
5500
5501 default:
5502 gcc_unreachable ();
5503 }
5504
5505 /* Create a constructor from the list of elements. */
5506 tmp = build_constructor (type, v);
5507 TREE_CONSTANT (tmp) = 1;
5508 return tmp;
5509 }
5510
5511
5512 /* Generate code to evaluate non-constant coarray cobounds. */
5513
5514 void
gfc_trans_array_cobounds(tree type,stmtblock_t * pblock,const gfc_symbol * sym)5515 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
5516 const gfc_symbol *sym)
5517 {
5518 int dim;
5519 tree ubound;
5520 tree lbound;
5521 gfc_se se;
5522 gfc_array_spec *as;
5523
5524 as = sym->as;
5525
5526 for (dim = as->rank; dim < as->rank + as->corank; dim++)
5527 {
5528 /* Evaluate non-constant array bound expressions. */
5529 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5530 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5531 {
5532 gfc_init_se (&se, NULL);
5533 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5534 gfc_add_block_to_block (pblock, &se.pre);
5535 gfc_add_modify (pblock, lbound, se.expr);
5536 }
5537 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5538 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5539 {
5540 gfc_init_se (&se, NULL);
5541 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5542 gfc_add_block_to_block (pblock, &se.pre);
5543 gfc_add_modify (pblock, ubound, se.expr);
5544 }
5545 }
5546 }
5547
5548
5549 /* Generate code to evaluate non-constant array bounds. Sets *poffset and
5550 returns the size (in elements) of the array. */
5551
5552 static tree
gfc_trans_array_bounds(tree type,gfc_symbol * sym,tree * poffset,stmtblock_t * pblock)5553 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
5554 stmtblock_t * pblock)
5555 {
5556 gfc_array_spec *as;
5557 tree size;
5558 tree stride;
5559 tree offset;
5560 tree ubound;
5561 tree lbound;
5562 tree tmp;
5563 gfc_se se;
5564
5565 int dim;
5566
5567 as = sym->as;
5568
5569 size = gfc_index_one_node;
5570 offset = gfc_index_zero_node;
5571 for (dim = 0; dim < as->rank; dim++)
5572 {
5573 /* Evaluate non-constant array bound expressions. */
5574 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
5575 if (as->lower[dim] && !INTEGER_CST_P (lbound))
5576 {
5577 gfc_init_se (&se, NULL);
5578 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
5579 gfc_add_block_to_block (pblock, &se.pre);
5580 gfc_add_modify (pblock, lbound, se.expr);
5581 }
5582 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
5583 if (as->upper[dim] && !INTEGER_CST_P (ubound))
5584 {
5585 gfc_init_se (&se, NULL);
5586 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
5587 gfc_add_block_to_block (pblock, &se.pre);
5588 gfc_add_modify (pblock, ubound, se.expr);
5589 }
5590 /* The offset of this dimension. offset = offset - lbound * stride. */
5591 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5592 lbound, size);
5593 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5594 offset, tmp);
5595
5596 /* The size of this dimension, and the stride of the next. */
5597 if (dim + 1 < as->rank)
5598 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
5599 else
5600 stride = GFC_TYPE_ARRAY_SIZE (type);
5601
5602 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
5603 {
5604 /* Calculate stride = size * (ubound + 1 - lbound). */
5605 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5606 gfc_array_index_type,
5607 gfc_index_one_node, lbound);
5608 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5609 gfc_array_index_type, ubound, tmp);
5610 tmp = fold_build2_loc (input_location, MULT_EXPR,
5611 gfc_array_index_type, size, tmp);
5612 if (stride)
5613 gfc_add_modify (pblock, stride, tmp);
5614 else
5615 stride = gfc_evaluate_now (tmp, pblock);
5616
5617 /* Make sure that negative size arrays are translated
5618 to being zero size. */
5619 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5620 stride, gfc_index_zero_node);
5621 tmp = fold_build3_loc (input_location, COND_EXPR,
5622 gfc_array_index_type, tmp,
5623 stride, gfc_index_zero_node);
5624 gfc_add_modify (pblock, stride, tmp);
5625 }
5626
5627 size = stride;
5628 }
5629
5630 gfc_trans_array_cobounds (type, pblock, sym);
5631 gfc_trans_vla_type_sizes (sym, pblock);
5632
5633 *poffset = offset;
5634 return size;
5635 }
5636
5637
5638 /* Generate code to initialize/allocate an array variable. */
5639
5640 void
gfc_trans_auto_array_allocation(tree decl,gfc_symbol * sym,gfc_wrapped_block * block)5641 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
5642 gfc_wrapped_block * block)
5643 {
5644 stmtblock_t init;
5645 tree type;
5646 tree tmp = NULL_TREE;
5647 tree size;
5648 tree offset;
5649 tree space;
5650 tree inittree;
5651 bool onstack;
5652
5653 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
5654
5655 /* Do nothing for USEd variables. */
5656 if (sym->attr.use_assoc)
5657 return;
5658
5659 type = TREE_TYPE (decl);
5660 gcc_assert (GFC_ARRAY_TYPE_P (type));
5661 onstack = TREE_CODE (type) != POINTER_TYPE;
5662
5663 gfc_init_block (&init);
5664
5665 /* Evaluate character string length. */
5666 if (sym->ts.type == BT_CHARACTER
5667 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5668 {
5669 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5670
5671 gfc_trans_vla_type_sizes (sym, &init);
5672
5673 /* Emit a DECL_EXPR for this variable, which will cause the
5674 gimplifier to allocate storage, and all that good stuff. */
5675 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
5676 gfc_add_expr_to_block (&init, tmp);
5677 }
5678
5679 if (onstack)
5680 {
5681 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5682 return;
5683 }
5684
5685 type = TREE_TYPE (type);
5686
5687 gcc_assert (!sym->attr.use_assoc);
5688 gcc_assert (!TREE_STATIC (decl));
5689 gcc_assert (!sym->module);
5690
5691 if (sym->ts.type == BT_CHARACTER
5692 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
5693 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5694
5695 size = gfc_trans_array_bounds (type, sym, &offset, &init);
5696
5697 /* Don't actually allocate space for Cray Pointees. */
5698 if (sym->attr.cray_pointee)
5699 {
5700 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5701 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5702
5703 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5704 return;
5705 }
5706
5707 if (gfc_option.flag_stack_arrays)
5708 {
5709 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
5710 space = build_decl (sym->declared_at.lb->location,
5711 VAR_DECL, create_tmp_var_name ("A"),
5712 TREE_TYPE (TREE_TYPE (decl)));
5713 gfc_trans_vla_type_sizes (sym, &init);
5714 }
5715 else
5716 {
5717 /* The size is the number of elements in the array, so multiply by the
5718 size of an element to get the total size. */
5719 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5720 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5721 size, fold_convert (gfc_array_index_type, tmp));
5722
5723 /* Allocate memory to hold the data. */
5724 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
5725 gfc_add_modify (&init, decl, tmp);
5726
5727 /* Free the temporary. */
5728 tmp = gfc_call_free (convert (pvoid_type_node, decl));
5729 space = NULL_TREE;
5730 }
5731
5732 /* Set offset of the array. */
5733 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5734 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5735
5736 /* Automatic arrays should not have initializers. */
5737 gcc_assert (!sym->value);
5738
5739 inittree = gfc_finish_block (&init);
5740
5741 if (space)
5742 {
5743 tree addr;
5744 pushdecl (space);
5745
5746 /* Don't create new scope, emit the DECL_EXPR in exactly the scope
5747 where also space is located. */
5748 gfc_init_block (&init);
5749 tmp = fold_build1_loc (input_location, DECL_EXPR,
5750 TREE_TYPE (space), space);
5751 gfc_add_expr_to_block (&init, tmp);
5752 addr = fold_build1_loc (sym->declared_at.lb->location,
5753 ADDR_EXPR, TREE_TYPE (decl), space);
5754 gfc_add_modify (&init, decl, addr);
5755 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
5756 tmp = NULL_TREE;
5757 }
5758 gfc_add_init_cleanup (block, inittree, tmp);
5759 }
5760
5761
5762 /* Generate entry and exit code for g77 calling convention arrays. */
5763
5764 void
gfc_trans_g77_array(gfc_symbol * sym,gfc_wrapped_block * block)5765 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
5766 {
5767 tree parm;
5768 tree type;
5769 locus loc;
5770 tree offset;
5771 tree tmp;
5772 tree stmt;
5773 stmtblock_t init;
5774
5775 gfc_save_backend_locus (&loc);
5776 gfc_set_backend_locus (&sym->declared_at);
5777
5778 /* Descriptor type. */
5779 parm = sym->backend_decl;
5780 type = TREE_TYPE (parm);
5781 gcc_assert (GFC_ARRAY_TYPE_P (type));
5782
5783 gfc_start_block (&init);
5784
5785 if (sym->ts.type == BT_CHARACTER
5786 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5787 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5788
5789 /* Evaluate the bounds of the array. */
5790 gfc_trans_array_bounds (type, sym, &offset, &init);
5791
5792 /* Set the offset. */
5793 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
5794 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
5795
5796 /* Set the pointer itself if we aren't using the parameter directly. */
5797 if (TREE_CODE (parm) != PARM_DECL)
5798 {
5799 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
5800 gfc_add_modify (&init, parm, tmp);
5801 }
5802 stmt = gfc_finish_block (&init);
5803
5804 gfc_restore_backend_locus (&loc);
5805
5806 /* Add the initialization code to the start of the function. */
5807
5808 if (sym->attr.optional || sym->attr.not_always_present)
5809 {
5810 tmp = gfc_conv_expr_present (sym);
5811 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
5812 }
5813
5814 gfc_add_init_cleanup (block, stmt, NULL_TREE);
5815 }
5816
5817
5818 /* Modify the descriptor of an array parameter so that it has the
5819 correct lower bound. Also move the upper bound accordingly.
5820 If the array is not packed, it will be copied into a temporary.
5821 For each dimension we set the new lower and upper bounds. Then we copy the
5822 stride and calculate the offset for this dimension. We also work out
5823 what the stride of a packed array would be, and see it the two match.
5824 If the array need repacking, we set the stride to the values we just
5825 calculated, recalculate the offset and copy the array data.
5826 Code is also added to copy the data back at the end of the function.
5827 */
5828
5829 void
gfc_trans_dummy_array_bias(gfc_symbol * sym,tree tmpdesc,gfc_wrapped_block * block)5830 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
5831 gfc_wrapped_block * block)
5832 {
5833 tree size;
5834 tree type;
5835 tree offset;
5836 locus loc;
5837 stmtblock_t init;
5838 tree stmtInit, stmtCleanup;
5839 tree lbound;
5840 tree ubound;
5841 tree dubound;
5842 tree dlbound;
5843 tree dumdesc;
5844 tree tmp;
5845 tree stride, stride2;
5846 tree stmt_packed;
5847 tree stmt_unpacked;
5848 tree partial;
5849 gfc_se se;
5850 int n;
5851 int checkparm;
5852 int no_repack;
5853 bool optional_arg;
5854
5855 /* Do nothing for pointer and allocatable arrays. */
5856 if (sym->attr.pointer || sym->attr.allocatable)
5857 return;
5858
5859 if (sym->attr.dummy && gfc_is_nodesc_array (sym))
5860 {
5861 gfc_trans_g77_array (sym, block);
5862 return;
5863 }
5864
5865 gfc_save_backend_locus (&loc);
5866 gfc_set_backend_locus (&sym->declared_at);
5867
5868 /* Descriptor type. */
5869 type = TREE_TYPE (tmpdesc);
5870 gcc_assert (GFC_ARRAY_TYPE_P (type));
5871 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5872 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
5873 gfc_start_block (&init);
5874
5875 if (sym->ts.type == BT_CHARACTER
5876 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
5877 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5878
5879 checkparm = (sym->as->type == AS_EXPLICIT
5880 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
5881
5882 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
5883 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
5884
5885 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
5886 {
5887 /* For non-constant shape arrays we only check if the first dimension
5888 is contiguous. Repacking higher dimensions wouldn't gain us
5889 anything as we still don't know the array stride. */
5890 partial = gfc_create_var (boolean_type_node, "partial");
5891 TREE_USED (partial) = 1;
5892 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5893 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
5894 gfc_index_one_node);
5895 gfc_add_modify (&init, partial, tmp);
5896 }
5897 else
5898 partial = NULL_TREE;
5899
5900 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive
5901 here, however I think it does the right thing. */
5902 if (no_repack)
5903 {
5904 /* Set the first stride. */
5905 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
5906 stride = gfc_evaluate_now (stride, &init);
5907
5908 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5909 stride, gfc_index_zero_node);
5910 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5911 tmp, gfc_index_one_node, stride);
5912 stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
5913 gfc_add_modify (&init, stride, tmp);
5914
5915 /* Allow the user to disable array repacking. */
5916 stmt_unpacked = NULL_TREE;
5917 }
5918 else
5919 {
5920 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
5921 /* A library call to repack the array if necessary. */
5922 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
5923 stmt_unpacked = build_call_expr_loc (input_location,
5924 gfor_fndecl_in_pack, 1, tmp);
5925
5926 stride = gfc_index_one_node;
5927
5928 if (gfc_option.warn_array_temp)
5929 gfc_warning ("Creating array temporary at %L", &loc);
5930 }
5931
5932 /* This is for the case where the array data is used directly without
5933 calling the repack function. */
5934 if (no_repack || partial != NULL_TREE)
5935 stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
5936 else
5937 stmt_packed = NULL_TREE;
5938
5939 /* Assign the data pointer. */
5940 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
5941 {
5942 /* Don't repack unknown shape arrays when the first stride is 1. */
5943 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
5944 partial, stmt_packed, stmt_unpacked);
5945 }
5946 else
5947 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
5948 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
5949
5950 offset = gfc_index_zero_node;
5951 size = gfc_index_one_node;
5952
5953 /* Evaluate the bounds of the array. */
5954 for (n = 0; n < sym->as->rank; n++)
5955 {
5956 if (checkparm || !sym->as->upper[n])
5957 {
5958 /* Get the bounds of the actual parameter. */
5959 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
5960 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
5961 }
5962 else
5963 {
5964 dubound = NULL_TREE;
5965 dlbound = NULL_TREE;
5966 }
5967
5968 lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
5969 if (!INTEGER_CST_P (lbound))
5970 {
5971 gfc_init_se (&se, NULL);
5972 gfc_conv_expr_type (&se, sym->as->lower[n],
5973 gfc_array_index_type);
5974 gfc_add_block_to_block (&init, &se.pre);
5975 gfc_add_modify (&init, lbound, se.expr);
5976 }
5977
5978 ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
5979 /* Set the desired upper bound. */
5980 if (sym->as->upper[n])
5981 {
5982 /* We know what we want the upper bound to be. */
5983 if (!INTEGER_CST_P (ubound))
5984 {
5985 gfc_init_se (&se, NULL);
5986 gfc_conv_expr_type (&se, sym->as->upper[n],
5987 gfc_array_index_type);
5988 gfc_add_block_to_block (&init, &se.pre);
5989 gfc_add_modify (&init, ubound, se.expr);
5990 }
5991
5992 /* Check the sizes match. */
5993 if (checkparm)
5994 {
5995 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
5996 char * msg;
5997 tree temp;
5998
5999 temp = fold_build2_loc (input_location, MINUS_EXPR,
6000 gfc_array_index_type, ubound, lbound);
6001 temp = fold_build2_loc (input_location, PLUS_EXPR,
6002 gfc_array_index_type,
6003 gfc_index_one_node, temp);
6004 stride2 = fold_build2_loc (input_location, MINUS_EXPR,
6005 gfc_array_index_type, dubound,
6006 dlbound);
6007 stride2 = fold_build2_loc (input_location, PLUS_EXPR,
6008 gfc_array_index_type,
6009 gfc_index_one_node, stride2);
6010 tmp = fold_build2_loc (input_location, NE_EXPR,
6011 gfc_array_index_type, temp, stride2);
6012 asprintf (&msg, "Dimension %d of array '%s' has extent "
6013 "%%ld instead of %%ld", n+1, sym->name);
6014
6015 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
6016 fold_convert (long_integer_type_node, temp),
6017 fold_convert (long_integer_type_node, stride2));
6018
6019 free (msg);
6020 }
6021 }
6022 else
6023 {
6024 /* For assumed shape arrays move the upper bound by the same amount
6025 as the lower bound. */
6026 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6027 gfc_array_index_type, dubound, dlbound);
6028 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6029 gfc_array_index_type, tmp, lbound);
6030 gfc_add_modify (&init, ubound, tmp);
6031 }
6032 /* The offset of this dimension. offset = offset - lbound * stride. */
6033 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6034 lbound, stride);
6035 offset = fold_build2_loc (input_location, MINUS_EXPR,
6036 gfc_array_index_type, offset, tmp);
6037
6038 /* The size of this dimension, and the stride of the next. */
6039 if (n + 1 < sym->as->rank)
6040 {
6041 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
6042
6043 if (no_repack || partial != NULL_TREE)
6044 stmt_unpacked =
6045 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
6046
6047 /* Figure out the stride if not a known constant. */
6048 if (!INTEGER_CST_P (stride))
6049 {
6050 if (no_repack)
6051 stmt_packed = NULL_TREE;
6052 else
6053 {
6054 /* Calculate stride = size * (ubound + 1 - lbound). */
6055 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6056 gfc_array_index_type,
6057 gfc_index_one_node, lbound);
6058 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6059 gfc_array_index_type, ubound, tmp);
6060 size = fold_build2_loc (input_location, MULT_EXPR,
6061 gfc_array_index_type, size, tmp);
6062 stmt_packed = size;
6063 }
6064
6065 /* Assign the stride. */
6066 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
6067 tmp = fold_build3_loc (input_location, COND_EXPR,
6068 gfc_array_index_type, partial,
6069 stmt_unpacked, stmt_packed);
6070 else
6071 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
6072 gfc_add_modify (&init, stride, tmp);
6073 }
6074 }
6075 else
6076 {
6077 stride = GFC_TYPE_ARRAY_SIZE (type);
6078
6079 if (stride && !INTEGER_CST_P (stride))
6080 {
6081 /* Calculate size = stride * (ubound + 1 - lbound). */
6082 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6083 gfc_array_index_type,
6084 gfc_index_one_node, lbound);
6085 tmp = fold_build2_loc (input_location, PLUS_EXPR,
6086 gfc_array_index_type,
6087 ubound, tmp);
6088 tmp = fold_build2_loc (input_location, MULT_EXPR,
6089 gfc_array_index_type,
6090 GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
6091 gfc_add_modify (&init, stride, tmp);
6092 }
6093 }
6094 }
6095
6096 gfc_trans_array_cobounds (type, &init, sym);
6097
6098 /* Set the offset. */
6099 if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
6100 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6101
6102 gfc_trans_vla_type_sizes (sym, &init);
6103
6104 stmtInit = gfc_finish_block (&init);
6105
6106 /* Only do the entry/initialization code if the arg is present. */
6107 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
6108 optional_arg = (sym->attr.optional
6109 || (sym->ns->proc_name->attr.entry_master
6110 && sym->attr.dummy));
6111 if (optional_arg)
6112 {
6113 tmp = gfc_conv_expr_present (sym);
6114 stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
6115 build_empty_stmt (input_location));
6116 }
6117
6118 /* Cleanup code. */
6119 if (no_repack)
6120 stmtCleanup = NULL_TREE;
6121 else
6122 {
6123 stmtblock_t cleanup;
6124 gfc_start_block (&cleanup);
6125
6126 if (sym->attr.intent != INTENT_IN)
6127 {
6128 /* Copy the data back. */
6129 tmp = build_call_expr_loc (input_location,
6130 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
6131 gfc_add_expr_to_block (&cleanup, tmp);
6132 }
6133
6134 /* Free the temporary. */
6135 tmp = gfc_call_free (tmpdesc);
6136 gfc_add_expr_to_block (&cleanup, tmp);
6137
6138 stmtCleanup = gfc_finish_block (&cleanup);
6139
6140 /* Only do the cleanup if the array was repacked. */
6141 tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
6142 tmp = gfc_conv_descriptor_data_get (tmp);
6143 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6144 tmp, tmpdesc);
6145 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6146 build_empty_stmt (input_location));
6147
6148 if (optional_arg)
6149 {
6150 tmp = gfc_conv_expr_present (sym);
6151 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
6152 build_empty_stmt (input_location));
6153 }
6154 }
6155
6156 /* We don't need to free any memory allocated by internal_pack as it will
6157 be freed at the end of the function by pop_context. */
6158 gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
6159
6160 gfc_restore_backend_locus (&loc);
6161 }
6162
6163
6164 /* Calculate the overall offset, including subreferences. */
6165 static void
gfc_get_dataptr_offset(stmtblock_t * block,tree parm,tree desc,tree offset,bool subref,gfc_expr * expr)6166 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
6167 bool subref, gfc_expr *expr)
6168 {
6169 tree tmp;
6170 tree field;
6171 tree stride;
6172 tree index;
6173 gfc_ref *ref;
6174 gfc_se start;
6175 int n;
6176
6177 /* If offset is NULL and this is not a subreferenced array, there is
6178 nothing to do. */
6179 if (offset == NULL_TREE)
6180 {
6181 if (subref)
6182 offset = gfc_index_zero_node;
6183 else
6184 return;
6185 }
6186
6187 tmp = build_array_ref (desc, offset, NULL);
6188
6189 /* Offset the data pointer for pointer assignments from arrays with
6190 subreferences; e.g. my_integer => my_type(:)%integer_component. */
6191 if (subref)
6192 {
6193 /* Go past the array reference. */
6194 for (ref = expr->ref; ref; ref = ref->next)
6195 if (ref->type == REF_ARRAY &&
6196 ref->u.ar.type != AR_ELEMENT)
6197 {
6198 ref = ref->next;
6199 break;
6200 }
6201
6202 /* Calculate the offset for each subsequent subreference. */
6203 for (; ref; ref = ref->next)
6204 {
6205 switch (ref->type)
6206 {
6207 case REF_COMPONENT:
6208 field = ref->u.c.component->backend_decl;
6209 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
6210 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6211 TREE_TYPE (field),
6212 tmp, field, NULL_TREE);
6213 break;
6214
6215 case REF_SUBSTRING:
6216 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
6217 gfc_init_se (&start, NULL);
6218 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
6219 gfc_add_block_to_block (block, &start.pre);
6220 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
6221 break;
6222
6223 case REF_ARRAY:
6224 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
6225 && ref->u.ar.type == AR_ELEMENT);
6226
6227 /* TODO - Add bounds checking. */
6228 stride = gfc_index_one_node;
6229 index = gfc_index_zero_node;
6230 for (n = 0; n < ref->u.ar.dimen; n++)
6231 {
6232 tree itmp;
6233 tree jtmp;
6234
6235 /* Update the index. */
6236 gfc_init_se (&start, NULL);
6237 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
6238 itmp = gfc_evaluate_now (start.expr, block);
6239 gfc_init_se (&start, NULL);
6240 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
6241 jtmp = gfc_evaluate_now (start.expr, block);
6242 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6243 gfc_array_index_type, itmp, jtmp);
6244 itmp = fold_build2_loc (input_location, MULT_EXPR,
6245 gfc_array_index_type, itmp, stride);
6246 index = fold_build2_loc (input_location, PLUS_EXPR,
6247 gfc_array_index_type, itmp, index);
6248 index = gfc_evaluate_now (index, block);
6249
6250 /* Update the stride. */
6251 gfc_init_se (&start, NULL);
6252 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
6253 itmp = fold_build2_loc (input_location, MINUS_EXPR,
6254 gfc_array_index_type, start.expr,
6255 jtmp);
6256 itmp = fold_build2_loc (input_location, PLUS_EXPR,
6257 gfc_array_index_type,
6258 gfc_index_one_node, itmp);
6259 stride = fold_build2_loc (input_location, MULT_EXPR,
6260 gfc_array_index_type, stride, itmp);
6261 stride = gfc_evaluate_now (stride, block);
6262 }
6263
6264 /* Apply the index to obtain the array element. */
6265 tmp = gfc_build_array_ref (tmp, index, NULL);
6266 break;
6267
6268 default:
6269 gcc_unreachable ();
6270 break;
6271 }
6272 }
6273 }
6274
6275 /* Set the target data pointer. */
6276 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
6277 gfc_conv_descriptor_data_set (block, parm, offset);
6278 }
6279
6280
6281 /* gfc_conv_expr_descriptor needs the string length an expression
6282 so that the size of the temporary can be obtained. This is done
6283 by adding up the string lengths of all the elements in the
6284 expression. Function with non-constant expressions have their
6285 string lengths mapped onto the actual arguments using the
6286 interface mapping machinery in trans-expr.c. */
6287 static void
get_array_charlen(gfc_expr * expr,gfc_se * se)6288 get_array_charlen (gfc_expr *expr, gfc_se *se)
6289 {
6290 gfc_interface_mapping mapping;
6291 gfc_formal_arglist *formal;
6292 gfc_actual_arglist *arg;
6293 gfc_se tse;
6294
6295 if (expr->ts.u.cl->length
6296 && gfc_is_constant_expr (expr->ts.u.cl->length))
6297 {
6298 if (!expr->ts.u.cl->backend_decl)
6299 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6300 return;
6301 }
6302
6303 switch (expr->expr_type)
6304 {
6305 case EXPR_OP:
6306 get_array_charlen (expr->value.op.op1, se);
6307
6308 /* For parentheses the expression ts.u.cl is identical. */
6309 if (expr->value.op.op == INTRINSIC_PARENTHESES)
6310 return;
6311
6312 expr->ts.u.cl->backend_decl =
6313 gfc_create_var (gfc_charlen_type_node, "sln");
6314
6315 if (expr->value.op.op2)
6316 {
6317 get_array_charlen (expr->value.op.op2, se);
6318
6319 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
6320
6321 /* Add the string lengths and assign them to the expression
6322 string length backend declaration. */
6323 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6324 fold_build2_loc (input_location, PLUS_EXPR,
6325 gfc_charlen_type_node,
6326 expr->value.op.op1->ts.u.cl->backend_decl,
6327 expr->value.op.op2->ts.u.cl->backend_decl));
6328 }
6329 else
6330 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6331 expr->value.op.op1->ts.u.cl->backend_decl);
6332 break;
6333
6334 case EXPR_FUNCTION:
6335 if (expr->value.function.esym == NULL
6336 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6337 {
6338 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6339 break;
6340 }
6341
6342 /* Map expressions involving the dummy arguments onto the actual
6343 argument expressions. */
6344 gfc_init_interface_mapping (&mapping);
6345 formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
6346 arg = expr->value.function.actual;
6347
6348 /* Set se = NULL in the calls to the interface mapping, to suppress any
6349 backend stuff. */
6350 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
6351 {
6352 if (!arg->expr)
6353 continue;
6354 if (formal->sym)
6355 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
6356 }
6357
6358 gfc_init_se (&tse, NULL);
6359
6360 /* Build the expression for the character length and convert it. */
6361 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
6362
6363 gfc_add_block_to_block (&se->pre, &tse.pre);
6364 gfc_add_block_to_block (&se->post, &tse.post);
6365 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
6366 tse.expr = fold_build2_loc (input_location, MAX_EXPR,
6367 gfc_charlen_type_node, tse.expr,
6368 build_int_cst (gfc_charlen_type_node, 0));
6369 expr->ts.u.cl->backend_decl = tse.expr;
6370 gfc_free_interface_mapping (&mapping);
6371 break;
6372
6373 default:
6374 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
6375 break;
6376 }
6377 }
6378
6379
6380 /* Helper function to check dimensions. */
6381 static bool
transposed_dims(gfc_ss * ss)6382 transposed_dims (gfc_ss *ss)
6383 {
6384 int n;
6385
6386 for (n = 0; n < ss->dimen; n++)
6387 if (ss->dim[n] != n)
6388 return true;
6389 return false;
6390 }
6391
6392
6393 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
6394 AR_FULL, suitable for the scalarizer. */
6395
6396 static gfc_ss *
walk_coarray(gfc_expr * e)6397 walk_coarray (gfc_expr *e)
6398 {
6399 gfc_ss *ss;
6400
6401 gcc_assert (gfc_get_corank (e) > 0);
6402
6403 ss = gfc_walk_expr (e);
6404
6405 /* Fix scalar coarray. */
6406 if (ss == gfc_ss_terminator)
6407 {
6408 gfc_ref *ref;
6409
6410 ref = e->ref;
6411 while (ref)
6412 {
6413 if (ref->type == REF_ARRAY
6414 && ref->u.ar.codimen > 0)
6415 break;
6416
6417 ref = ref->next;
6418 }
6419
6420 gcc_assert (ref != NULL);
6421 if (ref->u.ar.type == AR_ELEMENT)
6422 ref->u.ar.type = AR_SECTION;
6423 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
6424 }
6425
6426 return ss;
6427 }
6428
6429
6430 /* Convert an array for passing as an actual argument. Expressions and
6431 vector subscripts are evaluated and stored in a temporary, which is then
6432 passed. For whole arrays the descriptor is passed. For array sections
6433 a modified copy of the descriptor is passed, but using the original data.
6434
6435 This function is also used for array pointer assignments, and there
6436 are three cases:
6437
6438 - se->want_pointer && !se->direct_byref
6439 EXPR is an actual argument. On exit, se->expr contains a
6440 pointer to the array descriptor.
6441
6442 - !se->want_pointer && !se->direct_byref
6443 EXPR is an actual argument to an intrinsic function or the
6444 left-hand side of a pointer assignment. On exit, se->expr
6445 contains the descriptor for EXPR.
6446
6447 - !se->want_pointer && se->direct_byref
6448 EXPR is the right-hand side of a pointer assignment and
6449 se->expr is the descriptor for the previously-evaluated
6450 left-hand side. The function creates an assignment from
6451 EXPR to se->expr.
6452
6453
6454 The se->force_tmp flag disables the non-copying descriptor optimization
6455 that is used for transpose. It may be used in cases where there is an
6456 alias between the transpose argument and another argument in the same
6457 function call. */
6458
6459 void
gfc_conv_expr_descriptor(gfc_se * se,gfc_expr * expr)6460 gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
6461 {
6462 gfc_ss *ss;
6463 gfc_ss_type ss_type;
6464 gfc_ss_info *ss_info;
6465 gfc_loopinfo loop;
6466 gfc_array_info *info;
6467 int need_tmp;
6468 int n;
6469 tree tmp;
6470 tree desc;
6471 stmtblock_t block;
6472 tree start;
6473 tree offset;
6474 int full;
6475 bool subref_array_target = false;
6476 gfc_expr *arg, *ss_expr;
6477
6478 if (se->want_coarray)
6479 ss = walk_coarray (expr);
6480 else
6481 ss = gfc_walk_expr (expr);
6482
6483 gcc_assert (ss != NULL);
6484 gcc_assert (ss != gfc_ss_terminator);
6485
6486 ss_info = ss->info;
6487 ss_type = ss_info->type;
6488 ss_expr = ss_info->expr;
6489
6490 /* Special case: TRANSPOSE which needs no temporary. */
6491 while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
6492 && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
6493 {
6494 /* This is a call to transpose which has already been handled by the
6495 scalarizer, so that we just need to get its argument's descriptor. */
6496 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
6497 expr = expr->value.function.actual->expr;
6498 }
6499
6500 /* Special case things we know we can pass easily. */
6501 switch (expr->expr_type)
6502 {
6503 case EXPR_VARIABLE:
6504 /* If we have a linear array section, we can pass it directly.
6505 Otherwise we need to copy it into a temporary. */
6506
6507 gcc_assert (ss_type == GFC_SS_SECTION);
6508 gcc_assert (ss_expr == expr);
6509 info = &ss_info->data.array;
6510
6511 /* Get the descriptor for the array. */
6512 gfc_conv_ss_descriptor (&se->pre, ss, 0);
6513 desc = info->descriptor;
6514
6515 subref_array_target = se->direct_byref && is_subref_array (expr);
6516 need_tmp = gfc_ref_needs_temporary_p (expr->ref)
6517 && !subref_array_target;
6518
6519 if (se->force_tmp)
6520 need_tmp = 1;
6521
6522 if (need_tmp)
6523 full = 0;
6524 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6525 {
6526 /* Create a new descriptor if the array doesn't have one. */
6527 full = 0;
6528 }
6529 else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
6530 full = 1;
6531 else if (se->direct_byref)
6532 full = 0;
6533 else
6534 full = gfc_full_array_ref_p (info->ref, NULL);
6535
6536 if (full && !transposed_dims (ss))
6537 {
6538 if (se->direct_byref && !se->byref_noassign)
6539 {
6540 /* Copy the descriptor for pointer assignments. */
6541 gfc_add_modify (&se->pre, se->expr, desc);
6542
6543 /* Add any offsets from subreferences. */
6544 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
6545 subref_array_target, expr);
6546 }
6547 else if (se->want_pointer)
6548 {
6549 /* We pass full arrays directly. This means that pointers and
6550 allocatable arrays should also work. */
6551 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6552 }
6553 else
6554 {
6555 se->expr = desc;
6556 }
6557
6558 if (expr->ts.type == BT_CHARACTER)
6559 se->string_length = gfc_get_expr_charlen (expr);
6560
6561 gfc_free_ss_chain (ss);
6562 return;
6563 }
6564 break;
6565
6566 case EXPR_FUNCTION:
6567 /* A transformational function return value will be a temporary
6568 array descriptor. We still need to go through the scalarizer
6569 to create the descriptor. Elemental functions are handled as
6570 arbitrary expressions, i.e. copy to a temporary. */
6571
6572 if (se->direct_byref)
6573 {
6574 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
6575
6576 /* For pointer assignments pass the descriptor directly. */
6577 if (se->ss == NULL)
6578 se->ss = ss;
6579 else
6580 gcc_assert (se->ss == ss);
6581 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
6582 gfc_conv_expr (se, expr);
6583 gfc_free_ss_chain (ss);
6584 return;
6585 }
6586
6587 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION)
6588 {
6589 if (ss_expr != expr)
6590 /* Elemental function. */
6591 gcc_assert ((expr->value.function.esym != NULL
6592 && expr->value.function.esym->attr.elemental)
6593 || (expr->value.function.isym != NULL
6594 && expr->value.function.isym->elemental)
6595 || gfc_inline_intrinsic_function_p (expr));
6596 else
6597 gcc_assert (ss_type == GFC_SS_INTRINSIC);
6598
6599 need_tmp = 1;
6600 if (expr->ts.type == BT_CHARACTER
6601 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6602 get_array_charlen (expr, se);
6603
6604 info = NULL;
6605 }
6606 else
6607 {
6608 /* Transformational function. */
6609 info = &ss_info->data.array;
6610 need_tmp = 0;
6611 }
6612 break;
6613
6614 case EXPR_ARRAY:
6615 /* Constant array constructors don't need a temporary. */
6616 if (ss_type == GFC_SS_CONSTRUCTOR
6617 && expr->ts.type != BT_CHARACTER
6618 && gfc_constant_array_constructor_p (expr->value.constructor))
6619 {
6620 need_tmp = 0;
6621 info = &ss_info->data.array;
6622 }
6623 else
6624 {
6625 need_tmp = 1;
6626 info = NULL;
6627 }
6628 break;
6629
6630 default:
6631 /* Something complicated. Copy it into a temporary. */
6632 need_tmp = 1;
6633 info = NULL;
6634 break;
6635 }
6636
6637 /* If we are creating a temporary, we don't need to bother about aliases
6638 anymore. */
6639 if (need_tmp)
6640 se->force_tmp = 0;
6641
6642 gfc_init_loopinfo (&loop);
6643
6644 /* Associate the SS with the loop. */
6645 gfc_add_ss_to_loop (&loop, ss);
6646
6647 /* Tell the scalarizer not to bother creating loop variables, etc. */
6648 if (!need_tmp)
6649 loop.array_parameter = 1;
6650 else
6651 /* The right-hand side of a pointer assignment mustn't use a temporary. */
6652 gcc_assert (!se->direct_byref);
6653
6654 /* Setup the scalarizing loops and bounds. */
6655 gfc_conv_ss_startstride (&loop);
6656
6657 if (need_tmp)
6658 {
6659 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
6660 get_array_charlen (expr, se);
6661
6662 /* Tell the scalarizer to make a temporary. */
6663 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
6664 ((expr->ts.type == BT_CHARACTER)
6665 ? expr->ts.u.cl->backend_decl
6666 : NULL),
6667 loop.dimen);
6668
6669 se->string_length = loop.temp_ss->info->string_length;
6670 gcc_assert (loop.temp_ss->dimen == loop.dimen);
6671 gfc_add_ss_to_loop (&loop, loop.temp_ss);
6672 }
6673
6674 gfc_conv_loop_setup (&loop, & expr->where);
6675
6676 if (need_tmp)
6677 {
6678 /* Copy into a temporary and pass that. We don't need to copy the data
6679 back because expressions and vector subscripts must be INTENT_IN. */
6680 /* TODO: Optimize passing function return values. */
6681 gfc_se lse;
6682 gfc_se rse;
6683
6684 /* Start the copying loops. */
6685 gfc_mark_ss_chain_used (loop.temp_ss, 1);
6686 gfc_mark_ss_chain_used (ss, 1);
6687 gfc_start_scalarized_body (&loop, &block);
6688
6689 /* Copy each data element. */
6690 gfc_init_se (&lse, NULL);
6691 gfc_copy_loopinfo_to_se (&lse, &loop);
6692 gfc_init_se (&rse, NULL);
6693 gfc_copy_loopinfo_to_se (&rse, &loop);
6694
6695 lse.ss = loop.temp_ss;
6696 rse.ss = ss;
6697
6698 gfc_conv_scalarized_array_ref (&lse, NULL);
6699 if (expr->ts.type == BT_CHARACTER)
6700 {
6701 gfc_conv_expr (&rse, expr);
6702 if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
6703 rse.expr = build_fold_indirect_ref_loc (input_location,
6704 rse.expr);
6705 }
6706 else
6707 gfc_conv_expr_val (&rse, expr);
6708
6709 gfc_add_block_to_block (&block, &rse.pre);
6710 gfc_add_block_to_block (&block, &lse.pre);
6711
6712 lse.string_length = rse.string_length;
6713 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
6714 expr->expr_type == EXPR_VARIABLE
6715 || expr->expr_type == EXPR_ARRAY, true);
6716 gfc_add_expr_to_block (&block, tmp);
6717
6718 /* Finish the copying loops. */
6719 gfc_trans_scalarizing_loops (&loop, &block);
6720
6721 desc = loop.temp_ss->info->data.array.descriptor;
6722 }
6723 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
6724 {
6725 desc = info->descriptor;
6726 se->string_length = ss_info->string_length;
6727 }
6728 else
6729 {
6730 /* We pass sections without copying to a temporary. Make a new
6731 descriptor and point it at the section we want. The loop variable
6732 limits will be the limits of the section.
6733 A function may decide to repack the array to speed up access, but
6734 we're not bothered about that here. */
6735 int dim, ndim, codim;
6736 tree parm;
6737 tree parmtype;
6738 tree stride;
6739 tree from;
6740 tree to;
6741 tree base;
6742
6743 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
6744
6745 if (se->want_coarray)
6746 {
6747 gfc_array_ref *ar = &info->ref->u.ar;
6748
6749 codim = gfc_get_corank (expr);
6750 for (n = 0; n < codim - 1; n++)
6751 {
6752 /* Make sure we are not lost somehow. */
6753 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
6754
6755 /* Make sure the call to gfc_conv_section_startstride won't
6756 generate unnecessary code to calculate stride. */
6757 gcc_assert (ar->stride[n + ndim] == NULL);
6758
6759 gfc_conv_section_startstride (&loop.pre, ss, n + ndim);
6760 loop.from[n + loop.dimen] = info->start[n + ndim];
6761 loop.to[n + loop.dimen] = info->end[n + ndim];
6762 }
6763
6764 gcc_assert (n == codim - 1);
6765 evaluate_bound (&loop.pre, info->start, ar->start,
6766 info->descriptor, n + ndim, true);
6767 loop.from[n + loop.dimen] = info->start[n + ndim];
6768 }
6769 else
6770 codim = 0;
6771
6772 /* Set the string_length for a character array. */
6773 if (expr->ts.type == BT_CHARACTER)
6774 se->string_length = gfc_get_expr_charlen (expr);
6775
6776 desc = info->descriptor;
6777 if (se->direct_byref && !se->byref_noassign)
6778 {
6779 /* For pointer assignments we fill in the destination. */
6780 parm = se->expr;
6781 parmtype = TREE_TYPE (parm);
6782 }
6783 else
6784 {
6785 /* Otherwise make a new one. */
6786 parmtype = gfc_get_element_type (TREE_TYPE (desc));
6787 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
6788 loop.from, loop.to, 0,
6789 GFC_ARRAY_UNKNOWN, false);
6790 parm = gfc_create_var (parmtype, "parm");
6791 }
6792
6793 offset = gfc_index_zero_node;
6794
6795 /* The following can be somewhat confusing. We have two
6796 descriptors, a new one and the original array.
6797 {parm, parmtype, dim} refer to the new one.
6798 {desc, type, n, loop} refer to the original, which maybe
6799 a descriptorless array.
6800 The bounds of the scalarization are the bounds of the section.
6801 We don't have to worry about numeric overflows when calculating
6802 the offsets because all elements are within the array data. */
6803
6804 /* Set the dtype. */
6805 tmp = gfc_conv_descriptor_dtype (parm);
6806 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
6807
6808 /* Set offset for assignments to pointer only to zero if it is not
6809 the full array. */
6810 if ((se->direct_byref || se->use_offset)
6811 && ((info->ref && info->ref->u.ar.type != AR_FULL)
6812 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
6813 base = gfc_index_zero_node;
6814 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6815 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
6816 else
6817 base = NULL_TREE;
6818
6819 for (n = 0; n < ndim; n++)
6820 {
6821 stride = gfc_conv_array_stride (desc, n);
6822
6823 /* Work out the offset. */
6824 if (info->ref
6825 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6826 {
6827 gcc_assert (info->subscript[n]
6828 && info->subscript[n]->info->type == GFC_SS_SCALAR);
6829 start = info->subscript[n]->info->data.scalar.value;
6830 }
6831 else
6832 {
6833 /* Evaluate and remember the start of the section. */
6834 start = info->start[n];
6835 stride = gfc_evaluate_now (stride, &loop.pre);
6836 }
6837
6838 tmp = gfc_conv_array_lbound (desc, n);
6839 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6840 start, tmp);
6841 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
6842 tmp, stride);
6843 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
6844 offset, tmp);
6845
6846 if (info->ref
6847 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
6848 {
6849 /* For elemental dimensions, we only need the offset. */
6850 continue;
6851 }
6852
6853 /* Vector subscripts need copying and are handled elsewhere. */
6854 if (info->ref)
6855 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
6856
6857 /* look for the corresponding scalarizer dimension: dim. */
6858 for (dim = 0; dim < ndim; dim++)
6859 if (ss->dim[dim] == n)
6860 break;
6861
6862 /* loop exited early: the DIM being looked for has been found. */
6863 gcc_assert (dim < ndim);
6864
6865 /* Set the new lower bound. */
6866 from = loop.from[dim];
6867 to = loop.to[dim];
6868
6869 /* If we have an array section or are assigning make sure that
6870 the lower bound is 1. References to the full
6871 array should otherwise keep the original bounds. */
6872 if ((!info->ref
6873 || info->ref->u.ar.type != AR_FULL)
6874 && !integer_onep (from))
6875 {
6876 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6877 gfc_array_index_type, gfc_index_one_node,
6878 from);
6879 to = fold_build2_loc (input_location, PLUS_EXPR,
6880 gfc_array_index_type, to, tmp);
6881 from = gfc_index_one_node;
6882 }
6883 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6884 gfc_rank_cst[dim], from);
6885
6886 /* Set the new upper bound. */
6887 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6888 gfc_rank_cst[dim], to);
6889
6890 /* Multiply the stride by the section stride to get the
6891 total stride. */
6892 stride = fold_build2_loc (input_location, MULT_EXPR,
6893 gfc_array_index_type,
6894 stride, info->stride[n]);
6895
6896 if (se->direct_byref
6897 && ((info->ref && info->ref->u.ar.type != AR_FULL)
6898 || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
6899 {
6900 base = fold_build2_loc (input_location, MINUS_EXPR,
6901 TREE_TYPE (base), base, stride);
6902 }
6903 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
6904 {
6905 tmp = gfc_conv_array_lbound (desc, n);
6906 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6907 TREE_TYPE (base), tmp, loop.from[dim]);
6908 tmp = fold_build2_loc (input_location, MULT_EXPR,
6909 TREE_TYPE (base), tmp,
6910 gfc_conv_array_stride (desc, n));
6911 base = fold_build2_loc (input_location, PLUS_EXPR,
6912 TREE_TYPE (base), tmp, base);
6913 }
6914
6915 /* Store the new stride. */
6916 gfc_conv_descriptor_stride_set (&loop.pre, parm,
6917 gfc_rank_cst[dim], stride);
6918 }
6919
6920 for (n = loop.dimen; n < loop.dimen + codim; n++)
6921 {
6922 from = loop.from[n];
6923 to = loop.to[n];
6924 gfc_conv_descriptor_lbound_set (&loop.pre, parm,
6925 gfc_rank_cst[n], from);
6926 if (n < loop.dimen + codim - 1)
6927 gfc_conv_descriptor_ubound_set (&loop.pre, parm,
6928 gfc_rank_cst[n], to);
6929 }
6930
6931 if (se->data_not_needed)
6932 gfc_conv_descriptor_data_set (&loop.pre, parm,
6933 gfc_index_zero_node);
6934 else
6935 /* Point the data pointer at the 1st element in the section. */
6936 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
6937 subref_array_target, expr);
6938
6939 if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6940 && !se->data_not_needed)
6941 || (se->use_offset && base != NULL_TREE))
6942 {
6943 /* Set the offset. */
6944 gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
6945 }
6946 else
6947 {
6948 /* Only the callee knows what the correct offset it, so just set
6949 it to zero here. */
6950 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
6951 }
6952 desc = parm;
6953 }
6954
6955 if (!se->direct_byref || se->byref_noassign)
6956 {
6957 /* Get a pointer to the new descriptor. */
6958 if (se->want_pointer)
6959 se->expr = gfc_build_addr_expr (NULL_TREE, desc);
6960 else
6961 se->expr = desc;
6962 }
6963
6964 gfc_add_block_to_block (&se->pre, &loop.pre);
6965 gfc_add_block_to_block (&se->post, &loop.post);
6966
6967 /* Cleanup the scalarizer. */
6968 gfc_cleanup_loop (&loop);
6969 }
6970
6971 /* Helper function for gfc_conv_array_parameter if array size needs to be
6972 computed. */
6973
6974 static void
array_parameter_size(tree desc,gfc_expr * expr,tree * size)6975 array_parameter_size (tree desc, gfc_expr *expr, tree *size)
6976 {
6977 tree elem;
6978 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
6979 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
6980 else if (expr->rank > 1)
6981 *size = build_call_expr_loc (input_location,
6982 gfor_fndecl_size0, 1,
6983 gfc_build_addr_expr (NULL, desc));
6984 else
6985 {
6986 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
6987 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
6988
6989 *size = fold_build2_loc (input_location, MINUS_EXPR,
6990 gfc_array_index_type, ubound, lbound);
6991 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6992 *size, gfc_index_one_node);
6993 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6994 *size, gfc_index_zero_node);
6995 }
6996 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
6997 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6998 *size, fold_convert (gfc_array_index_type, elem));
6999 }
7000
7001 /* Convert an array for passing as an actual parameter. */
7002 /* TODO: Optimize passing g77 arrays. */
7003
7004 void
gfc_conv_array_parameter(gfc_se * se,gfc_expr * expr,bool g77,const gfc_symbol * fsym,const char * proc_name,tree * size)7005 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
7006 const gfc_symbol *fsym, const char *proc_name,
7007 tree *size)
7008 {
7009 tree ptr;
7010 tree desc;
7011 tree tmp = NULL_TREE;
7012 tree stmt;
7013 tree parent = DECL_CONTEXT (current_function_decl);
7014 bool full_array_var;
7015 bool this_array_result;
7016 bool contiguous;
7017 bool no_pack;
7018 bool array_constructor;
7019 bool good_allocatable;
7020 bool ultimate_ptr_comp;
7021 bool ultimate_alloc_comp;
7022 gfc_symbol *sym;
7023 stmtblock_t block;
7024 gfc_ref *ref;
7025
7026 ultimate_ptr_comp = false;
7027 ultimate_alloc_comp = false;
7028
7029 for (ref = expr->ref; ref; ref = ref->next)
7030 {
7031 if (ref->next == NULL)
7032 break;
7033
7034 if (ref->type == REF_COMPONENT)
7035 {
7036 ultimate_ptr_comp = ref->u.c.component->attr.pointer;
7037 ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
7038 }
7039 }
7040
7041 full_array_var = false;
7042 contiguous = false;
7043
7044 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
7045 full_array_var = gfc_full_array_ref_p (ref, &contiguous);
7046
7047 sym = full_array_var ? expr->symtree->n.sym : NULL;
7048
7049 /* The symbol should have an array specification. */
7050 gcc_assert (!sym || sym->as || ref->u.ar.as);
7051
7052 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
7053 {
7054 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
7055 expr->ts.u.cl->backend_decl = tmp;
7056 se->string_length = tmp;
7057 }
7058
7059 /* Is this the result of the enclosing procedure? */
7060 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
7061 if (this_array_result
7062 && (sym->backend_decl != current_function_decl)
7063 && (sym->backend_decl != parent))
7064 this_array_result = false;
7065
7066 /* Passing address of the array if it is not pointer or assumed-shape. */
7067 if (full_array_var && g77 && !this_array_result
7068 && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
7069 {
7070 tmp = gfc_get_symbol_decl (sym);
7071
7072 if (sym->ts.type == BT_CHARACTER)
7073 se->string_length = sym->ts.u.cl->backend_decl;
7074
7075 if (!sym->attr.pointer
7076 && sym->as
7077 && sym->as->type != AS_ASSUMED_SHAPE
7078 && sym->as->type != AS_DEFERRED
7079 && sym->as->type != AS_ASSUMED_RANK
7080 && !sym->attr.allocatable)
7081 {
7082 /* Some variables are declared directly, others are declared as
7083 pointers and allocated on the heap. */
7084 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
7085 se->expr = tmp;
7086 else
7087 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7088 if (size)
7089 array_parameter_size (tmp, expr, size);
7090 return;
7091 }
7092
7093 if (sym->attr.allocatable)
7094 {
7095 if (sym->attr.dummy || sym->attr.result)
7096 {
7097 gfc_conv_expr_descriptor (se, expr);
7098 tmp = se->expr;
7099 }
7100 if (size)
7101 array_parameter_size (tmp, expr, size);
7102 se->expr = gfc_conv_array_data (tmp);
7103 return;
7104 }
7105 }
7106
7107 /* A convenient reduction in scope. */
7108 contiguous = g77 && !this_array_result && contiguous;
7109
7110 /* There is no need to pack and unpack the array, if it is contiguous
7111 and not a deferred- or assumed-shape array, or if it is simply
7112 contiguous. */
7113 no_pack = ((sym && sym->as
7114 && !sym->attr.pointer
7115 && sym->as->type != AS_DEFERRED
7116 && sym->as->type != AS_ASSUMED_RANK
7117 && sym->as->type != AS_ASSUMED_SHAPE)
7118 ||
7119 (ref && ref->u.ar.as
7120 && ref->u.ar.as->type != AS_DEFERRED
7121 && ref->u.ar.as->type != AS_ASSUMED_RANK
7122 && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
7123 ||
7124 gfc_is_simply_contiguous (expr, false));
7125
7126 no_pack = contiguous && no_pack;
7127
7128 /* Array constructors are always contiguous and do not need packing. */
7129 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
7130
7131 /* Same is true of contiguous sections from allocatable variables. */
7132 good_allocatable = contiguous
7133 && expr->symtree
7134 && expr->symtree->n.sym->attr.allocatable;
7135
7136 /* Or ultimate allocatable components. */
7137 ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
7138
7139 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
7140 {
7141 gfc_conv_expr_descriptor (se, expr);
7142 if (expr->ts.type == BT_CHARACTER)
7143 se->string_length = expr->ts.u.cl->backend_decl;
7144 if (size)
7145 array_parameter_size (se->expr, expr, size);
7146 se->expr = gfc_conv_array_data (se->expr);
7147 return;
7148 }
7149
7150 if (this_array_result)
7151 {
7152 /* Result of the enclosing function. */
7153 gfc_conv_expr_descriptor (se, expr);
7154 if (size)
7155 array_parameter_size (se->expr, expr, size);
7156 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7157
7158 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
7159 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
7160 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
7161 se->expr));
7162
7163 return;
7164 }
7165 else
7166 {
7167 /* Every other type of array. */
7168 se->want_pointer = 1;
7169 gfc_conv_expr_descriptor (se, expr);
7170 if (size)
7171 array_parameter_size (build_fold_indirect_ref_loc (input_location,
7172 se->expr),
7173 expr, size);
7174 }
7175
7176 /* Deallocate the allocatable components of structures that are
7177 not variable. */
7178 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
7179 && expr->ts.u.derived->attr.alloc_comp
7180 && expr->expr_type != EXPR_VARIABLE)
7181 {
7182 tmp = build_fold_indirect_ref_loc (input_location, se->expr);
7183 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
7184
7185 /* The components shall be deallocated before their containing entity. */
7186 gfc_prepend_expr_to_block (&se->post, tmp);
7187 }
7188
7189 if (g77 || (fsym && fsym->attr.contiguous
7190 && !gfc_is_simply_contiguous (expr, false)))
7191 {
7192 tree origptr = NULL_TREE;
7193
7194 desc = se->expr;
7195
7196 /* For contiguous arrays, save the original value of the descriptor. */
7197 if (!g77)
7198 {
7199 origptr = gfc_create_var (pvoid_type_node, "origptr");
7200 tmp = build_fold_indirect_ref_loc (input_location, desc);
7201 tmp = gfc_conv_array_data (tmp);
7202 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7203 TREE_TYPE (origptr), origptr,
7204 fold_convert (TREE_TYPE (origptr), tmp));
7205 gfc_add_expr_to_block (&se->pre, tmp);
7206 }
7207
7208 /* Repack the array. */
7209 if (gfc_option.warn_array_temp)
7210 {
7211 if (fsym)
7212 gfc_warning ("Creating array temporary at %L for argument '%s'",
7213 &expr->where, fsym->name);
7214 else
7215 gfc_warning ("Creating array temporary at %L", &expr->where);
7216 }
7217
7218 ptr = build_call_expr_loc (input_location,
7219 gfor_fndecl_in_pack, 1, desc);
7220
7221 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7222 {
7223 tmp = gfc_conv_expr_present (sym);
7224 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
7225 tmp, fold_convert (TREE_TYPE (se->expr), ptr),
7226 fold_convert (TREE_TYPE (se->expr), null_pointer_node));
7227 }
7228
7229 ptr = gfc_evaluate_now (ptr, &se->pre);
7230
7231 /* Use the packed data for the actual argument, except for contiguous arrays,
7232 where the descriptor's data component is set. */
7233 if (g77)
7234 se->expr = ptr;
7235 else
7236 {
7237 tmp = build_fold_indirect_ref_loc (input_location, desc);
7238
7239 gfc_ss * ss = gfc_walk_expr (expr);
7240 if (!transposed_dims (ss))
7241 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
7242 else
7243 {
7244 tree old_field, new_field;
7245
7246 /* The original descriptor has transposed dims so we can't reuse
7247 it directly; we have to create a new one. */
7248 tree old_desc = tmp;
7249 tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
7250
7251 old_field = gfc_conv_descriptor_dtype (old_desc);
7252 new_field = gfc_conv_descriptor_dtype (new_desc);
7253 gfc_add_modify (&se->pre, new_field, old_field);
7254
7255 old_field = gfc_conv_descriptor_offset (old_desc);
7256 new_field = gfc_conv_descriptor_offset (new_desc);
7257 gfc_add_modify (&se->pre, new_field, old_field);
7258
7259 for (int i = 0; i < expr->rank; i++)
7260 {
7261 old_field = gfc_conv_descriptor_dimension (old_desc,
7262 gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]);
7263 new_field = gfc_conv_descriptor_dimension (new_desc,
7264 gfc_rank_cst[i]);
7265 gfc_add_modify (&se->pre, new_field, old_field);
7266 }
7267
7268 if (gfc_option.coarray == GFC_FCOARRAY_LIB
7269 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
7270 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
7271 == GFC_ARRAY_ALLOCATABLE)
7272 {
7273 old_field = gfc_conv_descriptor_token (old_desc);
7274 new_field = gfc_conv_descriptor_token (new_desc);
7275 gfc_add_modify (&se->pre, new_field, old_field);
7276 }
7277
7278 gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
7279 se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
7280 }
7281 gfc_free_ss (ss);
7282 }
7283
7284 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
7285 {
7286 char * msg;
7287
7288 if (fsym && proc_name)
7289 asprintf (&msg, "An array temporary was created for argument "
7290 "'%s' of procedure '%s'", fsym->name, proc_name);
7291 else
7292 asprintf (&msg, "An array temporary was created");
7293
7294 tmp = build_fold_indirect_ref_loc (input_location,
7295 desc);
7296 tmp = gfc_conv_array_data (tmp);
7297 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7298 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7299
7300 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7301 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7302 boolean_type_node,
7303 gfc_conv_expr_present (sym), tmp);
7304
7305 gfc_trans_runtime_check (false, true, tmp, &se->pre,
7306 &expr->where, msg);
7307 free (msg);
7308 }
7309
7310 gfc_start_block (&block);
7311
7312 /* Copy the data back. */
7313 if (fsym == NULL || fsym->attr.intent != INTENT_IN)
7314 {
7315 tmp = build_call_expr_loc (input_location,
7316 gfor_fndecl_in_unpack, 2, desc, ptr);
7317 gfc_add_expr_to_block (&block, tmp);
7318 }
7319
7320 /* Free the temporary. */
7321 tmp = gfc_call_free (convert (pvoid_type_node, ptr));
7322 gfc_add_expr_to_block (&block, tmp);
7323
7324 stmt = gfc_finish_block (&block);
7325
7326 gfc_init_block (&block);
7327 /* Only if it was repacked. This code needs to be executed before the
7328 loop cleanup code. */
7329 tmp = build_fold_indirect_ref_loc (input_location,
7330 desc);
7331 tmp = gfc_conv_array_data (tmp);
7332 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7333 fold_convert (TREE_TYPE (tmp), ptr), tmp);
7334
7335 if (fsym && fsym->attr.optional && sym && sym->attr.optional)
7336 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7337 boolean_type_node,
7338 gfc_conv_expr_present (sym), tmp);
7339
7340 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
7341
7342 gfc_add_expr_to_block (&block, tmp);
7343 gfc_add_block_to_block (&block, &se->post);
7344
7345 gfc_init_block (&se->post);
7346
7347 /* Reset the descriptor pointer. */
7348 if (!g77)
7349 {
7350 tmp = build_fold_indirect_ref_loc (input_location, desc);
7351 gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
7352 }
7353
7354 gfc_add_block_to_block (&se->post, &block);
7355 }
7356 }
7357
7358
7359 /* Generate code to deallocate an array, if it is allocated. */
7360
7361 tree
gfc_trans_dealloc_allocated(tree descriptor,bool coarray,gfc_expr * expr)7362 gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
7363 {
7364 tree tmp;
7365 tree var;
7366 stmtblock_t block;
7367
7368 gfc_start_block (&block);
7369
7370 var = gfc_conv_descriptor_data_get (descriptor);
7371 STRIP_NOPS (var);
7372
7373 /* Call array_deallocate with an int * present in the second argument.
7374 Although it is ignored here, it's presence ensures that arrays that
7375 are already deallocated are ignored. */
7376 tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
7377 NULL_TREE, NULL_TREE, NULL_TREE, true,
7378 expr, coarray);
7379 gfc_add_expr_to_block (&block, tmp);
7380
7381 /* Zero the data pointer. */
7382 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7383 var, build_int_cst (TREE_TYPE (var), 0));
7384 gfc_add_expr_to_block (&block, tmp);
7385
7386 return gfc_finish_block (&block);
7387 }
7388
7389
7390 /* This helper function calculates the size in words of a full array. */
7391
7392 tree
gfc_full_array_size(stmtblock_t * block,tree decl,int rank)7393 gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
7394 {
7395 tree idx;
7396 tree nelems;
7397 tree tmp;
7398 idx = gfc_rank_cst[rank - 1];
7399 nelems = gfc_conv_descriptor_ubound_get (decl, idx);
7400 tmp = gfc_conv_descriptor_lbound_get (decl, idx);
7401 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7402 nelems, tmp);
7403 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7404 tmp, gfc_index_one_node);
7405 tmp = gfc_evaluate_now (tmp, block);
7406
7407 nelems = gfc_conv_descriptor_stride_get (decl, idx);
7408 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7409 nelems, tmp);
7410 return gfc_evaluate_now (tmp, block);
7411 }
7412
7413
7414 /* Allocate dest to the same size as src, and copy src -> dest.
7415 If no_malloc is set, only the copy is done. */
7416
7417 static tree
duplicate_allocatable(tree dest,tree src,tree type,int rank,bool no_malloc,bool no_memcpy,tree str_sz)7418 duplicate_allocatable (tree dest, tree src, tree type, int rank,
7419 bool no_malloc, bool no_memcpy, tree str_sz)
7420 {
7421 tree tmp;
7422 tree size;
7423 tree nelems;
7424 tree null_cond;
7425 tree null_data;
7426 stmtblock_t block;
7427
7428 /* If the source is null, set the destination to null. Then,
7429 allocate memory to the destination. */
7430 gfc_init_block (&block);
7431
7432 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7433 {
7434 tmp = null_pointer_node;
7435 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
7436 gfc_add_expr_to_block (&block, tmp);
7437 null_data = gfc_finish_block (&block);
7438
7439 gfc_init_block (&block);
7440 if (str_sz != NULL_TREE)
7441 size = str_sz;
7442 else
7443 size = TYPE_SIZE_UNIT (TREE_TYPE (type));
7444
7445 if (!no_malloc)
7446 {
7447 tmp = gfc_call_malloc (&block, type, size);
7448 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7449 dest, fold_convert (type, tmp));
7450 gfc_add_expr_to_block (&block, tmp);
7451 }
7452
7453 if (!no_memcpy)
7454 {
7455 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7456 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
7457 fold_convert (size_type_node, size));
7458 gfc_add_expr_to_block (&block, tmp);
7459 }
7460 }
7461 else
7462 {
7463 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7464 null_data = gfc_finish_block (&block);
7465
7466 gfc_init_block (&block);
7467 if (rank)
7468 nelems = gfc_full_array_size (&block, src, rank);
7469 else
7470 nelems = gfc_index_one_node;
7471
7472 if (str_sz != NULL_TREE)
7473 tmp = fold_convert (gfc_array_index_type, str_sz);
7474 else
7475 tmp = fold_convert (gfc_array_index_type,
7476 TYPE_SIZE_UNIT (gfc_get_element_type (type)));
7477 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7478 nelems, tmp);
7479 if (!no_malloc)
7480 {
7481 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
7482 tmp = gfc_call_malloc (&block, tmp, size);
7483 gfc_conv_descriptor_data_set (&block, dest, tmp);
7484 }
7485
7486 /* We know the temporary and the value will be the same length,
7487 so can use memcpy. */
7488 if (!no_memcpy)
7489 {
7490 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
7491 tmp = build_call_expr_loc (input_location, tmp, 3,
7492 gfc_conv_descriptor_data_get (dest),
7493 gfc_conv_descriptor_data_get (src),
7494 fold_convert (size_type_node, size));
7495 gfc_add_expr_to_block (&block, tmp);
7496 }
7497 }
7498
7499 tmp = gfc_finish_block (&block);
7500
7501 /* Null the destination if the source is null; otherwise do
7502 the allocate and copy. */
7503 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
7504 null_cond = src;
7505 else
7506 null_cond = gfc_conv_descriptor_data_get (src);
7507
7508 null_cond = convert (pvoid_type_node, null_cond);
7509 null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7510 null_cond, null_pointer_node);
7511 return build3_v (COND_EXPR, null_cond, tmp, null_data);
7512 }
7513
7514
7515 /* Allocate dest to the same size as src, and copy data src -> dest. */
7516
7517 tree
gfc_duplicate_allocatable(tree dest,tree src,tree type,int rank)7518 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
7519 {
7520 return duplicate_allocatable (dest, src, type, rank, false, false,
7521 NULL_TREE);
7522 }
7523
7524
7525 /* Copy data src -> dest. */
7526
7527 tree
gfc_copy_allocatable_data(tree dest,tree src,tree type,int rank)7528 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
7529 {
7530 return duplicate_allocatable (dest, src, type, rank, true, false,
7531 NULL_TREE);
7532 }
7533
7534 /* Allocate dest to the same size as src, but don't copy anything. */
7535
7536 tree
gfc_duplicate_allocatable_nocopy(tree dest,tree src,tree type,int rank)7537 gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
7538 {
7539 return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE);
7540 }
7541
7542
7543 /* Recursively traverse an object of derived type, generating code to
7544 deallocate, nullify or copy allocatable components. This is the work horse
7545 function for the functions named in this enum. */
7546
7547 enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF,
7548 NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP,
7549 COPY_ALLOC_COMP_CAF};
7550
7551 static tree
structure_alloc_comps(gfc_symbol * der_type,tree decl,tree dest,int rank,int purpose)7552 structure_alloc_comps (gfc_symbol * der_type, tree decl,
7553 tree dest, int rank, int purpose)
7554 {
7555 gfc_component *c;
7556 gfc_loopinfo loop;
7557 stmtblock_t fnblock;
7558 stmtblock_t loopbody;
7559 stmtblock_t tmpblock;
7560 tree decl_type;
7561 tree tmp;
7562 tree comp;
7563 tree dcmp;
7564 tree nelems;
7565 tree index;
7566 tree var;
7567 tree cdecl;
7568 tree ctype;
7569 tree vref, dref;
7570 tree null_cond = NULL_TREE;
7571 bool called_dealloc_with_status;
7572
7573 gfc_init_block (&fnblock);
7574
7575 decl_type = TREE_TYPE (decl);
7576
7577 if ((POINTER_TYPE_P (decl_type) && rank != 0)
7578 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
7579 decl = build_fold_indirect_ref_loc (input_location, decl);
7580
7581 /* Just in case in gets dereferenced. */
7582 decl_type = TREE_TYPE (decl);
7583
7584 /* If this an array of derived types with allocatable components
7585 build a loop and recursively call this function. */
7586 if (TREE_CODE (decl_type) == ARRAY_TYPE
7587 || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
7588 {
7589 tmp = gfc_conv_array_data (decl);
7590 var = build_fold_indirect_ref_loc (input_location,
7591 tmp);
7592
7593 /* Get the number of elements - 1 and set the counter. */
7594 if (GFC_DESCRIPTOR_TYPE_P (decl_type))
7595 {
7596 /* Use the descriptor for an allocatable array. Since this
7597 is a full array reference, we only need the descriptor
7598 information from dimension = rank. */
7599 tmp = gfc_full_array_size (&fnblock, decl, rank);
7600 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7601 gfc_array_index_type, tmp,
7602 gfc_index_one_node);
7603
7604 null_cond = gfc_conv_descriptor_data_get (decl);
7605 null_cond = fold_build2_loc (input_location, NE_EXPR,
7606 boolean_type_node, null_cond,
7607 build_int_cst (TREE_TYPE (null_cond), 0));
7608 }
7609 else
7610 {
7611 /* Otherwise use the TYPE_DOMAIN information. */
7612 tmp = array_type_nelts (decl_type);
7613 tmp = fold_convert (gfc_array_index_type, tmp);
7614 }
7615
7616 /* Remember that this is, in fact, the no. of elements - 1. */
7617 nelems = gfc_evaluate_now (tmp, &fnblock);
7618 index = gfc_create_var (gfc_array_index_type, "S");
7619
7620 /* Build the body of the loop. */
7621 gfc_init_block (&loopbody);
7622
7623 vref = gfc_build_array_ref (var, index, NULL);
7624
7625 if (purpose == COPY_ALLOC_COMP)
7626 {
7627 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
7628 {
7629 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
7630 gfc_add_expr_to_block (&fnblock, tmp);
7631 }
7632 tmp = build_fold_indirect_ref_loc (input_location,
7633 gfc_conv_array_data (dest));
7634 dref = gfc_build_array_ref (tmp, index, NULL);
7635 tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
7636 }
7637 else if (purpose == COPY_ONLY_ALLOC_COMP)
7638 {
7639 tmp = build_fold_indirect_ref_loc (input_location,
7640 gfc_conv_array_data (dest));
7641 dref = gfc_build_array_ref (tmp, index, NULL);
7642 tmp = structure_alloc_comps (der_type, vref, dref, rank,
7643 COPY_ALLOC_COMP);
7644 }
7645 else
7646 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
7647
7648 gfc_add_expr_to_block (&loopbody, tmp);
7649
7650 /* Build the loop and return. */
7651 gfc_init_loopinfo (&loop);
7652 loop.dimen = 1;
7653 loop.from[0] = gfc_index_zero_node;
7654 loop.loopvar[0] = index;
7655 loop.to[0] = nelems;
7656 gfc_trans_scalarizing_loops (&loop, &loopbody);
7657 gfc_add_block_to_block (&fnblock, &loop.pre);
7658
7659 tmp = gfc_finish_block (&fnblock);
7660 if (null_cond != NULL_TREE)
7661 tmp = build3_v (COND_EXPR, null_cond, tmp,
7662 build_empty_stmt (input_location));
7663
7664 return tmp;
7665 }
7666
7667 /* Otherwise, act on the components or recursively call self to
7668 act on a chain of components. */
7669 for (c = der_type->components; c; c = c->next)
7670 {
7671 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
7672 || c->ts.type == BT_CLASS)
7673 && c->ts.u.derived->attr.alloc_comp;
7674 cdecl = c->backend_decl;
7675 ctype = TREE_TYPE (cdecl);
7676
7677 switch (purpose)
7678 {
7679 case DEALLOCATE_ALLOC_COMP:
7680 case DEALLOCATE_ALLOC_COMP_NO_CAF:
7681
7682 /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
7683 (i.e. this function) so generate all the calls and suppress the
7684 recursion from here, if necessary. */
7685 called_dealloc_with_status = false;
7686 gfc_init_block (&tmpblock);
7687
7688 if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
7689 || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
7690 {
7691 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7692 decl, cdecl, NULL_TREE);
7693
7694 /* The finalizer frees allocatable components. */
7695 called_dealloc_with_status
7696 = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
7697 purpose == DEALLOCATE_ALLOC_COMP);
7698 }
7699 else
7700 comp = NULL_TREE;
7701
7702 if (c->attr.allocatable && !c->attr.proc_pointer
7703 && (c->attr.dimension
7704 || (c->attr.codimension
7705 && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
7706 {
7707 if (comp == NULL_TREE)
7708 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7709 decl, cdecl, NULL_TREE);
7710 tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
7711 gfc_add_expr_to_block (&tmpblock, tmp);
7712 }
7713 else if (c->attr.allocatable && !c->attr.codimension)
7714 {
7715 /* Allocatable scalar components. */
7716 if (comp == NULL_TREE)
7717 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7718 decl, cdecl, NULL_TREE);
7719
7720 tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
7721 c->ts);
7722 gfc_add_expr_to_block (&tmpblock, tmp);
7723 called_dealloc_with_status = true;
7724
7725 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7726 void_type_node, comp,
7727 build_int_cst (TREE_TYPE (comp), 0));
7728 gfc_add_expr_to_block (&tmpblock, tmp);
7729 }
7730 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
7731 && (!CLASS_DATA (c)->attr.codimension
7732 || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
7733 {
7734 /* Allocatable CLASS components. */
7735
7736 /* Add reference to '_data' component. */
7737 tmp = CLASS_DATA (c)->backend_decl;
7738 comp = fold_build3_loc (input_location, COMPONENT_REF,
7739 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7740
7741 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
7742 tmp = gfc_trans_dealloc_allocated (comp,
7743 CLASS_DATA (c)->attr.codimension, NULL);
7744 else
7745 {
7746 tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
7747 CLASS_DATA (c)->ts);
7748 gfc_add_expr_to_block (&tmpblock, tmp);
7749 called_dealloc_with_status = true;
7750
7751 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7752 void_type_node, comp,
7753 build_int_cst (TREE_TYPE (comp), 0));
7754 }
7755 gfc_add_expr_to_block (&tmpblock, tmp);
7756 }
7757
7758 if (cmp_has_alloc_comps
7759 && !c->attr.pointer
7760 && !called_dealloc_with_status)
7761 {
7762 /* Do not deallocate the components of ultimate pointer
7763 components or iteratively call self if call has been made
7764 to gfc_trans_dealloc_allocated */
7765 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7766 decl, cdecl, NULL_TREE);
7767 rank = c->as ? c->as->rank : 0;
7768 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7769 rank, purpose);
7770 gfc_add_expr_to_block (&fnblock, tmp);
7771 }
7772
7773 /* Now add the deallocation of this component. */
7774 gfc_add_block_to_block (&fnblock, &tmpblock);
7775 break;
7776
7777 case NULLIFY_ALLOC_COMP:
7778 if (c->attr.pointer)
7779 continue;
7780 else if (c->attr.allocatable
7781 && (c->attr.dimension|| c->attr.codimension))
7782 {
7783 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7784 decl, cdecl, NULL_TREE);
7785 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7786 }
7787 else if (c->attr.allocatable)
7788 {
7789 /* Allocatable scalar components. */
7790 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7791 decl, cdecl, NULL_TREE);
7792 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7793 void_type_node, comp,
7794 build_int_cst (TREE_TYPE (comp), 0));
7795 gfc_add_expr_to_block (&fnblock, tmp);
7796 if (gfc_deferred_strlen (c, &comp))
7797 {
7798 comp = fold_build3_loc (input_location, COMPONENT_REF,
7799 TREE_TYPE (comp),
7800 decl, comp, NULL_TREE);
7801 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7802 TREE_TYPE (comp), comp,
7803 build_int_cst (TREE_TYPE (comp), 0));
7804 gfc_add_expr_to_block (&fnblock, tmp);
7805 }
7806 }
7807 else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7808 {
7809 /* Allocatable CLASS components. */
7810 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7811 decl, cdecl, NULL_TREE);
7812 /* Add reference to '_data' component. */
7813 tmp = CLASS_DATA (c)->backend_decl;
7814 comp = fold_build3_loc (input_location, COMPONENT_REF,
7815 TREE_TYPE (tmp), comp, tmp, NULL_TREE);
7816 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
7817 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
7818 else
7819 {
7820 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7821 void_type_node, comp,
7822 build_int_cst (TREE_TYPE (comp), 0));
7823 gfc_add_expr_to_block (&fnblock, tmp);
7824 }
7825 }
7826 else if (cmp_has_alloc_comps)
7827 {
7828 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
7829 decl, cdecl, NULL_TREE);
7830 rank = c->as ? c->as->rank : 0;
7831 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
7832 rank, purpose);
7833 gfc_add_expr_to_block (&fnblock, tmp);
7834 }
7835 break;
7836
7837 case COPY_ALLOC_COMP_CAF:
7838 if (!c->attr.codimension
7839 && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp)
7840 && (c->ts.type != BT_DERIVED
7841 || !c->ts.u.derived->attr.coarray_comp))
7842 continue;
7843
7844 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7845 cdecl, NULL_TREE);
7846 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7847 cdecl, NULL_TREE);
7848
7849 if (c->attr.codimension)
7850 {
7851 if (c->ts.type == BT_CLASS)
7852 {
7853 comp = gfc_class_data_get (comp);
7854 dcmp = gfc_class_data_get (dcmp);
7855 }
7856 gfc_conv_descriptor_data_set (&fnblock, dcmp,
7857 gfc_conv_descriptor_data_get (comp));
7858 }
7859 else
7860 {
7861 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7862 rank, purpose);
7863 gfc_add_expr_to_block (&fnblock, tmp);
7864
7865 }
7866 break;
7867
7868 case COPY_ALLOC_COMP:
7869 if (c->attr.pointer)
7870 continue;
7871
7872 /* We need source and destination components. */
7873 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
7874 cdecl, NULL_TREE);
7875 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
7876 cdecl, NULL_TREE);
7877 dcmp = fold_convert (TREE_TYPE (comp), dcmp);
7878
7879 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
7880 {
7881 tree ftn_tree;
7882 tree size;
7883 tree dst_data;
7884 tree src_data;
7885 tree null_data;
7886
7887 dst_data = gfc_class_data_get (dcmp);
7888 src_data = gfc_class_data_get (comp);
7889 size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
7890
7891 if (CLASS_DATA (c)->attr.dimension)
7892 {
7893 nelems = gfc_conv_descriptor_size (src_data,
7894 CLASS_DATA (c)->as->rank);
7895 size = fold_build2_loc (input_location, MULT_EXPR,
7896 size_type_node, size,
7897 fold_convert (size_type_node,
7898 nelems));
7899 }
7900 else
7901 nelems = build_int_cst (size_type_node, 1);
7902
7903 if (CLASS_DATA (c)->attr.dimension
7904 || CLASS_DATA (c)->attr.codimension)
7905 {
7906 src_data = gfc_conv_descriptor_data_get (src_data);
7907 dst_data = gfc_conv_descriptor_data_get (dst_data);
7908 }
7909
7910 gfc_init_block (&tmpblock);
7911
7912 /* Coarray component have to have the same allocation status and
7913 shape/type-parameter/effective-type on the LHS and RHS of an
7914 intrinsic assignment. Hence, we did not deallocated them - and
7915 do not allocate them here. */
7916 if (!CLASS_DATA (c)->attr.codimension)
7917 {
7918 ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
7919 tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
7920 gfc_add_modify (&tmpblock, dst_data,
7921 fold_convert (TREE_TYPE (dst_data), tmp));
7922 }
7923
7924 tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
7925 gfc_add_expr_to_block (&tmpblock, tmp);
7926 tmp = gfc_finish_block (&tmpblock);
7927
7928 gfc_init_block (&tmpblock);
7929 gfc_add_modify (&tmpblock, dst_data,
7930 fold_convert (TREE_TYPE (dst_data),
7931 null_pointer_node));
7932 null_data = gfc_finish_block (&tmpblock);
7933
7934 null_cond = fold_build2_loc (input_location, NE_EXPR,
7935 boolean_type_node, src_data,
7936 null_pointer_node);
7937
7938 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
7939 tmp, null_data));
7940 continue;
7941 }
7942
7943 if (gfc_deferred_strlen (c, &tmp))
7944 {
7945 tree len, size;
7946 len = tmp;
7947 tmp = fold_build3_loc (input_location, COMPONENT_REF,
7948 TREE_TYPE (len),
7949 decl, len, NULL_TREE);
7950 len = fold_build3_loc (input_location, COMPONENT_REF,
7951 TREE_TYPE (len),
7952 dest, len, NULL_TREE);
7953 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7954 TREE_TYPE (len), len, tmp);
7955 gfc_add_expr_to_block (&fnblock, tmp);
7956 size = size_of_string_in_bytes (c->ts.kind, len);
7957 tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
7958 false, false, size);
7959 gfc_add_expr_to_block (&fnblock, tmp);
7960 }
7961 else if (c->attr.allocatable && !c->attr.proc_pointer
7962 && !cmp_has_alloc_comps)
7963 {
7964 rank = c->as ? c->as->rank : 0;
7965 if (c->attr.codimension)
7966 tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
7967 else
7968 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
7969 gfc_add_expr_to_block (&fnblock, tmp);
7970 }
7971
7972 if (cmp_has_alloc_comps)
7973 {
7974 rank = c->as ? c->as->rank : 0;
7975 tmp = fold_convert (TREE_TYPE (dcmp), comp);
7976 gfc_add_modify (&fnblock, dcmp, tmp);
7977 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
7978 rank, purpose);
7979 gfc_add_expr_to_block (&fnblock, tmp);
7980 }
7981 break;
7982
7983 default:
7984 gcc_unreachable ();
7985 break;
7986 }
7987 }
7988
7989 return gfc_finish_block (&fnblock);
7990 }
7991
7992 /* Recursively traverse an object of derived type, generating code to
7993 nullify allocatable components. */
7994
7995 tree
gfc_nullify_alloc_comp(gfc_symbol * der_type,tree decl,int rank)7996 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
7997 {
7998 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
7999 NULLIFY_ALLOC_COMP);
8000 }
8001
8002
8003 /* Recursively traverse an object of derived type, generating code to
8004 deallocate allocatable components. */
8005
8006 tree
gfc_deallocate_alloc_comp(gfc_symbol * der_type,tree decl,int rank)8007 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
8008 {
8009 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8010 DEALLOCATE_ALLOC_COMP);
8011 }
8012
8013
8014 /* Recursively traverse an object of derived type, generating code to
8015 deallocate allocatable components. But do not deallocate coarrays.
8016 To be used for intrinsic assignment, which may not change the allocation
8017 status of coarrays. */
8018
8019 tree
gfc_deallocate_alloc_comp_no_caf(gfc_symbol * der_type,tree decl,int rank)8020 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
8021 {
8022 return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8023 DEALLOCATE_ALLOC_COMP_NO_CAF);
8024 }
8025
8026
8027 tree
gfc_reassign_alloc_comp_caf(gfc_symbol * der_type,tree decl,tree dest)8028 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
8029 {
8030 return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF);
8031 }
8032
8033
8034 /* Recursively traverse an object of derived type, generating code to
8035 copy it and its allocatable components. */
8036
8037 tree
gfc_copy_alloc_comp(gfc_symbol * der_type,tree decl,tree dest,int rank)8038 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
8039 {
8040 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
8041 }
8042
8043
8044 /* Recursively traverse an object of derived type, generating code to
8045 copy only its allocatable components. */
8046
8047 tree
gfc_copy_only_alloc_comp(gfc_symbol * der_type,tree decl,tree dest,int rank)8048 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
8049 {
8050 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
8051 }
8052
8053
8054 /* Returns the value of LBOUND for an expression. This could be broken out
8055 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
8056 called by gfc_alloc_allocatable_for_assignment. */
8057 static tree
get_std_lbound(gfc_expr * expr,tree desc,int dim,bool assumed_size)8058 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
8059 {
8060 tree lbound;
8061 tree ubound;
8062 tree stride;
8063 tree cond, cond1, cond3, cond4;
8064 tree tmp;
8065 gfc_ref *ref;
8066
8067 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8068 {
8069 tmp = gfc_rank_cst[dim];
8070 lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
8071 ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
8072 stride = gfc_conv_descriptor_stride_get (desc, tmp);
8073 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
8074 ubound, lbound);
8075 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
8076 stride, gfc_index_zero_node);
8077 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8078 boolean_type_node, cond3, cond1);
8079 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8080 stride, gfc_index_zero_node);
8081 if (assumed_size)
8082 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8083 tmp, build_int_cst (gfc_array_index_type,
8084 expr->rank - 1));
8085 else
8086 cond = boolean_false_node;
8087
8088 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8089 boolean_type_node, cond3, cond4);
8090 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8091 boolean_type_node, cond, cond1);
8092
8093 return fold_build3_loc (input_location, COND_EXPR,
8094 gfc_array_index_type, cond,
8095 lbound, gfc_index_one_node);
8096 }
8097
8098 if (expr->expr_type == EXPR_FUNCTION)
8099 {
8100 /* A conversion function, so use the argument. */
8101 gcc_assert (expr->value.function.isym
8102 && expr->value.function.isym->conversion);
8103 expr = expr->value.function.actual->expr;
8104 }
8105
8106 if (expr->expr_type == EXPR_VARIABLE)
8107 {
8108 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
8109 for (ref = expr->ref; ref; ref = ref->next)
8110 {
8111 if (ref->type == REF_COMPONENT
8112 && ref->u.c.component->as
8113 && ref->next
8114 && ref->next->u.ar.type == AR_FULL)
8115 tmp = TREE_TYPE (ref->u.c.component->backend_decl);
8116 }
8117 return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
8118 }
8119
8120 return gfc_index_one_node;
8121 }
8122
8123
8124 /* Returns true if an expression represents an lhs that can be reallocated
8125 on assignment. */
8126
8127 bool
gfc_is_reallocatable_lhs(gfc_expr * expr)8128 gfc_is_reallocatable_lhs (gfc_expr *expr)
8129 {
8130 gfc_ref * ref;
8131
8132 if (!expr->ref)
8133 return false;
8134
8135 /* An allocatable variable. */
8136 if (expr->symtree->n.sym->attr.allocatable
8137 && expr->ref
8138 && expr->ref->type == REF_ARRAY
8139 && expr->ref->u.ar.type == AR_FULL)
8140 return true;
8141
8142 /* All that can be left are allocatable components. */
8143 if ((expr->symtree->n.sym->ts.type != BT_DERIVED
8144 && expr->symtree->n.sym->ts.type != BT_CLASS)
8145 || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
8146 return false;
8147
8148 /* Find a component ref followed by an array reference. */
8149 for (ref = expr->ref; ref; ref = ref->next)
8150 if (ref->next
8151 && ref->type == REF_COMPONENT
8152 && ref->next->type == REF_ARRAY
8153 && !ref->next->next)
8154 break;
8155
8156 if (!ref)
8157 return false;
8158
8159 /* Return true if valid reallocatable lhs. */
8160 if (ref->u.c.component->attr.allocatable
8161 && ref->next->u.ar.type == AR_FULL)
8162 return true;
8163
8164 return false;
8165 }
8166
8167
8168 /* Allocate the lhs of an assignment to an allocatable array, otherwise
8169 reallocate it. */
8170
8171 tree
gfc_alloc_allocatable_for_assignment(gfc_loopinfo * loop,gfc_expr * expr1,gfc_expr * expr2)8172 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
8173 gfc_expr *expr1,
8174 gfc_expr *expr2)
8175 {
8176 stmtblock_t realloc_block;
8177 stmtblock_t alloc_block;
8178 stmtblock_t fblock;
8179 gfc_ss *rss;
8180 gfc_ss *lss;
8181 gfc_array_info *linfo;
8182 tree realloc_expr;
8183 tree alloc_expr;
8184 tree size1;
8185 tree size2;
8186 tree array1;
8187 tree cond_null;
8188 tree cond;
8189 tree tmp;
8190 tree tmp2;
8191 tree lbound;
8192 tree ubound;
8193 tree desc;
8194 tree old_desc;
8195 tree desc2;
8196 tree offset;
8197 tree jump_label1;
8198 tree jump_label2;
8199 tree neq_size;
8200 tree lbd;
8201 int n;
8202 int dim;
8203 gfc_array_spec * as;
8204
8205 /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
8206 Find the lhs expression in the loop chain and set expr1 and
8207 expr2 accordingly. */
8208 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
8209 {
8210 expr2 = expr1;
8211 /* Find the ss for the lhs. */
8212 lss = loop->ss;
8213 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
8214 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
8215 break;
8216 if (lss == gfc_ss_terminator)
8217 return NULL_TREE;
8218 expr1 = lss->info->expr;
8219 }
8220
8221 /* Bail out if this is not a valid allocate on assignment. */
8222 if (!gfc_is_reallocatable_lhs (expr1)
8223 || (expr2 && !expr2->rank))
8224 return NULL_TREE;
8225
8226 /* Find the ss for the lhs. */
8227 lss = loop->ss;
8228 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
8229 if (lss->info->expr == expr1)
8230 break;
8231
8232 if (lss == gfc_ss_terminator)
8233 return NULL_TREE;
8234
8235 linfo = &lss->info->data.array;
8236
8237 /* Find an ss for the rhs. For operator expressions, we see the
8238 ss's for the operands. Any one of these will do. */
8239 rss = loop->ss;
8240 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
8241 if (rss->info->expr != expr1 && rss != loop->temp_ss)
8242 break;
8243
8244 if (expr2 && rss == gfc_ss_terminator)
8245 return NULL_TREE;
8246
8247 gfc_start_block (&fblock);
8248
8249 /* Since the lhs is allocatable, this must be a descriptor type.
8250 Get the data and array size. */
8251 desc = linfo->descriptor;
8252 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8253 array1 = gfc_conv_descriptor_data_get (desc);
8254
8255 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
8256 deallocated if expr is an array of different shape or any of the
8257 corresponding length type parameter values of variable and expr
8258 differ." This assures F95 compatibility. */
8259 jump_label1 = gfc_build_label_decl (NULL_TREE);
8260 jump_label2 = gfc_build_label_decl (NULL_TREE);
8261
8262 /* Allocate if data is NULL. */
8263 cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8264 array1, build_int_cst (TREE_TYPE (array1), 0));
8265 tmp = build3_v (COND_EXPR, cond_null,
8266 build1_v (GOTO_EXPR, jump_label1),
8267 build_empty_stmt (input_location));
8268 gfc_add_expr_to_block (&fblock, tmp);
8269
8270 /* Get arrayspec if expr is a full array. */
8271 if (expr2 && expr2->expr_type == EXPR_FUNCTION
8272 && expr2->value.function.isym
8273 && expr2->value.function.isym->conversion)
8274 {
8275 /* For conversion functions, take the arg. */
8276 gfc_expr *arg = expr2->value.function.actual->expr;
8277 as = gfc_get_full_arrayspec_from_expr (arg);
8278 }
8279 else if (expr2)
8280 as = gfc_get_full_arrayspec_from_expr (expr2);
8281 else
8282 as = NULL;
8283
8284 /* If the lhs shape is not the same as the rhs jump to setting the
8285 bounds and doing the reallocation....... */
8286 for (n = 0; n < expr1->rank; n++)
8287 {
8288 /* Check the shape. */
8289 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
8290 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
8291 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8292 gfc_array_index_type,
8293 loop->to[n], loop->from[n]);
8294 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8295 gfc_array_index_type,
8296 tmp, lbound);
8297 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8298 gfc_array_index_type,
8299 tmp, ubound);
8300 cond = fold_build2_loc (input_location, NE_EXPR,
8301 boolean_type_node,
8302 tmp, gfc_index_zero_node);
8303 tmp = build3_v (COND_EXPR, cond,
8304 build1_v (GOTO_EXPR, jump_label1),
8305 build_empty_stmt (input_location));
8306 gfc_add_expr_to_block (&fblock, tmp);
8307 }
8308
8309 /* ....else jump past the (re)alloc code. */
8310 tmp = build1_v (GOTO_EXPR, jump_label2);
8311 gfc_add_expr_to_block (&fblock, tmp);
8312
8313 /* Add the label to start automatic (re)allocation. */
8314 tmp = build1_v (LABEL_EXPR, jump_label1);
8315 gfc_add_expr_to_block (&fblock, tmp);
8316
8317 /* If the lhs has not been allocated, its bounds will not have been
8318 initialized and so its size is set to zero. */
8319 size1 = gfc_create_var (gfc_array_index_type, NULL);
8320 gfc_init_block (&alloc_block);
8321 gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
8322 gfc_init_block (&realloc_block);
8323 gfc_add_modify (&realloc_block, size1,
8324 gfc_conv_descriptor_size (desc, expr1->rank));
8325 tmp = build3_v (COND_EXPR, cond_null,
8326 gfc_finish_block (&alloc_block),
8327 gfc_finish_block (&realloc_block));
8328 gfc_add_expr_to_block (&fblock, tmp);
8329
8330 /* Get the rhs size and fix it. */
8331 if (expr2)
8332 desc2 = rss->info->data.array.descriptor;
8333 else
8334 desc2 = NULL_TREE;
8335
8336 size2 = gfc_index_one_node;
8337 for (n = 0; n < expr2->rank; n++)
8338 {
8339 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8340 gfc_array_index_type,
8341 loop->to[n], loop->from[n]);
8342 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8343 gfc_array_index_type,
8344 tmp, gfc_index_one_node);
8345 size2 = fold_build2_loc (input_location, MULT_EXPR,
8346 gfc_array_index_type,
8347 tmp, size2);
8348 }
8349 size2 = gfc_evaluate_now (size2, &fblock);
8350
8351 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8352 size1, size2);
8353 neq_size = gfc_evaluate_now (cond, &fblock);
8354
8355 /* Deallocation of allocatable components will have to occur on
8356 reallocation. Fix the old descriptor now. */
8357 if ((expr1->ts.type == BT_DERIVED)
8358 && expr1->ts.u.derived->attr.alloc_comp)
8359 old_desc = gfc_evaluate_now (desc, &fblock);
8360 else
8361 old_desc = NULL_TREE;
8362
8363 /* Now modify the lhs descriptor and the associated scalarizer
8364 variables. F2003 7.4.1.3: "If variable is or becomes an
8365 unallocated allocatable variable, then it is allocated with each
8366 deferred type parameter equal to the corresponding type parameters
8367 of expr , with the shape of expr , and with each lower bound equal
8368 to the corresponding element of LBOUND(expr)."
8369 Reuse size1 to keep a dimension-by-dimension track of the
8370 stride of the new array. */
8371 size1 = gfc_index_one_node;
8372 offset = gfc_index_zero_node;
8373
8374 for (n = 0; n < expr2->rank; n++)
8375 {
8376 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8377 gfc_array_index_type,
8378 loop->to[n], loop->from[n]);
8379 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8380 gfc_array_index_type,
8381 tmp, gfc_index_one_node);
8382
8383 lbound = gfc_index_one_node;
8384 ubound = tmp;
8385
8386 if (as)
8387 {
8388 lbd = get_std_lbound (expr2, desc2, n,
8389 as->type == AS_ASSUMED_SIZE);
8390 ubound = fold_build2_loc (input_location,
8391 MINUS_EXPR,
8392 gfc_array_index_type,
8393 ubound, lbound);
8394 ubound = fold_build2_loc (input_location,
8395 PLUS_EXPR,
8396 gfc_array_index_type,
8397 ubound, lbd);
8398 lbound = lbd;
8399 }
8400
8401 gfc_conv_descriptor_lbound_set (&fblock, desc,
8402 gfc_rank_cst[n],
8403 lbound);
8404 gfc_conv_descriptor_ubound_set (&fblock, desc,
8405 gfc_rank_cst[n],
8406 ubound);
8407 gfc_conv_descriptor_stride_set (&fblock, desc,
8408 gfc_rank_cst[n],
8409 size1);
8410 lbound = gfc_conv_descriptor_lbound_get (desc,
8411 gfc_rank_cst[n]);
8412 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
8413 gfc_array_index_type,
8414 lbound, size1);
8415 offset = fold_build2_loc (input_location, MINUS_EXPR,
8416 gfc_array_index_type,
8417 offset, tmp2);
8418 size1 = fold_build2_loc (input_location, MULT_EXPR,
8419 gfc_array_index_type,
8420 tmp, size1);
8421 }
8422
8423 /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
8424 the array offset is saved and the info.offset is used for a
8425 running offset. Use the saved_offset instead. */
8426 tmp = gfc_conv_descriptor_offset (desc);
8427 gfc_add_modify (&fblock, tmp, offset);
8428 if (linfo->saved_offset
8429 && TREE_CODE (linfo->saved_offset) == VAR_DECL)
8430 gfc_add_modify (&fblock, linfo->saved_offset, tmp);
8431
8432 /* Now set the deltas for the lhs. */
8433 for (n = 0; n < expr1->rank; n++)
8434 {
8435 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
8436 dim = lss->dim[n];
8437 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8438 gfc_array_index_type, tmp,
8439 loop->from[dim]);
8440 if (linfo->delta[dim]
8441 && TREE_CODE (linfo->delta[dim]) == VAR_DECL)
8442 gfc_add_modify (&fblock, linfo->delta[dim], tmp);
8443 }
8444
8445 /* Get the new lhs size in bytes. */
8446 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
8447 {
8448 if (expr2->ts.deferred)
8449 {
8450 if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL)
8451 tmp = expr2->ts.u.cl->backend_decl;
8452 else
8453 tmp = rss->info->string_length;
8454 }
8455 else
8456 {
8457 tmp = expr2->ts.u.cl->backend_decl;
8458 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
8459 }
8460
8461 if (expr1->ts.u.cl->backend_decl
8462 && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
8463 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
8464 else
8465 gfc_add_modify (&fblock, lss->info->string_length, tmp);
8466 }
8467 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
8468 {
8469 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
8470 tmp = fold_build2_loc (input_location, MULT_EXPR,
8471 gfc_array_index_type, tmp,
8472 expr1->ts.u.cl->backend_decl);
8473 }
8474 else
8475 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
8476 tmp = fold_convert (gfc_array_index_type, tmp);
8477 size2 = fold_build2_loc (input_location, MULT_EXPR,
8478 gfc_array_index_type,
8479 tmp, size2);
8480 size2 = fold_convert (size_type_node, size2);
8481 size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
8482 size2, size_one_node);
8483 size2 = gfc_evaluate_now (size2, &fblock);
8484
8485 /* Realloc expression. Note that the scalarizer uses desc.data
8486 in the array reference - (*desc.data)[<element>]. */
8487 gfc_init_block (&realloc_block);
8488
8489 if ((expr1->ts.type == BT_DERIVED)
8490 && expr1->ts.u.derived->attr.alloc_comp)
8491 {
8492 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
8493 expr1->rank);
8494 gfc_add_expr_to_block (&realloc_block, tmp);
8495 }
8496
8497 tmp = build_call_expr_loc (input_location,
8498 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
8499 fold_convert (pvoid_type_node, array1),
8500 size2);
8501 gfc_conv_descriptor_data_set (&realloc_block,
8502 desc, tmp);
8503
8504 if ((expr1->ts.type == BT_DERIVED)
8505 && expr1->ts.u.derived->attr.alloc_comp)
8506 {
8507 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
8508 expr1->rank);
8509 gfc_add_expr_to_block (&realloc_block, tmp);
8510 }
8511
8512 realloc_expr = gfc_finish_block (&realloc_block);
8513
8514 /* Only reallocate if sizes are different. */
8515 tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
8516 build_empty_stmt (input_location));
8517 realloc_expr = tmp;
8518
8519
8520 /* Malloc expression. */
8521 gfc_init_block (&alloc_block);
8522 tmp = build_call_expr_loc (input_location,
8523 builtin_decl_explicit (BUILT_IN_MALLOC),
8524 1, size2);
8525 gfc_conv_descriptor_data_set (&alloc_block,
8526 desc, tmp);
8527 tmp = gfc_conv_descriptor_dtype (desc);
8528 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
8529 if ((expr1->ts.type == BT_DERIVED)
8530 && expr1->ts.u.derived->attr.alloc_comp)
8531 {
8532 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
8533 expr1->rank);
8534 gfc_add_expr_to_block (&alloc_block, tmp);
8535 }
8536 alloc_expr = gfc_finish_block (&alloc_block);
8537
8538 /* Malloc if not allocated; realloc otherwise. */
8539 tmp = build_int_cst (TREE_TYPE (array1), 0);
8540 cond = fold_build2_loc (input_location, EQ_EXPR,
8541 boolean_type_node,
8542 array1, tmp);
8543 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
8544 gfc_add_expr_to_block (&fblock, tmp);
8545
8546 /* Make sure that the scalarizer data pointer is updated. */
8547 if (linfo->data
8548 && TREE_CODE (linfo->data) == VAR_DECL)
8549 {
8550 tmp = gfc_conv_descriptor_data_get (desc);
8551 gfc_add_modify (&fblock, linfo->data, tmp);
8552 }
8553
8554 /* Add the exit label. */
8555 tmp = build1_v (LABEL_EXPR, jump_label2);
8556 gfc_add_expr_to_block (&fblock, tmp);
8557
8558 return gfc_finish_block (&fblock);
8559 }
8560
8561
8562 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
8563 Do likewise, recursively if necessary, with the allocatable components of
8564 derived types. */
8565
8566 void
gfc_trans_deferred_array(gfc_symbol * sym,gfc_wrapped_block * block)8567 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
8568 {
8569 tree type;
8570 tree tmp;
8571 tree descriptor;
8572 stmtblock_t init;
8573 stmtblock_t cleanup;
8574 locus loc;
8575 int rank;
8576 bool sym_has_alloc_comp, has_finalizer;
8577
8578 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
8579 || sym->ts.type == BT_CLASS)
8580 && sym->ts.u.derived->attr.alloc_comp;
8581 has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
8582 ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
8583
8584 /* Make sure the frontend gets these right. */
8585 gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
8586 || has_finalizer);
8587
8588 gfc_save_backend_locus (&loc);
8589 gfc_set_backend_locus (&sym->declared_at);
8590 gfc_init_block (&init);
8591
8592 gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
8593 || TREE_CODE (sym->backend_decl) == PARM_DECL);
8594
8595 if (sym->ts.type == BT_CHARACTER
8596 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
8597 {
8598 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
8599 gfc_trans_vla_type_sizes (sym, &init);
8600 }
8601
8602 /* Dummy, use associated and result variables don't need anything special. */
8603 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
8604 {
8605 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8606 gfc_restore_backend_locus (&loc);
8607 return;
8608 }
8609
8610 descriptor = sym->backend_decl;
8611
8612 /* Although static, derived types with default initializers and
8613 allocatable components must not be nulled wholesale; instead they
8614 are treated component by component. */
8615 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
8616 {
8617 /* SAVEd variables are not freed on exit. */
8618 gfc_trans_static_array_pointer (sym);
8619
8620 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
8621 gfc_restore_backend_locus (&loc);
8622 return;
8623 }
8624
8625 /* Get the descriptor type. */
8626 type = TREE_TYPE (sym->backend_decl);
8627
8628 if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
8629 && !(sym->attr.pointer || sym->attr.allocatable))
8630 {
8631 if (!sym->attr.save
8632 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
8633 {
8634 if (sym->value == NULL
8635 || !gfc_has_default_initializer (sym->ts.u.derived))
8636 {
8637 rank = sym->as ? sym->as->rank : 0;
8638 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived,
8639 descriptor, rank);
8640 gfc_add_expr_to_block (&init, tmp);
8641 }
8642 else
8643 gfc_init_default_dt (sym, &init, false);
8644 }
8645 }
8646 else if (!GFC_DESCRIPTOR_TYPE_P (type))
8647 {
8648 /* If the backend_decl is not a descriptor, we must have a pointer
8649 to one. */
8650 descriptor = build_fold_indirect_ref_loc (input_location,
8651 sym->backend_decl);
8652 type = TREE_TYPE (descriptor);
8653 }
8654
8655 /* NULLIFY the data pointer. */
8656 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
8657 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
8658
8659 gfc_restore_backend_locus (&loc);
8660 gfc_init_block (&cleanup);
8661
8662 /* Allocatable arrays need to be freed when they go out of scope.
8663 The allocatable components of pointers must not be touched. */
8664 if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
8665 && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
8666 && !sym->ns->proc_name->attr.is_main_program)
8667 {
8668 gfc_expr *e;
8669 sym->attr.referenced = 1;
8670 e = gfc_lval_expr_from_sym (sym);
8671 gfc_add_finalizer_call (&cleanup, e);
8672 gfc_free_expr (e);
8673 }
8674 else if ((!sym->attr.allocatable || !has_finalizer)
8675 && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
8676 && !sym->attr.pointer && !sym->attr.save
8677 && !sym->ns->proc_name->attr.is_main_program)
8678 {
8679 int rank;
8680 rank = sym->as ? sym->as->rank : 0;
8681 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
8682 gfc_add_expr_to_block (&cleanup, tmp);
8683 }
8684
8685 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
8686 && !sym->attr.save && !sym->attr.result
8687 && !sym->ns->proc_name->attr.is_main_program)
8688 {
8689 gfc_expr *e;
8690 e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
8691 tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
8692 sym->attr.codimension, e);
8693 if (e)
8694 gfc_free_expr (e);
8695 gfc_add_expr_to_block (&cleanup, tmp);
8696 }
8697
8698 gfc_add_init_cleanup (block, gfc_finish_block (&init),
8699 gfc_finish_block (&cleanup));
8700 }
8701
8702 /************ Expression Walking Functions ******************/
8703
8704 /* Walk a variable reference.
8705
8706 Possible extension - multiple component subscripts.
8707 x(:,:) = foo%a(:)%b(:)
8708 Transforms to
8709 forall (i=..., j=...)
8710 x(i,j) = foo%a(j)%b(i)
8711 end forall
8712 This adds a fair amount of complexity because you need to deal with more
8713 than one ref. Maybe handle in a similar manner to vector subscripts.
8714 Maybe not worth the effort. */
8715
8716
8717 static gfc_ss *
gfc_walk_variable_expr(gfc_ss * ss,gfc_expr * expr)8718 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
8719 {
8720 gfc_ref *ref;
8721
8722 for (ref = expr->ref; ref; ref = ref->next)
8723 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
8724 break;
8725
8726 return gfc_walk_array_ref (ss, expr, ref);
8727 }
8728
8729
8730 gfc_ss *
gfc_walk_array_ref(gfc_ss * ss,gfc_expr * expr,gfc_ref * ref)8731 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
8732 {
8733 gfc_array_ref *ar;
8734 gfc_ss *newss;
8735 int n;
8736
8737 for (; ref; ref = ref->next)
8738 {
8739 if (ref->type == REF_SUBSTRING)
8740 {
8741 ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
8742 ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
8743 }
8744
8745 /* We're only interested in array sections from now on. */
8746 if (ref->type != REF_ARRAY)
8747 continue;
8748
8749 ar = &ref->u.ar;
8750
8751 switch (ar->type)
8752 {
8753 case AR_ELEMENT:
8754 for (n = ar->dimen - 1; n >= 0; n--)
8755 ss = gfc_get_scalar_ss (ss, ar->start[n]);
8756 break;
8757
8758 case AR_FULL:
8759 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
8760 newss->info->data.array.ref = ref;
8761
8762 /* Make sure array is the same as array(:,:), this way
8763 we don't need to special case all the time. */
8764 ar->dimen = ar->as->rank;
8765 for (n = 0; n < ar->dimen; n++)
8766 {
8767 ar->dimen_type[n] = DIMEN_RANGE;
8768
8769 gcc_assert (ar->start[n] == NULL);
8770 gcc_assert (ar->end[n] == NULL);
8771 gcc_assert (ar->stride[n] == NULL);
8772 }
8773 ss = newss;
8774 break;
8775
8776 case AR_SECTION:
8777 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
8778 newss->info->data.array.ref = ref;
8779
8780 /* We add SS chains for all the subscripts in the section. */
8781 for (n = 0; n < ar->dimen; n++)
8782 {
8783 gfc_ss *indexss;
8784
8785 switch (ar->dimen_type[n])
8786 {
8787 case DIMEN_ELEMENT:
8788 /* Add SS for elemental (scalar) subscripts. */
8789 gcc_assert (ar->start[n]);
8790 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
8791 indexss->loop_chain = gfc_ss_terminator;
8792 newss->info->data.array.subscript[n] = indexss;
8793 break;
8794
8795 case DIMEN_RANGE:
8796 /* We don't add anything for sections, just remember this
8797 dimension for later. */
8798 newss->dim[newss->dimen] = n;
8799 newss->dimen++;
8800 break;
8801
8802 case DIMEN_VECTOR:
8803 /* Create a GFC_SS_VECTOR index in which we can store
8804 the vector's descriptor. */
8805 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
8806 1, GFC_SS_VECTOR);
8807 indexss->loop_chain = gfc_ss_terminator;
8808 newss->info->data.array.subscript[n] = indexss;
8809 newss->dim[newss->dimen] = n;
8810 newss->dimen++;
8811 break;
8812
8813 default:
8814 /* We should know what sort of section it is by now. */
8815 gcc_unreachable ();
8816 }
8817 }
8818 /* We should have at least one non-elemental dimension,
8819 unless we are creating a descriptor for a (scalar) coarray. */
8820 gcc_assert (newss->dimen > 0
8821 || newss->info->data.array.ref->u.ar.as->corank > 0);
8822 ss = newss;
8823 break;
8824
8825 default:
8826 /* We should know what sort of section it is by now. */
8827 gcc_unreachable ();
8828 }
8829
8830 }
8831 return ss;
8832 }
8833
8834
8835 /* Walk an expression operator. If only one operand of a binary expression is
8836 scalar, we must also add the scalar term to the SS chain. */
8837
8838 static gfc_ss *
gfc_walk_op_expr(gfc_ss * ss,gfc_expr * expr)8839 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
8840 {
8841 gfc_ss *head;
8842 gfc_ss *head2;
8843
8844 head = gfc_walk_subexpr (ss, expr->value.op.op1);
8845 if (expr->value.op.op2 == NULL)
8846 head2 = head;
8847 else
8848 head2 = gfc_walk_subexpr (head, expr->value.op.op2);
8849
8850 /* All operands are scalar. Pass back and let the caller deal with it. */
8851 if (head2 == ss)
8852 return head2;
8853
8854 /* All operands require scalarization. */
8855 if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
8856 return head2;
8857
8858 /* One of the operands needs scalarization, the other is scalar.
8859 Create a gfc_ss for the scalar expression. */
8860 if (head == ss)
8861 {
8862 /* First operand is scalar. We build the chain in reverse order, so
8863 add the scalar SS after the second operand. */
8864 head = head2;
8865 while (head && head->next != ss)
8866 head = head->next;
8867 /* Check we haven't somehow broken the chain. */
8868 gcc_assert (head);
8869 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
8870 }
8871 else /* head2 == head */
8872 {
8873 gcc_assert (head2 == head);
8874 /* Second operand is scalar. */
8875 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
8876 }
8877
8878 return head2;
8879 }
8880
8881
8882 /* Reverse a SS chain. */
8883
8884 gfc_ss *
gfc_reverse_ss(gfc_ss * ss)8885 gfc_reverse_ss (gfc_ss * ss)
8886 {
8887 gfc_ss *next;
8888 gfc_ss *head;
8889
8890 gcc_assert (ss != NULL);
8891
8892 head = gfc_ss_terminator;
8893 while (ss != gfc_ss_terminator)
8894 {
8895 next = ss->next;
8896 /* Check we didn't somehow break the chain. */
8897 gcc_assert (next != NULL);
8898 ss->next = head;
8899 head = ss;
8900 ss = next;
8901 }
8902
8903 return (head);
8904 }
8905
8906
8907 /* Given an expression referring to a procedure, return the symbol of its
8908 interface. We can't get the procedure symbol directly as we have to handle
8909 the case of (deferred) type-bound procedures. */
8910
8911 gfc_symbol *
gfc_get_proc_ifc_for_expr(gfc_expr * procedure_ref)8912 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
8913 {
8914 gfc_symbol *sym;
8915 gfc_ref *ref;
8916
8917 if (procedure_ref == NULL)
8918 return NULL;
8919
8920 /* Normal procedure case. */
8921 sym = procedure_ref->symtree->n.sym;
8922
8923 /* Typebound procedure case. */
8924 for (ref = procedure_ref->ref; ref; ref = ref->next)
8925 {
8926 if (ref->type == REF_COMPONENT
8927 && ref->u.c.component->attr.proc_pointer)
8928 sym = ref->u.c.component->ts.interface;
8929 else
8930 sym = NULL;
8931 }
8932
8933 return sym;
8934 }
8935
8936
8937 /* Walk the arguments of an elemental function.
8938 PROC_EXPR is used to check whether an argument is permitted to be absent. If
8939 it is NULL, we don't do the check and the argument is assumed to be present.
8940 */
8941
8942 gfc_ss *
gfc_walk_elemental_function_args(gfc_ss * ss,gfc_actual_arglist * arg,gfc_symbol * proc_ifc,gfc_ss_type type)8943 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
8944 gfc_symbol *proc_ifc, gfc_ss_type type)
8945 {
8946 gfc_formal_arglist *dummy_arg;
8947 int scalar;
8948 gfc_ss *head;
8949 gfc_ss *tail;
8950 gfc_ss *newss;
8951
8952 head = gfc_ss_terminator;
8953 tail = NULL;
8954
8955 if (proc_ifc)
8956 dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
8957 else
8958 dummy_arg = NULL;
8959
8960 scalar = 1;
8961 for (; arg; arg = arg->next)
8962 {
8963 if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
8964 continue;
8965
8966 newss = gfc_walk_subexpr (head, arg->expr);
8967 if (newss == head)
8968 {
8969 /* Scalar argument. */
8970 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
8971 newss = gfc_get_scalar_ss (head, arg->expr);
8972 newss->info->type = type;
8973
8974 }
8975 else
8976 scalar = 0;
8977
8978 if (dummy_arg != NULL
8979 && dummy_arg->sym->attr.optional
8980 && arg->expr->expr_type == EXPR_VARIABLE
8981 && (gfc_expr_attr (arg->expr).optional
8982 || gfc_expr_attr (arg->expr).allocatable
8983 || gfc_expr_attr (arg->expr).pointer))
8984 newss->info->can_be_null_ref = true;
8985
8986 head = newss;
8987 if (!tail)
8988 {
8989 tail = head;
8990 while (tail->next != gfc_ss_terminator)
8991 tail = tail->next;
8992 }
8993
8994 if (dummy_arg != NULL)
8995 dummy_arg = dummy_arg->next;
8996 }
8997
8998 if (scalar)
8999 {
9000 /* If all the arguments are scalar we don't need the argument SS. */
9001 gfc_free_ss_chain (head);
9002 /* Pass it back. */
9003 return ss;
9004 }
9005
9006 /* Add it onto the existing chain. */
9007 tail->next = ss;
9008 return head;
9009 }
9010
9011
9012 /* Walk a function call. Scalar functions are passed back, and taken out of
9013 scalarization loops. For elemental functions we walk their arguments.
9014 The result of functions returning arrays is stored in a temporary outside
9015 the loop, so that the function is only called once. Hence we do not need
9016 to walk their arguments. */
9017
9018 static gfc_ss *
gfc_walk_function_expr(gfc_ss * ss,gfc_expr * expr)9019 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
9020 {
9021 gfc_intrinsic_sym *isym;
9022 gfc_symbol *sym;
9023 gfc_component *comp = NULL;
9024
9025 isym = expr->value.function.isym;
9026
9027 /* Handle intrinsic functions separately. */
9028 if (isym)
9029 return gfc_walk_intrinsic_function (ss, expr, isym);
9030
9031 sym = expr->value.function.esym;
9032 if (!sym)
9033 sym = expr->symtree->n.sym;
9034
9035 /* A function that returns arrays. */
9036 comp = gfc_get_proc_ptr_comp (expr);
9037 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
9038 || (comp && comp->attr.dimension))
9039 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
9040
9041 /* Walk the parameters of an elemental function. For now we always pass
9042 by reference. */
9043 if (sym->attr.elemental || (comp && comp->attr.elemental))
9044 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
9045 gfc_get_proc_ifc_for_expr (expr),
9046 GFC_SS_REFERENCE);
9047
9048 /* Scalar functions are OK as these are evaluated outside the scalarization
9049 loop. Pass back and let the caller deal with it. */
9050 return ss;
9051 }
9052
9053
9054 /* An array temporary is constructed for array constructors. */
9055
9056 static gfc_ss *
gfc_walk_array_constructor(gfc_ss * ss,gfc_expr * expr)9057 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
9058 {
9059 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
9060 }
9061
9062
9063 /* Walk an expression. Add walked expressions to the head of the SS chain.
9064 A wholly scalar expression will not be added. */
9065
9066 gfc_ss *
gfc_walk_subexpr(gfc_ss * ss,gfc_expr * expr)9067 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
9068 {
9069 gfc_ss *head;
9070
9071 switch (expr->expr_type)
9072 {
9073 case EXPR_VARIABLE:
9074 head = gfc_walk_variable_expr (ss, expr);
9075 return head;
9076
9077 case EXPR_OP:
9078 head = gfc_walk_op_expr (ss, expr);
9079 return head;
9080
9081 case EXPR_FUNCTION:
9082 head = gfc_walk_function_expr (ss, expr);
9083 return head;
9084
9085 case EXPR_CONSTANT:
9086 case EXPR_NULL:
9087 case EXPR_STRUCTURE:
9088 /* Pass back and let the caller deal with it. */
9089 break;
9090
9091 case EXPR_ARRAY:
9092 head = gfc_walk_array_constructor (ss, expr);
9093 return head;
9094
9095 case EXPR_SUBSTRING:
9096 /* Pass back and let the caller deal with it. */
9097 break;
9098
9099 default:
9100 internal_error ("bad expression type during walk (%d)",
9101 expr->expr_type);
9102 }
9103 return ss;
9104 }
9105
9106
9107 /* Entry point for expression walking.
9108 A return value equal to the passed chain means this is
9109 a scalar expression. It is up to the caller to take whatever action is
9110 necessary to translate these. */
9111
9112 gfc_ss *
gfc_walk_expr(gfc_expr * expr)9113 gfc_walk_expr (gfc_expr * expr)
9114 {
9115 gfc_ss *res;
9116
9117 res = gfc_walk_subexpr (gfc_ss_terminator, expr);
9118 return gfc_reverse_ss (res);
9119 }
9120