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