]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Statement translation -- generate GCC trees from gfc_code. |
ec378180 | 2 | Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | and Steven Bosscher <s.bosscher@student.tudelft.nl> | |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
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 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b TS |
19 | along with GCC; see the file COPYING. If not, write to the Free |
20 | Software Foundation, 59 Temple Place - Suite 330, Boston, MA | |
21 | 02111-1307, USA. */ | |
6de9cd9a DN |
22 | |
23 | ||
24 | #include "config.h" | |
25 | #include "system.h" | |
26 | #include "coretypes.h" | |
27 | #include "tree.h" | |
eadf906f | 28 | #include "tree-gimple.h" |
6de9cd9a DN |
29 | #include "ggc.h" |
30 | #include "toplev.h" | |
31 | #include "real.h" | |
6de9cd9a DN |
32 | #include "gfortran.h" |
33 | #include "trans.h" | |
34 | #include "trans-stmt.h" | |
35 | #include "trans-types.h" | |
36 | #include "trans-array.h" | |
37 | #include "trans-const.h" | |
38 | #include "arith.h" | |
39 | ||
6de9cd9a DN |
40 | typedef struct iter_info |
41 | { | |
42 | tree var; | |
43 | tree start; | |
44 | tree end; | |
45 | tree step; | |
46 | struct iter_info *next; | |
47 | } | |
48 | iter_info; | |
49 | ||
50 | typedef struct temporary_list | |
51 | { | |
52 | tree temporary; | |
53 | struct temporary_list *next; | |
54 | } | |
55 | temporary_list; | |
56 | ||
57 | typedef struct forall_info | |
58 | { | |
59 | iter_info *this_loop; | |
60 | tree mask; | |
61 | tree pmask; | |
62 | tree maskindex; | |
63 | int nvar; | |
64 | tree size; | |
65 | struct forall_info *outer; | |
66 | struct forall_info *next_nest; | |
67 | } | |
68 | forall_info; | |
69 | ||
70 | static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *, | |
71 | stmtblock_t *, temporary_list **temp); | |
72 | ||
73 | /* Translate a F95 label number to a LABEL_EXPR. */ | |
74 | ||
75 | tree | |
76 | gfc_trans_label_here (gfc_code * code) | |
77 | { | |
78 | return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); | |
79 | } | |
80 | ||
ce2df7c6 FW |
81 | |
82 | /* Given a variable expression which has been ASSIGNed to, find the decl | |
83 | containing the auxiliary variables. For variables in common blocks this | |
84 | is a field_decl. */ | |
85 | ||
86 | void | |
87 | gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) | |
88 | { | |
89 | gcc_assert (expr->symtree->n.sym->attr.assign == 1); | |
90 | gfc_conv_expr (se, expr); | |
91 | /* Deals with variable in common block. Get the field declaration. */ | |
92 | if (TREE_CODE (se->expr) == COMPONENT_REF) | |
93 | se->expr = TREE_OPERAND (se->expr, 1); | |
94 | } | |
95 | ||
6de9cd9a | 96 | /* Translate a label assignment statement. */ |
ce2df7c6 | 97 | |
6de9cd9a DN |
98 | tree |
99 | gfc_trans_label_assign (gfc_code * code) | |
100 | { | |
101 | tree label_tree; | |
102 | gfc_se se; | |
103 | tree len; | |
104 | tree addr; | |
105 | tree len_tree; | |
106 | char *label_str; | |
107 | int label_len; | |
108 | ||
109 | /* Start a new block. */ | |
110 | gfc_init_se (&se, NULL); | |
111 | gfc_start_block (&se.pre); | |
ce2df7c6 FW |
112 | gfc_conv_label_variable (&se, code->expr); |
113 | ||
6de9cd9a DN |
114 | len = GFC_DECL_STRING_LEN (se.expr); |
115 | addr = GFC_DECL_ASSIGN_ADDR (se.expr); | |
116 | ||
117 | label_tree = gfc_get_label_decl (code->label); | |
118 | ||
119 | if (code->label->defined == ST_LABEL_TARGET) | |
120 | { | |
121 | label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); | |
122 | len_tree = integer_minus_one_node; | |
123 | } | |
124 | else | |
125 | { | |
126 | label_str = code->label->format->value.character.string; | |
127 | label_len = code->label->format->value.character.length; | |
7d60be94 | 128 | len_tree = build_int_cst (NULL_TREE, label_len); |
6de9cd9a | 129 | label_tree = gfc_build_string_const (label_len + 1, label_str); |
b078dfbf | 130 | label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); |
6de9cd9a DN |
131 | } |
132 | ||
133 | gfc_add_modify_expr (&se.pre, len, len_tree); | |
134 | gfc_add_modify_expr (&se.pre, addr, label_tree); | |
135 | ||
136 | return gfc_finish_block (&se.pre); | |
137 | } | |
138 | ||
139 | /* Translate a GOTO statement. */ | |
140 | ||
141 | tree | |
142 | gfc_trans_goto (gfc_code * code) | |
143 | { | |
144 | tree assigned_goto; | |
145 | tree target; | |
146 | tree tmp; | |
147 | tree assign_error; | |
148 | tree range_error; | |
149 | gfc_se se; | |
150 | ||
151 | ||
152 | if (code->label != NULL) | |
153 | return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); | |
154 | ||
155 | /* ASSIGNED GOTO. */ | |
156 | gfc_init_se (&se, NULL); | |
157 | gfc_start_block (&se.pre); | |
ce2df7c6 | 158 | gfc_conv_label_variable (&se, code->expr); |
6de9cd9a | 159 | assign_error = |
95638988 | 160 | gfc_build_cstring_const ("Assigned label is not a target label"); |
6de9cd9a | 161 | tmp = GFC_DECL_STRING_LEN (se.expr); |
923ab88c | 162 | tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node); |
6de9cd9a DN |
163 | gfc_trans_runtime_check (tmp, assign_error, &se.pre); |
164 | ||
165 | assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); | |
166 | target = build1 (GOTO_EXPR, void_type_node, assigned_goto); | |
167 | ||
168 | code = code->block; | |
169 | if (code == NULL) | |
170 | { | |
171 | gfc_add_expr_to_block (&se.pre, target); | |
172 | return gfc_finish_block (&se.pre); | |
173 | } | |
174 | ||
175 | /* Check the label list. */ | |
95638988 | 176 | range_error = gfc_build_cstring_const ("Assigned label is not in the list"); |
6de9cd9a DN |
177 | |
178 | do | |
179 | { | |
180 | tmp = gfc_get_label_decl (code->label); | |
181 | tmp = gfc_build_addr_expr (pvoid_type_node, tmp); | |
923ab88c TS |
182 | tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto); |
183 | tmp = build3_v (COND_EXPR, tmp, target, build_empty_stmt ()); | |
6de9cd9a DN |
184 | gfc_add_expr_to_block (&se.pre, tmp); |
185 | code = code->block; | |
186 | } | |
187 | while (code != NULL); | |
188 | gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre); | |
189 | return gfc_finish_block (&se.pre); | |
190 | } | |
191 | ||
192 | ||
3d79abbd PB |
193 | /* Translate an ENTRY statement. Just adds a label for this entry point. */ |
194 | tree | |
195 | gfc_trans_entry (gfc_code * code) | |
196 | { | |
197 | return build1_v (LABEL_EXPR, code->ext.entry->label); | |
198 | } | |
199 | ||
200 | ||
6de9cd9a DN |
201 | /* Translate the CALL statement. Builds a call to an F95 subroutine. */ |
202 | ||
203 | tree | |
204 | gfc_trans_call (gfc_code * code) | |
205 | { | |
206 | gfc_se se; | |
dda895f9 | 207 | int has_alternate_specifier; |
6de9cd9a DN |
208 | |
209 | /* A CALL starts a new block because the actual arguments may have to | |
210 | be evaluated first. */ | |
211 | gfc_init_se (&se, NULL); | |
212 | gfc_start_block (&se.pre); | |
213 | ||
6e45f57b | 214 | gcc_assert (code->resolved_sym); |
6de9cd9a DN |
215 | |
216 | /* Translate the call. */ | |
dda895f9 JJ |
217 | has_alternate_specifier |
218 | = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual); | |
6de9cd9a DN |
219 | |
220 | /* A subroutine without side-effect, by definition, does nothing! */ | |
221 | TREE_SIDE_EFFECTS (se.expr) = 1; | |
222 | ||
223 | /* Chain the pieces together and return the block. */ | |
224 | if (has_alternate_specifier) | |
225 | { | |
226 | gfc_code *select_code; | |
227 | gfc_symbol *sym; | |
228 | select_code = code->next; | |
6e45f57b | 229 | gcc_assert(select_code->op == EXEC_SELECT); |
6de9cd9a DN |
230 | sym = select_code->expr->symtree->n.sym; |
231 | se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); | |
232 | gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr); | |
233 | } | |
234 | else | |
235 | gfc_add_expr_to_block (&se.pre, se.expr); | |
236 | ||
237 | gfc_add_block_to_block (&se.pre, &se.post); | |
238 | return gfc_finish_block (&se.pre); | |
239 | } | |
240 | ||
241 | ||
242 | /* Translate the RETURN statement. */ | |
243 | ||
244 | tree | |
245 | gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) | |
246 | { | |
247 | if (code->expr) | |
248 | { | |
249 | gfc_se se; | |
250 | tree tmp; | |
251 | tree result; | |
252 | ||
253 | /* if code->expr is not NULL, this return statement must appear | |
254 | in a subroutine and current_fake_result_decl has already | |
255 | been generated. */ | |
256 | ||
257 | result = gfc_get_fake_result_decl (NULL); | |
258 | if (!result) | |
259 | { | |
260 | gfc_warning ("An alternate return at %L without a * dummy argument", | |
261 | &code->expr->where); | |
262 | return build1_v (GOTO_EXPR, gfc_get_return_label ()); | |
263 | } | |
264 | ||
265 | /* Start a new block for this statement. */ | |
266 | gfc_init_se (&se, NULL); | |
267 | gfc_start_block (&se.pre); | |
268 | ||
269 | gfc_conv_expr (&se, code->expr); | |
270 | ||
923ab88c | 271 | tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr); |
6de9cd9a DN |
272 | gfc_add_expr_to_block (&se.pre, tmp); |
273 | ||
274 | tmp = build1_v (GOTO_EXPR, gfc_get_return_label ()); | |
275 | gfc_add_expr_to_block (&se.pre, tmp); | |
276 | gfc_add_block_to_block (&se.pre, &se.post); | |
277 | return gfc_finish_block (&se.pre); | |
278 | } | |
279 | else | |
280 | return build1_v (GOTO_EXPR, gfc_get_return_label ()); | |
281 | } | |
282 | ||
283 | ||
284 | /* Translate the PAUSE statement. We have to translate this statement | |
285 | to a runtime library call. */ | |
286 | ||
287 | tree | |
288 | gfc_trans_pause (gfc_code * code) | |
289 | { | |
e2cad04b | 290 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
291 | gfc_se se; |
292 | tree args; | |
293 | tree tmp; | |
294 | tree fndecl; | |
295 | ||
296 | /* Start a new block for this statement. */ | |
297 | gfc_init_se (&se, NULL); | |
298 | gfc_start_block (&se.pre); | |
299 | ||
300 | ||
301 | if (code->expr == NULL) | |
302 | { | |
7d60be94 | 303 | tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); |
6de9cd9a DN |
304 | args = gfc_chainon_list (NULL_TREE, tmp); |
305 | fndecl = gfor_fndecl_pause_numeric; | |
306 | } | |
307 | else | |
308 | { | |
309 | gfc_conv_expr_reference (&se, code->expr); | |
310 | args = gfc_chainon_list (NULL_TREE, se.expr); | |
311 | args = gfc_chainon_list (args, se.string_length); | |
312 | fndecl = gfor_fndecl_pause_string; | |
313 | } | |
314 | ||
315 | tmp = gfc_build_function_call (fndecl, args); | |
316 | gfc_add_expr_to_block (&se.pre, tmp); | |
317 | ||
318 | gfc_add_block_to_block (&se.pre, &se.post); | |
319 | ||
320 | return gfc_finish_block (&se.pre); | |
321 | } | |
322 | ||
323 | ||
324 | /* Translate the STOP statement. We have to translate this statement | |
325 | to a runtime library call. */ | |
326 | ||
327 | tree | |
328 | gfc_trans_stop (gfc_code * code) | |
329 | { | |
e2cad04b | 330 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
331 | gfc_se se; |
332 | tree args; | |
333 | tree tmp; | |
334 | tree fndecl; | |
335 | ||
336 | /* Start a new block for this statement. */ | |
337 | gfc_init_se (&se, NULL); | |
338 | gfc_start_block (&se.pre); | |
339 | ||
340 | ||
341 | if (code->expr == NULL) | |
342 | { | |
7d60be94 | 343 | tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); |
6de9cd9a DN |
344 | args = gfc_chainon_list (NULL_TREE, tmp); |
345 | fndecl = gfor_fndecl_stop_numeric; | |
346 | } | |
347 | else | |
348 | { | |
349 | gfc_conv_expr_reference (&se, code->expr); | |
350 | args = gfc_chainon_list (NULL_TREE, se.expr); | |
351 | args = gfc_chainon_list (args, se.string_length); | |
352 | fndecl = gfor_fndecl_stop_string; | |
353 | } | |
354 | ||
355 | tmp = gfc_build_function_call (fndecl, args); | |
356 | gfc_add_expr_to_block (&se.pre, tmp); | |
357 | ||
358 | gfc_add_block_to_block (&se.pre, &se.post); | |
359 | ||
360 | return gfc_finish_block (&se.pre); | |
361 | } | |
362 | ||
363 | ||
364 | /* Generate GENERIC for the IF construct. This function also deals with | |
365 | the simple IF statement, because the front end translates the IF | |
366 | statement into an IF construct. | |
367 | ||
368 | We translate: | |
369 | ||
370 | IF (cond) THEN | |
371 | then_clause | |
372 | ELSEIF (cond2) | |
373 | elseif_clause | |
374 | ELSE | |
375 | else_clause | |
376 | ENDIF | |
377 | ||
378 | into: | |
379 | ||
380 | pre_cond_s; | |
381 | if (cond_s) | |
382 | { | |
383 | then_clause; | |
384 | } | |
385 | else | |
386 | { | |
387 | pre_cond_s | |
388 | if (cond_s) | |
389 | { | |
390 | elseif_clause | |
391 | } | |
392 | else | |
393 | { | |
394 | else_clause; | |
395 | } | |
396 | } | |
397 | ||
398 | where COND_S is the simplified version of the predicate. PRE_COND_S | |
399 | are the pre side-effects produced by the translation of the | |
400 | conditional. | |
401 | We need to build the chain recursively otherwise we run into | |
402 | problems with folding incomplete statements. */ | |
403 | ||
404 | static tree | |
405 | gfc_trans_if_1 (gfc_code * code) | |
406 | { | |
407 | gfc_se if_se; | |
408 | tree stmt, elsestmt; | |
409 | ||
410 | /* Check for an unconditional ELSE clause. */ | |
411 | if (!code->expr) | |
412 | return gfc_trans_code (code->next); | |
413 | ||
414 | /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ | |
415 | gfc_init_se (&if_se, NULL); | |
416 | gfc_start_block (&if_se.pre); | |
417 | ||
418 | /* Calculate the IF condition expression. */ | |
419 | gfc_conv_expr_val (&if_se, code->expr); | |
420 | ||
421 | /* Translate the THEN clause. */ | |
422 | stmt = gfc_trans_code (code->next); | |
423 | ||
424 | /* Translate the ELSE clause. */ | |
425 | if (code->block) | |
426 | elsestmt = gfc_trans_if_1 (code->block); | |
427 | else | |
428 | elsestmt = build_empty_stmt (); | |
429 | ||
430 | /* Build the condition expression and add it to the condition block. */ | |
923ab88c | 431 | stmt = build3_v (COND_EXPR, if_se.expr, stmt, elsestmt); |
6de9cd9a DN |
432 | |
433 | gfc_add_expr_to_block (&if_se.pre, stmt); | |
434 | ||
435 | /* Finish off this statement. */ | |
436 | return gfc_finish_block (&if_se.pre); | |
437 | } | |
438 | ||
439 | tree | |
440 | gfc_trans_if (gfc_code * code) | |
441 | { | |
442 | /* Ignore the top EXEC_IF, it only announces an IF construct. The | |
443 | actual code we must translate is in code->block. */ | |
444 | ||
445 | return gfc_trans_if_1 (code->block); | |
446 | } | |
447 | ||
448 | ||
449 | /* Translage an arithmetic IF expression. | |
450 | ||
451 | IF (cond) label1, label2, label3 translates to | |
452 | ||
453 | if (cond <= 0) | |
454 | { | |
455 | if (cond < 0) | |
456 | goto label1; | |
457 | else // cond == 0 | |
458 | goto label2; | |
459 | } | |
460 | else // cond > 0 | |
461 | goto label3; | |
462 | */ | |
463 | ||
464 | tree | |
465 | gfc_trans_arithmetic_if (gfc_code * code) | |
466 | { | |
467 | gfc_se se; | |
468 | tree tmp; | |
469 | tree branch1; | |
470 | tree branch2; | |
471 | tree zero; | |
472 | ||
473 | /* Start a new block. */ | |
474 | gfc_init_se (&se, NULL); | |
475 | gfc_start_block (&se.pre); | |
476 | ||
477 | /* Pre-evaluate COND. */ | |
478 | gfc_conv_expr_val (&se, code->expr); | |
479 | ||
480 | /* Build something to compare with. */ | |
481 | zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); | |
482 | ||
483 | /* If (cond < 0) take branch1 else take branch2. | |
484 | First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ | |
485 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); | |
486 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); | |
487 | ||
923ab88c TS |
488 | tmp = build2 (LT_EXPR, boolean_type_node, se.expr, zero); |
489 | branch1 = build3_v (COND_EXPR, tmp, branch1, branch2); | |
6de9cd9a DN |
490 | |
491 | /* if (cond <= 0) take branch1 else take branch2. */ | |
492 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); | |
923ab88c TS |
493 | tmp = build2 (LE_EXPR, boolean_type_node, se.expr, zero); |
494 | branch1 = build3_v (COND_EXPR, tmp, branch1, branch2); | |
6de9cd9a DN |
495 | |
496 | /* Append the COND_EXPR to the evaluation of COND, and return. */ | |
497 | gfc_add_expr_to_block (&se.pre, branch1); | |
498 | return gfc_finish_block (&se.pre); | |
499 | } | |
500 | ||
501 | ||
54c2d931 | 502 | /* Translate the simple DO construct. This is where the loop variable has |
fbdad37d PB |
503 | integer type and step +-1. We can't use this in the general case |
504 | because integer overflow and floating point errors could give incorrect | |
505 | results. | |
506 | We translate a do loop from: | |
507 | ||
508 | DO dovar = from, to, step | |
509 | body | |
510 | END DO | |
511 | ||
512 | to: | |
513 | ||
514 | [Evaluate loop bounds and step] | |
515 | dovar = from; | |
516 | if ((step > 0) ? (dovar <= to) : (dovar => to)) | |
517 | { | |
518 | for (;;) | |
519 | { | |
520 | body; | |
521 | cycle_label: | |
522 | cond = (dovar == to); | |
523 | dovar += step; | |
524 | if (cond) goto end_label; | |
525 | } | |
526 | } | |
527 | end_label: | |
528 | ||
529 | This helps the optimizers by avoiding the extra induction variable | |
530 | used in the general case. */ | |
531 | ||
532 | static tree | |
533 | gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, | |
534 | tree from, tree to, tree step) | |
535 | { | |
536 | stmtblock_t body; | |
537 | tree type; | |
538 | tree cond; | |
539 | tree tmp; | |
540 | tree cycle_label; | |
541 | tree exit_label; | |
542 | ||
543 | type = TREE_TYPE (dovar); | |
544 | ||
545 | /* Initialize the DO variable: dovar = from. */ | |
546 | gfc_add_modify_expr (pblock, dovar, from); | |
547 | ||
548 | /* Cycle and exit statements are implemented with gotos. */ | |
549 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
550 | exit_label = gfc_build_label_decl (NULL_TREE); | |
551 | ||
552 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
553 | code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); | |
554 | ||
555 | /* Loop body. */ | |
556 | gfc_start_block (&body); | |
557 | ||
558 | /* Main loop body. */ | |
559 | tmp = gfc_trans_code (code->block->next); | |
560 | gfc_add_expr_to_block (&body, tmp); | |
561 | ||
562 | /* Label for cycle statements (if needed). */ | |
563 | if (TREE_USED (cycle_label)) | |
564 | { | |
565 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
566 | gfc_add_expr_to_block (&body, tmp); | |
567 | } | |
568 | ||
569 | /* Evaluate the loop condition. */ | |
570 | cond = build2 (EQ_EXPR, boolean_type_node, dovar, to); | |
571 | cond = gfc_evaluate_now (cond, &body); | |
572 | ||
573 | /* Increment the loop variable. */ | |
574 | tmp = build2 (PLUS_EXPR, type, dovar, step); | |
575 | gfc_add_modify_expr (&body, dovar, tmp); | |
576 | ||
577 | /* The loop exit. */ | |
578 | tmp = build1_v (GOTO_EXPR, exit_label); | |
579 | TREE_USED (exit_label) = 1; | |
580 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); | |
581 | gfc_add_expr_to_block (&body, tmp); | |
582 | ||
583 | /* Finish the loop body. */ | |
584 | tmp = gfc_finish_block (&body); | |
585 | tmp = build1_v (LOOP_EXPR, tmp); | |
586 | ||
587 | /* Only execute the loop if the number of iterations is positive. */ | |
588 | if (tree_int_cst_sgn (step) > 0) | |
10c7a96f | 589 | cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to); |
fbdad37d | 590 | else |
10c7a96f | 591 | cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to); |
fbdad37d PB |
592 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
593 | gfc_add_expr_to_block (pblock, tmp); | |
594 | ||
595 | /* Add the exit label. */ | |
596 | tmp = build1_v (LABEL_EXPR, exit_label); | |
597 | gfc_add_expr_to_block (pblock, tmp); | |
598 | ||
599 | return gfc_finish_block (pblock); | |
600 | } | |
601 | ||
6de9cd9a DN |
602 | /* Translate the DO construct. This obviously is one of the most |
603 | important ones to get right with any compiler, but especially | |
604 | so for Fortran. | |
605 | ||
fbdad37d PB |
606 | We special case some loop forms as described in gfc_trans_simple_do. |
607 | For other cases we implement them with a separate loop count, | |
608 | as described in the standard. | |
6de9cd9a DN |
609 | |
610 | We translate a do loop from: | |
611 | ||
612 | DO dovar = from, to, step | |
613 | body | |
614 | END DO | |
615 | ||
616 | to: | |
617 | ||
fbdad37d PB |
618 | [evaluate loop bounds and step] |
619 | count = to + step - from; | |
620 | dovar = from; | |
621 | for (;;) | |
6de9cd9a DN |
622 | { |
623 | body; | |
624 | cycle_label: | |
fbdad37d PB |
625 | dovar += step |
626 | count--; | |
627 | if (count <=0) goto exit_label; | |
6de9cd9a DN |
628 | } |
629 | exit_label: | |
630 | ||
6de9cd9a | 631 | TODO: Large loop counts |
fbdad37d | 632 | The code above assumes the loop count fits into a signed integer kind, |
13795658 | 633 | i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables |
8d5cfa27 | 634 | We must support the full range. */ |
6de9cd9a DN |
635 | |
636 | tree | |
637 | gfc_trans_do (gfc_code * code) | |
638 | { | |
639 | gfc_se se; | |
640 | tree dovar; | |
641 | tree from; | |
642 | tree to; | |
643 | tree step; | |
644 | tree count; | |
8d5cfa27 | 645 | tree count_one; |
6de9cd9a DN |
646 | tree type; |
647 | tree cond; | |
648 | tree cycle_label; | |
649 | tree exit_label; | |
650 | tree tmp; | |
651 | stmtblock_t block; | |
652 | stmtblock_t body; | |
653 | ||
654 | gfc_start_block (&block); | |
655 | ||
fbdad37d | 656 | /* Evaluate all the expressions in the iterator. */ |
6de9cd9a DN |
657 | gfc_init_se (&se, NULL); |
658 | gfc_conv_expr_lhs (&se, code->ext.iterator->var); | |
659 | gfc_add_block_to_block (&block, &se.pre); | |
660 | dovar = se.expr; | |
661 | type = TREE_TYPE (dovar); | |
662 | ||
663 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 664 | gfc_conv_expr_val (&se, code->ext.iterator->start); |
6de9cd9a | 665 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 666 | from = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
667 | |
668 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 669 | gfc_conv_expr_val (&se, code->ext.iterator->end); |
6de9cd9a | 670 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 671 | to = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
672 | |
673 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 674 | gfc_conv_expr_val (&se, code->ext.iterator->step); |
6de9cd9a | 675 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d PB |
676 | step = gfc_evaluate_now (se.expr, &block); |
677 | ||
678 | /* Special case simple loops. */ | |
679 | if (TREE_CODE (type) == INTEGER_TYPE | |
680 | && (integer_onep (step) | |
681 | || tree_int_cst_equal (step, integer_minus_one_node))) | |
682 | return gfc_trans_simple_do (code, &block, dovar, from, to, step); | |
683 | ||
1f2959f0 | 684 | /* Initialize loop count. This code is executed before we enter the |
6de9cd9a DN |
685 | loop body. We generate: count = (to + step - from) / step. */ |
686 | ||
10c7a96f SB |
687 | tmp = fold_build2 (MINUS_EXPR, type, step, from); |
688 | tmp = fold_build2 (PLUS_EXPR, type, to, tmp); | |
8d5cfa27 SK |
689 | if (TREE_CODE (type) == INTEGER_TYPE) |
690 | { | |
10c7a96f | 691 | tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step); |
8d5cfa27 SK |
692 | count = gfc_create_var (type, "count"); |
693 | } | |
694 | else | |
695 | { | |
696 | /* TODO: We could use the same width as the real type. | |
697 | This would probably cause more problems that it solves | |
698 | when we implement "long double" types. */ | |
10c7a96f SB |
699 | tmp = fold_build2 (RDIV_EXPR, type, tmp, step); |
700 | tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp); | |
8d5cfa27 SK |
701 | count = gfc_create_var (gfc_array_index_type, "count"); |
702 | } | |
6de9cd9a DN |
703 | gfc_add_modify_expr (&block, count, tmp); |
704 | ||
8d5cfa27 SK |
705 | count_one = convert (TREE_TYPE (count), integer_one_node); |
706 | ||
1f2959f0 | 707 | /* Initialize the DO variable: dovar = from. */ |
6de9cd9a DN |
708 | gfc_add_modify_expr (&block, dovar, from); |
709 | ||
710 | /* Loop body. */ | |
711 | gfc_start_block (&body); | |
712 | ||
713 | /* Cycle and exit statements are implemented with gotos. */ | |
714 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
715 | exit_label = gfc_build_label_decl (NULL_TREE); | |
716 | ||
717 | /* Start with the loop condition. Loop until count <= 0. */ | |
8d5cfa27 SK |
718 | cond = build2 (LE_EXPR, boolean_type_node, count, |
719 | convert (TREE_TYPE (count), integer_zero_node)); | |
6de9cd9a DN |
720 | tmp = build1_v (GOTO_EXPR, exit_label); |
721 | TREE_USED (exit_label) = 1; | |
923ab88c | 722 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
6de9cd9a DN |
723 | gfc_add_expr_to_block (&body, tmp); |
724 | ||
725 | /* Put these labels where they can be found later. We put the | |
726 | labels in a TREE_LIST node (because TREE_CHAIN is already | |
727 | used). cycle_label goes in TREE_PURPOSE (backend_decl), exit | |
728 | label in TREE_VALUE (backend_decl). */ | |
729 | ||
730 | code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); | |
731 | ||
732 | /* Main loop body. */ | |
733 | tmp = gfc_trans_code (code->block->next); | |
734 | gfc_add_expr_to_block (&body, tmp); | |
735 | ||
736 | /* Label for cycle statements (if needed). */ | |
737 | if (TREE_USED (cycle_label)) | |
738 | { | |
739 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
740 | gfc_add_expr_to_block (&body, tmp); | |
741 | } | |
742 | ||
743 | /* Increment the loop variable. */ | |
923ab88c | 744 | tmp = build2 (PLUS_EXPR, type, dovar, step); |
6de9cd9a DN |
745 | gfc_add_modify_expr (&body, dovar, tmp); |
746 | ||
747 | /* Decrement the loop count. */ | |
8d5cfa27 | 748 | tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one); |
6de9cd9a DN |
749 | gfc_add_modify_expr (&body, count, tmp); |
750 | ||
751 | /* End of loop body. */ | |
752 | tmp = gfc_finish_block (&body); | |
753 | ||
754 | /* The for loop itself. */ | |
923ab88c | 755 | tmp = build1_v (LOOP_EXPR, tmp); |
6de9cd9a DN |
756 | gfc_add_expr_to_block (&block, tmp); |
757 | ||
758 | /* Add the exit label. */ | |
759 | tmp = build1_v (LABEL_EXPR, exit_label); | |
760 | gfc_add_expr_to_block (&block, tmp); | |
761 | ||
762 | return gfc_finish_block (&block); | |
763 | } | |
764 | ||
765 | ||
766 | /* Translate the DO WHILE construct. | |
767 | ||
768 | We translate | |
769 | ||
770 | DO WHILE (cond) | |
771 | body | |
772 | END DO | |
773 | ||
774 | to: | |
775 | ||
776 | for ( ; ; ) | |
777 | { | |
778 | pre_cond; | |
779 | if (! cond) goto exit_label; | |
780 | body; | |
781 | cycle_label: | |
782 | } | |
783 | exit_label: | |
784 | ||
785 | Because the evaluation of the exit condition `cond' may have side | |
786 | effects, we can't do much for empty loop bodies. The backend optimizers | |
787 | should be smart enough to eliminate any dead loops. */ | |
788 | ||
789 | tree | |
790 | gfc_trans_do_while (gfc_code * code) | |
791 | { | |
792 | gfc_se cond; | |
793 | tree tmp; | |
794 | tree cycle_label; | |
795 | tree exit_label; | |
796 | stmtblock_t block; | |
797 | ||
798 | /* Everything we build here is part of the loop body. */ | |
799 | gfc_start_block (&block); | |
800 | ||
801 | /* Cycle and exit statements are implemented with gotos. */ | |
802 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
803 | exit_label = gfc_build_label_decl (NULL_TREE); | |
804 | ||
805 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
806 | code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); | |
807 | ||
808 | /* Create a GIMPLE version of the exit condition. */ | |
809 | gfc_init_se (&cond, NULL); | |
810 | gfc_conv_expr_val (&cond, code->expr); | |
811 | gfc_add_block_to_block (&block, &cond.pre); | |
10c7a96f | 812 | cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr); |
6de9cd9a DN |
813 | |
814 | /* Build "IF (! cond) GOTO exit_label". */ | |
815 | tmp = build1_v (GOTO_EXPR, exit_label); | |
816 | TREE_USED (exit_label) = 1; | |
923ab88c | 817 | tmp = build3_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
818 | gfc_add_expr_to_block (&block, tmp); |
819 | ||
820 | /* The main body of the loop. */ | |
821 | tmp = gfc_trans_code (code->block->next); | |
822 | gfc_add_expr_to_block (&block, tmp); | |
823 | ||
824 | /* Label for cycle statements (if needed). */ | |
825 | if (TREE_USED (cycle_label)) | |
826 | { | |
827 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
828 | gfc_add_expr_to_block (&block, tmp); | |
829 | } | |
830 | ||
831 | /* End of loop body. */ | |
832 | tmp = gfc_finish_block (&block); | |
833 | ||
834 | gfc_init_block (&block); | |
835 | /* Build the loop. */ | |
923ab88c | 836 | tmp = build1_v (LOOP_EXPR, tmp); |
6de9cd9a DN |
837 | gfc_add_expr_to_block (&block, tmp); |
838 | ||
839 | /* Add the exit label. */ | |
840 | tmp = build1_v (LABEL_EXPR, exit_label); | |
841 | gfc_add_expr_to_block (&block, tmp); | |
842 | ||
843 | return gfc_finish_block (&block); | |
844 | } | |
845 | ||
846 | ||
847 | /* Translate the SELECT CASE construct for INTEGER case expressions, | |
848 | without killing all potential optimizations. The problem is that | |
849 | Fortran allows unbounded cases, but the back-end does not, so we | |
850 | need to intercept those before we enter the equivalent SWITCH_EXPR | |
851 | we can build. | |
852 | ||
853 | For example, we translate this, | |
854 | ||
855 | SELECT CASE (expr) | |
856 | CASE (:100,101,105:115) | |
857 | block_1 | |
858 | CASE (190:199,200:) | |
859 | block_2 | |
860 | CASE (300) | |
861 | block_3 | |
862 | CASE DEFAULT | |
863 | block_4 | |
864 | END SELECT | |
865 | ||
866 | to the GENERIC equivalent, | |
867 | ||
868 | switch (expr) | |
869 | { | |
870 | case (minimum value for typeof(expr) ... 100: | |
871 | case 101: | |
872 | case 105 ... 114: | |
873 | block1: | |
874 | goto end_label; | |
875 | ||
876 | case 200 ... (maximum value for typeof(expr): | |
877 | case 190 ... 199: | |
878 | block2; | |
879 | goto end_label; | |
880 | ||
881 | case 300: | |
882 | block_3; | |
883 | goto end_label; | |
884 | ||
885 | default: | |
886 | block_4; | |
887 | goto end_label; | |
888 | } | |
889 | ||
890 | end_label: */ | |
891 | ||
892 | static tree | |
893 | gfc_trans_integer_select (gfc_code * code) | |
894 | { | |
895 | gfc_code *c; | |
896 | gfc_case *cp; | |
897 | tree end_label; | |
898 | tree tmp; | |
899 | gfc_se se; | |
900 | stmtblock_t block; | |
901 | stmtblock_t body; | |
902 | ||
903 | gfc_start_block (&block); | |
904 | ||
905 | /* Calculate the switch expression. */ | |
906 | gfc_init_se (&se, NULL); | |
907 | gfc_conv_expr_val (&se, code->expr); | |
908 | gfc_add_block_to_block (&block, &se.pre); | |
909 | ||
910 | end_label = gfc_build_label_decl (NULL_TREE); | |
911 | ||
912 | gfc_init_block (&body); | |
913 | ||
914 | for (c = code->block; c; c = c->block) | |
915 | { | |
916 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
917 | { | |
918 | tree low, high; | |
919 | tree label; | |
920 | ||
921 | /* Assume it's the default case. */ | |
922 | low = high = NULL_TREE; | |
923 | ||
924 | if (cp->low) | |
925 | { | |
926 | low = gfc_conv_constant_to_tree (cp->low); | |
927 | ||
928 | /* If there's only a lower bound, set the high bound to the | |
929 | maximum value of the case expression. */ | |
930 | if (!cp->high) | |
931 | high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); | |
932 | } | |
933 | ||
934 | if (cp->high) | |
935 | { | |
936 | /* Three cases are possible here: | |
937 | ||
938 | 1) There is no lower bound, e.g. CASE (:N). | |
939 | 2) There is a lower bound .NE. high bound, that is | |
940 | a case range, e.g. CASE (N:M) where M>N (we make | |
941 | sure that M>N during type resolution). | |
942 | 3) There is a lower bound, and it has the same value | |
943 | as the high bound, e.g. CASE (N:N). This is our | |
944 | internal representation of CASE(N). | |
945 | ||
946 | In the first and second case, we need to set a value for | |
947 | high. In the thirth case, we don't because the GCC middle | |
948 | end represents a single case value by just letting high be | |
949 | a NULL_TREE. We can't do that because we need to be able | |
950 | to represent unbounded cases. */ | |
951 | ||
952 | if (!cp->low | |
953 | || (cp->low | |
954 | && mpz_cmp (cp->low->value.integer, | |
955 | cp->high->value.integer) != 0)) | |
956 | high = gfc_conv_constant_to_tree (cp->high); | |
957 | ||
958 | /* Unbounded case. */ | |
959 | if (!cp->low) | |
960 | low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); | |
961 | } | |
962 | ||
963 | /* Build a label. */ | |
c006df4e | 964 | label = gfc_build_label_decl (NULL_TREE); |
6de9cd9a DN |
965 | |
966 | /* Add this case label. | |
967 | Add parameter 'label', make it match GCC backend. */ | |
923ab88c | 968 | tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label); |
6de9cd9a DN |
969 | gfc_add_expr_to_block (&body, tmp); |
970 | } | |
971 | ||
972 | /* Add the statements for this case. */ | |
973 | tmp = gfc_trans_code (c->next); | |
974 | gfc_add_expr_to_block (&body, tmp); | |
975 | ||
976 | /* Break to the end of the construct. */ | |
977 | tmp = build1_v (GOTO_EXPR, end_label); | |
978 | gfc_add_expr_to_block (&body, tmp); | |
979 | } | |
980 | ||
981 | tmp = gfc_finish_block (&body); | |
923ab88c | 982 | tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE); |
6de9cd9a DN |
983 | gfc_add_expr_to_block (&block, tmp); |
984 | ||
985 | tmp = build1_v (LABEL_EXPR, end_label); | |
986 | gfc_add_expr_to_block (&block, tmp); | |
987 | ||
988 | return gfc_finish_block (&block); | |
989 | } | |
990 | ||
991 | ||
992 | /* Translate the SELECT CASE construct for LOGICAL case expressions. | |
993 | ||
994 | There are only two cases possible here, even though the standard | |
995 | does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., | |
996 | .FALSE., and DEFAULT. | |
997 | ||
998 | We never generate more than two blocks here. Instead, we always | |
999 | try to eliminate the DEFAULT case. This way, we can translate this | |
1000 | kind of SELECT construct to a simple | |
1001 | ||
1002 | if {} else {}; | |
1003 | ||
1004 | expression in GENERIC. */ | |
1005 | ||
1006 | static tree | |
1007 | gfc_trans_logical_select (gfc_code * code) | |
1008 | { | |
1009 | gfc_code *c; | |
1010 | gfc_code *t, *f, *d; | |
1011 | gfc_case *cp; | |
1012 | gfc_se se; | |
1013 | stmtblock_t block; | |
1014 | ||
1015 | /* Assume we don't have any cases at all. */ | |
1016 | t = f = d = NULL; | |
1017 | ||
1018 | /* Now see which ones we actually do have. We can have at most two | |
1019 | cases in a single case list: one for .TRUE. and one for .FALSE. | |
1020 | The default case is always separate. If the cases for .TRUE. and | |
1021 | .FALSE. are in the same case list, the block for that case list | |
1022 | always executed, and we don't generate code a COND_EXPR. */ | |
1023 | for (c = code->block; c; c = c->block) | |
1024 | { | |
1025 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
1026 | { | |
1027 | if (cp->low) | |
1028 | { | |
1029 | if (cp->low->value.logical == 0) /* .FALSE. */ | |
1030 | f = c; | |
1031 | else /* if (cp->value.logical != 0), thus .TRUE. */ | |
1032 | t = c; | |
1033 | } | |
1034 | else | |
1035 | d = c; | |
1036 | } | |
1037 | } | |
1038 | ||
1039 | /* Start a new block. */ | |
1040 | gfc_start_block (&block); | |
1041 | ||
1042 | /* Calculate the switch expression. We always need to do this | |
1043 | because it may have side effects. */ | |
1044 | gfc_init_se (&se, NULL); | |
1045 | gfc_conv_expr_val (&se, code->expr); | |
1046 | gfc_add_block_to_block (&block, &se.pre); | |
1047 | ||
1048 | if (t == f && t != NULL) | |
1049 | { | |
1050 | /* Cases for .TRUE. and .FALSE. are in the same block. Just | |
1051 | translate the code for these cases, append it to the current | |
1052 | block. */ | |
1053 | gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); | |
1054 | } | |
1055 | else | |
1056 | { | |
1057 | tree true_tree, false_tree; | |
1058 | ||
1059 | true_tree = build_empty_stmt (); | |
1060 | false_tree = build_empty_stmt (); | |
1061 | ||
1062 | /* If we have a case for .TRUE. and for .FALSE., discard the default case. | |
1063 | Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, | |
1064 | make the missing case the default case. */ | |
1065 | if (t != NULL && f != NULL) | |
1066 | d = NULL; | |
1067 | else if (d != NULL) | |
1068 | { | |
1069 | if (t == NULL) | |
1070 | t = d; | |
1071 | else | |
1072 | f = d; | |
1073 | } | |
1074 | ||
1075 | /* Translate the code for each of these blocks, and append it to | |
1076 | the current block. */ | |
1077 | if (t != NULL) | |
1078 | true_tree = gfc_trans_code (t->next); | |
1079 | ||
1080 | if (f != NULL) | |
1081 | false_tree = gfc_trans_code (f->next); | |
1082 | ||
923ab88c TS |
1083 | gfc_add_expr_to_block (&block, build3_v (COND_EXPR, se.expr, |
1084 | true_tree, false_tree)); | |
6de9cd9a DN |
1085 | } |
1086 | ||
1087 | return gfc_finish_block (&block); | |
1088 | } | |
1089 | ||
1090 | ||
1091 | /* Translate the SELECT CASE construct for CHARACTER case expressions. | |
1092 | Instead of generating compares and jumps, it is far simpler to | |
1093 | generate a data structure describing the cases in order and call a | |
1094 | library subroutine that locates the right case. | |
1095 | This is particularly true because this is the only case where we | |
1096 | might have to dispose of a temporary. | |
1097 | The library subroutine returns a pointer to jump to or NULL if no | |
1098 | branches are to be taken. */ | |
1099 | ||
1100 | static tree | |
1101 | gfc_trans_character_select (gfc_code *code) | |
1102 | { | |
1103 | tree init, node, end_label, tmp, type, args, *labels; | |
1104 | stmtblock_t block, body; | |
1105 | gfc_case *cp, *d; | |
1106 | gfc_code *c; | |
1107 | gfc_se se; | |
1108 | int i, n; | |
1109 | ||
1110 | static tree select_struct; | |
1111 | static tree ss_string1, ss_string1_len; | |
1112 | static tree ss_string2, ss_string2_len; | |
1113 | static tree ss_target; | |
1114 | ||
1115 | if (select_struct == NULL) | |
1116 | { | |
e2cad04b RH |
1117 | tree gfc_int4_type_node = gfc_get_int_type (4); |
1118 | ||
6de9cd9a DN |
1119 | select_struct = make_node (RECORD_TYPE); |
1120 | TYPE_NAME (select_struct) = get_identifier ("_jump_struct"); | |
1121 | ||
1122 | #undef ADD_FIELD | |
1123 | #define ADD_FIELD(NAME, TYPE) \ | |
1124 | ss_##NAME = gfc_add_field_to_struct \ | |
1125 | (&(TYPE_FIELDS (select_struct)), select_struct, \ | |
1126 | get_identifier (stringize(NAME)), TYPE) | |
1127 | ||
1128 | ADD_FIELD (string1, pchar_type_node); | |
1129 | ADD_FIELD (string1_len, gfc_int4_type_node); | |
1130 | ||
1131 | ADD_FIELD (string2, pchar_type_node); | |
1132 | ADD_FIELD (string2_len, gfc_int4_type_node); | |
1133 | ||
1134 | ADD_FIELD (target, pvoid_type_node); | |
1135 | #undef ADD_FIELD | |
1136 | ||
1137 | gfc_finish_type (select_struct); | |
1138 | } | |
1139 | ||
1140 | cp = code->block->ext.case_list; | |
1141 | while (cp->left != NULL) | |
1142 | cp = cp->left; | |
1143 | ||
1144 | n = 0; | |
1145 | for (d = cp; d; d = d->right) | |
1146 | d->n = n++; | |
1147 | ||
1148 | if (n != 0) | |
1149 | labels = gfc_getmem (n * sizeof (tree)); | |
1150 | else | |
1151 | labels = NULL; | |
1152 | ||
1153 | for(i = 0; i < n; i++) | |
1154 | { | |
1155 | labels[i] = gfc_build_label_decl (NULL_TREE); | |
1156 | TREE_USED (labels[i]) = 1; | |
1157 | /* TODO: The gimplifier should do this for us, but it has | |
1158 | inadequacies when dealing with static initializers. */ | |
1159 | FORCED_LABEL (labels[i]) = 1; | |
1160 | } | |
1161 | ||
1162 | end_label = gfc_build_label_decl (NULL_TREE); | |
1163 | ||
1164 | /* Generate the body */ | |
1165 | gfc_start_block (&block); | |
1166 | gfc_init_block (&body); | |
1167 | ||
1168 | for (c = code->block; c; c = c->block) | |
1169 | { | |
1170 | for (d = c->ext.case_list; d; d = d->next) | |
1171 | { | |
923ab88c | 1172 | tmp = build1_v (LABEL_EXPR, labels[d->n]); |
6de9cd9a DN |
1173 | gfc_add_expr_to_block (&body, tmp); |
1174 | } | |
1175 | ||
1176 | tmp = gfc_trans_code (c->next); | |
1177 | gfc_add_expr_to_block (&body, tmp); | |
1178 | ||
923ab88c | 1179 | tmp = build1_v (GOTO_EXPR, end_label); |
6de9cd9a DN |
1180 | gfc_add_expr_to_block (&body, tmp); |
1181 | } | |
1182 | ||
1183 | /* Generate the structure describing the branches */ | |
1184 | init = NULL_TREE; | |
1185 | i = 0; | |
1186 | ||
1187 | for(d = cp; d; d = d->right, i++) | |
1188 | { | |
1189 | node = NULL_TREE; | |
1190 | ||
1191 | gfc_init_se (&se, NULL); | |
1192 | ||
1193 | if (d->low == NULL) | |
1194 | { | |
1195 | node = tree_cons (ss_string1, null_pointer_node, node); | |
1196 | node = tree_cons (ss_string1_len, integer_zero_node, node); | |
1197 | } | |
1198 | else | |
1199 | { | |
1200 | gfc_conv_expr_reference (&se, d->low); | |
1201 | ||
1202 | node = tree_cons (ss_string1, se.expr, node); | |
1203 | node = tree_cons (ss_string1_len, se.string_length, node); | |
1204 | } | |
1205 | ||
1206 | if (d->high == NULL) | |
1207 | { | |
1208 | node = tree_cons (ss_string2, null_pointer_node, node); | |
1209 | node = tree_cons (ss_string2_len, integer_zero_node, node); | |
1210 | } | |
1211 | else | |
1212 | { | |
1213 | gfc_init_se (&se, NULL); | |
1214 | gfc_conv_expr_reference (&se, d->high); | |
1215 | ||
1216 | node = tree_cons (ss_string2, se.expr, node); | |
1217 | node = tree_cons (ss_string2_len, se.string_length, node); | |
1218 | } | |
1219 | ||
1220 | tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]); | |
1221 | node = tree_cons (ss_target, tmp, node); | |
1222 | ||
1223 | tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node)); | |
1224 | init = tree_cons (NULL_TREE, tmp, init); | |
1225 | } | |
1226 | ||
4a90aeeb | 1227 | type = build_array_type (select_struct, build_index_type |
7d60be94 | 1228 | (build_int_cst (NULL_TREE, n - 1))); |
6de9cd9a DN |
1229 | |
1230 | init = build1 (CONSTRUCTOR, type, nreverse(init)); | |
1231 | TREE_CONSTANT (init) = 1; | |
1232 | TREE_INVARIANT (init) = 1; | |
1233 | TREE_STATIC (init) = 1; | |
1234 | /* Create a static variable to hold the jump table. */ | |
1235 | tmp = gfc_create_var (type, "jumptable"); | |
1236 | TREE_CONSTANT (tmp) = 1; | |
1237 | TREE_INVARIANT (tmp) = 1; | |
1238 | TREE_STATIC (tmp) = 1; | |
1239 | DECL_INITIAL (tmp) = init; | |
1240 | init = tmp; | |
1241 | ||
1242 | /* Build an argument list for the library call */ | |
1243 | init = gfc_build_addr_expr (pvoid_type_node, init); | |
1244 | args = gfc_chainon_list (NULL_TREE, init); | |
1245 | ||
7d60be94 | 1246 | tmp = build_int_cst (NULL_TREE, n); |
6de9cd9a DN |
1247 | args = gfc_chainon_list (args, tmp); |
1248 | ||
1249 | tmp = gfc_build_addr_expr (pvoid_type_node, end_label); | |
1250 | args = gfc_chainon_list (args, tmp); | |
1251 | ||
1252 | gfc_init_se (&se, NULL); | |
1253 | gfc_conv_expr_reference (&se, code->expr); | |
1254 | ||
1255 | args = gfc_chainon_list (args, se.expr); | |
1256 | args = gfc_chainon_list (args, se.string_length); | |
1257 | ||
1258 | gfc_add_block_to_block (&block, &se.pre); | |
1259 | ||
1260 | tmp = gfc_build_function_call (gfor_fndecl_select_string, args); | |
1261 | tmp = build1 (GOTO_EXPR, void_type_node, tmp); | |
1262 | gfc_add_expr_to_block (&block, tmp); | |
1263 | ||
1264 | tmp = gfc_finish_block (&body); | |
1265 | gfc_add_expr_to_block (&block, tmp); | |
923ab88c | 1266 | tmp = build1_v (LABEL_EXPR, end_label); |
6de9cd9a DN |
1267 | gfc_add_expr_to_block (&block, tmp); |
1268 | ||
1269 | if (n != 0) | |
1270 | gfc_free (labels); | |
1271 | ||
1272 | return gfc_finish_block (&block); | |
1273 | } | |
1274 | ||
1275 | ||
1276 | /* Translate the three variants of the SELECT CASE construct. | |
1277 | ||
1278 | SELECT CASEs with INTEGER case expressions can be translated to an | |
1279 | equivalent GENERIC switch statement, and for LOGICAL case | |
1280 | expressions we build one or two if-else compares. | |
1281 | ||
1282 | SELECT CASEs with CHARACTER case expressions are a whole different | |
1283 | story, because they don't exist in GENERIC. So we sort them and | |
1284 | do a binary search at runtime. | |
1285 | ||
1286 | Fortran has no BREAK statement, and it does not allow jumps from | |
1287 | one case block to another. That makes things a lot easier for | |
1288 | the optimizers. */ | |
1289 | ||
1290 | tree | |
1291 | gfc_trans_select (gfc_code * code) | |
1292 | { | |
6e45f57b | 1293 | gcc_assert (code && code->expr); |
6de9cd9a DN |
1294 | |
1295 | /* Empty SELECT constructs are legal. */ | |
1296 | if (code->block == NULL) | |
1297 | return build_empty_stmt (); | |
1298 | ||
1299 | /* Select the correct translation function. */ | |
1300 | switch (code->expr->ts.type) | |
1301 | { | |
1302 | case BT_LOGICAL: return gfc_trans_logical_select (code); | |
1303 | case BT_INTEGER: return gfc_trans_integer_select (code); | |
1304 | case BT_CHARACTER: return gfc_trans_character_select (code); | |
1305 | default: | |
1306 | gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); | |
1307 | /* Not reached */ | |
1308 | } | |
1309 | } | |
1310 | ||
1311 | ||
1312 | /* Generate the loops for a FORALL block. The normal loop format: | |
1313 | count = (end - start + step) / step | |
1314 | loopvar = start | |
1315 | while (1) | |
1316 | { | |
1317 | if (count <=0 ) | |
1318 | goto end_of_loop | |
1319 | <body> | |
1320 | loopvar += step | |
1321 | count -- | |
1322 | } | |
1323 | end_of_loop: */ | |
1324 | ||
1325 | static tree | |
1326 | gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag) | |
1327 | { | |
1328 | int n; | |
1329 | tree tmp; | |
1330 | tree cond; | |
1331 | stmtblock_t block; | |
1332 | tree exit_label; | |
1333 | tree count; | |
1334 | tree var, start, end, step, mask, maskindex; | |
1335 | iter_info *iter; | |
1336 | ||
1337 | iter = forall_tmp->this_loop; | |
1338 | for (n = 0; n < nvar; n++) | |
1339 | { | |
1340 | var = iter->var; | |
1341 | start = iter->start; | |
1342 | end = iter->end; | |
1343 | step = iter->step; | |
1344 | ||
1345 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1346 | TREE_USED (exit_label) = 1; | |
1347 | ||
1348 | /* The loop counter. */ | |
1349 | count = gfc_create_var (TREE_TYPE (var), "count"); | |
1350 | ||
1351 | /* The body of the loop. */ | |
1352 | gfc_init_block (&block); | |
1353 | ||
1354 | /* The exit condition. */ | |
923ab88c | 1355 | cond = build2 (LE_EXPR, boolean_type_node, count, integer_zero_node); |
6de9cd9a | 1356 | tmp = build1_v (GOTO_EXPR, exit_label); |
923ab88c | 1357 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1358 | gfc_add_expr_to_block (&block, tmp); |
1359 | ||
1360 | /* The main loop body. */ | |
1361 | gfc_add_expr_to_block (&block, body); | |
1362 | ||
1363 | /* Increment the loop variable. */ | |
923ab88c | 1364 | tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step); |
6de9cd9a DN |
1365 | gfc_add_modify_expr (&block, var, tmp); |
1366 | ||
a8e12e4d TS |
1367 | /* Advance to the next mask element. Only do this for the |
1368 | innermost loop. */ | |
1369 | if (n == 0 && mask_flag) | |
6de9cd9a DN |
1370 | { |
1371 | mask = forall_tmp->mask; | |
1372 | maskindex = forall_tmp->maskindex; | |
1373 | if (mask) | |
1374 | { | |
923ab88c TS |
1375 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, |
1376 | maskindex, gfc_index_one_node); | |
6de9cd9a DN |
1377 | gfc_add_modify_expr (&block, maskindex, tmp); |
1378 | } | |
1379 | } | |
1380 | /* Decrement the loop counter. */ | |
923ab88c | 1381 | tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node); |
6de9cd9a DN |
1382 | gfc_add_modify_expr (&block, count, tmp); |
1383 | ||
1384 | body = gfc_finish_block (&block); | |
1385 | ||
1386 | /* Loop var initialization. */ | |
1387 | gfc_init_block (&block); | |
1388 | gfc_add_modify_expr (&block, var, start); | |
1389 | ||
1390 | /* Initialize the loop counter. */ | |
10c7a96f SB |
1391 | tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start); |
1392 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp); | |
1393 | tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step); | |
6de9cd9a DN |
1394 | gfc_add_modify_expr (&block, count, tmp); |
1395 | ||
1396 | /* The loop expression. */ | |
923ab88c | 1397 | tmp = build1_v (LOOP_EXPR, body); |
6de9cd9a DN |
1398 | gfc_add_expr_to_block (&block, tmp); |
1399 | ||
1400 | /* The exit label. */ | |
1401 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1402 | gfc_add_expr_to_block (&block, tmp); | |
1403 | ||
1404 | body = gfc_finish_block (&block); | |
1405 | iter = iter->next; | |
1406 | } | |
1407 | return body; | |
1408 | } | |
1409 | ||
1410 | ||
1411 | /* Generate the body and loops according to MASK_FLAG and NEST_FLAG. | |
13795658 | 1412 | if MASK_FLAG is nonzero, the body is controlled by maskes in forall |
6de9cd9a | 1413 | nest, otherwise, the body is not controlled by maskes. |
13795658 | 1414 | if NEST_FLAG is nonzero, generate loops for nested forall, otherwise, |
6de9cd9a DN |
1415 | only generate loops for the current forall level. */ |
1416 | ||
1417 | static tree | |
1418 | gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, | |
1419 | int mask_flag, int nest_flag) | |
1420 | { | |
1421 | tree tmp; | |
1422 | int nvar; | |
1423 | forall_info *forall_tmp; | |
1424 | tree pmask, mask, maskindex; | |
1425 | ||
1426 | forall_tmp = nested_forall_info; | |
1427 | /* Generate loops for nested forall. */ | |
1428 | if (nest_flag) | |
1429 | { | |
1430 | while (forall_tmp->next_nest != NULL) | |
1431 | forall_tmp = forall_tmp->next_nest; | |
1432 | while (forall_tmp != NULL) | |
1433 | { | |
1434 | /* Generate body with masks' control. */ | |
1435 | if (mask_flag) | |
1436 | { | |
1437 | pmask = forall_tmp->pmask; | |
1438 | mask = forall_tmp->mask; | |
1439 | maskindex = forall_tmp->maskindex; | |
1440 | ||
1441 | if (mask) | |
1442 | { | |
1f2959f0 | 1443 | /* If a mask was specified make the assignment conditional. */ |
6de9cd9a DN |
1444 | if (pmask) |
1445 | tmp = gfc_build_indirect_ref (mask); | |
1446 | else | |
1447 | tmp = mask; | |
1448 | tmp = gfc_build_array_ref (tmp, maskindex); | |
1449 | ||
923ab88c | 1450 | body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ()); |
6de9cd9a DN |
1451 | } |
1452 | } | |
1453 | nvar = forall_tmp->nvar; | |
1454 | body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag); | |
1455 | forall_tmp = forall_tmp->outer; | |
1456 | } | |
1457 | } | |
1458 | else | |
1459 | { | |
1460 | nvar = forall_tmp->nvar; | |
1461 | body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag); | |
1462 | } | |
1463 | ||
1464 | return body; | |
1465 | } | |
1466 | ||
1467 | ||
1468 | /* Allocate data for holding a temporary array. Returns either a local | |
1469 | temporary array or a pointer variable. */ | |
1470 | ||
1471 | static tree | |
1472 | gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, | |
1473 | tree elem_type) | |
1474 | { | |
1475 | tree tmpvar; | |
1476 | tree type; | |
1477 | tree tmp; | |
1478 | tree args; | |
1479 | ||
1480 | if (INTEGER_CST_P (size)) | |
1481 | { | |
10c7a96f SB |
1482 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, |
1483 | gfc_index_one_node); | |
6de9cd9a DN |
1484 | } |
1485 | else | |
1486 | tmp = NULL_TREE; | |
1487 | ||
7ab92584 | 1488 | type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); |
6de9cd9a DN |
1489 | type = build_array_type (elem_type, type); |
1490 | if (gfc_can_put_var_on_stack (bytesize)) | |
1491 | { | |
6e45f57b | 1492 | gcc_assert (INTEGER_CST_P (size)); |
6de9cd9a DN |
1493 | tmpvar = gfc_create_var (type, "temp"); |
1494 | *pdata = NULL_TREE; | |
1495 | } | |
1496 | else | |
1497 | { | |
1498 | tmpvar = gfc_create_var (build_pointer_type (type), "temp"); | |
1499 | *pdata = convert (pvoid_type_node, tmpvar); | |
1500 | ||
1501 | args = gfc_chainon_list (NULL_TREE, bytesize); | |
1502 | if (gfc_index_integer_kind == 4) | |
1503 | tmp = gfor_fndecl_internal_malloc; | |
1504 | else if (gfc_index_integer_kind == 8) | |
1505 | tmp = gfor_fndecl_internal_malloc64; | |
1506 | else | |
6e45f57b | 1507 | gcc_unreachable (); |
6de9cd9a DN |
1508 | tmp = gfc_build_function_call (tmp, args); |
1509 | tmp = convert (TREE_TYPE (tmpvar), tmp); | |
1510 | gfc_add_modify_expr (pblock, tmpvar, tmp); | |
1511 | } | |
1512 | return tmpvar; | |
1513 | } | |
1514 | ||
1515 | ||
1516 | /* Generate codes to copy the temporary to the actual lhs. */ | |
1517 | ||
1518 | static tree | |
8de1f441 JJ |
1519 | generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, |
1520 | tree count1, tree wheremask) | |
6de9cd9a DN |
1521 | { |
1522 | gfc_ss *lss; | |
1523 | gfc_se lse, rse; | |
1524 | stmtblock_t block, body; | |
1525 | gfc_loopinfo loop1; | |
1526 | tree tmp, tmp2; | |
6de9cd9a DN |
1527 | tree wheremaskexpr; |
1528 | ||
1529 | /* Walk the lhs. */ | |
1530 | lss = gfc_walk_expr (expr); | |
1531 | ||
1532 | if (lss == gfc_ss_terminator) | |
1533 | { | |
1534 | gfc_start_block (&block); | |
1535 | ||
1536 | gfc_init_se (&lse, NULL); | |
1537 | ||
1538 | /* Translate the expression. */ | |
1539 | gfc_conv_expr (&lse, expr); | |
1540 | ||
1541 | /* Form the expression for the temporary. */ | |
1542 | tmp = gfc_build_array_ref (tmp1, count1); | |
1543 | ||
1544 | /* Use the scalar assignment as is. */ | |
1545 | gfc_add_block_to_block (&block, &lse.pre); | |
1546 | gfc_add_modify_expr (&block, lse.expr, tmp); | |
1547 | gfc_add_block_to_block (&block, &lse.post); | |
1548 | ||
1549 | /* Increment the count1. */ | |
8de1f441 JJ |
1550 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, |
1551 | gfc_index_one_node); | |
6de9cd9a | 1552 | gfc_add_modify_expr (&block, count1, tmp); |
8de1f441 | 1553 | |
6de9cd9a DN |
1554 | tmp = gfc_finish_block (&block); |
1555 | } | |
1556 | else | |
1557 | { | |
1558 | gfc_start_block (&block); | |
1559 | ||
1560 | gfc_init_loopinfo (&loop1); | |
1561 | gfc_init_se (&rse, NULL); | |
1562 | gfc_init_se (&lse, NULL); | |
1563 | ||
1564 | /* Associate the lss with the loop. */ | |
1565 | gfc_add_ss_to_loop (&loop1, lss); | |
1566 | ||
1567 | /* Calculate the bounds of the scalarization. */ | |
1568 | gfc_conv_ss_startstride (&loop1); | |
1569 | /* Setup the scalarizing loops. */ | |
1570 | gfc_conv_loop_setup (&loop1); | |
1571 | ||
1572 | gfc_mark_ss_chain_used (lss, 1); | |
6de9cd9a DN |
1573 | |
1574 | /* Start the scalarized loop body. */ | |
1575 | gfc_start_scalarized_body (&loop1, &body); | |
1576 | ||
1577 | /* Setup the gfc_se structures. */ | |
1578 | gfc_copy_loopinfo_to_se (&lse, &loop1); | |
1579 | lse.ss = lss; | |
1580 | ||
1581 | /* Form the expression of the temporary. */ | |
1582 | if (lss != gfc_ss_terminator) | |
8de1f441 | 1583 | rse.expr = gfc_build_array_ref (tmp1, count1); |
6de9cd9a DN |
1584 | /* Translate expr. */ |
1585 | gfc_conv_expr (&lse, expr); | |
1586 | ||
1587 | /* Use the scalar assignment. */ | |
1588 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); | |
1589 | ||
1590 | /* Form the mask expression according to the mask tree list. */ | |
1591 | if (wheremask) | |
1592 | { | |
1ac26262 | 1593 | wheremaskexpr = gfc_build_array_ref (wheremask, count3); |
8de1f441 JJ |
1594 | tmp2 = TREE_CHAIN (wheremask); |
1595 | while (tmp2) | |
1596 | { | |
1597 | tmp1 = gfc_build_array_ref (tmp2, count3); | |
1598 | wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), | |
923ab88c | 1599 | wheremaskexpr, tmp1); |
8de1f441 JJ |
1600 | tmp2 = TREE_CHAIN (tmp2); |
1601 | } | |
1602 | tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
1603 | } |
1604 | ||
1605 | gfc_add_expr_to_block (&body, tmp); | |
1606 | ||
8de1f441 | 1607 | /* Increment count1. */ |
10c7a96f | 1608 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
8de1f441 JJ |
1609 | count1, gfc_index_one_node); |
1610 | gfc_add_modify_expr (&body, count1, tmp); | |
6de9cd9a DN |
1611 | |
1612 | /* Increment count3. */ | |
1613 | if (count3) | |
8de1f441 JJ |
1614 | { |
1615 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, | |
10c7a96f | 1616 | count3, gfc_index_one_node); |
8de1f441 JJ |
1617 | gfc_add_modify_expr (&body, count3, tmp); |
1618 | } | |
6de9cd9a DN |
1619 | |
1620 | /* Generate the copying loops. */ | |
1621 | gfc_trans_scalarizing_loops (&loop1, &body); | |
1622 | gfc_add_block_to_block (&block, &loop1.pre); | |
1623 | gfc_add_block_to_block (&block, &loop1.post); | |
1624 | gfc_cleanup_loop (&loop1); | |
1625 | ||
6de9cd9a DN |
1626 | tmp = gfc_finish_block (&block); |
1627 | } | |
1628 | return tmp; | |
1629 | } | |
1630 | ||
1631 | ||
1632 | /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary | |
1633 | LSS and RSS are formed in function compute_inner_temp_size(), and should | |
1634 | not be freed. */ | |
1635 | ||
1636 | static tree | |
8de1f441 JJ |
1637 | generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, |
1638 | tree count1, gfc_ss *lss, gfc_ss *rss, | |
1639 | tree wheremask) | |
6de9cd9a DN |
1640 | { |
1641 | stmtblock_t block, body1; | |
1642 | gfc_loopinfo loop; | |
1643 | gfc_se lse; | |
1644 | gfc_se rse; | |
8de1f441 | 1645 | tree tmp, tmp2; |
6de9cd9a DN |
1646 | tree wheremaskexpr; |
1647 | ||
1648 | gfc_start_block (&block); | |
1649 | ||
1650 | gfc_init_se (&rse, NULL); | |
1651 | gfc_init_se (&lse, NULL); | |
1652 | ||
1653 | if (lss == gfc_ss_terminator) | |
1654 | { | |
1655 | gfc_init_block (&body1); | |
1656 | gfc_conv_expr (&rse, expr2); | |
1657 | lse.expr = gfc_build_array_ref (tmp1, count1); | |
1658 | } | |
1659 | else | |
1660 | { | |
1f2959f0 | 1661 | /* Initialize the loop. */ |
6de9cd9a DN |
1662 | gfc_init_loopinfo (&loop); |
1663 | ||
1664 | /* We may need LSS to determine the shape of the expression. */ | |
1665 | gfc_add_ss_to_loop (&loop, lss); | |
1666 | gfc_add_ss_to_loop (&loop, rss); | |
1667 | ||
1668 | gfc_conv_ss_startstride (&loop); | |
1669 | gfc_conv_loop_setup (&loop); | |
1670 | ||
1671 | gfc_mark_ss_chain_used (rss, 1); | |
1672 | /* Start the loop body. */ | |
1673 | gfc_start_scalarized_body (&loop, &body1); | |
1674 | ||
1675 | /* Translate the expression. */ | |
1676 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
1677 | rse.ss = rss; | |
1678 | gfc_conv_expr (&rse, expr2); | |
1679 | ||
1680 | /* Form the expression of the temporary. */ | |
8de1f441 | 1681 | lse.expr = gfc_build_array_ref (tmp1, count1); |
6de9cd9a DN |
1682 | } |
1683 | ||
1684 | /* Use the scalar assignment. */ | |
1685 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type); | |
1686 | ||
1687 | /* Form the mask expression according to the mask tree list. */ | |
1688 | if (wheremask) | |
1689 | { | |
1ac26262 TS |
1690 | wheremaskexpr = gfc_build_array_ref (wheremask, count3); |
1691 | tmp2 = TREE_CHAIN (wheremask); | |
6de9cd9a | 1692 | while (tmp2) |
8de1f441 JJ |
1693 | { |
1694 | tmp1 = gfc_build_array_ref (tmp2, count3); | |
1695 | wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), | |
923ab88c | 1696 | wheremaskexpr, tmp1); |
8de1f441 JJ |
1697 | tmp2 = TREE_CHAIN (tmp2); |
1698 | } | |
923ab88c | 1699 | tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1700 | } |
1701 | ||
1702 | gfc_add_expr_to_block (&body1, tmp); | |
1703 | ||
1704 | if (lss == gfc_ss_terminator) | |
1705 | { | |
1706 | gfc_add_block_to_block (&block, &body1); | |
8de1f441 JJ |
1707 | |
1708 | /* Increment count1. */ | |
1709 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, | |
1710 | gfc_index_one_node); | |
1711 | gfc_add_modify_expr (&block, count1, tmp); | |
6de9cd9a DN |
1712 | } |
1713 | else | |
1714 | { | |
8de1f441 | 1715 | /* Increment count1. */ |
10c7a96f | 1716 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
8de1f441 JJ |
1717 | count1, gfc_index_one_node); |
1718 | gfc_add_modify_expr (&body1, count1, tmp); | |
6de9cd9a DN |
1719 | |
1720 | /* Increment count3. */ | |
1721 | if (count3) | |
8de1f441 JJ |
1722 | { |
1723 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, | |
10c7a96f | 1724 | count3, gfc_index_one_node); |
8de1f441 JJ |
1725 | gfc_add_modify_expr (&body1, count3, tmp); |
1726 | } | |
6de9cd9a DN |
1727 | |
1728 | /* Generate the copying loops. */ | |
1729 | gfc_trans_scalarizing_loops (&loop, &body1); | |
1730 | ||
1731 | gfc_add_block_to_block (&block, &loop.pre); | |
1732 | gfc_add_block_to_block (&block, &loop.post); | |
1733 | ||
1734 | gfc_cleanup_loop (&loop); | |
1735 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
8de1f441 | 1736 | as tree nodes in SS may not be valid in different scope. */ |
6de9cd9a | 1737 | } |
6de9cd9a DN |
1738 | |
1739 | tmp = gfc_finish_block (&block); | |
1740 | return tmp; | |
1741 | } | |
1742 | ||
1743 | ||
1744 | /* Calculate the size of temporary needed in the assignment inside forall. | |
1745 | LSS and RSS are filled in this function. */ | |
1746 | ||
1747 | static tree | |
1748 | compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, | |
1749 | stmtblock_t * pblock, | |
1750 | gfc_ss **lss, gfc_ss **rss) | |
1751 | { | |
1752 | gfc_loopinfo loop; | |
1753 | tree size; | |
1754 | int i; | |
1755 | tree tmp; | |
1756 | ||
1757 | *lss = gfc_walk_expr (expr1); | |
1758 | *rss = NULL; | |
1759 | ||
7ab92584 | 1760 | size = gfc_index_one_node; |
6de9cd9a DN |
1761 | if (*lss != gfc_ss_terminator) |
1762 | { | |
1763 | gfc_init_loopinfo (&loop); | |
1764 | ||
1765 | /* Walk the RHS of the expression. */ | |
1766 | *rss = gfc_walk_expr (expr2); | |
1767 | if (*rss == gfc_ss_terminator) | |
1768 | { | |
1769 | /* The rhs is scalar. Add a ss for the expression. */ | |
1770 | *rss = gfc_get_ss (); | |
1771 | (*rss)->next = gfc_ss_terminator; | |
1772 | (*rss)->type = GFC_SS_SCALAR; | |
1773 | (*rss)->expr = expr2; | |
1774 | } | |
1775 | ||
1776 | /* Associate the SS with the loop. */ | |
1777 | gfc_add_ss_to_loop (&loop, *lss); | |
1778 | /* We don't actually need to add the rhs at this point, but it might | |
1779 | make guessing the loop bounds a bit easier. */ | |
1780 | gfc_add_ss_to_loop (&loop, *rss); | |
1781 | ||
1782 | /* We only want the shape of the expression, not rest of the junk | |
1783 | generated by the scalarizer. */ | |
1784 | loop.array_parameter = 1; | |
1785 | ||
1786 | /* Calculate the bounds of the scalarization. */ | |
1787 | gfc_conv_ss_startstride (&loop); | |
1788 | gfc_conv_loop_setup (&loop); | |
1789 | ||
1790 | /* Figure out how many elements we need. */ | |
1791 | for (i = 0; i < loop.dimen; i++) | |
1792 | { | |
10c7a96f SB |
1793 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, |
1794 | gfc_index_one_node, loop.from[i]); | |
1795 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, | |
1796 | tmp, loop.to[i]); | |
1797 | size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); | |
6de9cd9a DN |
1798 | } |
1799 | gfc_add_block_to_block (pblock, &loop.pre); | |
1800 | size = gfc_evaluate_now (size, pblock); | |
1801 | gfc_add_block_to_block (pblock, &loop.post); | |
1802 | ||
1803 | /* TODO: write a function that cleans up a loopinfo without freeing | |
1804 | the SS chains. Currently a NOP. */ | |
1805 | } | |
1806 | ||
1807 | return size; | |
1808 | } | |
1809 | ||
1810 | ||
1811 | /* Calculate the overall iterator number of the nested forall construct. */ | |
1812 | ||
1813 | static tree | |
1814 | compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, | |
8de1f441 | 1815 | stmtblock_t *inner_size_body, stmtblock_t *block) |
6de9cd9a DN |
1816 | { |
1817 | tree tmp, number; | |
1818 | stmtblock_t body; | |
1819 | ||
1820 | /* TODO: optimizing the computing process. */ | |
1821 | number = gfc_create_var (gfc_array_index_type, "num"); | |
7ab92584 | 1822 | gfc_add_modify_expr (block, number, gfc_index_zero_node); |
6de9cd9a DN |
1823 | |
1824 | gfc_start_block (&body); | |
8de1f441 JJ |
1825 | if (inner_size_body) |
1826 | gfc_add_block_to_block (&body, inner_size_body); | |
6de9cd9a | 1827 | if (nested_forall_info) |
923ab88c TS |
1828 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, number, |
1829 | inner_size); | |
6de9cd9a DN |
1830 | else |
1831 | tmp = inner_size; | |
1832 | gfc_add_modify_expr (&body, number, tmp); | |
1833 | tmp = gfc_finish_block (&body); | |
1834 | ||
1835 | /* Generate loops. */ | |
1836 | if (nested_forall_info != NULL) | |
1837 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1); | |
1838 | ||
1839 | gfc_add_expr_to_block (block, tmp); | |
1840 | ||
1841 | return number; | |
1842 | } | |
1843 | ||
1844 | ||
8de1f441 JJ |
1845 | /* Allocate temporary for forall construct. SIZE is the size of temporary |
1846 | needed. PTEMP1 is returned for space free. */ | |
6de9cd9a DN |
1847 | |
1848 | static tree | |
8de1f441 JJ |
1849 | allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, |
1850 | tree * ptemp1) | |
6de9cd9a DN |
1851 | { |
1852 | tree unit; | |
1853 | tree temp1; | |
1854 | tree tmp; | |
8de1f441 | 1855 | tree bytesize; |
6de9cd9a DN |
1856 | |
1857 | unit = TYPE_SIZE_UNIT (type); | |
10c7a96f | 1858 | bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit); |
6de9cd9a DN |
1859 | |
1860 | *ptemp1 = NULL; | |
1861 | temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type); | |
1862 | ||
1863 | if (*ptemp1) | |
1864 | tmp = gfc_build_indirect_ref (temp1); | |
1865 | else | |
1866 | tmp = temp1; | |
1867 | ||
1868 | return tmp; | |
1869 | } | |
1870 | ||
1871 | ||
8de1f441 JJ |
1872 | /* Allocate temporary for forall construct according to the information in |
1873 | nested_forall_info. INNER_SIZE is the size of temporary needed in the | |
1874 | assignment inside forall. PTEMP1 is returned for space free. */ | |
1875 | ||
1876 | static tree | |
1877 | allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, | |
1878 | tree inner_size, stmtblock_t * inner_size_body, | |
1879 | stmtblock_t * block, tree * ptemp1) | |
1880 | { | |
1881 | tree size; | |
1882 | ||
1883 | /* Calculate the total size of temporary needed in forall construct. */ | |
1884 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
1885 | inner_size_body, block); | |
1886 | ||
1887 | return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); | |
1888 | } | |
1889 | ||
1890 | ||
1891 | /* Handle assignments inside forall which need temporary. | |
1892 | ||
1893 | forall (i=start:end:stride; maskexpr) | |
1894 | e<i> = f<i> | |
1895 | end forall | |
1896 | (where e,f<i> are arbitrary expressions possibly involving i | |
1897 | and there is a dependency between e<i> and f<i>) | |
1898 | Translates to: | |
1899 | masktmp(:) = maskexpr(:) | |
1900 | ||
1901 | maskindex = 0; | |
1902 | count1 = 0; | |
1903 | num = 0; | |
1904 | for (i = start; i <= end; i += stride) | |
1905 | num += SIZE (f<i>) | |
1906 | count1 = 0; | |
1907 | ALLOCATE (tmp(num)) | |
1908 | for (i = start; i <= end; i += stride) | |
1909 | { | |
1910 | if (masktmp[maskindex++]) | |
1911 | tmp[count1++] = f<i> | |
1912 | } | |
1913 | maskindex = 0; | |
1914 | count1 = 0; | |
1915 | for (i = start; i <= end; i += stride) | |
1916 | { | |
1917 | if (masktmp[maskindex++]) | |
1918 | e<i> = tmp[count1++] | |
1919 | } | |
1920 | DEALLOCATE (tmp) | |
1921 | */ | |
6de9cd9a DN |
1922 | static void |
1923 | gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask, | |
1924 | forall_info * nested_forall_info, | |
1925 | stmtblock_t * block) | |
1926 | { | |
1927 | tree type; | |
1928 | tree inner_size; | |
1929 | gfc_ss *lss, *rss; | |
8de1f441 | 1930 | tree count, count1; |
6de9cd9a DN |
1931 | tree tmp, tmp1; |
1932 | tree ptemp1; | |
1933 | tree mask, maskindex; | |
1934 | forall_info *forall_tmp; | |
8de1f441 | 1935 | stmtblock_t inner_size_body; |
6de9cd9a | 1936 | |
8de1f441 JJ |
1937 | /* Create vars. count1 is the current iterator number of the nested |
1938 | forall. */ | |
6de9cd9a | 1939 | count1 = gfc_create_var (gfc_array_index_type, "count1"); |
6de9cd9a DN |
1940 | |
1941 | /* Count is the wheremask index. */ | |
1942 | if (wheremask) | |
1943 | { | |
1944 | count = gfc_create_var (gfc_array_index_type, "count"); | |
7ab92584 | 1945 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
1946 | } |
1947 | else | |
1948 | count = NULL; | |
1949 | ||
1950 | /* Initialize count1. */ | |
7ab92584 | 1951 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
6de9cd9a DN |
1952 | |
1953 | /* Calculate the size of temporary needed in the assignment. Return loop, lss | |
1954 | and rss which are used in function generate_loop_for_rhs_to_temp(). */ | |
8de1f441 JJ |
1955 | gfc_init_block (&inner_size_body); |
1956 | inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, | |
1957 | &lss, &rss); | |
6de9cd9a DN |
1958 | |
1959 | /* The type of LHS. Used in function allocate_temp_for_forall_nest */ | |
1960 | type = gfc_typenode_for_spec (&expr1->ts); | |
1961 | ||
1962 | /* Allocate temporary for nested forall construct according to the | |
f7b529fa | 1963 | information in nested_forall_info and inner_size. */ |
8de1f441 JJ |
1964 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, |
1965 | &inner_size_body, block, &ptemp1); | |
6de9cd9a DN |
1966 | |
1967 | /* Initialize the maskindexes. */ | |
1968 | forall_tmp = nested_forall_info; | |
1969 | while (forall_tmp != NULL) | |
1970 | { | |
1971 | mask = forall_tmp->mask; | |
1972 | maskindex = forall_tmp->maskindex; | |
1973 | if (mask) | |
7ab92584 | 1974 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
1975 | forall_tmp = forall_tmp->next_nest; |
1976 | } | |
1977 | ||
1978 | /* Generate codes to copy rhs to the temporary . */ | |
8de1f441 JJ |
1979 | tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, |
1980 | wheremask); | |
6de9cd9a | 1981 | |
1f2959f0 | 1982 | /* Generate body and loops according to the information in |
6de9cd9a DN |
1983 | nested_forall_info. */ |
1984 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
1985 | gfc_add_expr_to_block (block, tmp); | |
1986 | ||
1987 | /* Reset count1. */ | |
7ab92584 | 1988 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
6de9cd9a DN |
1989 | |
1990 | /* Reset maskindexed. */ | |
1991 | forall_tmp = nested_forall_info; | |
1992 | while (forall_tmp != NULL) | |
1993 | { | |
1994 | mask = forall_tmp->mask; | |
1995 | maskindex = forall_tmp->maskindex; | |
1996 | if (mask) | |
7ab92584 | 1997 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
1998 | forall_tmp = forall_tmp->next_nest; |
1999 | } | |
2000 | ||
2001 | /* Reset count. */ | |
2002 | if (wheremask) | |
7ab92584 | 2003 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2004 | |
2005 | /* Generate codes to copy the temporary to lhs. */ | |
8de1f441 | 2006 | tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, wheremask); |
6de9cd9a | 2007 | |
1f2959f0 | 2008 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2009 | nested_forall_info. */ |
2010 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2011 | gfc_add_expr_to_block (block, tmp); | |
2012 | ||
2013 | if (ptemp1) | |
2014 | { | |
2015 | /* Free the temporary. */ | |
2016 | tmp = gfc_chainon_list (NULL_TREE, ptemp1); | |
2017 | tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); | |
2018 | gfc_add_expr_to_block (block, tmp); | |
2019 | } | |
2020 | } | |
2021 | ||
2022 | ||
2023 | /* Translate pointer assignment inside FORALL which need temporary. */ | |
2024 | ||
2025 | static void | |
2026 | gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, | |
2027 | forall_info * nested_forall_info, | |
2028 | stmtblock_t * block) | |
2029 | { | |
2030 | tree type; | |
2031 | tree inner_size; | |
2032 | gfc_ss *lss, *rss; | |
2033 | gfc_se lse; | |
2034 | gfc_se rse; | |
2035 | gfc_ss_info *info; | |
2036 | gfc_loopinfo loop; | |
2037 | tree desc; | |
2038 | tree parm; | |
2039 | tree parmtype; | |
2040 | stmtblock_t body; | |
2041 | tree count; | |
2042 | tree tmp, tmp1, ptemp1; | |
2043 | tree mask, maskindex; | |
2044 | forall_info *forall_tmp; | |
2045 | ||
2046 | count = gfc_create_var (gfc_array_index_type, "count"); | |
7ab92584 | 2047 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2048 | |
2049 | inner_size = integer_one_node; | |
2050 | lss = gfc_walk_expr (expr1); | |
2051 | rss = gfc_walk_expr (expr2); | |
2052 | if (lss == gfc_ss_terminator) | |
2053 | { | |
2054 | type = gfc_typenode_for_spec (&expr1->ts); | |
2055 | type = build_pointer_type (type); | |
2056 | ||
2057 | /* Allocate temporary for nested forall construct according to the | |
2058 | information in nested_forall_info and inner_size. */ | |
8de1f441 JJ |
2059 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, |
2060 | inner_size, NULL, block, &ptemp1); | |
6de9cd9a DN |
2061 | gfc_start_block (&body); |
2062 | gfc_init_se (&lse, NULL); | |
2063 | lse.expr = gfc_build_array_ref (tmp1, count); | |
2064 | gfc_init_se (&rse, NULL); | |
2065 | rse.want_pointer = 1; | |
2066 | gfc_conv_expr (&rse, expr2); | |
2067 | gfc_add_block_to_block (&body, &rse.pre); | |
2068 | gfc_add_modify_expr (&body, lse.expr, rse.expr); | |
2069 | gfc_add_block_to_block (&body, &rse.post); | |
2070 | ||
2071 | /* Increment count. */ | |
10c7a96f SB |
2072 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2073 | count, gfc_index_one_node); | |
6de9cd9a DN |
2074 | gfc_add_modify_expr (&body, count, tmp); |
2075 | ||
2076 | tmp = gfc_finish_block (&body); | |
2077 | ||
2078 | /* Initialize the maskindexes. */ | |
2079 | forall_tmp = nested_forall_info; | |
2080 | while (forall_tmp != NULL) | |
2081 | { | |
2082 | mask = forall_tmp->mask; | |
2083 | maskindex = forall_tmp->maskindex; | |
2084 | if (mask) | |
7ab92584 | 2085 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2086 | forall_tmp = forall_tmp->next_nest; |
2087 | } | |
2088 | ||
1f2959f0 | 2089 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2090 | nested_forall_info. */ |
2091 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2092 | gfc_add_expr_to_block (block, tmp); | |
2093 | ||
2094 | /* Reset count. */ | |
7ab92584 | 2095 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2096 | |
2097 | /* Reset maskindexes. */ | |
2098 | forall_tmp = nested_forall_info; | |
2099 | while (forall_tmp != NULL) | |
2100 | { | |
2101 | mask = forall_tmp->mask; | |
2102 | maskindex = forall_tmp->maskindex; | |
2103 | if (mask) | |
7ab92584 | 2104 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2105 | forall_tmp = forall_tmp->next_nest; |
2106 | } | |
2107 | gfc_start_block (&body); | |
2108 | gfc_init_se (&lse, NULL); | |
2109 | gfc_init_se (&rse, NULL); | |
2110 | rse.expr = gfc_build_array_ref (tmp1, count); | |
2111 | lse.want_pointer = 1; | |
2112 | gfc_conv_expr (&lse, expr1); | |
2113 | gfc_add_block_to_block (&body, &lse.pre); | |
2114 | gfc_add_modify_expr (&body, lse.expr, rse.expr); | |
2115 | gfc_add_block_to_block (&body, &lse.post); | |
2116 | /* Increment count. */ | |
10c7a96f SB |
2117 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2118 | count, gfc_index_one_node); | |
6de9cd9a DN |
2119 | gfc_add_modify_expr (&body, count, tmp); |
2120 | tmp = gfc_finish_block (&body); | |
2121 | ||
1f2959f0 | 2122 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2123 | nested_forall_info. */ |
2124 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2125 | gfc_add_expr_to_block (block, tmp); | |
2126 | } | |
2127 | else | |
2128 | { | |
2129 | gfc_init_loopinfo (&loop); | |
2130 | ||
2131 | /* Associate the SS with the loop. */ | |
2132 | gfc_add_ss_to_loop (&loop, rss); | |
2133 | ||
2134 | /* Setup the scalarizing loops and bounds. */ | |
2135 | gfc_conv_ss_startstride (&loop); | |
2136 | ||
2137 | gfc_conv_loop_setup (&loop); | |
2138 | ||
2139 | info = &rss->data.info; | |
2140 | desc = info->descriptor; | |
2141 | ||
2142 | /* Make a new descriptor. */ | |
2143 | parmtype = gfc_get_element_type (TREE_TYPE (desc)); | |
2144 | parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, | |
2145 | loop.from, loop.to, 1); | |
2146 | ||
2147 | /* Allocate temporary for nested forall construct. */ | |
2148 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, | |
8de1f441 | 2149 | inner_size, NULL, block, &ptemp1); |
6de9cd9a DN |
2150 | gfc_start_block (&body); |
2151 | gfc_init_se (&lse, NULL); | |
2152 | lse.expr = gfc_build_array_ref (tmp1, count); | |
2153 | lse.direct_byref = 1; | |
2154 | rss = gfc_walk_expr (expr2); | |
2155 | gfc_conv_expr_descriptor (&lse, expr2, rss); | |
2156 | ||
2157 | gfc_add_block_to_block (&body, &lse.pre); | |
2158 | gfc_add_block_to_block (&body, &lse.post); | |
2159 | ||
2160 | /* Increment count. */ | |
10c7a96f SB |
2161 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2162 | count, gfc_index_one_node); | |
6de9cd9a DN |
2163 | gfc_add_modify_expr (&body, count, tmp); |
2164 | ||
2165 | tmp = gfc_finish_block (&body); | |
2166 | ||
2167 | /* Initialize the maskindexes. */ | |
2168 | forall_tmp = nested_forall_info; | |
2169 | while (forall_tmp != NULL) | |
2170 | { | |
2171 | mask = forall_tmp->mask; | |
2172 | maskindex = forall_tmp->maskindex; | |
2173 | if (mask) | |
7ab92584 | 2174 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2175 | forall_tmp = forall_tmp->next_nest; |
2176 | } | |
2177 | ||
1f2959f0 | 2178 | /* Generate body and loops according to the information in |
6de9cd9a DN |
2179 | nested_forall_info. */ |
2180 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2181 | gfc_add_expr_to_block (block, tmp); | |
2182 | ||
2183 | /* Reset count. */ | |
7ab92584 | 2184 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2185 | |
2186 | /* Reset maskindexes. */ | |
2187 | forall_tmp = nested_forall_info; | |
2188 | while (forall_tmp != NULL) | |
2189 | { | |
2190 | mask = forall_tmp->mask; | |
2191 | maskindex = forall_tmp->maskindex; | |
2192 | if (mask) | |
7ab92584 | 2193 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2194 | forall_tmp = forall_tmp->next_nest; |
2195 | } | |
2196 | parm = gfc_build_array_ref (tmp1, count); | |
2197 | lss = gfc_walk_expr (expr1); | |
2198 | gfc_init_se (&lse, NULL); | |
2199 | gfc_conv_expr_descriptor (&lse, expr1, lss); | |
2200 | gfc_add_modify_expr (&lse.pre, lse.expr, parm); | |
2201 | gfc_start_block (&body); | |
2202 | gfc_add_block_to_block (&body, &lse.pre); | |
2203 | gfc_add_block_to_block (&body, &lse.post); | |
2204 | ||
2205 | /* Increment count. */ | |
10c7a96f SB |
2206 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2207 | count, gfc_index_one_node); | |
6de9cd9a DN |
2208 | gfc_add_modify_expr (&body, count, tmp); |
2209 | ||
2210 | tmp = gfc_finish_block (&body); | |
2211 | ||
2212 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); | |
2213 | gfc_add_expr_to_block (block, tmp); | |
2214 | } | |
2215 | /* Free the temporary. */ | |
2216 | if (ptemp1) | |
2217 | { | |
2218 | tmp = gfc_chainon_list (NULL_TREE, ptemp1); | |
2219 | tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); | |
2220 | gfc_add_expr_to_block (block, tmp); | |
2221 | } | |
2222 | } | |
2223 | ||
2224 | ||
2225 | /* FORALL and WHERE statements are really nasty, especially when you nest | |
2226 | them. All the rhs of a forall assignment must be evaluated before the | |
2227 | actual assignments are performed. Presumably this also applies to all the | |
2228 | assignments in an inner where statement. */ | |
2229 | ||
2230 | /* Generate code for a FORALL statement. Any temporaries are allocated as a | |
2231 | linear array, relying on the fact that we process in the same order in all | |
2232 | loops. | |
2233 | ||
2234 | forall (i=start:end:stride; maskexpr) | |
2235 | e<i> = f<i> | |
2236 | g<i> = h<i> | |
2237 | end forall | |
e7dc5b4f | 2238 | (where e,f,g,h<i> are arbitrary expressions possibly involving i) |
6de9cd9a | 2239 | Translates to: |
8de1f441 | 2240 | count = ((end + 1 - start) / stride) |
6de9cd9a DN |
2241 | masktmp(:) = maskexpr(:) |
2242 | ||
2243 | maskindex = 0; | |
2244 | for (i = start; i <= end; i += stride) | |
2245 | { | |
2246 | if (masktmp[maskindex++]) | |
2247 | e<i> = f<i> | |
2248 | } | |
2249 | maskindex = 0; | |
2250 | for (i = start; i <= end; i += stride) | |
2251 | { | |
2252 | if (masktmp[maskindex++]) | |
cafa34aa | 2253 | g<i> = h<i> |
6de9cd9a DN |
2254 | } |
2255 | ||
2256 | Note that this code only works when there are no dependencies. | |
2257 | Forall loop with array assignments and data dependencies are a real pain, | |
2258 | because the size of the temporary cannot always be determined before the | |
1f2959f0 | 2259 | loop is executed. This problem is compounded by the presence of nested |
6de9cd9a DN |
2260 | FORALL constructs. |
2261 | */ | |
2262 | ||
2263 | static tree | |
2264 | gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) | |
2265 | { | |
2266 | stmtblock_t block; | |
2267 | stmtblock_t body; | |
2268 | tree *var; | |
2269 | tree *start; | |
2270 | tree *end; | |
2271 | tree *step; | |
2272 | gfc_expr **varexpr; | |
2273 | tree tmp; | |
2274 | tree assign; | |
2275 | tree size; | |
2276 | tree bytesize; | |
2277 | tree tmpvar; | |
2278 | tree sizevar; | |
2279 | tree lenvar; | |
2280 | tree maskindex; | |
2281 | tree mask; | |
2282 | tree pmask; | |
2283 | int n; | |
2284 | int nvar; | |
2285 | int need_temp; | |
2286 | gfc_forall_iterator *fa; | |
2287 | gfc_se se; | |
2288 | gfc_code *c; | |
7b5b57b7 | 2289 | gfc_saved_var *saved_vars; |
6de9cd9a DN |
2290 | iter_info *this_forall, *iter_tmp; |
2291 | forall_info *info, *forall_tmp; | |
2292 | temporary_list *temp; | |
2293 | ||
2294 | gfc_start_block (&block); | |
2295 | ||
2296 | n = 0; | |
2297 | /* Count the FORALL index number. */ | |
2298 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
2299 | n++; | |
2300 | nvar = n; | |
2301 | ||
2302 | /* Allocate the space for var, start, end, step, varexpr. */ | |
2303 | var = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2304 | start = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2305 | end = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2306 | step = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
2307 | varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *)); | |
7b5b57b7 | 2308 | saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var)); |
6de9cd9a DN |
2309 | |
2310 | /* Allocate the space for info. */ | |
2311 | info = (forall_info *) gfc_getmem (sizeof (forall_info)); | |
2312 | n = 0; | |
2313 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
2314 | { | |
2315 | gfc_symbol *sym = fa->var->symtree->n.sym; | |
2316 | ||
2317 | /* allocate space for this_forall. */ | |
2318 | this_forall = (iter_info *) gfc_getmem (sizeof (iter_info)); | |
2319 | ||
6de9cd9a DN |
2320 | /* Create a temporary variable for the FORALL index. */ |
2321 | tmp = gfc_typenode_for_spec (&sym->ts); | |
2322 | var[n] = gfc_create_var (tmp, sym->name); | |
7b5b57b7 PB |
2323 | gfc_shadow_sym (sym, var[n], &saved_vars[n]); |
2324 | ||
6de9cd9a DN |
2325 | /* Record it in this_forall. */ |
2326 | this_forall->var = var[n]; | |
2327 | ||
2328 | /* Replace the index symbol's backend_decl with the temporary decl. */ | |
2329 | sym->backend_decl = var[n]; | |
2330 | ||
2331 | /* Work out the start, end and stride for the loop. */ | |
2332 | gfc_init_se (&se, NULL); | |
2333 | gfc_conv_expr_val (&se, fa->start); | |
2334 | /* Record it in this_forall. */ | |
2335 | this_forall->start = se.expr; | |
2336 | gfc_add_block_to_block (&block, &se.pre); | |
2337 | start[n] = se.expr; | |
2338 | ||
2339 | gfc_init_se (&se, NULL); | |
2340 | gfc_conv_expr_val (&se, fa->end); | |
2341 | /* Record it in this_forall. */ | |
2342 | this_forall->end = se.expr; | |
2343 | gfc_make_safe_expr (&se); | |
2344 | gfc_add_block_to_block (&block, &se.pre); | |
2345 | end[n] = se.expr; | |
2346 | ||
2347 | gfc_init_se (&se, NULL); | |
2348 | gfc_conv_expr_val (&se, fa->stride); | |
2349 | /* Record it in this_forall. */ | |
2350 | this_forall->step = se.expr; | |
2351 | gfc_make_safe_expr (&se); | |
2352 | gfc_add_block_to_block (&block, &se.pre); | |
2353 | step[n] = se.expr; | |
2354 | ||
2355 | /* Set the NEXT field of this_forall to NULL. */ | |
2356 | this_forall->next = NULL; | |
2357 | /* Link this_forall to the info construct. */ | |
2358 | if (info->this_loop == NULL) | |
2359 | info->this_loop = this_forall; | |
2360 | else | |
2361 | { | |
2362 | iter_tmp = info->this_loop; | |
2363 | while (iter_tmp->next != NULL) | |
2364 | iter_tmp = iter_tmp->next; | |
2365 | iter_tmp->next = this_forall; | |
2366 | } | |
2367 | ||
2368 | n++; | |
2369 | } | |
2370 | nvar = n; | |
2371 | ||
2372 | /* Work out the number of elements in the mask array. */ | |
2373 | tmpvar = NULL_TREE; | |
2374 | lenvar = NULL_TREE; | |
7ab92584 | 2375 | size = gfc_index_one_node; |
6de9cd9a DN |
2376 | sizevar = NULL_TREE; |
2377 | ||
2378 | for (n = 0; n < nvar; n++) | |
2379 | { | |
2380 | if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n])) | |
2381 | lenvar = NULL_TREE; | |
2382 | ||
2383 | /* size = (end + step - start) / step. */ | |
10c7a96f SB |
2384 | tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]), |
2385 | step[n], start[n]); | |
2386 | tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp); | |
6de9cd9a | 2387 | |
10c7a96f | 2388 | tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]); |
6de9cd9a DN |
2389 | tmp = convert (gfc_array_index_type, tmp); |
2390 | ||
10c7a96f | 2391 | size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); |
6de9cd9a DN |
2392 | } |
2393 | ||
2394 | /* Record the nvar and size of current forall level. */ | |
2395 | info->nvar = nvar; | |
2396 | info->size = size; | |
2397 | ||
2398 | /* Link the current forall level to nested_forall_info. */ | |
2399 | forall_tmp = nested_forall_info; | |
2400 | if (forall_tmp == NULL) | |
2401 | nested_forall_info = info; | |
2402 | else | |
2403 | { | |
2404 | while (forall_tmp->next_nest != NULL) | |
2405 | forall_tmp = forall_tmp->next_nest; | |
2406 | info->outer = forall_tmp; | |
2407 | forall_tmp->next_nest = info; | |
2408 | } | |
2409 | ||
2410 | /* Copy the mask into a temporary variable if required. | |
f7b529fa | 2411 | For now we assume a mask temporary is needed. */ |
6de9cd9a DN |
2412 | if (code->expr) |
2413 | { | |
2414 | /* Allocate the mask temporary. */ | |
10c7a96f SB |
2415 | bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, |
2416 | TYPE_SIZE_UNIT (boolean_type_node)); | |
6de9cd9a DN |
2417 | |
2418 | mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node); | |
2419 | ||
2420 | maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); | |
2421 | /* Record them in the info structure. */ | |
2422 | info->pmask = pmask; | |
2423 | info->mask = mask; | |
2424 | info->maskindex = maskindex; | |
2425 | ||
7ab92584 | 2426 | gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2427 | |
2428 | /* Start of mask assignment loop body. */ | |
2429 | gfc_start_block (&body); | |
2430 | ||
2431 | /* Evaluate the mask expression. */ | |
2432 | gfc_init_se (&se, NULL); | |
2433 | gfc_conv_expr_val (&se, code->expr); | |
2434 | gfc_add_block_to_block (&body, &se.pre); | |
2435 | ||
2436 | /* Store the mask. */ | |
2437 | se.expr = convert (boolean_type_node, se.expr); | |
2438 | ||
2439 | if (pmask) | |
2440 | tmp = gfc_build_indirect_ref (mask); | |
2441 | else | |
2442 | tmp = mask; | |
2443 | tmp = gfc_build_array_ref (tmp, maskindex); | |
2444 | gfc_add_modify_expr (&body, tmp, se.expr); | |
2445 | ||
2446 | /* Advance to the next mask element. */ | |
923ab88c | 2447 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, |
7ab92584 | 2448 | maskindex, gfc_index_one_node); |
6de9cd9a DN |
2449 | gfc_add_modify_expr (&body, maskindex, tmp); |
2450 | ||
2451 | /* Generate the loops. */ | |
2452 | tmp = gfc_finish_block (&body); | |
2453 | tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0); | |
2454 | gfc_add_expr_to_block (&block, tmp); | |
2455 | } | |
2456 | else | |
2457 | { | |
2458 | /* No mask was specified. */ | |
2459 | maskindex = NULL_TREE; | |
2460 | mask = pmask = NULL_TREE; | |
2461 | } | |
2462 | ||
2463 | c = code->block->next; | |
2464 | ||
2465 | /* TODO: loop merging in FORALL statements. */ | |
2466 | /* Now that we've got a copy of the mask, generate the assignment loops. */ | |
2467 | while (c) | |
2468 | { | |
2469 | switch (c->op) | |
2470 | { | |
2471 | case EXEC_ASSIGN: | |
1f2959f0 | 2472 | /* A scalar or array assignment. */ |
6de9cd9a | 2473 | need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar); |
69de3b83 | 2474 | /* Temporaries due to array assignment data dependencies introduce |
6de9cd9a DN |
2475 | no end of problems. */ |
2476 | if (need_temp) | |
2477 | gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, | |
2478 | nested_forall_info, &block); | |
2479 | else | |
2480 | { | |
2481 | /* Use the normal assignment copying routines. */ | |
2482 | assign = gfc_trans_assignment (c->expr, c->expr2); | |
2483 | ||
2484 | /* Reset the mask index. */ | |
2485 | if (mask) | |
7ab92584 | 2486 | gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2487 | |
2488 | /* Generate body and loops. */ | |
2489 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); | |
2490 | gfc_add_expr_to_block (&block, tmp); | |
2491 | } | |
2492 | ||
2493 | break; | |
2494 | ||
2495 | case EXEC_WHERE: | |
2496 | ||
2497 | /* Translate WHERE or WHERE construct nested in FORALL. */ | |
2498 | temp = NULL; | |
2499 | gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp); | |
2500 | ||
2501 | while (temp) | |
2502 | { | |
2503 | tree args; | |
2504 | temporary_list *p; | |
2505 | ||
2506 | /* Free the temporary. */ | |
2507 | args = gfc_chainon_list (NULL_TREE, temp->temporary); | |
2508 | tmp = gfc_build_function_call (gfor_fndecl_internal_free, args); | |
2509 | gfc_add_expr_to_block (&block, tmp); | |
2510 | ||
2511 | p = temp; | |
2512 | temp = temp->next; | |
2513 | gfc_free (p); | |
2514 | } | |
2515 | ||
2516 | break; | |
2517 | ||
2518 | /* Pointer assignment inside FORALL. */ | |
2519 | case EXEC_POINTER_ASSIGN: | |
2520 | need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar); | |
2521 | if (need_temp) | |
2522 | gfc_trans_pointer_assign_need_temp (c->expr, c->expr2, | |
2523 | nested_forall_info, &block); | |
2524 | else | |
2525 | { | |
2526 | /* Use the normal assignment copying routines. */ | |
2527 | assign = gfc_trans_pointer_assignment (c->expr, c->expr2); | |
2528 | ||
2529 | /* Reset the mask index. */ | |
2530 | if (mask) | |
7ab92584 | 2531 | gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
2532 | |
2533 | /* Generate body and loops. */ | |
2534 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, | |
2535 | 1, 1); | |
2536 | gfc_add_expr_to_block (&block, tmp); | |
2537 | } | |
2538 | break; | |
2539 | ||
2540 | case EXEC_FORALL: | |
2541 | tmp = gfc_trans_forall_1 (c, nested_forall_info); | |
2542 | gfc_add_expr_to_block (&block, tmp); | |
2543 | break; | |
2544 | ||
2545 | default: | |
6e45f57b | 2546 | gcc_unreachable (); |
6de9cd9a DN |
2547 | } |
2548 | ||
2549 | c = c->next; | |
2550 | } | |
2551 | ||
7b5b57b7 PB |
2552 | /* Restore the original index variables. */ |
2553 | for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) | |
2554 | gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); | |
6de9cd9a DN |
2555 | |
2556 | /* Free the space for var, start, end, step, varexpr. */ | |
2557 | gfc_free (var); | |
2558 | gfc_free (start); | |
2559 | gfc_free (end); | |
2560 | gfc_free (step); | |
2561 | gfc_free (varexpr); | |
7b5b57b7 | 2562 | gfc_free (saved_vars); |
6de9cd9a DN |
2563 | |
2564 | if (pmask) | |
2565 | { | |
2566 | /* Free the temporary for the mask. */ | |
2567 | tmp = gfc_chainon_list (NULL_TREE, pmask); | |
2568 | tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); | |
2569 | gfc_add_expr_to_block (&block, tmp); | |
2570 | } | |
2571 | if (maskindex) | |
2572 | pushdecl (maskindex); | |
2573 | ||
2574 | return gfc_finish_block (&block); | |
2575 | } | |
2576 | ||
2577 | ||
2578 | /* Translate the FORALL statement or construct. */ | |
2579 | ||
2580 | tree gfc_trans_forall (gfc_code * code) | |
2581 | { | |
2582 | return gfc_trans_forall_1 (code, NULL); | |
2583 | } | |
2584 | ||
2585 | ||
2586 | /* Evaluate the WHERE mask expression, copy its value to a temporary. | |
2587 | If the WHERE construct is nested in FORALL, compute the overall temporary | |
2588 | needed by the WHERE mask expression multiplied by the iterator number of | |
2589 | the nested forall. | |
2590 | ME is the WHERE mask expression. | |
2591 | MASK is the temporary which value is mask's value. | |
2592 | NMASK is another temporary which value is !mask. | |
2593 | TEMP records the temporary's address allocated in this function in order to | |
2594 | free them outside this function. | |
2595 | MASK, NMASK and TEMP are all OUT arguments. */ | |
2596 | ||
2597 | static tree | |
2598 | gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, | |
2599 | tree * mask, tree * nmask, temporary_list ** temp, | |
2600 | stmtblock_t * block) | |
2601 | { | |
2602 | tree tmp, tmp1; | |
2603 | gfc_ss *lss, *rss; | |
2604 | gfc_loopinfo loop; | |
2605 | tree ptemp1, ntmp, ptemp2; | |
8de1f441 JJ |
2606 | tree inner_size, size; |
2607 | stmtblock_t body, body1, inner_size_body; | |
6de9cd9a DN |
2608 | gfc_se lse, rse; |
2609 | tree count; | |
2610 | tree tmpexpr; | |
2611 | ||
2612 | gfc_init_loopinfo (&loop); | |
2613 | ||
2614 | /* Calculate the size of temporary needed by the mask-expr. */ | |
8de1f441 JJ |
2615 | gfc_init_block (&inner_size_body); |
2616 | inner_size = compute_inner_temp_size (me, me, &inner_size_body, &lss, &rss); | |
2617 | ||
2618 | /* Calculate the total size of temporary needed. */ | |
2619 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
2620 | &inner_size_body, block); | |
6de9cd9a DN |
2621 | |
2622 | /* Allocate temporary for where mask. */ | |
8de1f441 JJ |
2623 | tmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block, |
2624 | &ptemp1); | |
6de9cd9a DN |
2625 | /* Record the temporary address in order to free it later. */ |
2626 | if (ptemp1) | |
2627 | { | |
2628 | temporary_list *tempo; | |
2629 | tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list)); | |
2630 | tempo->temporary = ptemp1; | |
2631 | tempo->next = *temp; | |
2632 | *temp = tempo; | |
2633 | } | |
2634 | ||
2635 | /* Allocate temporary for !mask. */ | |
8de1f441 JJ |
2636 | ntmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block, |
2637 | &ptemp2); | |
6de9cd9a DN |
2638 | /* Record the temporary in order to free it later. */ |
2639 | if (ptemp2) | |
2640 | { | |
2641 | temporary_list *tempo; | |
2642 | tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list)); | |
2643 | tempo->temporary = ptemp2; | |
2644 | tempo->next = *temp; | |
2645 | *temp = tempo; | |
2646 | } | |
2647 | ||
2648 | /* Variable to index the temporary. */ | |
2649 | count = gfc_create_var (gfc_array_index_type, "count"); | |
1f2959f0 | 2650 | /* Initialize count. */ |
7ab92584 | 2651 | gfc_add_modify_expr (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2652 | |
2653 | gfc_start_block (&body); | |
2654 | ||
2655 | gfc_init_se (&rse, NULL); | |
2656 | gfc_init_se (&lse, NULL); | |
2657 | ||
2658 | if (lss == gfc_ss_terminator) | |
2659 | { | |
2660 | gfc_init_block (&body1); | |
2661 | } | |
2662 | else | |
2663 | { | |
1f2959f0 | 2664 | /* Initialize the loop. */ |
6de9cd9a DN |
2665 | gfc_init_loopinfo (&loop); |
2666 | ||
2667 | /* We may need LSS to determine the shape of the expression. */ | |
2668 | gfc_add_ss_to_loop (&loop, lss); | |
2669 | gfc_add_ss_to_loop (&loop, rss); | |
2670 | ||
2671 | gfc_conv_ss_startstride (&loop); | |
2672 | gfc_conv_loop_setup (&loop); | |
2673 | ||
2674 | gfc_mark_ss_chain_used (rss, 1); | |
2675 | /* Start the loop body. */ | |
2676 | gfc_start_scalarized_body (&loop, &body1); | |
2677 | ||
2678 | /* Translate the expression. */ | |
2679 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
2680 | rse.ss = rss; | |
2681 | gfc_conv_expr (&rse, me); | |
2682 | } | |
2683 | /* Form the expression of the temporary. */ | |
2684 | lse.expr = gfc_build_array_ref (tmp, count); | |
2685 | tmpexpr = gfc_build_array_ref (ntmp, count); | |
2686 | ||
2687 | /* Use the scalar assignment to fill temporary TMP. */ | |
2688 | tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type); | |
2689 | gfc_add_expr_to_block (&body1, tmp1); | |
2690 | ||
2691 | /* Fill temporary NTMP. */ | |
2692 | tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr); | |
2693 | gfc_add_modify_expr (&body1, tmpexpr, tmp1); | |
2694 | ||
2695 | if (lss == gfc_ss_terminator) | |
2696 | { | |
2697 | gfc_add_block_to_block (&body, &body1); | |
2698 | } | |
2699 | else | |
2700 | { | |
2701 | /* Increment count. */ | |
10c7a96f SB |
2702 | tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count, |
2703 | gfc_index_one_node); | |
6de9cd9a DN |
2704 | gfc_add_modify_expr (&body1, count, tmp1); |
2705 | ||
2706 | /* Generate the copying loops. */ | |
2707 | gfc_trans_scalarizing_loops (&loop, &body1); | |
2708 | ||
2709 | gfc_add_block_to_block (&body, &loop.pre); | |
2710 | gfc_add_block_to_block (&body, &loop.post); | |
2711 | ||
2712 | gfc_cleanup_loop (&loop); | |
2713 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
2714 | as tree nodes in SS may not be valid in different scope. */ | |
2715 | } | |
2716 | ||
2717 | tmp1 = gfc_finish_block (&body); | |
2718 | /* If the WHERE construct is inside FORALL, fill the full temporary. */ | |
2719 | if (nested_forall_info != NULL) | |
8de1f441 JJ |
2720 | { |
2721 | forall_info *forall_tmp; | |
2722 | tree maskindex; | |
6de9cd9a | 2723 | |
8de1f441 JJ |
2724 | /* Initialize the maskindexes. */ |
2725 | forall_tmp = nested_forall_info; | |
2726 | while (forall_tmp != NULL) | |
2727 | { | |
2728 | maskindex = forall_tmp->maskindex; | |
2729 | if (forall_tmp->mask) | |
2730 | gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); | |
2731 | forall_tmp = forall_tmp->next_nest; | |
2732 | } | |
2733 | ||
2734 | tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); | |
2735 | } | |
6de9cd9a DN |
2736 | |
2737 | gfc_add_expr_to_block (block, tmp1); | |
2738 | ||
2739 | *mask = tmp; | |
2740 | *nmask = ntmp; | |
2741 | ||
2742 | return tmp1; | |
2743 | } | |
2744 | ||
2745 | ||
2746 | /* Translate an assignment statement in a WHERE statement or construct | |
2747 | statement. The MASK expression is used to control which elements | |
2748 | of EXPR1 shall be assigned. */ | |
2749 | ||
2750 | static tree | |
2751 | gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask, | |
2752 | tree count1, tree count2) | |
2753 | { | |
2754 | gfc_se lse; | |
2755 | gfc_se rse; | |
2756 | gfc_ss *lss; | |
2757 | gfc_ss *lss_section; | |
2758 | gfc_ss *rss; | |
2759 | ||
2760 | gfc_loopinfo loop; | |
2761 | tree tmp; | |
2762 | stmtblock_t block; | |
2763 | stmtblock_t body; | |
2764 | tree index, maskexpr, tmp1; | |
2765 | ||
2766 | #if 0 | |
2767 | /* TODO: handle this special case. | |
2768 | Special case a single function returning an array. */ | |
2769 | if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) | |
2770 | { | |
2771 | tmp = gfc_trans_arrayfunc_assign (expr1, expr2); | |
2772 | if (tmp) | |
2773 | return tmp; | |
2774 | } | |
2775 | #endif | |
2776 | ||
2777 | /* Assignment of the form lhs = rhs. */ | |
2778 | gfc_start_block (&block); | |
2779 | ||
2780 | gfc_init_se (&lse, NULL); | |
2781 | gfc_init_se (&rse, NULL); | |
2782 | ||
2783 | /* Walk the lhs. */ | |
2784 | lss = gfc_walk_expr (expr1); | |
2785 | rss = NULL; | |
2786 | ||
2787 | /* In each where-assign-stmt, the mask-expr and the variable being | |
2788 | defined shall be arrays of the same shape. */ | |
6e45f57b | 2789 | gcc_assert (lss != gfc_ss_terminator); |
6de9cd9a DN |
2790 | |
2791 | /* The assignment needs scalarization. */ | |
2792 | lss_section = lss; | |
2793 | ||
2794 | /* Find a non-scalar SS from the lhs. */ | |
2795 | while (lss_section != gfc_ss_terminator | |
2796 | && lss_section->type != GFC_SS_SECTION) | |
2797 | lss_section = lss_section->next; | |
2798 | ||
6e45f57b | 2799 | gcc_assert (lss_section != gfc_ss_terminator); |
6de9cd9a DN |
2800 | |
2801 | /* Initialize the scalarizer. */ | |
2802 | gfc_init_loopinfo (&loop); | |
2803 | ||
2804 | /* Walk the rhs. */ | |
2805 | rss = gfc_walk_expr (expr2); | |
2806 | if (rss == gfc_ss_terminator) | |
2807 | { | |
2808 | /* The rhs is scalar. Add a ss for the expression. */ | |
2809 | rss = gfc_get_ss (); | |
2810 | rss->next = gfc_ss_terminator; | |
2811 | rss->type = GFC_SS_SCALAR; | |
2812 | rss->expr = expr2; | |
2813 | } | |
2814 | ||
2815 | /* Associate the SS with the loop. */ | |
2816 | gfc_add_ss_to_loop (&loop, lss); | |
2817 | gfc_add_ss_to_loop (&loop, rss); | |
2818 | ||
2819 | /* Calculate the bounds of the scalarization. */ | |
2820 | gfc_conv_ss_startstride (&loop); | |
2821 | ||
2822 | /* Resolve any data dependencies in the statement. */ | |
2823 | gfc_conv_resolve_dependencies (&loop, lss_section, rss); | |
2824 | ||
2825 | /* Setup the scalarizing loops. */ | |
2826 | gfc_conv_loop_setup (&loop); | |
2827 | ||
2828 | /* Setup the gfc_se structures. */ | |
2829 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
2830 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
2831 | ||
2832 | rse.ss = rss; | |
2833 | gfc_mark_ss_chain_used (rss, 1); | |
2834 | if (loop.temp_ss == NULL) | |
2835 | { | |
2836 | lse.ss = lss; | |
2837 | gfc_mark_ss_chain_used (lss, 1); | |
2838 | } | |
2839 | else | |
2840 | { | |
2841 | lse.ss = loop.temp_ss; | |
2842 | gfc_mark_ss_chain_used (lss, 3); | |
2843 | gfc_mark_ss_chain_used (loop.temp_ss, 3); | |
2844 | } | |
2845 | ||
2846 | /* Start the scalarized loop body. */ | |
2847 | gfc_start_scalarized_body (&loop, &body); | |
2848 | ||
2849 | /* Translate the expression. */ | |
2850 | gfc_conv_expr (&rse, expr2); | |
2851 | if (lss != gfc_ss_terminator && loop.temp_ss != NULL) | |
2852 | { | |
2853 | gfc_conv_tmp_array_ref (&lse); | |
2854 | gfc_advance_se_ss_chain (&lse); | |
2855 | } | |
2856 | else | |
2857 | gfc_conv_expr (&lse, expr1); | |
2858 | ||
2859 | /* Form the mask expression according to the mask tree list. */ | |
2860 | index = count1; | |
2861 | tmp = mask; | |
2862 | if (tmp != NULL) | |
2863 | maskexpr = gfc_build_array_ref (tmp, index); | |
2864 | else | |
2865 | maskexpr = NULL; | |
2866 | ||
2867 | tmp = TREE_CHAIN (tmp); | |
2868 | while (tmp) | |
2869 | { | |
2870 | tmp1 = gfc_build_array_ref (tmp, index); | |
923ab88c | 2871 | maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1); |
6de9cd9a DN |
2872 | tmp = TREE_CHAIN (tmp); |
2873 | } | |
2874 | /* Use the scalar assignment as is. */ | |
2875 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); | |
923ab88c | 2876 | tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
2877 | |
2878 | gfc_add_expr_to_block (&body, tmp); | |
2879 | ||
2880 | if (lss == gfc_ss_terminator) | |
2881 | { | |
2882 | /* Increment count1. */ | |
10c7a96f SB |
2883 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2884 | count1, gfc_index_one_node); | |
6de9cd9a DN |
2885 | gfc_add_modify_expr (&body, count1, tmp); |
2886 | ||
2887 | /* Use the scalar assignment as is. */ | |
2888 | gfc_add_block_to_block (&block, &body); | |
2889 | } | |
2890 | else | |
2891 | { | |
6e45f57b PB |
2892 | gcc_assert (lse.ss == gfc_ss_terminator |
2893 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
2894 | |
2895 | if (loop.temp_ss != NULL) | |
2896 | { | |
2897 | /* Increment count1 before finish the main body of a scalarized | |
2898 | expression. */ | |
10c7a96f SB |
2899 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2900 | count1, gfc_index_one_node); | |
6de9cd9a DN |
2901 | gfc_add_modify_expr (&body, count1, tmp); |
2902 | gfc_trans_scalarized_loop_boundary (&loop, &body); | |
2903 | ||
2904 | /* We need to copy the temporary to the actual lhs. */ | |
2905 | gfc_init_se (&lse, NULL); | |
2906 | gfc_init_se (&rse, NULL); | |
2907 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
2908 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
2909 | ||
2910 | rse.ss = loop.temp_ss; | |
2911 | lse.ss = lss; | |
2912 | ||
2913 | gfc_conv_tmp_array_ref (&rse); | |
2914 | gfc_advance_se_ss_chain (&rse); | |
2915 | gfc_conv_expr (&lse, expr1); | |
2916 | ||
6e45f57b PB |
2917 | gcc_assert (lse.ss == gfc_ss_terminator |
2918 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
2919 | |
2920 | /* Form the mask expression according to the mask tree list. */ | |
2921 | index = count2; | |
2922 | tmp = mask; | |
2923 | if (tmp != NULL) | |
2924 | maskexpr = gfc_build_array_ref (tmp, index); | |
2925 | else | |
2926 | maskexpr = NULL; | |
2927 | ||
2928 | tmp = TREE_CHAIN (tmp); | |
2929 | while (tmp) | |
2930 | { | |
2931 | tmp1 = gfc_build_array_ref (tmp, index); | |
923ab88c TS |
2932 | maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), |
2933 | maskexpr, tmp1); | |
6de9cd9a DN |
2934 | tmp = TREE_CHAIN (tmp); |
2935 | } | |
2936 | /* Use the scalar assignment as is. */ | |
2937 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); | |
923ab88c | 2938 | tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); |
6de9cd9a | 2939 | gfc_add_expr_to_block (&body, tmp); |
7ab92584 | 2940 | |
6de9cd9a | 2941 | /* Increment count2. */ |
10c7a96f SB |
2942 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2943 | count2, gfc_index_one_node); | |
6de9cd9a DN |
2944 | gfc_add_modify_expr (&body, count2, tmp); |
2945 | } | |
2946 | else | |
2947 | { | |
2948 | /* Increment count1. */ | |
10c7a96f SB |
2949 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, |
2950 | count1, gfc_index_one_node); | |
6de9cd9a DN |
2951 | gfc_add_modify_expr (&body, count1, tmp); |
2952 | } | |
2953 | ||
2954 | /* Generate the copying loops. */ | |
2955 | gfc_trans_scalarizing_loops (&loop, &body); | |
2956 | ||
2957 | /* Wrap the whole thing up. */ | |
2958 | gfc_add_block_to_block (&block, &loop.pre); | |
2959 | gfc_add_block_to_block (&block, &loop.post); | |
2960 | gfc_cleanup_loop (&loop); | |
2961 | } | |
2962 | ||
2963 | return gfc_finish_block (&block); | |
2964 | } | |
2965 | ||
2966 | ||
2967 | /* Translate the WHERE construct or statement. | |
aa9c57ec | 2968 | This function can be called iteratively to translate the nested WHERE |
6de9cd9a DN |
2969 | construct or statement. |
2970 | MASK is the control mask, and PMASK is the pending control mask. | |
2971 | TEMP records the temporary address which must be freed later. */ | |
2972 | ||
2973 | static void | |
2974 | gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask, | |
2975 | forall_info * nested_forall_info, stmtblock_t * block, | |
2976 | temporary_list ** temp) | |
2977 | { | |
2978 | gfc_expr *expr1; | |
2979 | gfc_expr *expr2; | |
2980 | gfc_code *cblock; | |
2981 | gfc_code *cnext; | |
2982 | tree tmp, tmp1, tmp2; | |
2983 | tree count1, count2; | |
2984 | tree mask_copy; | |
2985 | int need_temp; | |
2986 | ||
2987 | /* the WHERE statement or the WHERE construct statement. */ | |
2988 | cblock = code->block; | |
2989 | while (cblock) | |
2990 | { | |
2991 | /* Has mask-expr. */ | |
2992 | if (cblock->expr) | |
2993 | { | |
2994 | /* Ensure that the WHERE mask be evaluated only once. */ | |
2995 | tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info, | |
2996 | &tmp, &tmp1, temp, block); | |
2997 | ||
2998 | /* Set the control mask and the pending control mask. */ | |
2999 | /* It's a where-stmt. */ | |
3000 | if (mask == NULL) | |
3001 | { | |
3002 | mask = tmp; | |
3003 | pmask = tmp1; | |
3004 | } | |
3005 | /* It's a nested where-stmt. */ | |
3006 | else if (mask && pmask == NULL) | |
3007 | { | |
3008 | tree tmp2; | |
3009 | /* Use the TREE_CHAIN to list the masks. */ | |
3010 | tmp2 = copy_list (mask); | |
3011 | pmask = chainon (mask, tmp1); | |
3012 | mask = chainon (tmp2, tmp); | |
3013 | } | |
3014 | /* It's a masked-elsewhere-stmt. */ | |
3015 | else if (mask && cblock->expr) | |
3016 | { | |
3017 | tree tmp2; | |
3018 | tmp2 = copy_list (pmask); | |
3019 | ||
3020 | mask = pmask; | |
3021 | tmp2 = chainon (tmp2, tmp); | |
3022 | pmask = chainon (mask, tmp1); | |
3023 | mask = tmp2; | |
3024 | } | |
3025 | } | |
3026 | /* It's a elsewhere-stmt. No mask-expr is present. */ | |
3027 | else | |
3028 | mask = pmask; | |
3029 | ||
3030 | /* Get the assignment statement of a WHERE statement, or the first | |
3031 | statement in where-body-construct of a WHERE construct. */ | |
3032 | cnext = cblock->next; | |
3033 | while (cnext) | |
3034 | { | |
3035 | switch (cnext->op) | |
3036 | { | |
3037 | /* WHERE assignment statement. */ | |
3038 | case EXEC_ASSIGN: | |
3039 | expr1 = cnext->expr; | |
3040 | expr2 = cnext->expr2; | |
3041 | if (nested_forall_info != NULL) | |
3042 | { | |
3043 | int nvar; | |
3044 | gfc_expr **varexpr; | |
3045 | ||
3046 | nvar = nested_forall_info->nvar; | |
3047 | varexpr = (gfc_expr **) | |
3048 | gfc_getmem (nvar * sizeof (gfc_expr *)); | |
3049 | need_temp = gfc_check_dependency (expr1, expr2, varexpr, | |
3050 | nvar); | |
3051 | if (need_temp) | |
3052 | gfc_trans_assign_need_temp (expr1, expr2, mask, | |
3053 | nested_forall_info, block); | |
3054 | else | |
3055 | { | |
8de1f441 JJ |
3056 | forall_info *forall_tmp; |
3057 | tree maskindex; | |
3058 | ||
6de9cd9a DN |
3059 | /* Variables to control maskexpr. */ |
3060 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
3061 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
7ab92584 SB |
3062 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
3063 | gfc_add_modify_expr (block, count2, gfc_index_zero_node); | |
6de9cd9a DN |
3064 | |
3065 | tmp = gfc_trans_where_assign (expr1, expr2, mask, count1, | |
3066 | count2); | |
8de1f441 JJ |
3067 | |
3068 | /* Initialize the maskindexes. */ | |
3069 | forall_tmp = nested_forall_info; | |
3070 | while (forall_tmp != NULL) | |
3071 | { | |
3072 | maskindex = forall_tmp->maskindex; | |
3073 | if (forall_tmp->mask) | |
3074 | gfc_add_modify_expr (block, maskindex, | |
3075 | gfc_index_zero_node); | |
3076 | forall_tmp = forall_tmp->next_nest; | |
3077 | } | |
3078 | ||
6de9cd9a DN |
3079 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
3080 | tmp, 1, 1); | |
3081 | gfc_add_expr_to_block (block, tmp); | |
3082 | } | |
3083 | } | |
3084 | else | |
3085 | { | |
3086 | /* Variables to control maskexpr. */ | |
3087 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
3088 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
7ab92584 SB |
3089 | gfc_add_modify_expr (block, count1, gfc_index_zero_node); |
3090 | gfc_add_modify_expr (block, count2, gfc_index_zero_node); | |
6de9cd9a DN |
3091 | |
3092 | tmp = gfc_trans_where_assign (expr1, expr2, mask, count1, | |
3093 | count2); | |
3094 | gfc_add_expr_to_block (block, tmp); | |
3095 | ||
3096 | } | |
3097 | break; | |
3098 | ||
3099 | /* WHERE or WHERE construct is part of a where-body-construct. */ | |
3100 | case EXEC_WHERE: | |
3101 | /* Ensure that MASK is not modified by next gfc_trans_where_2. */ | |
3102 | mask_copy = copy_list (mask); | |
3103 | gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info, | |
3104 | block, temp); | |
3105 | break; | |
3106 | ||
3107 | default: | |
6e45f57b | 3108 | gcc_unreachable (); |
6de9cd9a DN |
3109 | } |
3110 | ||
3111 | /* The next statement within the same where-body-construct. */ | |
3112 | cnext = cnext->next; | |
3113 | } | |
3114 | /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ | |
3115 | cblock = cblock->block; | |
3116 | } | |
3117 | } | |
3118 | ||
3119 | ||
3120 | /* As the WHERE or WHERE construct statement can be nested, we call | |
3121 | gfc_trans_where_2 to do the translation, and pass the initial | |
f7b529fa | 3122 | NULL values for both the control mask and the pending control mask. */ |
6de9cd9a DN |
3123 | |
3124 | tree | |
3125 | gfc_trans_where (gfc_code * code) | |
3126 | { | |
3127 | stmtblock_t block; | |
3128 | temporary_list *temp, *p; | |
3129 | tree args; | |
3130 | tree tmp; | |
3131 | ||
3132 | gfc_start_block (&block); | |
3133 | temp = NULL; | |
3134 | ||
3135 | gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp); | |
3136 | ||
3137 | /* Add calls to free temporaries which were dynamically allocated. */ | |
3138 | while (temp) | |
3139 | { | |
3140 | args = gfc_chainon_list (NULL_TREE, temp->temporary); | |
3141 | tmp = gfc_build_function_call (gfor_fndecl_internal_free, args); | |
3142 | gfc_add_expr_to_block (&block, tmp); | |
3143 | ||
3144 | p = temp; | |
3145 | temp = temp->next; | |
3146 | gfc_free (p); | |
3147 | } | |
3148 | return gfc_finish_block (&block); | |
3149 | } | |
3150 | ||
3151 | ||
3152 | /* CYCLE a DO loop. The label decl has already been created by | |
3153 | gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code | |
3154 | node at the head of the loop. We must mark the label as used. */ | |
3155 | ||
3156 | tree | |
3157 | gfc_trans_cycle (gfc_code * code) | |
3158 | { | |
3159 | tree cycle_label; | |
3160 | ||
3161 | cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl); | |
3162 | TREE_USED (cycle_label) = 1; | |
3163 | return build1_v (GOTO_EXPR, cycle_label); | |
3164 | } | |
3165 | ||
3166 | ||
e7dc5b4f | 3167 | /* EXIT a DO loop. Similar to CYCLE, but now the label is in |
6de9cd9a DN |
3168 | TREE_VALUE (backend_decl) of the gfc_code node at the head of the |
3169 | loop. */ | |
3170 | ||
3171 | tree | |
3172 | gfc_trans_exit (gfc_code * code) | |
3173 | { | |
3174 | tree exit_label; | |
3175 | ||
3176 | exit_label = TREE_VALUE (code->ext.whichloop->backend_decl); | |
3177 | TREE_USED (exit_label) = 1; | |
3178 | return build1_v (GOTO_EXPR, exit_label); | |
3179 | } | |
3180 | ||
3181 | ||
3182 | /* Translate the ALLOCATE statement. */ | |
3183 | ||
3184 | tree | |
3185 | gfc_trans_allocate (gfc_code * code) | |
3186 | { | |
3187 | gfc_alloc *al; | |
3188 | gfc_expr *expr; | |
3189 | gfc_se se; | |
3190 | tree tmp; | |
3191 | tree parm; | |
3192 | gfc_ref *ref; | |
3193 | tree stat; | |
3194 | tree pstat; | |
3195 | tree error_label; | |
3196 | stmtblock_t block; | |
3197 | ||
3198 | if (!code->ext.alloc_list) | |
3199 | return NULL_TREE; | |
3200 | ||
3201 | gfc_start_block (&block); | |
3202 | ||
3203 | if (code->expr) | |
3204 | { | |
e2cad04b RH |
3205 | tree gfc_int4_type_node = gfc_get_int_type (4); |
3206 | ||
6de9cd9a DN |
3207 | stat = gfc_create_var (gfc_int4_type_node, "stat"); |
3208 | pstat = gfc_build_addr_expr (NULL, stat); | |
3209 | ||
3210 | error_label = gfc_build_label_decl (NULL_TREE); | |
3211 | TREE_USED (error_label) = 1; | |
3212 | } | |
3213 | else | |
3214 | { | |
3215 | pstat = integer_zero_node; | |
3216 | stat = error_label = NULL_TREE; | |
3217 | } | |
3218 | ||
3219 | ||
3220 | for (al = code->ext.alloc_list; al != NULL; al = al->next) | |
3221 | { | |
3222 | expr = al->expr; | |
3223 | ||
3224 | gfc_init_se (&se, NULL); | |
3225 | gfc_start_block (&se.pre); | |
3226 | ||
3227 | se.want_pointer = 1; | |
3228 | se.descriptor_only = 1; | |
3229 | gfc_conv_expr (&se, expr); | |
3230 | ||
3231 | ref = expr->ref; | |
3232 | ||
3233 | /* Find the last reference in the chain. */ | |
3234 | while (ref && ref->next != NULL) | |
3235 | { | |
6e45f57b | 3236 | gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); |
6de9cd9a DN |
3237 | ref = ref->next; |
3238 | } | |
3239 | ||
3240 | if (ref != NULL && ref->type == REF_ARRAY) | |
3241 | { | |
3242 | /* An array. */ | |
3243 | gfc_array_allocate (&se, ref, pstat); | |
3244 | } | |
3245 | else | |
3246 | { | |
3247 | /* A scalar or derived type. */ | |
3248 | tree val; | |
3249 | ||
3250 | val = gfc_create_var (ppvoid_type_node, "ptr"); | |
3251 | tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr); | |
3252 | gfc_add_modify_expr (&se.pre, val, tmp); | |
3253 | ||
3254 | tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); | |
3255 | parm = gfc_chainon_list (NULL_TREE, val); | |
3256 | parm = gfc_chainon_list (parm, tmp); | |
3257 | parm = gfc_chainon_list (parm, pstat); | |
3258 | tmp = gfc_build_function_call (gfor_fndecl_allocate, parm); | |
3259 | gfc_add_expr_to_block (&se.pre, tmp); | |
3260 | ||
3261 | if (code->expr) | |
3262 | { | |
3263 | tmp = build1_v (GOTO_EXPR, error_label); | |
3264 | parm = | |
923ab88c TS |
3265 | build2 (NE_EXPR, boolean_type_node, stat, integer_zero_node); |
3266 | tmp = build3_v (COND_EXPR, parm, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
3267 | gfc_add_expr_to_block (&se.pre, tmp); |
3268 | } | |
3269 | } | |
3270 | ||
3271 | tmp = gfc_finish_block (&se.pre); | |
3272 | gfc_add_expr_to_block (&block, tmp); | |
3273 | } | |
3274 | ||
3275 | /* Assign the value to the status variable. */ | |
3276 | if (code->expr) | |
3277 | { | |
3278 | tmp = build1_v (LABEL_EXPR, error_label); | |
3279 | gfc_add_expr_to_block (&block, tmp); | |
3280 | ||
3281 | gfc_init_se (&se, NULL); | |
3282 | gfc_conv_expr_lhs (&se, code->expr); | |
3283 | tmp = convert (TREE_TYPE (se.expr), stat); | |
3284 | gfc_add_modify_expr (&block, se.expr, tmp); | |
3285 | } | |
3286 | ||
3287 | return gfc_finish_block (&block); | |
3288 | } | |
3289 | ||
3290 | ||
364667a1 SK |
3291 | /* Translate a DEALLOCATE statement. |
3292 | There are two cases within the for loop: | |
3293 | (1) deallocate(a1, a2, a3) is translated into the following sequence | |
3294 | _gfortran_deallocate(a1, 0B) | |
3295 | _gfortran_deallocate(a2, 0B) | |
3296 | _gfortran_deallocate(a3, 0B) | |
3297 | where the STAT= variable is passed a NULL pointer. | |
3298 | (2) deallocate(a1, a2, a3, stat=i) is translated into the following | |
3299 | astat = 0 | |
3300 | _gfortran_deallocate(a1, &stat) | |
3301 | astat = astat + stat | |
3302 | _gfortran_deallocate(a2, &stat) | |
3303 | astat = astat + stat | |
3304 | _gfortran_deallocate(a3, &stat) | |
3305 | astat = astat + stat | |
3306 | In case (1), we simply return at the end of the for loop. In case (2) | |
3307 | we set STAT= astat. */ | |
6de9cd9a DN |
3308 | tree |
3309 | gfc_trans_deallocate (gfc_code * code) | |
3310 | { | |
3311 | gfc_se se; | |
3312 | gfc_alloc *al; | |
3313 | gfc_expr *expr; | |
364667a1 | 3314 | tree apstat, astat, parm, pstat, stat, tmp, type, var; |
6de9cd9a DN |
3315 | stmtblock_t block; |
3316 | ||
3317 | gfc_start_block (&block); | |
3318 | ||
364667a1 SK |
3319 | /* Set up the optional STAT= */ |
3320 | if (code->expr) | |
3321 | { | |
3322 | tree gfc_int4_type_node = gfc_get_int_type (4); | |
3323 | ||
3324 | /* Variable used with the library call. */ | |
3325 | stat = gfc_create_var (gfc_int4_type_node, "stat"); | |
3326 | pstat = gfc_build_addr_expr (NULL, stat); | |
3327 | ||
3328 | /* Running total of possible deallocation failures. */ | |
3329 | astat = gfc_create_var (gfc_int4_type_node, "astat"); | |
3330 | apstat = gfc_build_addr_expr (NULL, astat); | |
3331 | ||
3332 | /* Initialize astat to 0. */ | |
3333 | gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); | |
3334 | } | |
3335 | else | |
3336 | { | |
3337 | pstat = apstat = null_pointer_node; | |
3338 | stat = astat = NULL_TREE; | |
3339 | } | |
3340 | ||
6de9cd9a DN |
3341 | for (al = code->ext.alloc_list; al != NULL; al = al->next) |
3342 | { | |
3343 | expr = al->expr; | |
6e45f57b | 3344 | gcc_assert (expr->expr_type == EXPR_VARIABLE); |
6de9cd9a DN |
3345 | |
3346 | gfc_init_se (&se, NULL); | |
3347 | gfc_start_block (&se.pre); | |
3348 | ||
3349 | se.want_pointer = 1; | |
3350 | se.descriptor_only = 1; | |
3351 | gfc_conv_expr (&se, expr); | |
3352 | ||
3353 | if (expr->symtree->n.sym->attr.dimension) | |
364667a1 | 3354 | tmp = gfc_array_deallocate (se.expr, pstat); |
6de9cd9a DN |
3355 | else |
3356 | { | |
3357 | type = build_pointer_type (TREE_TYPE (se.expr)); | |
3358 | var = gfc_create_var (type, "ptr"); | |
3359 | tmp = gfc_build_addr_expr (type, se.expr); | |
3360 | gfc_add_modify_expr (&se.pre, var, tmp); | |
3361 | ||
364667a1 SK |
3362 | parm = gfc_chainon_list (NULL_TREE, var); |
3363 | parm = gfc_chainon_list (parm, pstat); | |
3364 | tmp = gfc_build_function_call (gfor_fndecl_deallocate, parm); | |
6de9cd9a | 3365 | } |
364667a1 SK |
3366 | |
3367 | gfc_add_expr_to_block (&se.pre, tmp); | |
3368 | ||
3369 | /* Keep track of the number of failed deallocations by adding stat | |
3370 | of the last deallocation to the running total. */ | |
3371 | if (code->expr) | |
3372 | { | |
3373 | apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat); | |
3374 | gfc_add_modify_expr (&se.pre, astat, apstat); | |
3375 | } | |
3376 | ||
6de9cd9a DN |
3377 | tmp = gfc_finish_block (&se.pre); |
3378 | gfc_add_expr_to_block (&block, tmp); | |
364667a1 SK |
3379 | |
3380 | } | |
3381 | ||
3382 | /* Assign the value to the status variable. */ | |
3383 | if (code->expr) | |
3384 | { | |
3385 | gfc_init_se (&se, NULL); | |
3386 | gfc_conv_expr_lhs (&se, code->expr); | |
3387 | tmp = convert (TREE_TYPE (se.expr), astat); | |
3388 | gfc_add_modify_expr (&block, se.expr, tmp); | |
6de9cd9a DN |
3389 | } |
3390 | ||
3391 | return gfc_finish_block (&block); | |
3392 | } | |
3393 |