]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-expr.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* trans.h (build2_v, build3_v): New macros.
[thirdparty/gcc.git] / gcc / fortran / trans-expr.c
CommitLineData
4ee9c684 1/* Expression translation
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
c84b470d 6This file is part of GCC.
4ee9c684 7
c84b470d 8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 2, or (at your option) any later
11version.
4ee9c684 12
c84b470d 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
4ee9c684 17
18You should have received a copy of the GNU General Public License
c84b470d 19along with GCC; see the file COPYING. If not, write to the Free
20Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2102111-1307, USA. */
4ee9c684 22
23/* trans-expr.c-- generate GENERIC trees for gfc_expr. */
24
25#include "config.h"
26#include "system.h"
27#include "coretypes.h"
28#include "tree.h"
29#include "convert.h"
30#include <stdio.h>
31#include "ggc.h"
32#include "toplev.h"
33#include "real.h"
88bce636 34#include "tree-gimple.h"
4ee9c684 35#include "flags.h"
36#include <gmp.h>
37#include <assert.h>
38#include "gfortran.h"
39#include "trans.h"
40#include "trans-const.h"
41#include "trans-types.h"
42#include "trans-array.h"
43/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44#include "trans-stmt.h"
45
9a0aec1d 46static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
4ee9c684 47
48/* Copy the scalarization loop variables. */
49
50static void
51gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
52{
53 dest->ss = src->ss;
54 dest->loop = src->loop;
55}
56
57
f888a3fb 58/* Initialize a simple expression holder.
4ee9c684 59
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
63
64void
65gfc_init_se (gfc_se * se, gfc_se * parent)
66{
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
70
71 se->parent = parent;
72
73 if (parent)
74 gfc_copy_se_loopvars (se, parent);
75}
76
77
78/* Advances to the next SS in the chain. Use this rather than setting
f888a3fb 79 se->ss = se->ss->next because all the parents needs to be kept in sync.
4ee9c684 80 See gfc_init_se. */
81
82void
83gfc_advance_se_ss_chain (gfc_se * se)
84{
85 gfc_se *p;
86
87 assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
88
89 p = se;
90 /* Walk down the parent chain. */
91 while (p != NULL)
92 {
f888a3fb 93 /* Simple consistency check. */
4ee9c684 94 assert (p->parent == NULL || p->parent->ss == p->ss);
95
96 p->ss = p->ss->next;
97
98 p = p->parent;
99 }
100}
101
102
103/* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
105
106void
107gfc_make_safe_expr (gfc_se * se)
108{
109 tree var;
110
111 if (TREE_CODE_CLASS (TREE_CODE (se->expr)) == 'c')
112 return;
113
f888a3fb 114 /* We need a temporary for this result. */
4ee9c684 115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify_expr (&se->pre, var, se->expr);
117 se->expr = var;
118}
119
120
121/* Return an expression which determines if a dummy parameter is present. */
122
123tree
124gfc_conv_expr_present (gfc_symbol * sym)
125{
126 tree decl;
127
128 assert (sym->attr.dummy && sym->attr.optional);
129
130 decl = gfc_get_symbol_decl (sym);
131 if (TREE_CODE (decl) != PARM_DECL)
132 {
133 /* Array parameters use a temporary descriptor, we want the real
134 parameter. */
135 assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
137 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
138 }
ed52ef8b 139 return build2 (NE_EXPR, boolean_type_node, decl,
140 fold_convert (TREE_TYPE (decl), null_pointer_node));
4ee9c684 141}
142
143
144/* Generate code to initialize a string length variable. Returns the
145 value. */
146
147void
148gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
149{
150 gfc_se se;
151 tree tmp;
152
153 gfc_init_se (&se, NULL);
154 gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node);
155 gfc_add_block_to_block (pblock, &se.pre);
156
157 tmp = cl->backend_decl;
158 gfc_add_modify_expr (pblock, tmp, se.expr);
159}
160
f888a3fb 161
4ee9c684 162static void
163gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
164{
165 tree tmp;
166 tree type;
167 tree var;
168 gfc_se start;
169 gfc_se end;
170
171 type = gfc_get_character_type (kind, ref->u.ss.length);
172 type = build_pointer_type (type);
173
174 var = NULL_TREE;
175 gfc_init_se (&start, se);
176 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node);
177 gfc_add_block_to_block (&se->pre, &start.pre);
178
179 if (integer_onep (start.expr))
260abd71 180 gfc_conv_string_parameter (se);
4ee9c684 181 else
182 {
183 /* Change the start of the string. */
184 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
185 tmp = se->expr;
186 else
187 tmp = gfc_build_indirect_ref (se->expr);
188 tmp = gfc_build_array_ref (tmp, start.expr);
189 se->expr = gfc_build_addr_expr (type, tmp);
190 }
191
192 /* Length = end + 1 - start. */
193 gfc_init_se (&end, se);
194 if (ref->u.ss.end == NULL)
195 end.expr = se->string_length;
196 else
197 {
198 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node);
199 gfc_add_block_to_block (&se->pre, &end.pre);
200 }
201 tmp =
ed52ef8b 202 build2 (MINUS_EXPR, gfc_strlen_type_node,
203 fold_convert (gfc_strlen_type_node, integer_one_node),
204 start.expr);
205 tmp = build2 (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
4ee9c684 206 se->string_length = fold (tmp);
207}
208
209
210/* Convert a derived type component reference. */
211
212static void
213gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
214{
215 gfc_component *c;
216 tree tmp;
217 tree decl;
218 tree field;
219
220 c = ref->u.c.component;
221
222 assert (c->backend_decl);
223
224 field = c->backend_decl;
225 assert (TREE_CODE (field) == FIELD_DECL);
226 decl = se->expr;
ed52ef8b 227 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
4ee9c684 228
229 se->expr = tmp;
230
231 if (c->ts.type == BT_CHARACTER)
232 {
233 tmp = c->ts.cl->backend_decl;
234 assert (tmp);
235 if (!INTEGER_CST_P (tmp))
236 gfc_todo_error ("Unknown length character component");
237 se->string_length = tmp;
238 }
239
240 if (c->pointer && c->dimension == 0)
241 se->expr = gfc_build_indirect_ref (se->expr);
242}
243
244
245/* Return the contents of a variable. Also handles reference/pointer
246 variables (all Fortran pointer references are implicit). */
247
248static void
249gfc_conv_variable (gfc_se * se, gfc_expr * expr)
250{
251 gfc_ref *ref;
252 gfc_symbol *sym;
253
254 sym = expr->symtree->n.sym;
255 if (se->ss != NULL)
256 {
257 /* Check that something hasn't gone horribly wrong. */
258 assert (se->ss != gfc_ss_terminator);
259 assert (se->ss->expr == expr);
260
261 /* A scalarized term. We already know the descriptor. */
262 se->expr = se->ss->data.info.descriptor;
263 ref = se->ss->data.info.ref;
264 }
265 else
266 {
267 se->expr = gfc_get_symbol_decl (sym);
268
269 /* Procedure actual arguments. */
270 if (sym->attr.flavor == FL_PROCEDURE
271 && se->expr != current_function_decl)
272 {
273 assert (se->want_pointer);
274 if (!sym->attr.dummy)
275 {
276 assert (TREE_CODE (se->expr) == FUNCTION_DECL);
277 se->expr = gfc_build_addr_expr (NULL, se->expr);
278 }
279 return;
280 }
281
282 /* Special case for assigning the return value of a function.
283 Self recursive functions must have an explicit return value. */
284 if (se->expr == current_function_decl && sym->attr.function
285 && (sym->result == sym))
286 {
287 se->expr = gfc_get_fake_result_decl (sym);
288 }
289
290 /* Dereference scalar dummy variables. */
291 if (sym->attr.dummy
292 && sym->ts.type != BT_CHARACTER
293 && !sym->attr.dimension)
294 se->expr = gfc_build_indirect_ref (se->expr);
295
296 /* Dereference pointer variables. */
297 if ((sym->attr.pointer || sym->attr.allocatable)
298 && (sym->attr.dummy
299 || sym->attr.result
300 || sym->attr.function
301 || !sym->attr.dimension)
302 && sym->ts.type != BT_CHARACTER)
303 se->expr = gfc_build_indirect_ref (se->expr);
304
305 ref = expr->ref;
306 }
307
308 /* For character variables, also get the length. */
309 if (sym->ts.type == BT_CHARACTER)
310 {
311 se->string_length = sym->ts.cl->backend_decl;
312 assert (se->string_length);
313 }
314
315 while (ref)
316 {
317 switch (ref->type)
318 {
319 case REF_ARRAY:
320 /* Return the descriptor if that's what we want and this is an array
321 section reference. */
322 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
323 return;
324/* TODO: Pointers to single elements of array sections, eg elemental subs. */
325 /* Return the descriptor for array pointers and allocations. */
326 if (se->want_pointer
327 && ref->next == NULL && (se->descriptor_only))
328 return;
329
330 gfc_conv_array_ref (se, &ref->u.ar);
331 /* Return a pointer to an element. */
332 break;
333
334 case REF_COMPONENT:
335 gfc_conv_component_ref (se, ref);
336 break;
337
338 case REF_SUBSTRING:
339 gfc_conv_substring (se, ref, expr->ts.kind);
340 break;
341
342 default:
343 abort ();
344 break;
345 }
346 ref = ref->next;
347 }
348 /* Pointer assignment, allocation or pass by reference. Arrays are handled
f888a3fb 349 separately. */
4ee9c684 350 if (se->want_pointer)
351 {
352 if (expr->ts.type == BT_CHARACTER)
353 gfc_conv_string_parameter (se);
354 else
355 se->expr = gfc_build_addr_expr (NULL, se->expr);
356 }
357 if (se->ss != NULL)
358 gfc_advance_se_ss_chain (se);
359}
360
361
362/* Unary ops are easy... Or they would be if ! was a valid op. */
363
364static void
365gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
366{
367 gfc_se operand;
368 tree type;
369
370 assert (expr->ts.type != BT_CHARACTER);
371 /* Initialize the operand. */
372 gfc_init_se (&operand, se);
373 gfc_conv_expr_val (&operand, expr->op1);
374 gfc_add_block_to_block (&se->pre, &operand.pre);
375
376 type = gfc_typenode_for_spec (&expr->ts);
377
378 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
379 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
f888a3fb 380 All other unary operators have an equivalent GIMPLE unary operator. */
4ee9c684 381 if (code == TRUTH_NOT_EXPR)
ed52ef8b 382 se->expr = build2 (EQ_EXPR, type, operand.expr,
383 convert (type, integer_zero_node));
4ee9c684 384 else
385 se->expr = build1 (code, type, operand.expr);
386
387}
388
76834664 389/* Expand power operator to optimal multiplications when a value is raised
f888a3fb 390 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
76834664 391 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
392 Programming", 3rd Edition, 1998. */
393
394/* This code is mostly duplicated from expand_powi in the backend.
395 We establish the "optimal power tree" lookup table with the defined size.
396 The items in the table are the exponents used to calculate the index
397 exponents. Any integer n less than the value can get an "addition chain",
398 with the first node being one. */
399#define POWI_TABLE_SIZE 256
400
f888a3fb 401/* The table is from builtins.c. */
76834664 402static const unsigned char powi_table[POWI_TABLE_SIZE] =
403 {
404 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
405 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
406 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
407 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
408 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
409 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
410 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
411 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
412 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
413 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
414 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
415 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
416 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
417 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
418 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
419 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
420 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
421 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
422 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
423 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
424 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
425 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
426 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
427 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
428 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
429 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
430 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
431 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
432 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
433 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
434 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
435 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
436 };
437
f888a3fb 438/* If n is larger than lookup table's max index, we use the "window
439 method". */
76834664 440#define POWI_WINDOW_SIZE 3
441
f888a3fb 442/* Recursive function to expand the power operator. The temporary
443 values are put in tmpvar. The function returns tmpvar[1] ** n. */
76834664 444static tree
445gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
4ee9c684 446{
76834664 447 tree op0;
448 tree op1;
4ee9c684 449 tree tmp;
76834664 450 int digit;
4ee9c684 451
76834664 452 if (n < POWI_TABLE_SIZE)
4ee9c684 453 {
76834664 454 if (tmpvar[n])
455 return tmpvar[n];
4ee9c684 456
76834664 457 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
458 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
459 }
460 else if (n & 1)
461 {
462 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
463 op0 = gfc_conv_powi (se, n - digit, tmpvar);
464 op1 = gfc_conv_powi (se, digit, tmpvar);
4ee9c684 465 }
466 else
467 {
76834664 468 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
469 op1 = op0;
4ee9c684 470 }
471
ed52ef8b 472 tmp = fold (build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1));
76834664 473 tmp = gfc_evaluate_now (tmp, &se->pre);
4ee9c684 474
76834664 475 if (n < POWI_TABLE_SIZE)
476 tmpvar[n] = tmp;
4ee9c684 477
76834664 478 return tmp;
479}
4ee9c684 480
f888a3fb 481
482/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
483 return 1. Else return 0 and a call to runtime library functions
484 will have to be built. */
76834664 485static int
486gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
487{
488 tree cond;
489 tree tmp;
490 tree type;
491 tree vartmp[POWI_TABLE_SIZE];
492 int n;
493 int sgn;
4ee9c684 494
76834664 495 type = TREE_TYPE (lhs);
496 n = abs (TREE_INT_CST_LOW (rhs));
497 sgn = tree_int_cst_sgn (rhs);
4ee9c684 498
76834664 499 if ((!flag_unsafe_math_optimizations || optimize_size) && (n > 2 || n < -1))
500 return 0;
4ee9c684 501
76834664 502 /* rhs == 0 */
503 if (sgn == 0)
504 {
505 se->expr = gfc_build_const (type, integer_one_node);
506 return 1;
507 }
508 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
509 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
510 {
ed52ef8b 511 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
512 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
513 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
514 convert (TREE_TYPE (lhs), integer_one_node));
76834664 515
f888a3fb 516 /* If rhs is even,
260abd71 517 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
76834664 518 if ((n & 1) == 0)
519 {
ed52ef8b 520 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
521 se->expr = build3 (COND_EXPR, type, tmp,
522 convert (type, integer_one_node),
523 convert (type, integer_zero_node));
76834664 524 return 1;
525 }
f888a3fb 526 /* If rhs is odd,
76834664 527 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
ed52ef8b 528 tmp = build3 (COND_EXPR, type, tmp,
529 convert (type, integer_minus_one_node),
530 convert (type, integer_zero_node));
531 se->expr = build3 (COND_EXPR, type, cond,
532 convert (type, integer_one_node),
533 tmp);
76834664 534 return 1;
535 }
4ee9c684 536
76834664 537 memset (vartmp, 0, sizeof (vartmp));
538 vartmp[1] = lhs;
76834664 539 if (sgn == -1)
540 {
541 tmp = gfc_build_const (type, integer_one_node);
ed52ef8b 542 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
76834664 543 }
f5efe504 544
545 se->expr = gfc_conv_powi (se, n, vartmp);
546
76834664 547 return 1;
4ee9c684 548}
549
550
76834664 551/* Power op (**). Constant integer exponent has special handling. */
4ee9c684 552
553static void
554gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
555{
556 int kind;
76834664 557 int ikind;
4ee9c684 558 gfc_se lse;
559 gfc_se rse;
560 tree fndecl;
561 tree tmp;
4ee9c684 562
563 gfc_init_se (&lse, se);
564 gfc_conv_expr_val (&lse, expr->op1);
565 gfc_add_block_to_block (&se->pre, &lse.pre);
566
567 gfc_init_se (&rse, se);
568 gfc_conv_expr_val (&rse, expr->op2);
569 gfc_add_block_to_block (&se->pre, &rse.pre);
570
76834664 571 if (expr->op2->ts.type == BT_INTEGER
572 && expr->op2->expr_type == EXPR_CONSTANT)
573 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
574 return;
4ee9c684 575
576 kind = expr->op1->ts.kind;
577 switch (expr->op2->ts.type)
578 {
579 case BT_INTEGER:
76834664 580 ikind = expr->op2->ts.kind;
581 switch (ikind)
582 {
583 case 1:
584 case 2:
585 rse.expr = convert (gfc_int4_type_node, rse.expr);
586 /* Fall through. */
587
588 case 4:
589 ikind = 0;
590 break;
591
592 case 8:
593 ikind = 1;
594 break;
595
596 default:
597 abort();
598 }
599 switch (kind)
600 {
601 case 1:
602 case 2:
603 if (expr->op1->ts.type == BT_INTEGER)
604 lse.expr = convert (gfc_int4_type_node, lse.expr);
605 else
606 abort ();
607 /* Fall through. */
608
609 case 4:
610 kind = 0;
611 break;
612
613 case 8:
614 kind = 1;
615 break;
616
617 default:
618 abort();
619 }
620
621 switch (expr->op1->ts.type)
622 {
623 case BT_INTEGER:
624 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
625 break;
626
627 case BT_REAL:
628 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
629 break;
630
631 case BT_COMPLEX:
632 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
633 break;
634
635 default:
636 abort ();
637 }
638 break;
4ee9c684 639
640 case BT_REAL:
641 switch (kind)
642 {
643 case 4:
76834664 644 fndecl = built_in_decls[BUILT_IN_POWF];
4ee9c684 645 break;
646 case 8:
76834664 647 fndecl = built_in_decls[BUILT_IN_POW];
4ee9c684 648 break;
649 default:
650 abort ();
651 }
652 break;
653
654 case BT_COMPLEX:
655 switch (kind)
656 {
657 case 4:
658 fndecl = gfor_fndecl_math_cpowf;
659 break;
660 case 8:
661 fndecl = gfor_fndecl_math_cpow;
662 break;
663 default:
664 abort ();
665 }
666 break;
667
668 default:
669 abort ();
670 break;
671 }
672
673 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
674 tmp = gfc_chainon_list (tmp, rse.expr);
76834664 675 se->expr = fold (gfc_build_function_call (fndecl, tmp));
4ee9c684 676}
677
678
679/* Generate code to allocate a string temporary. */
680
681tree
682gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
683{
684 tree var;
685 tree tmp;
686 tree args;
687
260abd71 688 if (TREE_TYPE (len) != gfc_strlen_type_node)
689 abort ();
690
4ee9c684 691 if (gfc_can_put_var_on_stack (len))
692 {
693 /* Create a temporary variable to hold the result. */
ed52ef8b 694 tmp = fold (build2 (MINUS_EXPR, gfc_strlen_type_node, len,
695 convert (gfc_strlen_type_node,
696 integer_one_node)));
260abd71 697 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
4ee9c684 698 tmp = build_array_type (gfc_character1_type_node, tmp);
699 var = gfc_create_var (tmp, "str");
700 var = gfc_build_addr_expr (type, var);
701 }
702 else
703 {
704 /* Allocate a temporary to hold the result. */
705 var = gfc_create_var (type, "pstr");
706 args = gfc_chainon_list (NULL_TREE, len);
707 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
708 tmp = convert (type, tmp);
709 gfc_add_modify_expr (&se->pre, var, tmp);
710
711 /* Free the temporary afterwards. */
712 tmp = convert (pvoid_type_node, var);
713 args = gfc_chainon_list (NULL_TREE, tmp);
714 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
715 gfc_add_expr_to_block (&se->post, tmp);
716 }
717
718 return var;
719}
720
721
722/* Handle a string concatenation operation. A temporary will be allocated to
723 hold the result. */
724
725static void
726gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
727{
728 gfc_se lse;
729 gfc_se rse;
730 tree len;
731 tree type;
732 tree var;
733 tree args;
734 tree tmp;
735
736 assert (expr->op1->ts.type == BT_CHARACTER
737 && expr->op2->ts.type == BT_CHARACTER);
738
739 gfc_init_se (&lse, se);
740 gfc_conv_expr (&lse, expr->op1);
741 gfc_conv_string_parameter (&lse);
742 gfc_init_se (&rse, se);
743 gfc_conv_expr (&rse, expr->op2);
744 gfc_conv_string_parameter (&rse);
745
746 gfc_add_block_to_block (&se->pre, &lse.pre);
747 gfc_add_block_to_block (&se->pre, &rse.pre);
748
749 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
750 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
751 if (len == NULL_TREE)
752 {
ed52ef8b 753 len = fold (build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
754 lse.string_length, rse.string_length));
4ee9c684 755 }
756
757 type = build_pointer_type (type);
758
759 var = gfc_conv_string_tmp (se, type, len);
760
761 /* Do the actual concatenation. */
762 args = NULL_TREE;
763 args = gfc_chainon_list (args, len);
764 args = gfc_chainon_list (args, var);
765 args = gfc_chainon_list (args, lse.string_length);
766 args = gfc_chainon_list (args, lse.expr);
767 args = gfc_chainon_list (args, rse.string_length);
768 args = gfc_chainon_list (args, rse.expr);
769 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
770 gfc_add_expr_to_block (&se->pre, tmp);
771
772 /* Add the cleanup for the operands. */
773 gfc_add_block_to_block (&se->pre, &rse.post);
774 gfc_add_block_to_block (&se->pre, &lse.post);
775
776 se->expr = var;
777 se->string_length = len;
778}
779
780
781/* Translates an op expression. Common (binary) cases are handled by this
782 function, others are passed on. Recursion is used in either case.
783 We use the fact that (op1.ts == op2.ts) (except for the power
f888a3fb 784 operator **).
4ee9c684 785 Operators need no special handling for scalarized expressions as long as
f888a3fb 786 they call gfc_conv_simple_val to get their operands.
4ee9c684 787 Character strings get special handling. */
788
789static void
790gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
791{
792 enum tree_code code;
793 gfc_se lse;
794 gfc_se rse;
795 tree type;
796 tree tmp;
797 int lop;
798 int checkstring;
799
800 checkstring = 0;
801 lop = 0;
802 switch (expr->operator)
803 {
804 case INTRINSIC_UPLUS:
805 gfc_conv_expr (se, expr->op1);
806 return;
807
808 case INTRINSIC_UMINUS:
809 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
810 return;
811
812 case INTRINSIC_NOT:
813 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
814 return;
815
816 case INTRINSIC_PLUS:
817 code = PLUS_EXPR;
818 break;
819
820 case INTRINSIC_MINUS:
821 code = MINUS_EXPR;
822 break;
823
824 case INTRINSIC_TIMES:
825 code = MULT_EXPR;
826 break;
827
828 case INTRINSIC_DIVIDE:
829 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
830 an integer, we must round towards zero, so we use a
831 TRUNC_DIV_EXPR. */
832 if (expr->ts.type == BT_INTEGER)
833 code = TRUNC_DIV_EXPR;
834 else
835 code = RDIV_EXPR;
836 break;
837
838 case INTRINSIC_POWER:
839 gfc_conv_power_op (se, expr);
840 return;
841
842 case INTRINSIC_CONCAT:
843 gfc_conv_concat_op (se, expr);
844 return;
845
846 case INTRINSIC_AND:
847 code = TRUTH_ANDIF_EXPR;
848 lop = 1;
849 break;
850
851 case INTRINSIC_OR:
852 code = TRUTH_ORIF_EXPR;
853 lop = 1;
854 break;
855
856 /* EQV and NEQV only work on logicals, but since we represent them
88bce636 857 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4ee9c684 858 case INTRINSIC_EQ:
859 case INTRINSIC_EQV:
860 code = EQ_EXPR;
861 checkstring = 1;
862 lop = 1;
863 break;
864
865 case INTRINSIC_NE:
866 case INTRINSIC_NEQV:
867 code = NE_EXPR;
868 checkstring = 1;
869 lop = 1;
870 break;
871
872 case INTRINSIC_GT:
873 code = GT_EXPR;
874 checkstring = 1;
875 lop = 1;
876 break;
877
878 case INTRINSIC_GE:
879 code = GE_EXPR;
880 checkstring = 1;
881 lop = 1;
882 break;
883
884 case INTRINSIC_LT:
885 code = LT_EXPR;
886 checkstring = 1;
887 lop = 1;
888 break;
889
890 case INTRINSIC_LE:
891 code = LE_EXPR;
892 checkstring = 1;
893 lop = 1;
894 break;
895
896 case INTRINSIC_USER:
897 case INTRINSIC_ASSIGN:
898 /* These should be converted into function calls by the frontend. */
899 abort ();
900 return;
901
902 default:
903 fatal_error ("Unknown intrinsic op");
904 return;
905 }
906
f888a3fb 907 /* The only exception to this is **, which is handled separately anyway. */
4ee9c684 908 assert (expr->op1->ts.type == expr->op2->ts.type);
909
910 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
911 checkstring = 0;
912
913 /* lhs */
914 gfc_init_se (&lse, se);
915 gfc_conv_expr (&lse, expr->op1);
916 gfc_add_block_to_block (&se->pre, &lse.pre);
917
918 /* rhs */
919 gfc_init_se (&rse, se);
920 gfc_conv_expr (&rse, expr->op2);
921 gfc_add_block_to_block (&se->pre, &rse.pre);
922
923 /* For string comparisons we generate a library call, and compare the return
924 value with 0. */
925 if (checkstring)
926 {
927 gfc_conv_string_parameter (&lse);
928 gfc_conv_string_parameter (&rse);
929 tmp = NULL_TREE;
930 tmp = gfc_chainon_list (tmp, lse.string_length);
931 tmp = gfc_chainon_list (tmp, lse.expr);
932 tmp = gfc_chainon_list (tmp, rse.string_length);
933 tmp = gfc_chainon_list (tmp, rse.expr);
934
935 /* Build a call for the comparison. */
936 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
937 gfc_add_block_to_block (&lse.post, &rse.post);
938
939 rse.expr = integer_zero_node;
940 }
941
942 type = gfc_typenode_for_spec (&expr->ts);
943
944 if (lop)
945 {
946 /* The result of logical ops is always boolean_type_node. */
ed52ef8b 947 tmp = fold (build2 (code, type, lse.expr, rse.expr));
4ee9c684 948 se->expr = convert (type, tmp);
949 }
950 else
ed52ef8b 951 se->expr = fold (build2 (code, type, lse.expr, rse.expr));
4ee9c684 952
4ee9c684 953 /* Add the post blocks. */
954 gfc_add_block_to_block (&se->post, &rse.post);
955 gfc_add_block_to_block (&se->post, &lse.post);
956}
957
f888a3fb 958
4ee9c684 959static void
960gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
961{
962 tree tmp;
963
964 if (sym->attr.dummy)
965 {
966 tmp = gfc_get_symbol_decl (sym);
967 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
968 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
969
970 se->expr = tmp;
971 }
972 else
973 {
974 if (!sym->backend_decl)
975 sym->backend_decl = gfc_get_extern_function_decl (sym);
976
977 tmp = sym->backend_decl;
978 assert (TREE_CODE (tmp) == FUNCTION_DECL);
979 se->expr = gfc_build_addr_expr (NULL, tmp);
980 }
981}
982
983
984/* Generate code for a procedure call. Note can return se->post != NULL.
985 If se->direct_byref is set then se->expr contains the return parameter. */
986
987void
988gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
989 gfc_actual_arglist * arg)
990{
991 tree arglist;
992 tree tmp;
993 tree fntype;
994 gfc_se parmse;
995 gfc_ss *argss;
996 gfc_ss_info *info;
997 int byref;
998 tree type;
999 tree var;
1000 tree len;
1001 tree stringargs;
1002 gfc_formal_arglist *formal;
1003
1004 arglist = NULL_TREE;
1005 stringargs = NULL_TREE;
1006 var = NULL_TREE;
1007 len = NULL_TREE;
1008
1009 if (se->ss != NULL)
1010 {
1011 if (!sym->attr.elemental)
1012 {
1013 assert (se->ss->type == GFC_SS_FUNCTION);
1014 if (se->ss->useflags)
1015 {
1016 assert (gfc_return_by_reference (sym)
1017 && sym->result->attr.dimension);
1018 assert (se->loop != NULL);
1019
1020 /* Access the previously obtained result. */
1021 gfc_conv_tmp_array_ref (se);
1022 gfc_advance_se_ss_chain (se);
1023 return;
1024 }
1025 }
1026 info = &se->ss->data.info;
1027 }
1028 else
1029 info = NULL;
1030
1031 byref = gfc_return_by_reference (sym);
1032 if (byref)
1033 {
1034 if (se->direct_byref)
1035 arglist = gfc_chainon_list (arglist, se->expr);
1036 else if (sym->result->attr.dimension)
1037 {
1038 assert (se->loop && se->ss);
1039 /* Set the type of the array. */
1040 tmp = gfc_typenode_for_spec (&sym->ts);
1041 info->dimen = se->loop->dimen;
1042 /* Allocate a temporary to store the result. */
1043 gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
1044
1045 /* Zero the first stride to indicate a temporary. */
1046 tmp =
1047 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
260abd71 1048 gfc_add_modify_expr (&se->pre, tmp,
1049 convert (TREE_TYPE (tmp), integer_zero_node));
4ee9c684 1050 /* Pass the temporary as the first argument. */
1051 tmp = info->descriptor;
1052 tmp = gfc_build_addr_expr (NULL, tmp);
1053 arglist = gfc_chainon_list (arglist, tmp);
1054 }
1055 else if (sym->ts.type == BT_CHARACTER)
1056 {
1057 assert (sym->ts.cl && sym->ts.cl->length
1058 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1059 len = gfc_conv_mpz_to_tree
1060 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1061 sym->ts.cl->backend_decl = len;
1062 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1063 type = build_pointer_type (type);
1064
1065 var = gfc_conv_string_tmp (se, type, len);
1066 arglist = gfc_chainon_list (arglist, var);
1067 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1068 len));
1069 }
1070 else /* TODO: derived type function return values. */
1071 abort ();
1072 }
1073
1074 formal = sym->formal;
1075 /* Evaluate the arguments. */
1076 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1077 {
1078 if (arg->expr == NULL)
1079 {
1080
1081 if (se->ignore_optional)
1082 {
1083 /* Some intrinsics have already been resolved to the correct
1084 parameters. */
1085 continue;
1086 }
1087 else if (arg->label)
1088 {
1089 has_alternate_specifier = 1;
1090 continue;
1091 }
1092 else
1093 {
1094 /* Pass a NULL pointer for an absent arg. */
1095 gfc_init_se (&parmse, NULL);
1096 parmse.expr = null_pointer_node;
0fe9e56f 1097 if (arg->missing_arg_type == BT_CHARACTER)
4ee9c684 1098 {
260abd71 1099 stringargs =
1100 gfc_chainon_list (stringargs,
1101 convert (gfc_strlen_type_node,
1102 integer_zero_node));
4ee9c684 1103 }
1104 }
1105 }
1106 else if (se->ss && se->ss->useflags)
1107 {
1108 /* An elemental function inside a scalarized loop. */
1109 gfc_init_se (&parmse, se);
1110 gfc_conv_expr_reference (&parmse, arg->expr);
1111 }
1112 else
1113 {
1114 /* A scalar or transformational function. */
1115 gfc_init_se (&parmse, NULL);
1116 argss = gfc_walk_expr (arg->expr);
1117
1118 if (argss == gfc_ss_terminator)
1119 {
1120 gfc_conv_expr_reference (&parmse, arg->expr);
d6606878 1121 if (formal && formal->sym->attr.pointer
1122 && arg->expr->expr_type != EXPR_NULL)
4ee9c684 1123 {
1124 /* Scalar pointer dummy args require an extra level of
d6606878 1125 indirection. The null pointer already contains
1126 this level of indirection. */
4ee9c684 1127 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1128 }
1129 }
1130 else
1131 {
f888a3fb 1132 /* If the procedure requires an explicit interface, the
1133 actual argument is passed according to the
1134 corresponding formal argument. If the corresponding
1135 formal argument is a POINTER or assumed shape, we do
1136 not use g77's calling aonvention, and pass the
1137 address of the array descriptor instead. Otherwise we
1138 use g77's calling convention. */
4ee9c684 1139 int f;
1140 f = (formal != NULL)
1141 && !formal->sym->attr.pointer
1142 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1143 f = f || !sym->attr.always_explicit;
1144 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1145 }
1146 }
1147
1148 gfc_add_block_to_block (&se->pre, &parmse.pre);
1149 gfc_add_block_to_block (&se->post, &parmse.post);
1150
1151 /* Character strings are passed as two paramarers, a length and a
1152 pointer. */
1153 if (parmse.string_length != NULL_TREE)
1154 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1155
1156 arglist = gfc_chainon_list (arglist, parmse.expr);
1157 }
1158
1159 /* Add the hidden string length parameters to the arguments. */
1160 arglist = chainon (arglist, stringargs);
1161
1162 /* Generate the actual call. */
1163 gfc_conv_function_val (se, sym);
1164 /* If there are alternate return labels, function type should be
1165 integer. */
1166 if (has_alternate_specifier)
1167 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1168
1169 fntype = TREE_TYPE (TREE_TYPE (se->expr));
ed52ef8b 1170 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1171 arglist, NULL_TREE);
4ee9c684 1172
f888a3fb 1173 /* A pure function may still have side-effects - it may modify its
1174 parameters. */
4ee9c684 1175 TREE_SIDE_EFFECTS (se->expr) = 1;
1176#if 0
1177 if (!sym->attr.pure)
1178 TREE_SIDE_EFFECTS (se->expr) = 1;
1179#endif
1180
4396343e 1181 if (byref)
4ee9c684 1182 {
4396343e 1183 /* Add the function call to the pre chain. There is no expression. */
4ee9c684 1184 gfc_add_expr_to_block (&se->pre, se->expr);
4396343e 1185 se->expr = NULL_TREE;
4ee9c684 1186
4396343e 1187 if (!se->direct_byref)
4ee9c684 1188 {
4396343e 1189 if (sym->result->attr.dimension)
4ee9c684 1190 {
4396343e 1191 if (flag_bounds_check)
1192 {
1193 /* Check the data pointer hasn't been modified. This would
1194 happen in a function returning a pointer. */
1195 tmp = gfc_conv_descriptor_data (info->descriptor);
ed52ef8b 1196 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
4396343e 1197 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1198 }
1199 se->expr = info->descriptor;
4ee9c684 1200 }
4396343e 1201 else if (sym->ts.type == BT_CHARACTER)
1202 {
1203 se->expr = var;
1204 se->string_length = len;
1205 }
1206 else
1207 abort ();
4ee9c684 1208 }
4ee9c684 1209 }
1210}
1211
1212
dbe60343 1213/* Generate code to copy a string. */
1214
1215static void
1216gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1217 tree slen, tree src)
1218{
1219 tree tmp;
1220
1221 tmp = NULL_TREE;
1222 tmp = gfc_chainon_list (tmp, dlen);
1223 tmp = gfc_chainon_list (tmp, dest);
1224 tmp = gfc_chainon_list (tmp, slen);
1225 tmp = gfc_chainon_list (tmp, src);
1226 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1227 gfc_add_expr_to_block (block, tmp);
1228}
1229
1230
4ee9c684 1231/* Translate a statement function.
1232 The value of a statement function reference is obtained by evaluating the
1233 expression using the values of the actual arguments for the values of the
1234 corresponding dummy arguments. */
1235
1236static void
1237gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1238{
1239 gfc_symbol *sym;
1240 gfc_symbol *fsym;
1241 gfc_formal_arglist *fargs;
1242 gfc_actual_arglist *args;
1243 gfc_se lse;
1244 gfc_se rse;
dbe60343 1245 gfc_saved_var *saved_vars;
1246 tree *temp_vars;
1247 tree type;
1248 tree tmp;
1249 int n;
4ee9c684 1250
1251 sym = expr->symtree->n.sym;
1252 args = expr->value.function.actual;
1253 gfc_init_se (&lse, NULL);
1254 gfc_init_se (&rse, NULL);
1255
dbe60343 1256 n = 0;
4ee9c684 1257 for (fargs = sym->formal; fargs; fargs = fargs->next)
dbe60343 1258 n++;
1259 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1260 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1261
1262 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
4ee9c684 1263 {
1264 /* Each dummy shall be specified, explicitly or implicitly, to be
1265 scalar. */
1266 assert (fargs->sym->attr.dimension == 0);
1267 fsym = fargs->sym;
4ee9c684 1268
dbe60343 1269 /* Create a temporary to hold the value. */
1270 type = gfc_typenode_for_spec (&fsym->ts);
1271 temp_vars[n] = gfc_create_var (type, fsym->name);
1272
1273 if (fsym->ts.type == BT_CHARACTER)
4ee9c684 1274 {
dbe60343 1275 /* Copy string arguments. */
1276 tree arglen;
4ee9c684 1277
1278 assert (fsym->ts.cl && fsym->ts.cl->length
1279 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1280
dbe60343 1281 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1282 tmp = gfc_build_addr_expr (build_pointer_type (type),
1283 temp_vars[n]);
4ee9c684 1284
1285 gfc_conv_expr (&rse, args->expr);
1286 gfc_conv_string_parameter (&rse);
4ee9c684 1287 gfc_add_block_to_block (&se->pre, &lse.pre);
1288 gfc_add_block_to_block (&se->pre, &rse.pre);
1289
dbe60343 1290 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1291 rse.expr);
4ee9c684 1292 gfc_add_block_to_block (&se->pre, &lse.post);
1293 gfc_add_block_to_block (&se->pre, &rse.post);
1294 }
1295 else
1296 {
1297 /* For everything else, just evaluate the expression. */
4ee9c684 1298 gfc_conv_expr (&lse, args->expr);
1299
1300 gfc_add_block_to_block (&se->pre, &lse.pre);
dbe60343 1301 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
4ee9c684 1302 gfc_add_block_to_block (&se->pre, &lse.post);
1303 }
dbe60343 1304
4ee9c684 1305 args = args->next;
1306 }
dbe60343 1307
1308 /* Use the temporary variables in place of the real ones. */
1309 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1310 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1311
4ee9c684 1312 gfc_conv_expr (se, sym->value);
dbe60343 1313
1314 if (sym->ts.type == BT_CHARACTER)
1315 {
1316 gfc_conv_const_charlen (sym->ts.cl);
1317
1318 /* Force the expression to the correct length. */
1319 if (!INTEGER_CST_P (se->string_length)
1320 || tree_int_cst_lt (se->string_length,
1321 sym->ts.cl->backend_decl))
1322 {
1323 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1324 tmp = gfc_create_var (type, sym->name);
1325 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1326 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1327 se->string_length, se->expr);
1328 se->expr = tmp;
1329 }
1330 se->string_length = sym->ts.cl->backend_decl;
1331 }
1332
f888a3fb 1333 /* Restore the original variables. */
dbe60343 1334 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1335 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1336 gfc_free (saved_vars);
4ee9c684 1337}
1338
1339
1340/* Translate a function expression. */
1341
1342static void
1343gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1344{
1345 gfc_symbol *sym;
1346
1347 if (expr->value.function.isym)
1348 {
1349 gfc_conv_intrinsic_function (se, expr);
1350 return;
1351 }
1352
f888a3fb 1353 /* We distinguish statement functions from general functions to improve
4ee9c684 1354 runtime performance. */
1355 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1356 {
1357 gfc_conv_statement_function (se, expr);
1358 return;
1359 }
1360
1361 /* expr.value.function.esym is the resolved (specific) function symbol for
1362 most functions. However this isn't set for dummy procedures. */
1363 sym = expr->value.function.esym;
1364 if (!sym)
1365 sym = expr->symtree->n.sym;
1366 gfc_conv_function_call (se, sym, expr->value.function.actual);
1367}
1368
f888a3fb 1369
4ee9c684 1370static void
1371gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1372{
1373 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1374 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1375
1376 gfc_conv_tmp_array_ref (se);
1377 gfc_advance_se_ss_chain (se);
1378}
1379
1380
bda1f152 1381/* Build a static initializer. EXPR is the expression for the initial value.
f888a3fb 1382 The other parameters describe the variable of the component being
1383 initialized. EXPR may be null. */
4ee9c684 1384
bda1f152 1385tree
1386gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1387 bool array, bool pointer)
1388{
1389 gfc_se se;
1390
1391 if (!(expr || pointer))
1392 return NULL_TREE;
1393
1394 if (array)
1395 {
1396 /* Arrays need special handling. */
1397 if (pointer)
1398 return gfc_build_null_descriptor (type);
1399 else
1400 return gfc_conv_array_initializer (type, expr);
1401 }
1402 else if (pointer)
1403 return fold_convert (type, null_pointer_node);
1404 else
1405 {
1406 switch (ts->type)
1407 {
1408 case BT_DERIVED:
1409 gfc_init_se (&se, NULL);
1410 gfc_conv_structure (&se, expr, 1);
1411 return se.expr;
1412
1413 case BT_CHARACTER:
1414 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1415
1416 default:
1417 gfc_init_se (&se, NULL);
1418 gfc_conv_constant (&se, expr);
1419 return se.expr;
1420 }
1421 }
1422}
1423
9a0aec1d 1424static tree
1425gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1426{
1427 gfc_se rse;
1428 gfc_se lse;
1429 gfc_ss *rss;
1430 gfc_ss *lss;
1431 stmtblock_t body;
1432 stmtblock_t block;
1433 gfc_loopinfo loop;
1434 int n;
1435 tree tmp;
1436
1437 gfc_start_block (&block);
1438
1439 /* Initialize the scalarizer. */
1440 gfc_init_loopinfo (&loop);
1441
1442 gfc_init_se (&lse, NULL);
1443 gfc_init_se (&rse, NULL);
1444
1445 /* Walk the rhs. */
1446 rss = gfc_walk_expr (expr);
1447 if (rss == gfc_ss_terminator)
1448 {
1449 /* The rhs is scalar. Add a ss for the expression. */
1450 rss = gfc_get_ss ();
1451 rss->next = gfc_ss_terminator;
1452 rss->type = GFC_SS_SCALAR;
1453 rss->expr = expr;
1454 }
1455
1456 /* Create a SS for the destination. */
1457 lss = gfc_get_ss ();
1458 lss->type = GFC_SS_COMPONENT;
1459 lss->expr = NULL;
1460 lss->shape = gfc_get_shape (cm->as->rank);
1461 lss->next = gfc_ss_terminator;
1462 lss->data.info.dimen = cm->as->rank;
1463 lss->data.info.descriptor = dest;
1464 lss->data.info.data = gfc_conv_array_data (dest);
1465 lss->data.info.offset = gfc_conv_array_offset (dest);
1466 for (n = 0; n < cm->as->rank; n++)
1467 {
1468 lss->data.info.dim[n] = n;
1469 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1470 lss->data.info.stride[n] = gfc_index_one_node;
1471
1472 mpz_init (lss->shape[n]);
1473 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1474 cm->as->lower[n]->value.integer);
1475 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1476 }
1477
1478 /* Associate the SS with the loop. */
1479 gfc_add_ss_to_loop (&loop, lss);
1480 gfc_add_ss_to_loop (&loop, rss);
1481
1482 /* Calculate the bounds of the scalarization. */
1483 gfc_conv_ss_startstride (&loop);
1484
1485 /* Setup the scalarizing loops. */
1486 gfc_conv_loop_setup (&loop);
1487
1488 /* Setup the gfc_se structures. */
1489 gfc_copy_loopinfo_to_se (&lse, &loop);
1490 gfc_copy_loopinfo_to_se (&rse, &loop);
1491
1492 rse.ss = rss;
1493 gfc_mark_ss_chain_used (rss, 1);
1494 lse.ss = lss;
1495 gfc_mark_ss_chain_used (lss, 1);
1496
1497 /* Start the scalarized loop body. */
1498 gfc_start_scalarized_body (&loop, &body);
1499
1500 gfc_conv_tmp_array_ref (&lse);
1501 gfc_conv_expr (&rse, expr);
1502
1503 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1504 gfc_add_expr_to_block (&body, tmp);
1505
1506 if (rse.ss != gfc_ss_terminator)
1507 abort ();
1508
1509 /* Generate the copying loops. */
1510 gfc_trans_scalarizing_loops (&loop, &body);
1511
1512 /* Wrap the whole thing up. */
1513 gfc_add_block_to_block (&block, &loop.pre);
1514 gfc_add_block_to_block (&block, &loop.post);
1515
1516 gfc_cleanup_loop (&loop);
1517
1518 for (n = 0; n < cm->as->rank; n++)
1519 mpz_clear (lss->shape[n]);
1520 gfc_free (lss->shape);
1521
1522 return gfc_finish_block (&block);
1523}
1524
1525/* Assign a single component of a derived type constructor. */
1526
1527static tree
1528gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1529{
1530 gfc_se se;
1531 gfc_ss *rss;
1532 stmtblock_t block;
1533 tree tmp;
1534
1535 gfc_start_block (&block);
1536 if (cm->pointer)
1537 {
1538 gfc_init_se (&se, NULL);
1539 /* Pointer component. */
1540 if (cm->dimension)
1541 {
1542 /* Array pointer. */
1543 if (expr->expr_type == EXPR_NULL)
1544 {
1545 dest = gfc_conv_descriptor_data (dest);
1546 tmp = fold_convert (TREE_TYPE (se.expr),
1547 null_pointer_node);
1548 gfc_add_modify_expr (&block, dest, tmp);
1549 }
1550 else
1551 {
1552 rss = gfc_walk_expr (expr);
1553 se.direct_byref = 1;
1554 se.expr = dest;
1555 gfc_conv_expr_descriptor (&se, expr, rss);
1556 gfc_add_block_to_block (&block, &se.pre);
1557 gfc_add_block_to_block (&block, &se.post);
1558 }
1559 }
1560 else
1561 {
1562 /* Scalar pointers. */
1563 se.want_pointer = 1;
1564 gfc_conv_expr (&se, expr);
1565 gfc_add_block_to_block (&block, &se.pre);
1566 gfc_add_modify_expr (&block, dest,
1567 fold_convert (TREE_TYPE (dest), se.expr));
1568 gfc_add_block_to_block (&block, &se.post);
1569 }
1570 }
1571 else if (cm->dimension)
1572 {
1573 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1574 gfc_add_expr_to_block (&block, tmp);
1575 }
1576 else if (expr->ts.type == BT_DERIVED)
1577 {
1578 /* Nested dervived type. */
1579 tmp = gfc_trans_structure_assign (dest, expr);
1580 gfc_add_expr_to_block (&block, tmp);
1581 }
1582 else
1583 {
1584 /* Scalar component. */
1585 gfc_se lse;
1586
1587 gfc_init_se (&se, NULL);
1588 gfc_init_se (&lse, NULL);
1589
1590 gfc_conv_expr (&se, expr);
1591 if (cm->ts.type == BT_CHARACTER)
1592 lse.string_length = cm->ts.cl->backend_decl;
1593 lse.expr = dest;
1594 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1595 gfc_add_expr_to_block (&block, tmp);
1596 }
1597 return gfc_finish_block (&block);
1598}
1599
1600/* Assign a derived type contructor to a variable. */
1601
1602static tree
1603gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1604{
1605 gfc_constructor *c;
1606 gfc_component *cm;
1607 stmtblock_t block;
1608 tree field;
1609 tree tmp;
1610
1611 gfc_start_block (&block);
1612 cm = expr->ts.derived->components;
1613 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1614 {
1615 /* Skip absent members in default initializers. */
1616 if (!c->expr)
1617 continue;
1618
1619 field = cm->backend_decl;
ed52ef8b 1620 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
9a0aec1d 1621 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1622 gfc_add_expr_to_block (&block, tmp);
1623 }
1624 return gfc_finish_block (&block);
1625}
1626
4ee9c684 1627/* Build an expression for a constructor. If init is nonzero then
1628 this is part of a static variable initializer. */
1629
1630void
1631gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1632{
1633 gfc_constructor *c;
1634 gfc_component *cm;
1635 tree head;
1636 tree tail;
1637 tree val;
4ee9c684 1638 tree type;
9a0aec1d 1639 tree tmp;
4ee9c684 1640
9a0aec1d 1641 assert (se->ss == NULL);
1642 assert (expr->expr_type == EXPR_STRUCTURE);
4ee9c684 1643 type = gfc_typenode_for_spec (&expr->ts);
9a0aec1d 1644
1645 if (!init)
1646 {
1647 /* Create a temporary variable and fill it in. */
1648 se->expr = gfc_create_var (type, expr->ts.derived->name);
1649 tmp = gfc_trans_structure_assign (se->expr, expr);
1650 gfc_add_expr_to_block (&se->pre, tmp);
1651 return;
1652 }
1653
4ee9c684 1654 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1655 tail = NULL_TREE;
1656
1657 cm = expr->ts.derived->components;
1658 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1659 {
1660 /* Skip absent members in default initializers. */
1661 if (!c->expr)
1662 continue;
1663
9a0aec1d 1664 val = gfc_conv_initializer (c->expr, &cm->ts,
1665 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
4ee9c684 1666
1667 /* Build a TREE_CHAIN to hold it. */
9a0aec1d 1668 val = tree_cons (cm->backend_decl, val, NULL_TREE);
4ee9c684 1669
1670 /* Add it to the list. */
1671 if (tail == NULL_TREE)
1672 TREE_OPERAND(head, 0) = tail = val;
1673 else
1674 {
1675 TREE_CHAIN (tail) = val;
1676 tail = val;
1677 }
1678 }
1679 se->expr = head;
1680}
1681
1682
f888a3fb 1683/* Translate a substring expression. */
4ee9c684 1684
1685static void
1686gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1687{
1688 gfc_ref *ref;
1689
1690 ref = expr->ref;
1691
1692 assert(ref->type == REF_SUBSTRING);
1693
1694 se->expr = gfc_build_string_const(expr->value.character.length,
1695 expr->value.character.string);
1696 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1697 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1698
1699 gfc_conv_substring(se,ref,expr->ts.kind);
1700}
1701
1702
1703/* Entry point for expression translation. */
1704
1705void
1706gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1707{
1708 if (se->ss && se->ss->expr == expr
1709 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1710 {
9a0aec1d 1711 /* Substitute a scalar expression evaluated outside the scalarization
4ee9c684 1712 loop. */
1713 se->expr = se->ss->data.scalar.expr;
1714 se->string_length = se->ss->data.scalar.string_length;
1715 gfc_advance_se_ss_chain (se);
1716 return;
1717 }
1718
1719 switch (expr->expr_type)
1720 {
1721 case EXPR_OP:
1722 gfc_conv_expr_op (se, expr);
1723 break;
1724
1725 case EXPR_FUNCTION:
1726 gfc_conv_function_expr (se, expr);
1727 break;
1728
1729 case EXPR_CONSTANT:
1730 gfc_conv_constant (se, expr);
1731 break;
1732
1733 case EXPR_VARIABLE:
1734 gfc_conv_variable (se, expr);
1735 break;
1736
1737 case EXPR_NULL:
1738 se->expr = null_pointer_node;
1739 break;
1740
1741 case EXPR_SUBSTRING:
1742 gfc_conv_substring_expr (se, expr);
1743 break;
1744
1745 case EXPR_STRUCTURE:
1746 gfc_conv_structure (se, expr, 0);
1747 break;
1748
1749 case EXPR_ARRAY:
1750 gfc_conv_array_constructor_expr (se, expr);
1751 break;
1752
1753 default:
1754 abort ();
1755 break;
1756 }
1757}
1758
1759void
1760gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1761{
1762 gfc_conv_expr (se, expr);
1763 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1764 figure out a way of rewriting an lvalue so that it has no post chain. */
1765 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1766}
1767
1768void
1769gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1770{
1771 tree val;
1772
1773 assert (expr->ts.type != BT_CHARACTER);
1774 gfc_conv_expr (se, expr);
1775 if (se->post.head)
1776 {
1777 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1778 gfc_add_modify_expr (&se->pre, val, se->expr);
1779 }
1780}
1781
1782void
1783gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1784{
1785 gfc_conv_expr_val (se, expr);
1786 se->expr = convert (type, se->expr);
1787}
1788
1789
f888a3fb 1790/* Converts an expression so that it can be passed by reference. Scalar
4ee9c684 1791 values only. */
1792
1793void
1794gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1795{
1796 tree var;
1797
1798 if (se->ss && se->ss->expr == expr
1799 && se->ss->type == GFC_SS_REFERENCE)
1800 {
1801 se->expr = se->ss->data.scalar.expr;
1802 se->string_length = se->ss->data.scalar.string_length;
1803 gfc_advance_se_ss_chain (se);
1804 return;
1805 }
1806
1807 if (expr->ts.type == BT_CHARACTER)
1808 {
1809 gfc_conv_expr (se, expr);
1810 gfc_conv_string_parameter (se);
1811 return;
1812 }
1813
1814 if (expr->expr_type == EXPR_VARIABLE)
1815 {
1816 se->want_pointer = 1;
1817 gfc_conv_expr (se, expr);
1818 if (se->post.head)
1819 {
1820 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1821 gfc_add_modify_expr (&se->pre, var, se->expr);
1822 gfc_add_block_to_block (&se->pre, &se->post);
1823 se->expr = var;
1824 }
1825 return;
1826 }
1827
1828 gfc_conv_expr (se, expr);
1829
1830 /* Create a temporary var to hold the value. */
e67e5e1f 1831 if (TREE_CONSTANT (se->expr))
1832 {
1833 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1834 DECL_INITIAL (var) = se->expr;
1835 pushdecl (var);
1836 }
1837 else
1838 {
1839 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1840 gfc_add_modify_expr (&se->pre, var, se->expr);
1841 }
4ee9c684 1842 gfc_add_block_to_block (&se->pre, &se->post);
1843
1844 /* Take the address of that value. */
1845 se->expr = gfc_build_addr_expr (NULL, var);
1846}
1847
1848
1849tree
1850gfc_trans_pointer_assign (gfc_code * code)
1851{
1852 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1853}
1854
1855
4396343e 1856/* Generate code for a pointer assignment. */
1857
4ee9c684 1858tree
1859gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1860{
1861 gfc_se lse;
1862 gfc_se rse;
1863 gfc_ss *lss;
1864 gfc_ss *rss;
1865 stmtblock_t block;
4ee9c684 1866
1867 gfc_start_block (&block);
1868
1869 gfc_init_se (&lse, NULL);
1870
1871 lss = gfc_walk_expr (expr1);
1872 rss = gfc_walk_expr (expr2);
1873 if (lss == gfc_ss_terminator)
1874 {
4396343e 1875 /* Scalar pointers. */
4ee9c684 1876 lse.want_pointer = 1;
1877 gfc_conv_expr (&lse, expr1);
1878 assert (rss == gfc_ss_terminator);
1879 gfc_init_se (&rse, NULL);
1880 rse.want_pointer = 1;
1881 gfc_conv_expr (&rse, expr2);
1882 gfc_add_block_to_block (&block, &lse.pre);
1883 gfc_add_block_to_block (&block, &rse.pre);
260abd71 1884 gfc_add_modify_expr (&block, lse.expr,
1885 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4ee9c684 1886 gfc_add_block_to_block (&block, &rse.post);
1887 gfc_add_block_to_block (&block, &lse.post);
1888 }
1889 else
1890 {
4396343e 1891 /* Array pointer. */
4ee9c684 1892 gfc_conv_expr_descriptor (&lse, expr1, lss);
1893 /* Implement Nullify. */
1894 if (expr2->expr_type == EXPR_NULL)
1895 {
1896 lse.expr = gfc_conv_descriptor_data (lse.expr);
260abd71 1897 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1898 gfc_add_modify_expr (&block, lse.expr, rse.expr);
4ee9c684 1899 }
1900 else
1901 {
1902 lse.direct_byref = 1;
1903 gfc_conv_expr_descriptor (&lse, expr2, rss);
1904 }
1905 gfc_add_block_to_block (&block, &lse.pre);
1906 gfc_add_block_to_block (&block, &lse.post);
1907 }
1908 return gfc_finish_block (&block);
1909}
1910
1911
1912/* Makes sure se is suitable for passing as a function string parameter. */
1913/* TODO: Need to check all callers fo this function. It may be abused. */
1914
1915void
1916gfc_conv_string_parameter (gfc_se * se)
1917{
1918 tree type;
1919
1920 if (TREE_CODE (se->expr) == STRING_CST)
1921 {
1922 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1923 return;
1924 }
1925
1926 type = TREE_TYPE (se->expr);
1927 if (TYPE_STRING_FLAG (type))
1928 {
1929 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1930 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1931 }
1932
1933 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1934 assert (se->string_length
1935 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1936}
1937
1938
1939/* Generate code for assignment of scalar variables. Includes character
1940 strings. */
1941
1942tree
1943gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1944{
4ee9c684 1945 stmtblock_t block;
1946
1947 gfc_init_block (&block);
1948
4ee9c684 1949 if (type == BT_CHARACTER)
1950 {
4ee9c684 1951 assert (lse->string_length != NULL_TREE
1952 && rse->string_length != NULL_TREE);
1953
1954 gfc_conv_string_parameter (lse);
1955 gfc_conv_string_parameter (rse);
1956
1957 gfc_add_block_to_block (&block, &lse->pre);
1958 gfc_add_block_to_block (&block, &rse->pre);
1959
dbe60343 1960 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1961 rse->string_length, rse->expr);
4ee9c684 1962 }
1963 else
1964 {
1965 gfc_add_block_to_block (&block, &lse->pre);
1966 gfc_add_block_to_block (&block, &rse->pre);
1967
260abd71 1968 gfc_add_modify_expr (&block, lse->expr,
1969 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4ee9c684 1970 }
1971
1972 gfc_add_block_to_block (&block, &lse->post);
1973 gfc_add_block_to_block (&block, &rse->post);
1974
1975 return gfc_finish_block (&block);
1976}
1977
1978
1979/* Try to translate array(:) = func (...), where func is a transformational
1980 array function, without using a temporary. Returns NULL is this isn't the
1981 case. */
1982
1983static tree
1984gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1985{
1986 gfc_se se;
1987 gfc_ss *ss;
1988
1989 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1990 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1991 return NULL;
1992
1993 /* Elemental functions don't need a temporary anyway. */
1994 if (expr2->symtree->n.sym->attr.elemental)
1995 return NULL;
1996
1997 /* Check for a dependency. */
1998 if (gfc_check_fncall_dependency (expr1, expr2))
1999 return NULL;
2000
2001 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2002 functions. */
2003 assert (expr2->value.function.isym
2004 || (gfc_return_by_reference (expr2->symtree->n.sym)
2005 && expr2->symtree->n.sym->result->attr.dimension));
2006
2007 ss = gfc_walk_expr (expr1);
2008 assert (ss != gfc_ss_terminator);
2009 gfc_init_se (&se, NULL);
2010 gfc_start_block (&se.pre);
2011 se.want_pointer = 1;
2012
2013 gfc_conv_array_parameter (&se, expr1, ss, 0);
2014
2015 se.direct_byref = 1;
2016 se.ss = gfc_walk_expr (expr2);
2017 assert (se.ss != gfc_ss_terminator);
2018 gfc_conv_function_expr (&se, expr2);
4ee9c684 2019 gfc_add_block_to_block (&se.pre, &se.post);
2020
2021 return gfc_finish_block (&se.pre);
2022}
2023
2024
2025/* Translate an assignment. Most of the code is concerned with
2026 setting up the scalarizer. */
2027
2028tree
2029gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2030{
2031 gfc_se lse;
2032 gfc_se rse;
2033 gfc_ss *lss;
2034 gfc_ss *lss_section;
2035 gfc_ss *rss;
2036 gfc_loopinfo loop;
2037 tree tmp;
2038 stmtblock_t block;
2039 stmtblock_t body;
2040
2041 /* Special case a single function returning an array. */
2042 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2043 {
2044 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2045 if (tmp)
2046 return tmp;
2047 }
2048
2049 /* Assignment of the form lhs = rhs. */
2050 gfc_start_block (&block);
2051
2052 gfc_init_se (&lse, NULL);
2053 gfc_init_se (&rse, NULL);
2054
2055 /* Walk the lhs. */
2056 lss = gfc_walk_expr (expr1);
2057 rss = NULL;
2058 if (lss != gfc_ss_terminator)
2059 {
2060 /* The assignment needs scalarization. */
2061 lss_section = lss;
2062
2063 /* Find a non-scalar SS from the lhs. */
2064 while (lss_section != gfc_ss_terminator
2065 && lss_section->type != GFC_SS_SECTION)
2066 lss_section = lss_section->next;
2067
2068 assert (lss_section != gfc_ss_terminator);
2069
2070 /* Initialize the scalarizer. */
2071 gfc_init_loopinfo (&loop);
2072
2073 /* Walk the rhs. */
2074 rss = gfc_walk_expr (expr2);
2075 if (rss == gfc_ss_terminator)
2076 {
2077 /* The rhs is scalar. Add a ss for the expression. */
2078 rss = gfc_get_ss ();
2079 rss->next = gfc_ss_terminator;
2080 rss->type = GFC_SS_SCALAR;
2081 rss->expr = expr2;
2082 }
2083 /* Associate the SS with the loop. */
2084 gfc_add_ss_to_loop (&loop, lss);
2085 gfc_add_ss_to_loop (&loop, rss);
2086
2087 /* Calculate the bounds of the scalarization. */
2088 gfc_conv_ss_startstride (&loop);
2089 /* Resolve any data dependencies in the statement. */
2090 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2091 /* Setup the scalarizing loops. */
2092 gfc_conv_loop_setup (&loop);
2093
2094 /* Setup the gfc_se structures. */
2095 gfc_copy_loopinfo_to_se (&lse, &loop);
2096 gfc_copy_loopinfo_to_se (&rse, &loop);
2097
2098 rse.ss = rss;
2099 gfc_mark_ss_chain_used (rss, 1);
2100 if (loop.temp_ss == NULL)
2101 {
2102 lse.ss = lss;
2103 gfc_mark_ss_chain_used (lss, 1);
2104 }
2105 else
2106 {
2107 lse.ss = loop.temp_ss;
2108 gfc_mark_ss_chain_used (lss, 3);
2109 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2110 }
2111
2112 /* Start the scalarized loop body. */
2113 gfc_start_scalarized_body (&loop, &body);
2114 }
2115 else
2116 gfc_init_block (&body);
2117
2118 /* Translate the expression. */
2119 gfc_conv_expr (&rse, expr2);
2120
2121 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2122 {
2123 gfc_conv_tmp_array_ref (&lse);
2124 gfc_advance_se_ss_chain (&lse);
2125 }
2126 else
2127 gfc_conv_expr (&lse, expr1);
2128
2129 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2130 gfc_add_expr_to_block (&body, tmp);
2131
2132 if (lss == gfc_ss_terminator)
2133 {
2134 /* Use the scalar assignment as is. */
2135 gfc_add_block_to_block (&block, &body);
2136 }
2137 else
2138 {
2139 if (lse.ss != gfc_ss_terminator)
2140 abort ();
2141 if (rse.ss != gfc_ss_terminator)
2142 abort ();
2143
2144 if (loop.temp_ss != NULL)
2145 {
2146 gfc_trans_scalarized_loop_boundary (&loop, &body);
2147
2148 /* We need to copy the temporary to the actual lhs. */
2149 gfc_init_se (&lse, NULL);
2150 gfc_init_se (&rse, NULL);
2151 gfc_copy_loopinfo_to_se (&lse, &loop);
2152 gfc_copy_loopinfo_to_se (&rse, &loop);
2153
2154 rse.ss = loop.temp_ss;
2155 lse.ss = lss;
2156
2157 gfc_conv_tmp_array_ref (&rse);
2158 gfc_advance_se_ss_chain (&rse);
2159 gfc_conv_expr (&lse, expr1);
2160
2161 if (lse.ss != gfc_ss_terminator)
2162 abort ();
2163
2164 if (rse.ss != gfc_ss_terminator)
2165 abort ();
2166
2167 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2168 gfc_add_expr_to_block (&body, tmp);
2169 }
2170 /* Generate the copying loops. */
2171 gfc_trans_scalarizing_loops (&loop, &body);
2172
2173 /* Wrap the whole thing up. */
2174 gfc_add_block_to_block (&block, &loop.pre);
2175 gfc_add_block_to_block (&block, &loop.post);
2176
2177 gfc_cleanup_loop (&loop);
2178 }
2179
2180 return gfc_finish_block (&block);
2181}
2182
2183tree
2184gfc_trans_assign (gfc_code * code)
2185{
2186 return gfc_trans_assignment (code->expr, code->expr2);
2187}
Mirror of https://gcc.gnu.org/git/gcc.git