]>
Commit | Line | Data |
---|---|---|
5532a4d1 | 1 | /* Pass manager for Fortran front end. |
1c287e8d | 2 | Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
5532a4d1 | 3 | Contributed by Thomas König. |
4 | ||
5 | This file is part of GCC. | |
6 | ||
7 | GCC is free software; you can redistribute it and/or modify it under | |
8 | the terms of the GNU General Public License as published by the Free | |
9 | Software Foundation; either version 3, or (at your option) any later | |
10 | version. | |
11 | ||
12 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY | |
13 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 | for more details. | |
16 | ||
17 | You should have received a copy of the GNU General Public License | |
18 | along with GCC; see the file COPYING3. If not see | |
19 | <http://www.gnu.org/licenses/>. */ | |
20 | ||
21 | #include "config.h" | |
22 | #include "system.h" | |
23 | #include "gfortran.h" | |
24 | #include "arith.h" | |
25 | #include "flags.h" | |
cca7236e | 26 | #include "dependency.h" |
0477c944 | 27 | #include "constructor.h" |
80f5c112 | 28 | #include "opts.h" |
5532a4d1 | 29 | |
30 | /* Forward declarations. */ | |
31 | ||
32 | static void strip_function_call (gfc_expr *); | |
3b2d9202 | 33 | static void optimize_namespace (gfc_namespace *); |
5532a4d1 | 34 | static void optimize_assignment (gfc_code *); |
5532a4d1 | 35 | static bool optimize_op (gfc_expr *); |
80f5c112 | 36 | static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); |
3498c2ca | 37 | static bool optimize_trim (gfc_expr *); |
0ae5e891 | 38 | static bool optimize_lexical_comparison (gfc_expr *); |
1c287e8d | 39 | static void optimize_minmaxloc (gfc_expr **); |
3498c2ca | 40 | |
41 | /* How deep we are inside an argument list. */ | |
42 | ||
43 | static int count_arglist; | |
5532a4d1 | 44 | |
bf48f16e | 45 | /* Pointer to an array of gfc_expr ** we operate on, plus its size |
46 | and counter. */ | |
47 | ||
48 | static gfc_expr ***expr_array; | |
49 | static int expr_size, expr_count; | |
50 | ||
51 | /* Pointer to the gfc_code we currently work on - to be able to insert | |
d9ef40e7 | 52 | a block before the statement. */ |
bf48f16e | 53 | |
54 | static gfc_code **current_code; | |
55 | ||
d9ef40e7 | 56 | /* Pointer to the block to be inserted, and the statement we are |
57 | changing within the block. */ | |
58 | ||
59 | static gfc_code *inserted_block, **changed_statement; | |
60 | ||
bf48f16e | 61 | /* The namespace we are currently dealing with. */ |
62 | ||
63 | gfc_namespace *current_ns; | |
64 | ||
5532a4d1 | 65 | /* Entry point - run all passes for a namespace. So far, only an |
66 | optimization pass is run. */ | |
67 | ||
68 | void | |
3b2d9202 | 69 | gfc_run_passes (gfc_namespace *ns) |
5532a4d1 | 70 | { |
10b2bb30 | 71 | if (gfc_option.flag_frontend_optimize) |
f1a51f6b | 72 | { |
bf48f16e | 73 | expr_size = 20; |
74 | expr_array = XNEWVEC(gfc_expr **, expr_size); | |
75 | ||
f1a51f6b | 76 | optimize_namespace (ns); |
77 | if (gfc_option.dump_fortran_optimized) | |
78 | gfc_dump_parse_tree (ns, stdout); | |
bf48f16e | 79 | |
1e9c5433 | 80 | XDELETEVEC (expr_array); |
f1a51f6b | 81 | } |
3b2d9202 | 82 | } |
83 | ||
5f99b526 | 84 | /* Callback for each gfc_code node invoked through gfc_code_walker |
85 | from optimize_namespace. */ | |
3b2d9202 | 86 | |
5f99b526 | 87 | static int |
88 | optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, | |
89 | void *data ATTRIBUTE_UNUSED) | |
3b2d9202 | 90 | { |
3498c2ca | 91 | |
92 | gfc_exec_op op; | |
93 | ||
94 | op = (*c)->op; | |
95 | ||
96 | if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL | |
97 | || op == EXEC_CALL_PPC) | |
98 | count_arglist = 1; | |
99 | else | |
100 | count_arglist = 0; | |
101 | ||
102 | if (op == EXEC_ASSIGN) | |
5f99b526 | 103 | optimize_assignment (*c); |
104 | return 0; | |
5532a4d1 | 105 | } |
106 | ||
5f99b526 | 107 | /* Callback for each gfc_expr node invoked through gfc_code_walker |
108 | from optimize_namespace. */ | |
109 | ||
110 | static int | |
111 | optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, | |
112 | void *data ATTRIBUTE_UNUSED) | |
5532a4d1 | 113 | { |
3498c2ca | 114 | bool function_expr; |
115 | ||
116 | if ((*e)->expr_type == EXPR_FUNCTION) | |
117 | { | |
118 | count_arglist ++; | |
119 | function_expr = true; | |
120 | } | |
121 | else | |
122 | function_expr = false; | |
123 | ||
124 | if (optimize_trim (*e)) | |
125 | gfc_simplify_expr (*e, 0); | |
126 | ||
0ae5e891 | 127 | if (optimize_lexical_comparison (*e)) |
128 | gfc_simplify_expr (*e, 0); | |
129 | ||
5f99b526 | 130 | if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) |
131 | gfc_simplify_expr (*e, 0); | |
3498c2ca | 132 | |
1c287e8d | 133 | if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) |
134 | switch ((*e)->value.function.isym->id) | |
135 | { | |
136 | case GFC_ISYM_MINLOC: | |
137 | case GFC_ISYM_MAXLOC: | |
138 | optimize_minmaxloc (e); | |
139 | break; | |
140 | default: | |
141 | break; | |
142 | } | |
143 | ||
3498c2ca | 144 | if (function_expr) |
145 | count_arglist --; | |
146 | ||
5f99b526 | 147 | return 0; |
5532a4d1 | 148 | } |
149 | ||
bf48f16e | 150 | |
151 | /* Callback function for common function elimination, called from cfe_expr_0. | |
7eb1e18e | 152 | Put all eligible function expressions into expr_array. */ |
bf48f16e | 153 | |
154 | static int | |
155 | cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, | |
156 | void *data ATTRIBUTE_UNUSED) | |
157 | { | |
d1aaa84e | 158 | |
bf48f16e | 159 | if ((*e)->expr_type != EXPR_FUNCTION) |
160 | return 0; | |
161 | ||
7eb1e18e | 162 | /* We don't do character functions with unknown charlens. */ |
163 | if ((*e)->ts.type == BT_CHARACTER | |
164 | && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL | |
165 | || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) | |
bf48f16e | 166 | return 0; |
167 | ||
3b4c8f33 | 168 | /* If we don't know the shape at compile time, we create an allocatable |
169 | temporary variable to hold the intermediate result, but only if | |
170 | allocation on assignment is active. */ | |
bf48f16e | 171 | |
3b4c8f33 | 172 | if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs) |
bf48f16e | 173 | return 0; |
174 | ||
175 | /* Skip the test for pure functions if -faggressive-function-elimination | |
176 | is specified. */ | |
177 | if ((*e)->value.function.esym) | |
178 | { | |
bf48f16e | 179 | /* Don't create an array temporary for elemental functions. */ |
180 | if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0) | |
181 | return 0; | |
182 | ||
183 | /* Only eliminate potentially impure functions if the | |
184 | user specifically requested it. */ | |
185 | if (!gfc_option.flag_aggressive_function_elimination | |
186 | && !(*e)->value.function.esym->attr.pure | |
187 | && !(*e)->value.function.esym->attr.implicit_pure) | |
188 | return 0; | |
189 | } | |
190 | ||
191 | if ((*e)->value.function.isym) | |
192 | { | |
193 | /* Conversions are handled on the fly by the middle end, | |
7eb1e18e | 194 | transpose during trans-* stages and TRANSFER by the middle end. */ |
bf48f16e | 195 | if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION |
7eb1e18e | 196 | || (*e)->value.function.isym->id == GFC_ISYM_TRANSPOSE |
197 | || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER) | |
bf48f16e | 198 | return 0; |
199 | ||
200 | /* Don't create an array temporary for elemental functions, | |
201 | as this would be wasteful of memory. | |
202 | FIXME: Create a scalar temporary during scalarization. */ | |
203 | if ((*e)->value.function.isym->elemental && (*e)->rank > 0) | |
204 | return 0; | |
205 | ||
206 | if (!(*e)->value.function.isym->pure) | |
207 | return 0; | |
208 | } | |
209 | ||
210 | if (expr_count >= expr_size) | |
211 | { | |
212 | expr_size += expr_size; | |
213 | expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size); | |
214 | } | |
215 | expr_array[expr_count] = e; | |
216 | expr_count ++; | |
217 | return 0; | |
218 | } | |
219 | ||
220 | /* Returns a new expression (a variable) to be used in place of the old one, | |
221 | with an an assignment statement before the current statement to set | |
d9ef40e7 | 222 | the value of the variable. Creates a new BLOCK for the statement if |
223 | that hasn't already been done and puts the statement, plus the | |
224 | newly created variables, in that block. */ | |
bf48f16e | 225 | |
226 | static gfc_expr* | |
227 | create_var (gfc_expr * e) | |
228 | { | |
229 | char name[GFC_MAX_SYMBOL_LEN +1]; | |
230 | static int num = 1; | |
231 | gfc_symtree *symtree; | |
232 | gfc_symbol *symbol; | |
233 | gfc_expr *result; | |
234 | gfc_code *n; | |
d9ef40e7 | 235 | gfc_namespace *ns; |
bf48f16e | 236 | int i; |
237 | ||
d9ef40e7 | 238 | /* If the block hasn't already been created, do so. */ |
239 | if (inserted_block == NULL) | |
240 | { | |
241 | inserted_block = XCNEW (gfc_code); | |
242 | inserted_block->op = EXEC_BLOCK; | |
243 | inserted_block->loc = (*current_code)->loc; | |
244 | ns = gfc_build_block_ns (current_ns); | |
245 | inserted_block->ext.block.ns = ns; | |
246 | inserted_block->ext.block.assoc = NULL; | |
247 | ||
248 | ns->code = *current_code; | |
249 | inserted_block->next = (*current_code)->next; | |
250 | changed_statement = &(inserted_block->ext.block.ns->code); | |
251 | (*current_code)->next = NULL; | |
252 | /* Insert the BLOCK at the right position. */ | |
253 | *current_code = inserted_block; | |
254 | } | |
255 | else | |
256 | ns = inserted_block->ext.block.ns; | |
257 | ||
bf48f16e | 258 | sprintf(name, "__var_%d",num++); |
d9ef40e7 | 259 | if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) |
bf48f16e | 260 | gcc_unreachable (); |
261 | ||
262 | symbol = symtree->n.sym; | |
263 | symbol->ts = e->ts; | |
3b4c8f33 | 264 | |
265 | if (e->rank > 0) | |
bf48f16e | 266 | { |
3b4c8f33 | 267 | symbol->as = gfc_get_array_spec (); |
268 | symbol->as->rank = e->rank; | |
269 | ||
270 | if (e->shape == NULL) | |
271 | { | |
272 | /* We don't know the shape at compile time, so we use an | |
273 | allocatable. */ | |
274 | symbol->as->type = AS_DEFERRED; | |
275 | symbol->attr.allocatable = 1; | |
276 | } | |
277 | else | |
278 | { | |
279 | symbol->as->type = AS_EXPLICIT; | |
280 | /* Copy the shape. */ | |
281 | for (i=0; i<e->rank; i++) | |
282 | { | |
283 | gfc_expr *p, *q; | |
bf48f16e | 284 | |
3b4c8f33 | 285 | p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, |
286 | &(e->where)); | |
287 | mpz_set_si (p->value.integer, 1); | |
288 | symbol->as->lower[i] = p; | |
289 | ||
290 | q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, | |
291 | &(e->where)); | |
292 | mpz_set (q->value.integer, e->shape[i]); | |
293 | symbol->as->upper[i] = q; | |
294 | } | |
295 | } | |
bf48f16e | 296 | } |
297 | ||
298 | symbol->attr.flavor = FL_VARIABLE; | |
299 | symbol->attr.referenced = 1; | |
300 | symbol->attr.dimension = e->rank > 0; | |
301 | gfc_commit_symbol (symbol); | |
302 | ||
303 | result = gfc_get_expr (); | |
304 | result->expr_type = EXPR_VARIABLE; | |
305 | result->ts = e->ts; | |
306 | result->rank = e->rank; | |
307 | result->shape = gfc_copy_shape (e->shape, e->rank); | |
308 | result->symtree = symtree; | |
309 | result->where = e->where; | |
310 | if (e->rank > 0) | |
311 | { | |
312 | result->ref = gfc_get_ref (); | |
313 | result->ref->type = REF_ARRAY; | |
314 | result->ref->u.ar.type = AR_FULL; | |
315 | result->ref->u.ar.where = e->where; | |
316 | result->ref->u.ar.as = symbol->as; | |
7cd993c9 | 317 | if (gfc_option.warn_array_temp) |
318 | gfc_warning ("Creating array temporary at %L", &(e->where)); | |
bf48f16e | 319 | } |
320 | ||
321 | /* Generate the new assignment. */ | |
322 | n = XCNEW (gfc_code); | |
323 | n->op = EXEC_ASSIGN; | |
324 | n->loc = (*current_code)->loc; | |
d9ef40e7 | 325 | n->next = *changed_statement; |
bf48f16e | 326 | n->expr1 = gfc_copy_expr (result); |
327 | n->expr2 = e; | |
d9ef40e7 | 328 | *changed_statement = n; |
bf48f16e | 329 | |
330 | return result; | |
331 | } | |
332 | ||
10b2bb30 | 333 | /* Warn about function elimination. */ |
334 | ||
335 | static void | |
336 | warn_function_elimination (gfc_expr *e) | |
337 | { | |
338 | if (e->expr_type != EXPR_FUNCTION) | |
339 | return; | |
340 | if (e->value.function.esym) | |
341 | gfc_warning ("Removing call to function '%s' at %L", | |
342 | e->value.function.esym->name, &(e->where)); | |
343 | else if (e->value.function.isym) | |
344 | gfc_warning ("Removing call to function '%s' at %L", | |
345 | e->value.function.isym->name, &(e->where)); | |
346 | } | |
bf48f16e | 347 | /* Callback function for the code walker for doing common function |
348 | elimination. This builds up the list of functions in the expression | |
349 | and goes through them to detect duplicates, which it then replaces | |
350 | by variables. */ | |
351 | ||
352 | static int | |
353 | cfe_expr_0 (gfc_expr **e, int *walk_subtrees, | |
354 | void *data ATTRIBUTE_UNUSED) | |
355 | { | |
356 | int i,j; | |
357 | gfc_expr *newvar; | |
358 | ||
359 | expr_count = 0; | |
360 | ||
361 | gfc_expr_walker (e, cfe_register_funcs, NULL); | |
362 | ||
f6e36c3d | 363 | /* Walk through all the functions. */ |
364 | ||
365 | for (i=1; i<expr_count; i++) | |
bf48f16e | 366 | { |
367 | /* Skip if the function has been replaced by a variable already. */ | |
368 | if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE) | |
369 | continue; | |
370 | ||
371 | newvar = NULL; | |
f6e36c3d | 372 | for (j=0; j<i; j++) |
bf48f16e | 373 | { |
374 | if (gfc_dep_compare_functions(*(expr_array[i]), | |
375 | *(expr_array[j]), true) == 0) | |
376 | { | |
377 | if (newvar == NULL) | |
378 | newvar = create_var (*(expr_array[i])); | |
10b2bb30 | 379 | |
380 | if (gfc_option.warn_function_elimination) | |
381 | warn_function_elimination (*(expr_array[j])); | |
382 | ||
434f0922 | 383 | free (*(expr_array[j])); |
bf48f16e | 384 | *(expr_array[j]) = gfc_copy_expr (newvar); |
385 | } | |
386 | } | |
387 | if (newvar) | |
388 | *(expr_array[i]) = newvar; | |
389 | } | |
390 | ||
391 | /* We did all the necessary walking in this function. */ | |
392 | *walk_subtrees = 0; | |
393 | return 0; | |
394 | } | |
395 | ||
396 | /* Callback function for common function elimination, called from | |
397 | gfc_code_walker. This keeps track of the current code, in order | |
398 | to insert statements as needed. */ | |
399 | ||
400 | static int | |
401 | cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, | |
402 | void *data ATTRIBUTE_UNUSED) | |
403 | { | |
404 | current_code = c; | |
d9ef40e7 | 405 | inserted_block = NULL; |
406 | changed_statement = NULL; | |
bf48f16e | 407 | return 0; |
408 | } | |
409 | ||
5f99b526 | 410 | /* Optimize a namespace, including all contained namespaces. */ |
5532a4d1 | 411 | |
412 | static void | |
5f99b526 | 413 | optimize_namespace (gfc_namespace *ns) |
5532a4d1 | 414 | { |
bf48f16e | 415 | |
416 | current_ns = ns; | |
417 | ||
418 | gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); | |
5f99b526 | 419 | gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); |
5532a4d1 | 420 | |
5f99b526 | 421 | for (ns = ns->contained; ns; ns = ns->sibling) |
422 | optimize_namespace (ns); | |
5532a4d1 | 423 | } |
424 | ||
15474d41 | 425 | /* Replace code like |
426 | a = matmul(b,c) + d | |
427 | with | |
428 | a = matmul(b,c) ; a = a + d | |
429 | where the array function is not elemental and not allocatable | |
430 | and does not depend on the left-hand side. | |
431 | */ | |
432 | ||
433 | static bool | |
434 | optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) | |
435 | { | |
436 | gfc_expr *e; | |
437 | ||
438 | e = *rhs; | |
439 | if (e->expr_type == EXPR_OP) | |
440 | { | |
441 | switch (e->value.op.op) | |
442 | { | |
443 | /* Unary operators and exponentiation: Only look at a single | |
444 | operand. */ | |
445 | case INTRINSIC_NOT: | |
446 | case INTRINSIC_UPLUS: | |
447 | case INTRINSIC_UMINUS: | |
448 | case INTRINSIC_PARENTHESES: | |
449 | case INTRINSIC_POWER: | |
450 | if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) | |
451 | return true; | |
452 | break; | |
453 | ||
454 | default: | |
455 | /* Binary operators. */ | |
456 | if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) | |
457 | return true; | |
458 | ||
459 | if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) | |
460 | return true; | |
461 | ||
462 | break; | |
463 | } | |
464 | } | |
465 | else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 | |
466 | && ! (e->value.function.esym | |
467 | && (e->value.function.esym->attr.elemental | |
4ecf2718 | 468 | || e->value.function.esym->attr.allocatable |
469 | || e->value.function.esym->ts.type != c->expr1->ts.type | |
470 | || e->value.function.esym->ts.kind != c->expr1->ts.kind)) | |
471 | && ! (e->value.function.isym | |
472 | && (e->value.function.isym->elemental | |
473 | || e->ts.type != c->expr1->ts.type | |
474 | || e->ts.kind != c->expr1->ts.kind))) | |
15474d41 | 475 | { |
476 | ||
477 | gfc_code *n; | |
478 | gfc_expr *new_expr; | |
479 | ||
480 | /* Insert a new assignment statement after the current one. */ | |
481 | n = XCNEW (gfc_code); | |
482 | n->op = EXEC_ASSIGN; | |
483 | n->loc = c->loc; | |
484 | n->next = c->next; | |
485 | c->next = n; | |
486 | ||
487 | n->expr1 = gfc_copy_expr (c->expr1); | |
488 | n->expr2 = c->expr2; | |
489 | new_expr = gfc_copy_expr (c->expr1); | |
490 | c->expr2 = e; | |
491 | *rhs = new_expr; | |
492 | ||
493 | return true; | |
494 | ||
495 | } | |
496 | ||
497 | /* Nothing to optimize. */ | |
498 | return false; | |
499 | } | |
500 | ||
28b8f982 | 501 | /* Remove unneeded TRIMs at the end of expressions. */ |
502 | ||
503 | static bool | |
504 | remove_trim (gfc_expr *rhs) | |
505 | { | |
506 | bool ret; | |
507 | ||
508 | ret = false; | |
509 | ||
510 | /* Check for a // b // trim(c). Looping is probably not | |
511 | necessary because the parser usually generates | |
512 | (// (// a b ) trim(c) ) , but better safe than sorry. */ | |
513 | ||
514 | while (rhs->expr_type == EXPR_OP | |
515 | && rhs->value.op.op == INTRINSIC_CONCAT) | |
516 | rhs = rhs->value.op.op2; | |
517 | ||
518 | while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym | |
519 | && rhs->value.function.isym->id == GFC_ISYM_TRIM) | |
520 | { | |
521 | strip_function_call (rhs); | |
522 | /* Recursive call to catch silly stuff like trim ( a // trim(b)). */ | |
523 | remove_trim (rhs); | |
524 | ret = true; | |
525 | } | |
526 | ||
527 | return ret; | |
528 | } | |
529 | ||
5532a4d1 | 530 | /* Optimizations for an assignment. */ |
531 | ||
532 | static void | |
533 | optimize_assignment (gfc_code * c) | |
534 | { | |
535 | gfc_expr *lhs, *rhs; | |
536 | ||
537 | lhs = c->expr1; | |
538 | rhs = c->expr2; | |
539 | ||
540 | /* Optimize away a = trim(b), where a is a character variable. */ | |
541 | ||
542 | if (lhs->ts.type == BT_CHARACTER) | |
28b8f982 | 543 | remove_trim (rhs); |
5532a4d1 | 544 | |
15474d41 | 545 | if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) |
546 | optimize_binop_array_assignment (c, &rhs, false); | |
5532a4d1 | 547 | } |
548 | ||
549 | ||
550 | /* Remove an unneeded function call, modifying the expression. | |
551 | This replaces the function call with the value of its | |
552 | first argument. The rest of the argument list is freed. */ | |
553 | ||
554 | static void | |
555 | strip_function_call (gfc_expr *e) | |
556 | { | |
557 | gfc_expr *e1; | |
558 | gfc_actual_arglist *a; | |
559 | ||
560 | a = e->value.function.actual; | |
561 | ||
562 | /* We should have at least one argument. */ | |
563 | gcc_assert (a->expr != NULL); | |
564 | ||
565 | e1 = a->expr; | |
566 | ||
567 | /* Free the remaining arglist, if any. */ | |
568 | if (a->next) | |
569 | gfc_free_actual_arglist (a->next); | |
570 | ||
571 | /* Graft the argument expression onto the original function. */ | |
572 | *e = *e1; | |
434f0922 | 573 | free (e1); |
5532a4d1 | 574 | |
575 | } | |
576 | ||
0ae5e891 | 577 | /* Optimization of lexical comparison functions. */ |
578 | ||
579 | static bool | |
580 | optimize_lexical_comparison (gfc_expr *e) | |
581 | { | |
582 | if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL) | |
583 | return false; | |
584 | ||
585 | switch (e->value.function.isym->id) | |
586 | { | |
587 | case GFC_ISYM_LLE: | |
588 | return optimize_comparison (e, INTRINSIC_LE); | |
589 | ||
590 | case GFC_ISYM_LGE: | |
591 | return optimize_comparison (e, INTRINSIC_GE); | |
592 | ||
593 | case GFC_ISYM_LGT: | |
594 | return optimize_comparison (e, INTRINSIC_GT); | |
595 | ||
596 | case GFC_ISYM_LLT: | |
597 | return optimize_comparison (e, INTRINSIC_LT); | |
598 | ||
599 | default: | |
600 | break; | |
601 | } | |
602 | return false; | |
603 | } | |
604 | ||
5532a4d1 | 605 | /* Recursive optimization of operators. */ |
606 | ||
607 | static bool | |
608 | optimize_op (gfc_expr *e) | |
609 | { | |
5f99b526 | 610 | gfc_intrinsic_op op = e->value.op.op; |
5532a4d1 | 611 | |
612 | switch (op) | |
613 | { | |
614 | case INTRINSIC_EQ: | |
615 | case INTRINSIC_EQ_OS: | |
616 | case INTRINSIC_GE: | |
617 | case INTRINSIC_GE_OS: | |
618 | case INTRINSIC_LE: | |
619 | case INTRINSIC_LE_OS: | |
5532a4d1 | 620 | case INTRINSIC_NE: |
621 | case INTRINSIC_NE_OS: | |
622 | case INTRINSIC_GT: | |
623 | case INTRINSIC_GT_OS: | |
624 | case INTRINSIC_LT: | |
625 | case INTRINSIC_LT_OS: | |
80f5c112 | 626 | return optimize_comparison (e, op); |
5532a4d1 | 627 | |
628 | default: | |
629 | break; | |
630 | } | |
631 | ||
632 | return false; | |
633 | } | |
634 | ||
635 | /* Optimize expressions for equality. */ | |
636 | ||
637 | static bool | |
80f5c112 | 638 | optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) |
5532a4d1 | 639 | { |
5532a4d1 | 640 | gfc_expr *op1, *op2; |
641 | bool change; | |
80f5c112 | 642 | int eq; |
643 | bool result; | |
0ae5e891 | 644 | gfc_actual_arglist *firstarg, *secondarg; |
5532a4d1 | 645 | |
0ae5e891 | 646 | if (e->expr_type == EXPR_OP) |
647 | { | |
648 | firstarg = NULL; | |
649 | secondarg = NULL; | |
650 | op1 = e->value.op.op1; | |
651 | op2 = e->value.op.op2; | |
652 | } | |
653 | else if (e->expr_type == EXPR_FUNCTION) | |
654 | { | |
655 | /* One of the lexical comparision functions. */ | |
656 | firstarg = e->value.function.actual; | |
657 | secondarg = firstarg->next; | |
658 | op1 = firstarg->expr; | |
659 | op2 = secondarg->expr; | |
660 | } | |
661 | else | |
662 | gcc_unreachable (); | |
5532a4d1 | 663 | |
664 | /* Strip off unneeded TRIM calls from string comparisons. */ | |
665 | ||
28b8f982 | 666 | change = remove_trim (op1); |
5532a4d1 | 667 | |
28b8f982 | 668 | if (remove_trim (op2)) |
669 | change = true; | |
5532a4d1 | 670 | |
5309e73e | 671 | /* An expression of type EXPR_CONSTANT is only valid for scalars. */ |
672 | /* TODO: A scalar constant may be acceptable in some cases (the scalarizer | |
673 | handles them well). However, there are also cases that need a non-scalar | |
674 | argument. For example the any intrinsic. See PR 45380. */ | |
675 | if (e->rank > 0) | |
28b8f982 | 676 | return change; |
5309e73e | 677 | |
80f5c112 | 678 | /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ |
679 | ||
680 | if (flag_finite_math_only | |
681 | || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL | |
682 | && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX)) | |
5532a4d1 | 683 | { |
80f5c112 | 684 | eq = gfc_dep_compare_expr (op1, op2); |
61bc1860 | 685 | if (eq <= -2) |
80f5c112 | 686 | { |
687 | /* Replace A // B < A // C with B < C, and A // B < C // B | |
688 | with A < C. */ | |
689 | if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER | |
690 | && op1->value.op.op == INTRINSIC_CONCAT | |
691 | && op2->value.op.op == INTRINSIC_CONCAT) | |
692 | { | |
693 | gfc_expr *op1_left = op1->value.op.op1; | |
694 | gfc_expr *op2_left = op2->value.op.op1; | |
695 | gfc_expr *op1_right = op1->value.op.op2; | |
696 | gfc_expr *op2_right = op2->value.op.op2; | |
697 | ||
698 | if (gfc_dep_compare_expr (op1_left, op2_left) == 0) | |
699 | { | |
700 | /* Watch out for 'A ' // x vs. 'A' // x. */ | |
701 | ||
702 | if (op1_left->expr_type == EXPR_CONSTANT | |
703 | && op2_left->expr_type == EXPR_CONSTANT | |
704 | && op1_left->value.character.length | |
705 | != op2_left->value.character.length) | |
28b8f982 | 706 | return change; |
80f5c112 | 707 | else |
708 | { | |
434f0922 | 709 | free (op1_left); |
710 | free (op2_left); | |
0ae5e891 | 711 | if (firstarg) |
712 | { | |
713 | firstarg->expr = op1_right; | |
714 | secondarg->expr = op2_right; | |
715 | } | |
716 | else | |
717 | { | |
718 | e->value.op.op1 = op1_right; | |
719 | e->value.op.op2 = op2_right; | |
720 | } | |
80f5c112 | 721 | optimize_comparison (e, op); |
722 | return true; | |
723 | } | |
724 | } | |
725 | if (gfc_dep_compare_expr (op1_right, op2_right) == 0) | |
726 | { | |
434f0922 | 727 | free (op1_right); |
728 | free (op2_right); | |
0ae5e891 | 729 | if (firstarg) |
730 | { | |
731 | firstarg->expr = op1_left; | |
732 | secondarg->expr = op2_left; | |
733 | } | |
734 | else | |
735 | { | |
736 | e->value.op.op1 = op1_left; | |
737 | e->value.op.op2 = op2_left; | |
738 | } | |
739 | ||
80f5c112 | 740 | optimize_comparison (e, op); |
741 | return true; | |
742 | } | |
743 | } | |
744 | } | |
745 | else | |
746 | { | |
747 | /* eq can only be -1, 0 or 1 at this point. */ | |
748 | switch (op) | |
749 | { | |
750 | case INTRINSIC_EQ: | |
751 | case INTRINSIC_EQ_OS: | |
752 | result = eq == 0; | |
753 | break; | |
754 | ||
755 | case INTRINSIC_GE: | |
756 | case INTRINSIC_GE_OS: | |
757 | result = eq >= 0; | |
758 | break; | |
759 | ||
760 | case INTRINSIC_LE: | |
761 | case INTRINSIC_LE_OS: | |
762 | result = eq <= 0; | |
763 | break; | |
764 | ||
765 | case INTRINSIC_NE: | |
766 | case INTRINSIC_NE_OS: | |
767 | result = eq != 0; | |
768 | break; | |
769 | ||
770 | case INTRINSIC_GT: | |
771 | case INTRINSIC_GT_OS: | |
772 | result = eq > 0; | |
773 | break; | |
774 | ||
775 | case INTRINSIC_LT: | |
776 | case INTRINSIC_LT_OS: | |
777 | result = eq < 0; | |
778 | break; | |
779 | ||
780 | default: | |
781 | gfc_internal_error ("illegal OP in optimize_comparison"); | |
782 | break; | |
783 | } | |
784 | ||
785 | /* Replace the expression by a constant expression. The typespec | |
786 | and where remains the way it is. */ | |
434f0922 | 787 | free (op1); |
788 | free (op2); | |
80f5c112 | 789 | e->expr_type = EXPR_CONSTANT; |
790 | e->value.logical = result; | |
791 | return true; | |
792 | } | |
5532a4d1 | 793 | } |
80f5c112 | 794 | |
28b8f982 | 795 | return change; |
5532a4d1 | 796 | } |
797 | ||
3498c2ca | 798 | /* Optimize a trim function by replacing it with an equivalent substring |
799 | involving a call to len_trim. This only works for expressions where | |
800 | variables are trimmed. Return true if anything was modified. */ | |
801 | ||
802 | static bool | |
803 | optimize_trim (gfc_expr *e) | |
804 | { | |
805 | gfc_expr *a; | |
806 | gfc_ref *ref; | |
807 | gfc_expr *fcn; | |
808 | gfc_actual_arglist *actual_arglist, *next; | |
5a165e92 | 809 | gfc_ref **rr = NULL; |
3498c2ca | 810 | |
811 | /* Don't do this optimization within an argument list, because | |
812 | otherwise aliasing issues may occur. */ | |
813 | ||
814 | if (count_arglist != 1) | |
815 | return false; | |
816 | ||
817 | if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION | |
818 | || e->value.function.isym == NULL | |
819 | || e->value.function.isym->id != GFC_ISYM_TRIM) | |
820 | return false; | |
821 | ||
822 | a = e->value.function.actual->expr; | |
823 | ||
824 | if (a->expr_type != EXPR_VARIABLE) | |
825 | return false; | |
826 | ||
5a165e92 | 827 | /* Follow all references to find the correct place to put the newly |
828 | created reference. FIXME: Also handle substring references and | |
829 | array references. Array references cause strange regressions at | |
830 | the moment. */ | |
831 | ||
3498c2ca | 832 | if (a->ref) |
833 | { | |
5a165e92 | 834 | for (rr = &(a->ref); *rr; rr = &((*rr)->next)) |
835 | { | |
836 | if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) | |
837 | return false; | |
838 | } | |
3498c2ca | 839 | } |
3498c2ca | 840 | |
5a165e92 | 841 | strip_function_call (e); |
3498c2ca | 842 | |
5a165e92 | 843 | if (e->ref == NULL) |
844 | rr = &(e->ref); | |
3498c2ca | 845 | |
5a165e92 | 846 | /* Create the reference. */ |
3498c2ca | 847 | |
5a165e92 | 848 | ref = gfc_get_ref (); |
849 | ref->type = REF_SUBSTRING; | |
3498c2ca | 850 | |
5a165e92 | 851 | /* Set the start of the reference. */ |
3498c2ca | 852 | |
5a165e92 | 853 | ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); |
3498c2ca | 854 | |
5a165e92 | 855 | /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */ |
3498c2ca | 856 | |
5a165e92 | 857 | fcn = gfc_get_expr (); |
858 | fcn->expr_type = EXPR_FUNCTION; | |
859 | fcn->value.function.isym = | |
860 | gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); | |
861 | actual_arglist = gfc_get_actual_arglist (); | |
862 | actual_arglist->expr = gfc_copy_expr (e); | |
863 | next = gfc_get_actual_arglist (); | |
864 | next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, | |
865 | gfc_default_integer_kind); | |
866 | actual_arglist->next = next; | |
867 | fcn->value.function.actual = actual_arglist; | |
868 | ||
869 | /* Set the end of the reference to the call to len_trim. */ | |
870 | ||
871 | ref->u.ss.end = fcn; | |
872 | gcc_assert (*rr == NULL); | |
873 | *rr = ref; | |
874 | return true; | |
3498c2ca | 875 | } |
876 | ||
1c287e8d | 877 | /* Optimize minloc(b), where b is rank 1 array, into |
878 | (/ minloc(b, dim=1) /), and similarly for maxloc, | |
879 | as the latter forms are expanded inline. */ | |
880 | ||
881 | static void | |
882 | optimize_minmaxloc (gfc_expr **e) | |
883 | { | |
884 | gfc_expr *fn = *e; | |
885 | gfc_actual_arglist *a; | |
886 | char *name, *p; | |
887 | ||
888 | if (fn->rank != 1 | |
889 | || fn->value.function.actual == NULL | |
890 | || fn->value.function.actual->expr == NULL | |
891 | || fn->value.function.actual->expr->rank != 1) | |
892 | return; | |
893 | ||
894 | *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); | |
895 | (*e)->shape = fn->shape; | |
896 | fn->rank = 0; | |
897 | fn->shape = NULL; | |
898 | gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); | |
899 | ||
900 | name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); | |
901 | strcpy (name, fn->value.function.name); | |
902 | p = strstr (name, "loc0"); | |
903 | p[3] = '1'; | |
904 | fn->value.function.name = gfc_get_string (name); | |
905 | if (fn->value.function.actual->next) | |
906 | { | |
907 | a = fn->value.function.actual->next; | |
908 | gcc_assert (a->expr == NULL); | |
909 | } | |
910 | else | |
911 | { | |
912 | a = gfc_get_actual_arglist (); | |
913 | fn->value.function.actual->next = a; | |
914 | } | |
915 | a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, | |
916 | &fn->where); | |
917 | mpz_set_ui (a->expr->value.integer, 1); | |
918 | } | |
919 | ||
5f99b526 | 920 | #define WALK_SUBEXPR(NODE) \ |
921 | do \ | |
922 | { \ | |
923 | result = gfc_expr_walker (&(NODE), exprfn, data); \ | |
924 | if (result) \ | |
925 | return result; \ | |
926 | } \ | |
927 | while (0) | |
928 | #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue | |
5532a4d1 | 929 | |
5f99b526 | 930 | /* Walk expression *E, calling EXPRFN on each expression in it. */ |
931 | ||
932 | int | |
933 | gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) | |
5532a4d1 | 934 | { |
5f99b526 | 935 | while (*e) |
936 | { | |
937 | int walk_subtrees = 1; | |
938 | gfc_actual_arglist *a; | |
0477c944 | 939 | gfc_ref *r; |
940 | gfc_constructor *c; | |
941 | ||
5f99b526 | 942 | int result = exprfn (e, &walk_subtrees, data); |
943 | if (result) | |
944 | return result; | |
945 | if (walk_subtrees) | |
946 | switch ((*e)->expr_type) | |
947 | { | |
948 | case EXPR_OP: | |
949 | WALK_SUBEXPR ((*e)->value.op.op1); | |
950 | WALK_SUBEXPR_TAIL ((*e)->value.op.op2); | |
951 | break; | |
952 | case EXPR_FUNCTION: | |
953 | for (a = (*e)->value.function.actual; a; a = a->next) | |
954 | WALK_SUBEXPR (a->expr); | |
955 | break; | |
956 | case EXPR_COMPCALL: | |
957 | case EXPR_PPC: | |
958 | WALK_SUBEXPR ((*e)->value.compcall.base_object); | |
959 | for (a = (*e)->value.compcall.actual; a; a = a->next) | |
960 | WALK_SUBEXPR (a->expr); | |
961 | break; | |
0477c944 | 962 | |
963 | case EXPR_STRUCTURE: | |
964 | case EXPR_ARRAY: | |
965 | for (c = gfc_constructor_first ((*e)->value.constructor); c; | |
966 | c = gfc_constructor_next (c)) | |
967 | { | |
968 | WALK_SUBEXPR (c->expr); | |
969 | if (c->iterator != NULL) | |
970 | { | |
971 | WALK_SUBEXPR (c->iterator->var); | |
972 | WALK_SUBEXPR (c->iterator->start); | |
973 | WALK_SUBEXPR (c->iterator->end); | |
974 | WALK_SUBEXPR (c->iterator->step); | |
975 | } | |
976 | } | |
977 | ||
978 | if ((*e)->expr_type != EXPR_ARRAY) | |
979 | break; | |
980 | ||
981 | /* Fall through to the variable case in order to walk the | |
851d9296 | 982 | reference. */ |
0477c944 | 983 | |
83428098 | 984 | case EXPR_SUBSTRING: |
0477c944 | 985 | case EXPR_VARIABLE: |
986 | for (r = (*e)->ref; r; r = r->next) | |
987 | { | |
988 | gfc_array_ref *ar; | |
989 | int i; | |
990 | ||
991 | switch (r->type) | |
992 | { | |
993 | case REF_ARRAY: | |
994 | ar = &r->u.ar; | |
995 | if (ar->type == AR_SECTION || ar->type == AR_ELEMENT) | |
996 | { | |
997 | for (i=0; i< ar->dimen; i++) | |
998 | { | |
999 | WALK_SUBEXPR (ar->start[i]); | |
1000 | WALK_SUBEXPR (ar->end[i]); | |
1001 | WALK_SUBEXPR (ar->stride[i]); | |
1002 | } | |
1003 | } | |
1004 | ||
1005 | break; | |
1006 | ||
1007 | case REF_SUBSTRING: | |
1008 | WALK_SUBEXPR (r->u.ss.start); | |
1009 | WALK_SUBEXPR (r->u.ss.end); | |
1010 | break; | |
1011 | ||
1012 | case REF_COMPONENT: | |
1013 | break; | |
1014 | } | |
1015 | } | |
1016 | ||
5f99b526 | 1017 | default: |
1018 | break; | |
1019 | } | |
1020 | return 0; | |
1021 | } | |
1022 | return 0; | |
1023 | } | |
5532a4d1 | 1024 | |
5f99b526 | 1025 | #define WALK_SUBCODE(NODE) \ |
1026 | do \ | |
1027 | { \ | |
1028 | result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ | |
1029 | if (result) \ | |
1030 | return result; \ | |
1031 | } \ | |
1032 | while (0) | |
1033 | ||
1034 | /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN | |
1035 | on each expression in it. If any of the hooks returns non-zero, that | |
1036 | value is immediately returned. If the hook sets *WALK_SUBTREES to 0, | |
1037 | no subcodes or subexpressions are traversed. */ | |
1038 | ||
1039 | int | |
1040 | gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, | |
1041 | void *data) | |
1042 | { | |
1043 | for (; *c; c = &(*c)->next) | |
5532a4d1 | 1044 | { |
5f99b526 | 1045 | int walk_subtrees = 1; |
1046 | int result = codefn (c, &walk_subtrees, data); | |
1047 | if (result) | |
1048 | return result; | |
b9495b88 | 1049 | |
5f99b526 | 1050 | if (walk_subtrees) |
1051 | { | |
1052 | gfc_code *b; | |
b9495b88 | 1053 | gfc_actual_arglist *a; |
499edb69 | 1054 | gfc_code *co; |
1055 | ||
1056 | /* There might be statement insertions before the current code, | |
1057 | which must not affect the expression walker. */ | |
1058 | ||
1059 | co = *c; | |
b9495b88 | 1060 | |
499edb69 | 1061 | switch (co->op) |
5f99b526 | 1062 | { |
1063 | case EXEC_DO: | |
499edb69 | 1064 | WALK_SUBEXPR (co->ext.iterator->var); |
1065 | WALK_SUBEXPR (co->ext.iterator->start); | |
1066 | WALK_SUBEXPR (co->ext.iterator->end); | |
1067 | WALK_SUBEXPR (co->ext.iterator->step); | |
5f99b526 | 1068 | break; |
b9495b88 | 1069 | |
1070 | case EXEC_CALL: | |
1071 | case EXEC_ASSIGN_CALL: | |
499edb69 | 1072 | for (a = co->ext.actual; a; a = a->next) |
b9495b88 | 1073 | WALK_SUBEXPR (a->expr); |
1074 | break; | |
1075 | ||
1076 | case EXEC_CALL_PPC: | |
499edb69 | 1077 | WALK_SUBEXPR (co->expr1); |
1078 | for (a = co->ext.actual; a; a = a->next) | |
b9495b88 | 1079 | WALK_SUBEXPR (a->expr); |
1080 | break; | |
1081 | ||
5f99b526 | 1082 | case EXEC_SELECT: |
499edb69 | 1083 | WALK_SUBEXPR (co->expr1); |
1084 | for (b = co->block; b; b = b->block) | |
5f99b526 | 1085 | { |
1086 | gfc_case *cp; | |
030b7e6d | 1087 | for (cp = b->ext.block.case_list; cp; cp = cp->next) |
5f99b526 | 1088 | { |
1089 | WALK_SUBEXPR (cp->low); | |
1090 | WALK_SUBEXPR (cp->high); | |
1091 | } | |
1092 | WALK_SUBCODE (b->next); | |
1093 | } | |
1094 | continue; | |
b9495b88 | 1095 | |
5f99b526 | 1096 | case EXEC_ALLOCATE: |
1097 | case EXEC_DEALLOCATE: | |
1098 | { | |
1099 | gfc_alloc *a; | |
499edb69 | 1100 | for (a = co->ext.alloc.list; a; a = a->next) |
5f99b526 | 1101 | WALK_SUBEXPR (a->expr); |
1102 | break; | |
1103 | } | |
b9495b88 | 1104 | |
5f99b526 | 1105 | case EXEC_FORALL: |
1106 | { | |
1107 | gfc_forall_iterator *fa; | |
499edb69 | 1108 | for (fa = co->ext.forall_iterator; fa; fa = fa->next) |
5f99b526 | 1109 | { |
1110 | WALK_SUBEXPR (fa->var); | |
1111 | WALK_SUBEXPR (fa->start); | |
1112 | WALK_SUBEXPR (fa->end); | |
1113 | WALK_SUBEXPR (fa->stride); | |
1114 | } | |
1115 | break; | |
1116 | } | |
b9495b88 | 1117 | |
5f99b526 | 1118 | case EXEC_OPEN: |
499edb69 | 1119 | WALK_SUBEXPR (co->ext.open->unit); |
1120 | WALK_SUBEXPR (co->ext.open->file); | |
1121 | WALK_SUBEXPR (co->ext.open->status); | |
1122 | WALK_SUBEXPR (co->ext.open->access); | |
1123 | WALK_SUBEXPR (co->ext.open->form); | |
1124 | WALK_SUBEXPR (co->ext.open->recl); | |
1125 | WALK_SUBEXPR (co->ext.open->blank); | |
1126 | WALK_SUBEXPR (co->ext.open->position); | |
1127 | WALK_SUBEXPR (co->ext.open->action); | |
1128 | WALK_SUBEXPR (co->ext.open->delim); | |
1129 | WALK_SUBEXPR (co->ext.open->pad); | |
1130 | WALK_SUBEXPR (co->ext.open->iostat); | |
1131 | WALK_SUBEXPR (co->ext.open->iomsg); | |
1132 | WALK_SUBEXPR (co->ext.open->convert); | |
1133 | WALK_SUBEXPR (co->ext.open->decimal); | |
1134 | WALK_SUBEXPR (co->ext.open->encoding); | |
1135 | WALK_SUBEXPR (co->ext.open->round); | |
1136 | WALK_SUBEXPR (co->ext.open->sign); | |
1137 | WALK_SUBEXPR (co->ext.open->asynchronous); | |
1138 | WALK_SUBEXPR (co->ext.open->id); | |
1139 | WALK_SUBEXPR (co->ext.open->newunit); | |
5f99b526 | 1140 | break; |
b9495b88 | 1141 | |
5f99b526 | 1142 | case EXEC_CLOSE: |
499edb69 | 1143 | WALK_SUBEXPR (co->ext.close->unit); |
1144 | WALK_SUBEXPR (co->ext.close->status); | |
1145 | WALK_SUBEXPR (co->ext.close->iostat); | |
1146 | WALK_SUBEXPR (co->ext.close->iomsg); | |
5f99b526 | 1147 | break; |
b9495b88 | 1148 | |
5f99b526 | 1149 | case EXEC_BACKSPACE: |
1150 | case EXEC_ENDFILE: | |
1151 | case EXEC_REWIND: | |
1152 | case EXEC_FLUSH: | |
499edb69 | 1153 | WALK_SUBEXPR (co->ext.filepos->unit); |
1154 | WALK_SUBEXPR (co->ext.filepos->iostat); | |
1155 | WALK_SUBEXPR (co->ext.filepos->iomsg); | |
5f99b526 | 1156 | break; |
b9495b88 | 1157 | |
5f99b526 | 1158 | case EXEC_INQUIRE: |
499edb69 | 1159 | WALK_SUBEXPR (co->ext.inquire->unit); |
1160 | WALK_SUBEXPR (co->ext.inquire->file); | |
1161 | WALK_SUBEXPR (co->ext.inquire->iomsg); | |
1162 | WALK_SUBEXPR (co->ext.inquire->iostat); | |
1163 | WALK_SUBEXPR (co->ext.inquire->exist); | |
1164 | WALK_SUBEXPR (co->ext.inquire->opened); | |
1165 | WALK_SUBEXPR (co->ext.inquire->number); | |
1166 | WALK_SUBEXPR (co->ext.inquire->named); | |
1167 | WALK_SUBEXPR (co->ext.inquire->name); | |
1168 | WALK_SUBEXPR (co->ext.inquire->access); | |
1169 | WALK_SUBEXPR (co->ext.inquire->sequential); | |
1170 | WALK_SUBEXPR (co->ext.inquire->direct); | |
1171 | WALK_SUBEXPR (co->ext.inquire->form); | |
1172 | WALK_SUBEXPR (co->ext.inquire->formatted); | |
1173 | WALK_SUBEXPR (co->ext.inquire->unformatted); | |
1174 | WALK_SUBEXPR (co->ext.inquire->recl); | |
1175 | WALK_SUBEXPR (co->ext.inquire->nextrec); | |
1176 | WALK_SUBEXPR (co->ext.inquire->blank); | |
1177 | WALK_SUBEXPR (co->ext.inquire->position); | |
1178 | WALK_SUBEXPR (co->ext.inquire->action); | |
1179 | WALK_SUBEXPR (co->ext.inquire->read); | |
1180 | WALK_SUBEXPR (co->ext.inquire->write); | |
1181 | WALK_SUBEXPR (co->ext.inquire->readwrite); | |
1182 | WALK_SUBEXPR (co->ext.inquire->delim); | |
1183 | WALK_SUBEXPR (co->ext.inquire->encoding); | |
1184 | WALK_SUBEXPR (co->ext.inquire->pad); | |
1185 | WALK_SUBEXPR (co->ext.inquire->iolength); | |
1186 | WALK_SUBEXPR (co->ext.inquire->convert); | |
1187 | WALK_SUBEXPR (co->ext.inquire->strm_pos); | |
1188 | WALK_SUBEXPR (co->ext.inquire->asynchronous); | |
1189 | WALK_SUBEXPR (co->ext.inquire->decimal); | |
1190 | WALK_SUBEXPR (co->ext.inquire->pending); | |
1191 | WALK_SUBEXPR (co->ext.inquire->id); | |
1192 | WALK_SUBEXPR (co->ext.inquire->sign); | |
1193 | WALK_SUBEXPR (co->ext.inquire->size); | |
1194 | WALK_SUBEXPR (co->ext.inquire->round); | |
5f99b526 | 1195 | break; |
b9495b88 | 1196 | |
5f99b526 | 1197 | case EXEC_WAIT: |
499edb69 | 1198 | WALK_SUBEXPR (co->ext.wait->unit); |
1199 | WALK_SUBEXPR (co->ext.wait->iostat); | |
1200 | WALK_SUBEXPR (co->ext.wait->iomsg); | |
1201 | WALK_SUBEXPR (co->ext.wait->id); | |
5f99b526 | 1202 | break; |
b9495b88 | 1203 | |
5f99b526 | 1204 | case EXEC_READ: |
1205 | case EXEC_WRITE: | |
499edb69 | 1206 | WALK_SUBEXPR (co->ext.dt->io_unit); |
1207 | WALK_SUBEXPR (co->ext.dt->format_expr); | |
1208 | WALK_SUBEXPR (co->ext.dt->rec); | |
1209 | WALK_SUBEXPR (co->ext.dt->advance); | |
1210 | WALK_SUBEXPR (co->ext.dt->iostat); | |
1211 | WALK_SUBEXPR (co->ext.dt->size); | |
1212 | WALK_SUBEXPR (co->ext.dt->iomsg); | |
1213 | WALK_SUBEXPR (co->ext.dt->id); | |
1214 | WALK_SUBEXPR (co->ext.dt->pos); | |
1215 | WALK_SUBEXPR (co->ext.dt->asynchronous); | |
1216 | WALK_SUBEXPR (co->ext.dt->blank); | |
1217 | WALK_SUBEXPR (co->ext.dt->decimal); | |
1218 | WALK_SUBEXPR (co->ext.dt->delim); | |
1219 | WALK_SUBEXPR (co->ext.dt->pad); | |
1220 | WALK_SUBEXPR (co->ext.dt->round); | |
1221 | WALK_SUBEXPR (co->ext.dt->sign); | |
1222 | WALK_SUBEXPR (co->ext.dt->extra_comma); | |
5f99b526 | 1223 | break; |
b9495b88 | 1224 | |
5f99b526 | 1225 | case EXEC_OMP_DO: |
1226 | case EXEC_OMP_PARALLEL: | |
1227 | case EXEC_OMP_PARALLEL_DO: | |
1228 | case EXEC_OMP_PARALLEL_SECTIONS: | |
1229 | case EXEC_OMP_PARALLEL_WORKSHARE: | |
1230 | case EXEC_OMP_SECTIONS: | |
1231 | case EXEC_OMP_SINGLE: | |
1232 | case EXEC_OMP_WORKSHARE: | |
1233 | case EXEC_OMP_END_SINGLE: | |
1234 | case EXEC_OMP_TASK: | |
499edb69 | 1235 | if (co->ext.omp_clauses) |
5f99b526 | 1236 | { |
499edb69 | 1237 | WALK_SUBEXPR (co->ext.omp_clauses->if_expr); |
2169f33b | 1238 | WALK_SUBEXPR (co->ext.omp_clauses->final_expr); |
499edb69 | 1239 | WALK_SUBEXPR (co->ext.omp_clauses->num_threads); |
1240 | WALK_SUBEXPR (co->ext.omp_clauses->chunk_size); | |
5f99b526 | 1241 | } |
1242 | break; | |
1243 | default: | |
1244 | break; | |
1245 | } | |
b9495b88 | 1246 | |
499edb69 | 1247 | WALK_SUBEXPR (co->expr1); |
1248 | WALK_SUBEXPR (co->expr2); | |
1249 | WALK_SUBEXPR (co->expr3); | |
3f73d66e | 1250 | WALK_SUBEXPR (co->expr4); |
499edb69 | 1251 | for (b = co->block; b; b = b->block) |
5f99b526 | 1252 | { |
1253 | WALK_SUBEXPR (b->expr1); | |
1254 | WALK_SUBEXPR (b->expr2); | |
1255 | WALK_SUBCODE (b->next); | |
1256 | } | |
1257 | } | |
5532a4d1 | 1258 | } |
5f99b526 | 1259 | return 0; |
5532a4d1 | 1260 | } |