2005-08-04 Paul Brook <paul@codesourcery.com>
[official-gcc.git] / gcc / fortran / trans-expr.c
bloba3846f3288e968f8c0b8b15110f0d192e12d874f
1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
25 #include "config.h"
26 #include "system.h"
27 #include "coretypes.h"
28 #include "tree.h"
29 #include "convert.h"
30 #include "ggc.h"
31 #include "toplev.h"
32 #include "real.h"
33 #include "tree-gimple.h"
34 #include "flags.h"
35 #include "gfortran.h"
36 #include "trans.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 /* Copy the scalarization loop variables. */
47 static void
48 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
50 dest->ss = src->ss;
51 dest->loop = src->loop;
55 /* Initialize a simple expression holder.
57 Care must be taken when multiple se are created with the same parent.
58 The child se must be kept in sync. The easiest way is to delay creation
59 of a child se until after after the previous se has been translated. */
61 void
62 gfc_init_se (gfc_se * se, gfc_se * parent)
64 memset (se, 0, sizeof (gfc_se));
65 gfc_init_block (&se->pre);
66 gfc_init_block (&se->post);
68 se->parent = parent;
70 if (parent)
71 gfc_copy_se_loopvars (se, parent);
75 /* Advances to the next SS in the chain. Use this rather than setting
76 se->ss = se->ss->next because all the parents needs to be kept in sync.
77 See gfc_init_se. */
79 void
80 gfc_advance_se_ss_chain (gfc_se * se)
82 gfc_se *p;
84 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
86 p = se;
87 /* Walk down the parent chain. */
88 while (p != NULL)
90 /* Simple consistency check. */
91 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
93 p->ss = p->ss->next;
95 p = p->parent;
100 /* Ensures the result of the expression as either a temporary variable
101 or a constant so that it can be used repeatedly. */
103 void
104 gfc_make_safe_expr (gfc_se * se)
106 tree var;
108 if (CONSTANT_CLASS_P (se->expr))
109 return;
111 /* We need a temporary for this result. */
112 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
113 gfc_add_modify_expr (&se->pre, var, se->expr);
114 se->expr = var;
118 /* Return an expression which determines if a dummy parameter is present.
119 Also used for arguments to procedures with multiple entry points. */
121 tree
122 gfc_conv_expr_present (gfc_symbol * sym)
124 tree decl;
126 gcc_assert (sym->attr.dummy);
128 decl = gfc_get_symbol_decl (sym);
129 if (TREE_CODE (decl) != PARM_DECL)
131 /* Array parameters use a temporary descriptor, we want the real
132 parameter. */
133 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
134 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
135 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
137 return build2 (NE_EXPR, boolean_type_node, decl,
138 fold_convert (TREE_TYPE (decl), null_pointer_node));
142 /* Get the character length of an expression, looking through gfc_refs
143 if necessary. */
145 tree
146 gfc_get_expr_charlen (gfc_expr *e)
148 gfc_ref *r;
149 tree length;
151 gcc_assert (e->expr_type == EXPR_VARIABLE
152 && e->ts.type == BT_CHARACTER);
154 length = NULL; /* To silence compiler warning. */
156 /* First candidate: if the variable is of type CHARACTER, the
157 expression's length could be the length of the character
158 variable. */
159 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
160 length = e->symtree->n.sym->ts.cl->backend_decl;
162 /* Look through the reference chain for component references. */
163 for (r = e->ref; r; r = r->next)
165 switch (r->type)
167 case REF_COMPONENT:
168 if (r->u.c.component->ts.type == BT_CHARACTER)
169 length = r->u.c.component->ts.cl->backend_decl;
170 break;
172 case REF_ARRAY:
173 /* Do nothing. */
174 break;
176 default:
177 /* We should never got substring references here. These will be
178 broken down by the scalarizer. */
179 gcc_unreachable ();
183 gcc_assert (length != NULL);
184 return length;
189 /* Generate code to initialize a string length variable. Returns the
190 value. */
192 void
193 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
195 gfc_se se;
196 tree tmp;
198 gfc_init_se (&se, NULL);
199 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
200 gfc_add_block_to_block (pblock, &se.pre);
202 tmp = cl->backend_decl;
203 gfc_add_modify_expr (pblock, tmp, se.expr);
207 static void
208 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
210 tree tmp;
211 tree type;
212 tree var;
213 gfc_se start;
214 gfc_se end;
216 type = gfc_get_character_type (kind, ref->u.ss.length);
217 type = build_pointer_type (type);
219 var = NULL_TREE;
220 gfc_init_se (&start, se);
221 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
222 gfc_add_block_to_block (&se->pre, &start.pre);
224 if (integer_onep (start.expr))
225 gfc_conv_string_parameter (se);
226 else
228 /* Change the start of the string. */
229 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
230 tmp = se->expr;
231 else
232 tmp = gfc_build_indirect_ref (se->expr);
233 tmp = gfc_build_array_ref (tmp, start.expr);
234 se->expr = gfc_build_addr_expr (type, tmp);
237 /* Length = end + 1 - start. */
238 gfc_init_se (&end, se);
239 if (ref->u.ss.end == NULL)
240 end.expr = se->string_length;
241 else
243 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
244 gfc_add_block_to_block (&se->pre, &end.pre);
246 tmp =
247 build2 (MINUS_EXPR, gfc_charlen_type_node,
248 fold_convert (gfc_charlen_type_node, integer_one_node),
249 start.expr);
250 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
251 se->string_length = fold (tmp);
255 /* Convert a derived type component reference. */
257 static void
258 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
260 gfc_component *c;
261 tree tmp;
262 tree decl;
263 tree field;
265 c = ref->u.c.component;
267 gcc_assert (c->backend_decl);
269 field = c->backend_decl;
270 gcc_assert (TREE_CODE (field) == FIELD_DECL);
271 decl = se->expr;
272 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
274 se->expr = tmp;
276 if (c->ts.type == BT_CHARACTER)
278 tmp = c->ts.cl->backend_decl;
279 /* Components must always be constant length. */
280 gcc_assert (tmp && INTEGER_CST_P (tmp));
281 se->string_length = tmp;
284 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
285 se->expr = gfc_build_indirect_ref (se->expr);
289 /* Return the contents of a variable. Also handles reference/pointer
290 variables (all Fortran pointer references are implicit). */
292 static void
293 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
295 gfc_ref *ref;
296 gfc_symbol *sym;
298 sym = expr->symtree->n.sym;
299 if (se->ss != NULL)
301 /* Check that something hasn't gone horribly wrong. */
302 gcc_assert (se->ss != gfc_ss_terminator);
303 gcc_assert (se->ss->expr == expr);
305 /* A scalarized term. We already know the descriptor. */
306 se->expr = se->ss->data.info.descriptor;
307 se->string_length = se->ss->string_length;
308 ref = se->ss->data.info.ref;
310 else
312 tree se_expr = NULL_TREE;
314 se->expr = gfc_get_symbol_decl (sym);
316 /* Special case for assigning the return value of a function.
317 Self recursive functions must have an explicit return value. */
318 if (se->expr == current_function_decl && sym->attr.function
319 && (sym->result == sym))
320 se_expr = gfc_get_fake_result_decl (sym);
322 /* Similarly for alternate entry points. */
323 else if (sym->attr.function && sym->attr.entry
324 && (sym->result == sym)
325 && sym->ns->proc_name->backend_decl == current_function_decl)
327 gfc_entry_list *el = NULL;
329 for (el = sym->ns->entries; el; el = el->next)
330 if (sym == el->sym)
332 se_expr = gfc_get_fake_result_decl (sym);
333 break;
337 else if (sym->attr.result
338 && sym->ns->proc_name->backend_decl == current_function_decl
339 && sym->ns->proc_name->attr.entry_master
340 && !gfc_return_by_reference (sym->ns->proc_name))
341 se_expr = gfc_get_fake_result_decl (sym);
343 if (se_expr)
344 se->expr = se_expr;
346 /* Procedure actual arguments. */
347 else if (sym->attr.flavor == FL_PROCEDURE
348 && se->expr != current_function_decl)
350 gcc_assert (se->want_pointer);
351 if (!sym->attr.dummy)
353 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
354 se->expr = gfc_build_addr_expr (NULL, se->expr);
356 return;
360 /* Dereference the expression, where needed. Since characters
361 are entirely different from other types, they are treated
362 separately. */
363 if (sym->ts.type == BT_CHARACTER)
365 /* Dereference character pointer dummy arguments
366 or results. */
367 if ((sym->attr.pointer || sym->attr.allocatable)
368 && (sym->attr.dummy
369 || sym->attr.function
370 || sym->attr.result))
371 se->expr = gfc_build_indirect_ref (se->expr);
373 else
375 /* Dereference non-character scalar dummy arguments. */
376 if (sym->attr.dummy && !sym->attr.dimension)
377 se->expr = gfc_build_indirect_ref (se->expr);
379 /* Dereference scalar hidden result. */
380 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
381 && (sym->attr.function || sym->attr.result)
382 && !sym->attr.dimension && !sym->attr.pointer)
383 se->expr = gfc_build_indirect_ref (se->expr);
385 /* Dereference non-character pointer variables.
386 These must be dummies, results, or scalars. */
387 if ((sym->attr.pointer || sym->attr.allocatable)
388 && (sym->attr.dummy
389 || sym->attr.function
390 || sym->attr.result
391 || !sym->attr.dimension))
392 se->expr = gfc_build_indirect_ref (se->expr);
395 ref = expr->ref;
398 /* For character variables, also get the length. */
399 if (sym->ts.type == BT_CHARACTER)
401 se->string_length = sym->ts.cl->backend_decl;
402 gcc_assert (se->string_length);
405 while (ref)
407 switch (ref->type)
409 case REF_ARRAY:
410 /* Return the descriptor if that's what we want and this is an array
411 section reference. */
412 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
413 return;
414 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
415 /* Return the descriptor for array pointers and allocations. */
416 if (se->want_pointer
417 && ref->next == NULL && (se->descriptor_only))
418 return;
420 gfc_conv_array_ref (se, &ref->u.ar);
421 /* Return a pointer to an element. */
422 break;
424 case REF_COMPONENT:
425 gfc_conv_component_ref (se, ref);
426 break;
428 case REF_SUBSTRING:
429 gfc_conv_substring (se, ref, expr->ts.kind);
430 break;
432 default:
433 gcc_unreachable ();
434 break;
436 ref = ref->next;
438 /* Pointer assignment, allocation or pass by reference. Arrays are handled
439 separately. */
440 if (se->want_pointer)
442 if (expr->ts.type == BT_CHARACTER)
443 gfc_conv_string_parameter (se);
444 else
445 se->expr = gfc_build_addr_expr (NULL, se->expr);
447 if (se->ss != NULL)
448 gfc_advance_se_ss_chain (se);
452 /* Unary ops are easy... Or they would be if ! was a valid op. */
454 static void
455 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
457 gfc_se operand;
458 tree type;
460 gcc_assert (expr->ts.type != BT_CHARACTER);
461 /* Initialize the operand. */
462 gfc_init_se (&operand, se);
463 gfc_conv_expr_val (&operand, expr->value.op.op1);
464 gfc_add_block_to_block (&se->pre, &operand.pre);
466 type = gfc_typenode_for_spec (&expr->ts);
468 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
469 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
470 All other unary operators have an equivalent GIMPLE unary operator. */
471 if (code == TRUTH_NOT_EXPR)
472 se->expr = build2 (EQ_EXPR, type, operand.expr,
473 convert (type, integer_zero_node));
474 else
475 se->expr = build1 (code, type, operand.expr);
479 /* Expand power operator to optimal multiplications when a value is raised
480 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
481 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
482 Programming", 3rd Edition, 1998. */
484 /* This code is mostly duplicated from expand_powi in the backend.
485 We establish the "optimal power tree" lookup table with the defined size.
486 The items in the table are the exponents used to calculate the index
487 exponents. Any integer n less than the value can get an "addition chain",
488 with the first node being one. */
489 #define POWI_TABLE_SIZE 256
491 /* The table is from builtins.c. */
492 static const unsigned char powi_table[POWI_TABLE_SIZE] =
494 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
495 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
496 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
497 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
498 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
499 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
500 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
501 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
502 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
503 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
504 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
505 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
506 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
507 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
508 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
509 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
510 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
511 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
512 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
513 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
514 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
515 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
516 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
517 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
518 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
519 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
520 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
521 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
522 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
523 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
524 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
525 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
528 /* If n is larger than lookup table's max index, we use the "window
529 method". */
530 #define POWI_WINDOW_SIZE 3
532 /* Recursive function to expand the power operator. The temporary
533 values are put in tmpvar. The function returns tmpvar[1] ** n. */
534 static tree
535 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
537 tree op0;
538 tree op1;
539 tree tmp;
540 int digit;
542 if (n < POWI_TABLE_SIZE)
544 if (tmpvar[n])
545 return tmpvar[n];
547 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
548 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
550 else if (n & 1)
552 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
553 op0 = gfc_conv_powi (se, n - digit, tmpvar);
554 op1 = gfc_conv_powi (se, digit, tmpvar);
556 else
558 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
559 op1 = op0;
562 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
563 tmp = gfc_evaluate_now (tmp, &se->pre);
565 if (n < POWI_TABLE_SIZE)
566 tmpvar[n] = tmp;
568 return tmp;
572 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
573 return 1. Else return 0 and a call to runtime library functions
574 will have to be built. */
575 static int
576 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
578 tree cond;
579 tree tmp;
580 tree type;
581 tree vartmp[POWI_TABLE_SIZE];
582 int n;
583 int sgn;
585 type = TREE_TYPE (lhs);
586 n = abs (TREE_INT_CST_LOW (rhs));
587 sgn = tree_int_cst_sgn (rhs);
589 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
590 && (n > 2 || n < -1))
591 return 0;
593 /* rhs == 0 */
594 if (sgn == 0)
596 se->expr = gfc_build_const (type, integer_one_node);
597 return 1;
599 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
600 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
602 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
603 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
604 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
605 convert (TREE_TYPE (lhs), integer_one_node));
607 /* If rhs is even,
608 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
609 if ((n & 1) == 0)
611 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
612 se->expr = build3 (COND_EXPR, type, tmp,
613 convert (type, integer_one_node),
614 convert (type, integer_zero_node));
615 return 1;
617 /* If rhs is odd,
618 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
619 tmp = build3 (COND_EXPR, type, tmp,
620 convert (type, integer_minus_one_node),
621 convert (type, integer_zero_node));
622 se->expr = build3 (COND_EXPR, type, cond,
623 convert (type, integer_one_node),
624 tmp);
625 return 1;
628 memset (vartmp, 0, sizeof (vartmp));
629 vartmp[1] = lhs;
630 if (sgn == -1)
632 tmp = gfc_build_const (type, integer_one_node);
633 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
636 se->expr = gfc_conv_powi (se, n, vartmp);
638 return 1;
642 /* Power op (**). Constant integer exponent has special handling. */
644 static void
645 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
647 tree gfc_int4_type_node;
648 int kind;
649 int ikind;
650 gfc_se lse;
651 gfc_se rse;
652 tree fndecl;
653 tree tmp;
655 gfc_init_se (&lse, se);
656 gfc_conv_expr_val (&lse, expr->value.op.op1);
657 gfc_add_block_to_block (&se->pre, &lse.pre);
659 gfc_init_se (&rse, se);
660 gfc_conv_expr_val (&rse, expr->value.op.op2);
661 gfc_add_block_to_block (&se->pre, &rse.pre);
663 if (expr->value.op.op2->ts.type == BT_INTEGER
664 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
665 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
666 return;
668 gfc_int4_type_node = gfc_get_int_type (4);
670 kind = expr->value.op.op1->ts.kind;
671 switch (expr->value.op.op2->ts.type)
673 case BT_INTEGER:
674 ikind = expr->value.op.op2->ts.kind;
675 switch (ikind)
677 case 1:
678 case 2:
679 rse.expr = convert (gfc_int4_type_node, rse.expr);
680 /* Fall through. */
682 case 4:
683 ikind = 0;
684 break;
686 case 8:
687 ikind = 1;
688 break;
690 default:
691 gcc_unreachable ();
693 switch (kind)
695 case 1:
696 case 2:
697 if (expr->value.op.op1->ts.type == BT_INTEGER)
698 lse.expr = convert (gfc_int4_type_node, lse.expr);
699 else
700 gcc_unreachable ();
701 /* Fall through. */
703 case 4:
704 kind = 0;
705 break;
707 case 8:
708 kind = 1;
709 break;
711 default:
712 gcc_unreachable ();
715 switch (expr->value.op.op1->ts.type)
717 case BT_INTEGER:
718 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
719 break;
721 case BT_REAL:
722 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
723 break;
725 case BT_COMPLEX:
726 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
727 break;
729 default:
730 gcc_unreachable ();
732 break;
734 case BT_REAL:
735 switch (kind)
737 case 4:
738 fndecl = built_in_decls[BUILT_IN_POWF];
739 break;
740 case 8:
741 fndecl = built_in_decls[BUILT_IN_POW];
742 break;
743 default:
744 gcc_unreachable ();
746 break;
748 case BT_COMPLEX:
749 switch (kind)
751 case 4:
752 fndecl = gfor_fndecl_math_cpowf;
753 break;
754 case 8:
755 fndecl = gfor_fndecl_math_cpow;
756 break;
757 default:
758 gcc_unreachable ();
760 break;
762 default:
763 gcc_unreachable ();
764 break;
767 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
768 tmp = gfc_chainon_list (tmp, rse.expr);
769 se->expr = fold (gfc_build_function_call (fndecl, tmp));
773 /* Generate code to allocate a string temporary. */
775 tree
776 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
778 tree var;
779 tree tmp;
780 tree args;
782 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
784 if (gfc_can_put_var_on_stack (len))
786 /* Create a temporary variable to hold the result. */
787 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
788 convert (gfc_charlen_type_node, integer_one_node));
789 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
790 tmp = build_array_type (gfc_character1_type_node, tmp);
791 var = gfc_create_var (tmp, "str");
792 var = gfc_build_addr_expr (type, var);
794 else
796 /* Allocate a temporary to hold the result. */
797 var = gfc_create_var (type, "pstr");
798 args = gfc_chainon_list (NULL_TREE, len);
799 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
800 tmp = convert (type, tmp);
801 gfc_add_modify_expr (&se->pre, var, tmp);
803 /* Free the temporary afterwards. */
804 tmp = convert (pvoid_type_node, var);
805 args = gfc_chainon_list (NULL_TREE, tmp);
806 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
807 gfc_add_expr_to_block (&se->post, tmp);
810 return var;
814 /* Handle a string concatenation operation. A temporary will be allocated to
815 hold the result. */
817 static void
818 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
820 gfc_se lse;
821 gfc_se rse;
822 tree len;
823 tree type;
824 tree var;
825 tree args;
826 tree tmp;
828 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
829 && expr->value.op.op2->ts.type == BT_CHARACTER);
831 gfc_init_se (&lse, se);
832 gfc_conv_expr (&lse, expr->value.op.op1);
833 gfc_conv_string_parameter (&lse);
834 gfc_init_se (&rse, se);
835 gfc_conv_expr (&rse, expr->value.op.op2);
836 gfc_conv_string_parameter (&rse);
838 gfc_add_block_to_block (&se->pre, &lse.pre);
839 gfc_add_block_to_block (&se->pre, &rse.pre);
841 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
842 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
843 if (len == NULL_TREE)
845 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
846 lse.string_length, rse.string_length);
849 type = build_pointer_type (type);
851 var = gfc_conv_string_tmp (se, type, len);
853 /* Do the actual concatenation. */
854 args = NULL_TREE;
855 args = gfc_chainon_list (args, len);
856 args = gfc_chainon_list (args, var);
857 args = gfc_chainon_list (args, lse.string_length);
858 args = gfc_chainon_list (args, lse.expr);
859 args = gfc_chainon_list (args, rse.string_length);
860 args = gfc_chainon_list (args, rse.expr);
861 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
862 gfc_add_expr_to_block (&se->pre, tmp);
864 /* Add the cleanup for the operands. */
865 gfc_add_block_to_block (&se->pre, &rse.post);
866 gfc_add_block_to_block (&se->pre, &lse.post);
868 se->expr = var;
869 se->string_length = len;
873 /* Translates an op expression. Common (binary) cases are handled by this
874 function, others are passed on. Recursion is used in either case.
875 We use the fact that (op1.ts == op2.ts) (except for the power
876 operator **).
877 Operators need no special handling for scalarized expressions as long as
878 they call gfc_conv_simple_val to get their operands.
879 Character strings get special handling. */
881 static void
882 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
884 enum tree_code code;
885 gfc_se lse;
886 gfc_se rse;
887 tree type;
888 tree tmp;
889 int lop;
890 int checkstring;
892 checkstring = 0;
893 lop = 0;
894 switch (expr->value.op.operator)
896 case INTRINSIC_UPLUS:
897 gfc_conv_expr (se, expr->value.op.op1);
898 return;
900 case INTRINSIC_UMINUS:
901 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
902 return;
904 case INTRINSIC_NOT:
905 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
906 return;
908 case INTRINSIC_PLUS:
909 code = PLUS_EXPR;
910 break;
912 case INTRINSIC_MINUS:
913 code = MINUS_EXPR;
914 break;
916 case INTRINSIC_TIMES:
917 code = MULT_EXPR;
918 break;
920 case INTRINSIC_DIVIDE:
921 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
922 an integer, we must round towards zero, so we use a
923 TRUNC_DIV_EXPR. */
924 if (expr->ts.type == BT_INTEGER)
925 code = TRUNC_DIV_EXPR;
926 else
927 code = RDIV_EXPR;
928 break;
930 case INTRINSIC_POWER:
931 gfc_conv_power_op (se, expr);
932 return;
934 case INTRINSIC_CONCAT:
935 gfc_conv_concat_op (se, expr);
936 return;
938 case INTRINSIC_AND:
939 code = TRUTH_ANDIF_EXPR;
940 lop = 1;
941 break;
943 case INTRINSIC_OR:
944 code = TRUTH_ORIF_EXPR;
945 lop = 1;
946 break;
948 /* EQV and NEQV only work on logicals, but since we represent them
949 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
950 case INTRINSIC_EQ:
951 case INTRINSIC_EQV:
952 code = EQ_EXPR;
953 checkstring = 1;
954 lop = 1;
955 break;
957 case INTRINSIC_NE:
958 case INTRINSIC_NEQV:
959 code = NE_EXPR;
960 checkstring = 1;
961 lop = 1;
962 break;
964 case INTRINSIC_GT:
965 code = GT_EXPR;
966 checkstring = 1;
967 lop = 1;
968 break;
970 case INTRINSIC_GE:
971 code = GE_EXPR;
972 checkstring = 1;
973 lop = 1;
974 break;
976 case INTRINSIC_LT:
977 code = LT_EXPR;
978 checkstring = 1;
979 lop = 1;
980 break;
982 case INTRINSIC_LE:
983 code = LE_EXPR;
984 checkstring = 1;
985 lop = 1;
986 break;
988 case INTRINSIC_USER:
989 case INTRINSIC_ASSIGN:
990 /* These should be converted into function calls by the frontend. */
991 gcc_unreachable ();
993 default:
994 fatal_error ("Unknown intrinsic op");
995 return;
998 /* The only exception to this is **, which is handled separately anyway. */
999 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1001 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1002 checkstring = 0;
1004 /* lhs */
1005 gfc_init_se (&lse, se);
1006 gfc_conv_expr (&lse, expr->value.op.op1);
1007 gfc_add_block_to_block (&se->pre, &lse.pre);
1009 /* rhs */
1010 gfc_init_se (&rse, se);
1011 gfc_conv_expr (&rse, expr->value.op.op2);
1012 gfc_add_block_to_block (&se->pre, &rse.pre);
1014 /* For string comparisons we generate a library call, and compare the return
1015 value with 0. */
1016 if (checkstring)
1018 gfc_conv_string_parameter (&lse);
1019 gfc_conv_string_parameter (&rse);
1020 tmp = NULL_TREE;
1021 tmp = gfc_chainon_list (tmp, lse.string_length);
1022 tmp = gfc_chainon_list (tmp, lse.expr);
1023 tmp = gfc_chainon_list (tmp, rse.string_length);
1024 tmp = gfc_chainon_list (tmp, rse.expr);
1026 /* Build a call for the comparison. */
1027 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1028 gfc_add_block_to_block (&lse.post, &rse.post);
1030 rse.expr = integer_zero_node;
1033 type = gfc_typenode_for_spec (&expr->ts);
1035 if (lop)
1037 /* The result of logical ops is always boolean_type_node. */
1038 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1039 se->expr = convert (type, tmp);
1041 else
1042 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1044 /* Add the post blocks. */
1045 gfc_add_block_to_block (&se->post, &rse.post);
1046 gfc_add_block_to_block (&se->post, &lse.post);
1050 static void
1051 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1053 tree tmp;
1055 if (sym->attr.dummy)
1057 tmp = gfc_get_symbol_decl (sym);
1058 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1059 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1061 se->expr = tmp;
1063 else
1065 if (!sym->backend_decl)
1066 sym->backend_decl = gfc_get_extern_function_decl (sym);
1068 tmp = sym->backend_decl;
1069 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1070 se->expr = gfc_build_addr_expr (NULL, tmp);
1075 /* Generate code for a procedure call. Note can return se->post != NULL.
1076 If se->direct_byref is set then se->expr contains the return parameter.
1077 Return non-zero, if the call has alternate specifiers. */
1080 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1081 gfc_actual_arglist * arg)
1083 tree arglist;
1084 tree tmp;
1085 tree fntype;
1086 gfc_se parmse;
1087 gfc_ss *argss;
1088 gfc_ss_info *info;
1089 int byref;
1090 tree type;
1091 tree var;
1092 tree len;
1093 tree stringargs;
1094 gfc_formal_arglist *formal;
1095 int has_alternate_specifier = 0;
1097 arglist = NULL_TREE;
1098 stringargs = NULL_TREE;
1099 var = NULL_TREE;
1100 len = NULL_TREE;
1102 /* Obtain the string length now because it is needed often below. */
1103 if (sym->ts.type == BT_CHARACTER)
1105 gcc_assert (sym->ts.cl && sym->ts.cl->length
1106 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1107 len = gfc_conv_mpz_to_tree
1108 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1111 if (se->ss != NULL)
1113 if (!sym->attr.elemental)
1115 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1116 if (se->ss->useflags)
1118 gcc_assert (gfc_return_by_reference (sym)
1119 && sym->result->attr.dimension);
1120 gcc_assert (se->loop != NULL);
1122 /* Access the previously obtained result. */
1123 gfc_conv_tmp_array_ref (se);
1124 gfc_advance_se_ss_chain (se);
1126 /* Bundle in the string length. */
1127 se->string_length = len;
1128 return 0;
1131 info = &se->ss->data.info;
1133 else
1134 info = NULL;
1136 byref = gfc_return_by_reference (sym);
1137 if (byref)
1139 if (se->direct_byref)
1141 arglist = gfc_chainon_list (arglist, se->expr);
1143 /* Add string length to argument list. */
1144 if (sym->ts.type == BT_CHARACTER)
1146 sym->ts.cl->backend_decl = len;
1147 arglist = gfc_chainon_list (arglist,
1148 convert (gfc_charlen_type_node, len));
1151 else if (sym->result->attr.dimension)
1153 gcc_assert (se->loop && se->ss);
1155 /* Set the type of the array. */
1156 tmp = gfc_typenode_for_spec (&sym->ts);
1157 info->dimen = se->loop->dimen;
1159 /* Allocate a temporary to store the result. */
1160 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1162 /* Zero the first stride to indicate a temporary. */
1163 tmp =
1164 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1165 gfc_add_modify_expr (&se->pre, tmp,
1166 convert (TREE_TYPE (tmp), integer_zero_node));
1168 /* Pass the temporary as the first argument. */
1169 tmp = info->descriptor;
1170 tmp = gfc_build_addr_expr (NULL, tmp);
1171 arglist = gfc_chainon_list (arglist, tmp);
1173 /* Add string length to argument list. */
1174 if (sym->ts.type == BT_CHARACTER)
1176 sym->ts.cl->backend_decl = len;
1177 arglist = gfc_chainon_list (arglist,
1178 convert (gfc_charlen_type_node, len));
1182 else if (sym->ts.type == BT_CHARACTER)
1185 /* Pass the string length. */
1186 sym->ts.cl->backend_decl = len;
1187 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1188 type = build_pointer_type (type);
1190 /* Return an address to a char[0:len-1]* temporary for character pointers. */
1191 if (sym->attr.pointer || sym->attr.allocatable)
1193 /* Build char[0:len-1] * pstr. */
1194 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1195 build_int_cst (gfc_charlen_type_node, 1));
1196 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1197 tmp = build_array_type (gfc_character1_type_node, tmp);
1198 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1200 /* Provide an address expression for the function arguments. */
1201 var = gfc_build_addr_expr (NULL, var);
1203 else
1205 var = gfc_conv_string_tmp (se, type, len);
1207 arglist = gfc_chainon_list (arglist, var);
1208 arglist = gfc_chainon_list (arglist,
1209 convert (gfc_charlen_type_node, len));
1211 else
1213 gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
1215 type = gfc_get_complex_type (sym->ts.kind);
1216 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1217 arglist = gfc_chainon_list (arglist, var);
1221 formal = sym->formal;
1222 /* Evaluate the arguments. */
1223 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1225 if (arg->expr == NULL)
1228 if (se->ignore_optional)
1230 /* Some intrinsics have already been resolved to the correct
1231 parameters. */
1232 continue;
1234 else if (arg->label)
1236 has_alternate_specifier = 1;
1237 continue;
1239 else
1241 /* Pass a NULL pointer for an absent arg. */
1242 gfc_init_se (&parmse, NULL);
1243 parmse.expr = null_pointer_node;
1244 if (arg->missing_arg_type == BT_CHARACTER)
1246 stringargs =
1247 gfc_chainon_list (stringargs,
1248 convert (gfc_charlen_type_node,
1249 integer_zero_node));
1253 else if (se->ss && se->ss->useflags)
1255 /* An elemental function inside a scalarized loop. */
1256 gfc_init_se (&parmse, se);
1257 gfc_conv_expr_reference (&parmse, arg->expr);
1259 else
1261 /* A scalar or transformational function. */
1262 gfc_init_se (&parmse, NULL);
1263 argss = gfc_walk_expr (arg->expr);
1265 if (argss == gfc_ss_terminator)
1267 gfc_conv_expr_reference (&parmse, arg->expr);
1268 if (formal && formal->sym->attr.pointer
1269 && arg->expr->expr_type != EXPR_NULL)
1271 /* Scalar pointer dummy args require an extra level of
1272 indirection. The null pointer already contains
1273 this level of indirection. */
1274 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1277 else
1279 /* If the procedure requires an explicit interface, the
1280 actual argument is passed according to the
1281 corresponding formal argument. If the corresponding
1282 formal argument is a POINTER or assumed shape, we do
1283 not use g77's calling convention, and pass the
1284 address of the array descriptor instead. Otherwise we
1285 use g77's calling convention. */
1286 int f;
1287 f = (formal != NULL)
1288 && !formal->sym->attr.pointer
1289 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1290 f = f || !sym->attr.always_explicit;
1291 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1295 gfc_add_block_to_block (&se->pre, &parmse.pre);
1296 gfc_add_block_to_block (&se->post, &parmse.post);
1298 /* Character strings are passed as two parameters, a length and a
1299 pointer. */
1300 if (parmse.string_length != NULL_TREE)
1301 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1303 arglist = gfc_chainon_list (arglist, parmse.expr);
1306 /* Add the hidden string length parameters to the arguments. */
1307 arglist = chainon (arglist, stringargs);
1309 /* Generate the actual call. */
1310 gfc_conv_function_val (se, sym);
1311 /* If there are alternate return labels, function type should be
1312 integer. Can't modify the type in place though, since it can be shared
1313 with other functions. */
1314 if (has_alternate_specifier
1315 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1317 gcc_assert (! sym->attr.dummy);
1318 TREE_TYPE (sym->backend_decl)
1319 = build_function_type (integer_type_node,
1320 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1321 se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1324 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1325 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1326 arglist, NULL_TREE);
1328 /* If we have a pointer function, but we don't want a pointer, e.g.
1329 something like
1330 x = f()
1331 where f is pointer valued, we have to dereference the result. */
1332 if (!se->want_pointer && !byref && sym->attr.pointer)
1333 se->expr = gfc_build_indirect_ref (se->expr);
1335 /* f2c calling conventions require a scalar default real function to
1336 return a double precision result. Convert this back to default
1337 real. We only care about the cases that can happen in Fortran 77.
1339 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1340 && sym->ts.kind == gfc_default_real_kind
1341 && !sym->attr.always_explicit)
1342 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1344 /* A pure function may still have side-effects - it may modify its
1345 parameters. */
1346 TREE_SIDE_EFFECTS (se->expr) = 1;
1347 #if 0
1348 if (!sym->attr.pure)
1349 TREE_SIDE_EFFECTS (se->expr) = 1;
1350 #endif
1352 if (byref)
1354 /* Add the function call to the pre chain. There is no expression. */
1355 gfc_add_expr_to_block (&se->pre, se->expr);
1356 se->expr = NULL_TREE;
1358 if (!se->direct_byref)
1360 if (sym->attr.dimension)
1362 if (flag_bounds_check)
1364 /* Check the data pointer hasn't been modified. This would
1365 happen in a function returning a pointer. */
1366 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1367 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1368 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1370 se->expr = info->descriptor;
1371 /* Bundle in the string length. */
1372 se->string_length = len;
1374 else if (sym->ts.type == BT_CHARACTER)
1376 /* Dereference for character pointer results. */
1377 if (sym->attr.pointer || sym->attr.allocatable)
1378 se->expr = gfc_build_indirect_ref (var);
1379 else
1380 se->expr = var;
1382 se->string_length = len;
1384 else
1386 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1387 se->expr = gfc_build_indirect_ref (var);
1392 return has_alternate_specifier;
1396 /* Generate code to copy a string. */
1398 static void
1399 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1400 tree slen, tree src)
1402 tree tmp;
1404 tmp = NULL_TREE;
1405 tmp = gfc_chainon_list (tmp, dlen);
1406 tmp = gfc_chainon_list (tmp, dest);
1407 tmp = gfc_chainon_list (tmp, slen);
1408 tmp = gfc_chainon_list (tmp, src);
1409 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1410 gfc_add_expr_to_block (block, tmp);
1414 /* Translate a statement function.
1415 The value of a statement function reference is obtained by evaluating the
1416 expression using the values of the actual arguments for the values of the
1417 corresponding dummy arguments. */
1419 static void
1420 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1422 gfc_symbol *sym;
1423 gfc_symbol *fsym;
1424 gfc_formal_arglist *fargs;
1425 gfc_actual_arglist *args;
1426 gfc_se lse;
1427 gfc_se rse;
1428 gfc_saved_var *saved_vars;
1429 tree *temp_vars;
1430 tree type;
1431 tree tmp;
1432 int n;
1434 sym = expr->symtree->n.sym;
1435 args = expr->value.function.actual;
1436 gfc_init_se (&lse, NULL);
1437 gfc_init_se (&rse, NULL);
1439 n = 0;
1440 for (fargs = sym->formal; fargs; fargs = fargs->next)
1441 n++;
1442 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1443 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1445 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1447 /* Each dummy shall be specified, explicitly or implicitly, to be
1448 scalar. */
1449 gcc_assert (fargs->sym->attr.dimension == 0);
1450 fsym = fargs->sym;
1452 /* Create a temporary to hold the value. */
1453 type = gfc_typenode_for_spec (&fsym->ts);
1454 temp_vars[n] = gfc_create_var (type, fsym->name);
1456 if (fsym->ts.type == BT_CHARACTER)
1458 /* Copy string arguments. */
1459 tree arglen;
1461 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1462 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1464 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1465 tmp = gfc_build_addr_expr (build_pointer_type (type),
1466 temp_vars[n]);
1468 gfc_conv_expr (&rse, args->expr);
1469 gfc_conv_string_parameter (&rse);
1470 gfc_add_block_to_block (&se->pre, &lse.pre);
1471 gfc_add_block_to_block (&se->pre, &rse.pre);
1473 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1474 rse.expr);
1475 gfc_add_block_to_block (&se->pre, &lse.post);
1476 gfc_add_block_to_block (&se->pre, &rse.post);
1478 else
1480 /* For everything else, just evaluate the expression. */
1481 gfc_conv_expr (&lse, args->expr);
1483 gfc_add_block_to_block (&se->pre, &lse.pre);
1484 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1485 gfc_add_block_to_block (&se->pre, &lse.post);
1488 args = args->next;
1491 /* Use the temporary variables in place of the real ones. */
1492 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1493 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1495 gfc_conv_expr (se, sym->value);
1497 if (sym->ts.type == BT_CHARACTER)
1499 gfc_conv_const_charlen (sym->ts.cl);
1501 /* Force the expression to the correct length. */
1502 if (!INTEGER_CST_P (se->string_length)
1503 || tree_int_cst_lt (se->string_length,
1504 sym->ts.cl->backend_decl))
1506 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1507 tmp = gfc_create_var (type, sym->name);
1508 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1509 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1510 se->string_length, se->expr);
1511 se->expr = tmp;
1513 se->string_length = sym->ts.cl->backend_decl;
1516 /* Restore the original variables. */
1517 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1518 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1519 gfc_free (saved_vars);
1523 /* Translate a function expression. */
1525 static void
1526 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1528 gfc_symbol *sym;
1530 if (expr->value.function.isym)
1532 gfc_conv_intrinsic_function (se, expr);
1533 return;
1536 /* We distinguish statement functions from general functions to improve
1537 runtime performance. */
1538 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1540 gfc_conv_statement_function (se, expr);
1541 return;
1544 /* expr.value.function.esym is the resolved (specific) function symbol for
1545 most functions. However this isn't set for dummy procedures. */
1546 sym = expr->value.function.esym;
1547 if (!sym)
1548 sym = expr->symtree->n.sym;
1549 gfc_conv_function_call (se, sym, expr->value.function.actual);
1553 static void
1554 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1556 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1557 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1559 gfc_conv_tmp_array_ref (se);
1560 gfc_advance_se_ss_chain (se);
1564 /* Build a static initializer. EXPR is the expression for the initial value.
1565 The other parameters describe the variable of the component being
1566 initialized. EXPR may be null. */
1568 tree
1569 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1570 bool array, bool pointer)
1572 gfc_se se;
1574 if (!(expr || pointer))
1575 return NULL_TREE;
1577 if (array)
1579 /* Arrays need special handling. */
1580 if (pointer)
1581 return gfc_build_null_descriptor (type);
1582 else
1583 return gfc_conv_array_initializer (type, expr);
1585 else if (pointer)
1586 return fold_convert (type, null_pointer_node);
1587 else
1589 switch (ts->type)
1591 case BT_DERIVED:
1592 gfc_init_se (&se, NULL);
1593 gfc_conv_structure (&se, expr, 1);
1594 return se.expr;
1596 case BT_CHARACTER:
1597 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1599 default:
1600 gfc_init_se (&se, NULL);
1601 gfc_conv_constant (&se, expr);
1602 return se.expr;
1607 static tree
1608 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1610 gfc_se rse;
1611 gfc_se lse;
1612 gfc_ss *rss;
1613 gfc_ss *lss;
1614 stmtblock_t body;
1615 stmtblock_t block;
1616 gfc_loopinfo loop;
1617 int n;
1618 tree tmp;
1620 gfc_start_block (&block);
1622 /* Initialize the scalarizer. */
1623 gfc_init_loopinfo (&loop);
1625 gfc_init_se (&lse, NULL);
1626 gfc_init_se (&rse, NULL);
1628 /* Walk the rhs. */
1629 rss = gfc_walk_expr (expr);
1630 if (rss == gfc_ss_terminator)
1632 /* The rhs is scalar. Add a ss for the expression. */
1633 rss = gfc_get_ss ();
1634 rss->next = gfc_ss_terminator;
1635 rss->type = GFC_SS_SCALAR;
1636 rss->expr = expr;
1639 /* Create a SS for the destination. */
1640 lss = gfc_get_ss ();
1641 lss->type = GFC_SS_COMPONENT;
1642 lss->expr = NULL;
1643 lss->shape = gfc_get_shape (cm->as->rank);
1644 lss->next = gfc_ss_terminator;
1645 lss->data.info.dimen = cm->as->rank;
1646 lss->data.info.descriptor = dest;
1647 lss->data.info.data = gfc_conv_array_data (dest);
1648 lss->data.info.offset = gfc_conv_array_offset (dest);
1649 for (n = 0; n < cm->as->rank; n++)
1651 lss->data.info.dim[n] = n;
1652 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1653 lss->data.info.stride[n] = gfc_index_one_node;
1655 mpz_init (lss->shape[n]);
1656 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1657 cm->as->lower[n]->value.integer);
1658 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1661 /* Associate the SS with the loop. */
1662 gfc_add_ss_to_loop (&loop, lss);
1663 gfc_add_ss_to_loop (&loop, rss);
1665 /* Calculate the bounds of the scalarization. */
1666 gfc_conv_ss_startstride (&loop);
1668 /* Setup the scalarizing loops. */
1669 gfc_conv_loop_setup (&loop);
1671 /* Setup the gfc_se structures. */
1672 gfc_copy_loopinfo_to_se (&lse, &loop);
1673 gfc_copy_loopinfo_to_se (&rse, &loop);
1675 rse.ss = rss;
1676 gfc_mark_ss_chain_used (rss, 1);
1677 lse.ss = lss;
1678 gfc_mark_ss_chain_used (lss, 1);
1680 /* Start the scalarized loop body. */
1681 gfc_start_scalarized_body (&loop, &body);
1683 gfc_conv_tmp_array_ref (&lse);
1684 if (cm->ts.type == BT_CHARACTER)
1685 lse.string_length = cm->ts.cl->backend_decl;
1687 gfc_conv_expr (&rse, expr);
1689 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1690 gfc_add_expr_to_block (&body, tmp);
1692 gcc_assert (rse.ss == gfc_ss_terminator);
1694 /* Generate the copying loops. */
1695 gfc_trans_scalarizing_loops (&loop, &body);
1697 /* Wrap the whole thing up. */
1698 gfc_add_block_to_block (&block, &loop.pre);
1699 gfc_add_block_to_block (&block, &loop.post);
1701 for (n = 0; n < cm->as->rank; n++)
1702 mpz_clear (lss->shape[n]);
1703 gfc_free (lss->shape);
1705 gfc_cleanup_loop (&loop);
1707 return gfc_finish_block (&block);
1710 /* Assign a single component of a derived type constructor. */
1712 static tree
1713 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1715 gfc_se se;
1716 gfc_ss *rss;
1717 stmtblock_t block;
1718 tree tmp;
1720 gfc_start_block (&block);
1721 if (cm->pointer)
1723 gfc_init_se (&se, NULL);
1724 /* Pointer component. */
1725 if (cm->dimension)
1727 /* Array pointer. */
1728 if (expr->expr_type == EXPR_NULL)
1729 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
1730 else
1732 rss = gfc_walk_expr (expr);
1733 se.direct_byref = 1;
1734 se.expr = dest;
1735 gfc_conv_expr_descriptor (&se, expr, rss);
1736 gfc_add_block_to_block (&block, &se.pre);
1737 gfc_add_block_to_block (&block, &se.post);
1740 else
1742 /* Scalar pointers. */
1743 se.want_pointer = 1;
1744 gfc_conv_expr (&se, expr);
1745 gfc_add_block_to_block (&block, &se.pre);
1746 gfc_add_modify_expr (&block, dest,
1747 fold_convert (TREE_TYPE (dest), se.expr));
1748 gfc_add_block_to_block (&block, &se.post);
1751 else if (cm->dimension)
1753 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1754 gfc_add_expr_to_block (&block, tmp);
1756 else if (expr->ts.type == BT_DERIVED)
1758 /* Nested derived type. */
1759 tmp = gfc_trans_structure_assign (dest, expr);
1760 gfc_add_expr_to_block (&block, tmp);
1762 else
1764 /* Scalar component. */
1765 gfc_se lse;
1767 gfc_init_se (&se, NULL);
1768 gfc_init_se (&lse, NULL);
1770 gfc_conv_expr (&se, expr);
1771 if (cm->ts.type == BT_CHARACTER)
1772 lse.string_length = cm->ts.cl->backend_decl;
1773 lse.expr = dest;
1774 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1775 gfc_add_expr_to_block (&block, tmp);
1777 return gfc_finish_block (&block);
1780 /* Assign a derived type constructor to a variable. */
1782 static tree
1783 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1785 gfc_constructor *c;
1786 gfc_component *cm;
1787 stmtblock_t block;
1788 tree field;
1789 tree tmp;
1791 gfc_start_block (&block);
1792 cm = expr->ts.derived->components;
1793 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1795 /* Skip absent members in default initializers. */
1796 if (!c->expr)
1797 continue;
1799 field = cm->backend_decl;
1800 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1801 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1802 gfc_add_expr_to_block (&block, tmp);
1804 return gfc_finish_block (&block);
1807 /* Build an expression for a constructor. If init is nonzero then
1808 this is part of a static variable initializer. */
1810 void
1811 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1813 gfc_constructor *c;
1814 gfc_component *cm;
1815 tree val;
1816 tree type;
1817 tree tmp;
1818 VEC(constructor_elt,gc) *v = NULL;
1820 gcc_assert (se->ss == NULL);
1821 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1822 type = gfc_typenode_for_spec (&expr->ts);
1824 if (!init)
1826 /* Create a temporary variable and fill it in. */
1827 se->expr = gfc_create_var (type, expr->ts.derived->name);
1828 tmp = gfc_trans_structure_assign (se->expr, expr);
1829 gfc_add_expr_to_block (&se->pre, tmp);
1830 return;
1833 cm = expr->ts.derived->components;
1834 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1836 /* Skip absent members in default initializers. */
1837 if (!c->expr)
1838 continue;
1840 val = gfc_conv_initializer (c->expr, &cm->ts,
1841 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1843 /* Append it to the constructor list. */
1844 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
1846 se->expr = build_constructor (type, v);
1850 /* Translate a substring expression. */
1852 static void
1853 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1855 gfc_ref *ref;
1857 ref = expr->ref;
1859 gcc_assert (ref->type == REF_SUBSTRING);
1861 se->expr = gfc_build_string_const(expr->value.character.length,
1862 expr->value.character.string);
1863 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1864 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1866 gfc_conv_substring(se,ref,expr->ts.kind);
1870 /* Entry point for expression translation. Evaluates a scalar quantity.
1871 EXPR is the expression to be translated, and SE is the state structure if
1872 called from within the scalarized. */
1874 void
1875 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1877 if (se->ss && se->ss->expr == expr
1878 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1880 /* Substitute a scalar expression evaluated outside the scalarization
1881 loop. */
1882 se->expr = se->ss->data.scalar.expr;
1883 se->string_length = se->ss->string_length;
1884 gfc_advance_se_ss_chain (se);
1885 return;
1888 switch (expr->expr_type)
1890 case EXPR_OP:
1891 gfc_conv_expr_op (se, expr);
1892 break;
1894 case EXPR_FUNCTION:
1895 gfc_conv_function_expr (se, expr);
1896 break;
1898 case EXPR_CONSTANT:
1899 gfc_conv_constant (se, expr);
1900 break;
1902 case EXPR_VARIABLE:
1903 gfc_conv_variable (se, expr);
1904 break;
1906 case EXPR_NULL:
1907 se->expr = null_pointer_node;
1908 break;
1910 case EXPR_SUBSTRING:
1911 gfc_conv_substring_expr (se, expr);
1912 break;
1914 case EXPR_STRUCTURE:
1915 gfc_conv_structure (se, expr, 0);
1916 break;
1918 case EXPR_ARRAY:
1919 gfc_conv_array_constructor_expr (se, expr);
1920 break;
1922 default:
1923 gcc_unreachable ();
1924 break;
1928 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
1929 of an assignment. */
1930 void
1931 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1933 gfc_conv_expr (se, expr);
1934 /* All numeric lvalues should have empty post chains. If not we need to
1935 figure out a way of rewriting an lvalue so that it has no post chain. */
1936 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
1939 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
1940 numeric expressions. Used for scalar values whee inserting cleanup code
1941 is inconvenient. */
1942 void
1943 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1945 tree val;
1947 gcc_assert (expr->ts.type != BT_CHARACTER);
1948 gfc_conv_expr (se, expr);
1949 if (se->post.head)
1951 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1952 gfc_add_modify_expr (&se->pre, val, se->expr);
1953 se->expr = val;
1954 gfc_add_block_to_block (&se->pre, &se->post);
1958 /* Helper to translate and expression and convert it to a particular type. */
1959 void
1960 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1962 gfc_conv_expr_val (se, expr);
1963 se->expr = convert (type, se->expr);
1967 /* Converts an expression so that it can be passed by reference. Scalar
1968 values only. */
1970 void
1971 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1973 tree var;
1975 if (se->ss && se->ss->expr == expr
1976 && se->ss->type == GFC_SS_REFERENCE)
1978 se->expr = se->ss->data.scalar.expr;
1979 se->string_length = se->ss->string_length;
1980 gfc_advance_se_ss_chain (se);
1981 return;
1984 if (expr->ts.type == BT_CHARACTER)
1986 gfc_conv_expr (se, expr);
1987 gfc_conv_string_parameter (se);
1988 return;
1991 if (expr->expr_type == EXPR_VARIABLE)
1993 se->want_pointer = 1;
1994 gfc_conv_expr (se, expr);
1995 if (se->post.head)
1997 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1998 gfc_add_modify_expr (&se->pre, var, se->expr);
1999 gfc_add_block_to_block (&se->pre, &se->post);
2000 se->expr = var;
2002 return;
2005 gfc_conv_expr (se, expr);
2007 /* Create a temporary var to hold the value. */
2008 if (TREE_CONSTANT (se->expr))
2010 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2011 DECL_INITIAL (var) = se->expr;
2012 pushdecl (var);
2014 else
2016 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2017 gfc_add_modify_expr (&se->pre, var, se->expr);
2019 gfc_add_block_to_block (&se->pre, &se->post);
2021 /* Take the address of that value. */
2022 se->expr = gfc_build_addr_expr (NULL, var);
2026 tree
2027 gfc_trans_pointer_assign (gfc_code * code)
2029 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2033 /* Generate code for a pointer assignment. */
2035 tree
2036 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2038 gfc_se lse;
2039 gfc_se rse;
2040 gfc_ss *lss;
2041 gfc_ss *rss;
2042 stmtblock_t block;
2044 gfc_start_block (&block);
2046 gfc_init_se (&lse, NULL);
2048 lss = gfc_walk_expr (expr1);
2049 rss = gfc_walk_expr (expr2);
2050 if (lss == gfc_ss_terminator)
2052 /* Scalar pointers. */
2053 lse.want_pointer = 1;
2054 gfc_conv_expr (&lse, expr1);
2055 gcc_assert (rss == gfc_ss_terminator);
2056 gfc_init_se (&rse, NULL);
2057 rse.want_pointer = 1;
2058 gfc_conv_expr (&rse, expr2);
2059 gfc_add_block_to_block (&block, &lse.pre);
2060 gfc_add_block_to_block (&block, &rse.pre);
2061 gfc_add_modify_expr (&block, lse.expr,
2062 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2063 gfc_add_block_to_block (&block, &rse.post);
2064 gfc_add_block_to_block (&block, &lse.post);
2066 else
2068 /* Array pointer. */
2069 gfc_conv_expr_descriptor (&lse, expr1, lss);
2070 /* Implement Nullify. */
2071 if (expr2->expr_type == EXPR_NULL)
2072 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2073 else
2075 lse.direct_byref = 1;
2076 gfc_conv_expr_descriptor (&lse, expr2, rss);
2078 gfc_add_block_to_block (&block, &lse.pre);
2079 gfc_add_block_to_block (&block, &lse.post);
2081 return gfc_finish_block (&block);
2085 /* Makes sure se is suitable for passing as a function string parameter. */
2086 /* TODO: Need to check all callers fo this function. It may be abused. */
2088 void
2089 gfc_conv_string_parameter (gfc_se * se)
2091 tree type;
2093 if (TREE_CODE (se->expr) == STRING_CST)
2095 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2096 return;
2099 type = TREE_TYPE (se->expr);
2100 if (TYPE_STRING_FLAG (type))
2102 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2103 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2106 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2107 gcc_assert (se->string_length
2108 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2112 /* Generate code for assignment of scalar variables. Includes character
2113 strings. */
2115 tree
2116 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2118 stmtblock_t block;
2120 gfc_init_block (&block);
2122 if (type == BT_CHARACTER)
2124 gcc_assert (lse->string_length != NULL_TREE
2125 && rse->string_length != NULL_TREE);
2127 gfc_conv_string_parameter (lse);
2128 gfc_conv_string_parameter (rse);
2130 gfc_add_block_to_block (&block, &lse->pre);
2131 gfc_add_block_to_block (&block, &rse->pre);
2133 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2134 rse->string_length, rse->expr);
2136 else
2138 gfc_add_block_to_block (&block, &lse->pre);
2139 gfc_add_block_to_block (&block, &rse->pre);
2141 gfc_add_modify_expr (&block, lse->expr,
2142 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2145 gfc_add_block_to_block (&block, &lse->post);
2146 gfc_add_block_to_block (&block, &rse->post);
2148 return gfc_finish_block (&block);
2152 /* Try to translate array(:) = func (...), where func is a transformational
2153 array function, without using a temporary. Returns NULL is this isn't the
2154 case. */
2156 static tree
2157 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2159 gfc_se se;
2160 gfc_ss *ss;
2162 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2163 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2164 return NULL;
2166 /* Elemental functions don't need a temporary anyway. */
2167 if (expr2->symtree->n.sym->attr.elemental)
2168 return NULL;
2170 /* Check for a dependency. */
2171 if (gfc_check_fncall_dependency (expr1, expr2))
2172 return NULL;
2174 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2175 functions. */
2176 gcc_assert (expr2->value.function.isym
2177 || (gfc_return_by_reference (expr2->value.function.esym)
2178 && expr2->value.function.esym->result->attr.dimension));
2180 ss = gfc_walk_expr (expr1);
2181 gcc_assert (ss != gfc_ss_terminator);
2182 gfc_init_se (&se, NULL);
2183 gfc_start_block (&se.pre);
2184 se.want_pointer = 1;
2186 gfc_conv_array_parameter (&se, expr1, ss, 0);
2188 se.direct_byref = 1;
2189 se.ss = gfc_walk_expr (expr2);
2190 gcc_assert (se.ss != gfc_ss_terminator);
2191 gfc_conv_function_expr (&se, expr2);
2192 gfc_add_block_to_block (&se.pre, &se.post);
2194 return gfc_finish_block (&se.pre);
2198 /* Translate an assignment. Most of the code is concerned with
2199 setting up the scalarizer. */
2201 tree
2202 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2204 gfc_se lse;
2205 gfc_se rse;
2206 gfc_ss *lss;
2207 gfc_ss *lss_section;
2208 gfc_ss *rss;
2209 gfc_loopinfo loop;
2210 tree tmp;
2211 stmtblock_t block;
2212 stmtblock_t body;
2214 /* Special case a single function returning an array. */
2215 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2217 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2218 if (tmp)
2219 return tmp;
2222 /* Assignment of the form lhs = rhs. */
2223 gfc_start_block (&block);
2225 gfc_init_se (&lse, NULL);
2226 gfc_init_se (&rse, NULL);
2228 /* Walk the lhs. */
2229 lss = gfc_walk_expr (expr1);
2230 rss = NULL;
2231 if (lss != gfc_ss_terminator)
2233 /* The assignment needs scalarization. */
2234 lss_section = lss;
2236 /* Find a non-scalar SS from the lhs. */
2237 while (lss_section != gfc_ss_terminator
2238 && lss_section->type != GFC_SS_SECTION)
2239 lss_section = lss_section->next;
2241 gcc_assert (lss_section != gfc_ss_terminator);
2243 /* Initialize the scalarizer. */
2244 gfc_init_loopinfo (&loop);
2246 /* Walk the rhs. */
2247 rss = gfc_walk_expr (expr2);
2248 if (rss == gfc_ss_terminator)
2250 /* The rhs is scalar. Add a ss for the expression. */
2251 rss = gfc_get_ss ();
2252 rss->next = gfc_ss_terminator;
2253 rss->type = GFC_SS_SCALAR;
2254 rss->expr = expr2;
2256 /* Associate the SS with the loop. */
2257 gfc_add_ss_to_loop (&loop, lss);
2258 gfc_add_ss_to_loop (&loop, rss);
2260 /* Calculate the bounds of the scalarization. */
2261 gfc_conv_ss_startstride (&loop);
2262 /* Resolve any data dependencies in the statement. */
2263 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2264 /* Setup the scalarizing loops. */
2265 gfc_conv_loop_setup (&loop);
2267 /* Setup the gfc_se structures. */
2268 gfc_copy_loopinfo_to_se (&lse, &loop);
2269 gfc_copy_loopinfo_to_se (&rse, &loop);
2271 rse.ss = rss;
2272 gfc_mark_ss_chain_used (rss, 1);
2273 if (loop.temp_ss == NULL)
2275 lse.ss = lss;
2276 gfc_mark_ss_chain_used (lss, 1);
2278 else
2280 lse.ss = loop.temp_ss;
2281 gfc_mark_ss_chain_used (lss, 3);
2282 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2285 /* Start the scalarized loop body. */
2286 gfc_start_scalarized_body (&loop, &body);
2288 else
2289 gfc_init_block (&body);
2291 /* Translate the expression. */
2292 gfc_conv_expr (&rse, expr2);
2294 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2296 gfc_conv_tmp_array_ref (&lse);
2297 gfc_advance_se_ss_chain (&lse);
2299 else
2300 gfc_conv_expr (&lse, expr1);
2302 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2303 gfc_add_expr_to_block (&body, tmp);
2305 if (lss == gfc_ss_terminator)
2307 /* Use the scalar assignment as is. */
2308 gfc_add_block_to_block (&block, &body);
2310 else
2312 gcc_assert (lse.ss == gfc_ss_terminator
2313 && rse.ss == gfc_ss_terminator);
2315 if (loop.temp_ss != NULL)
2317 gfc_trans_scalarized_loop_boundary (&loop, &body);
2319 /* We need to copy the temporary to the actual lhs. */
2320 gfc_init_se (&lse, NULL);
2321 gfc_init_se (&rse, NULL);
2322 gfc_copy_loopinfo_to_se (&lse, &loop);
2323 gfc_copy_loopinfo_to_se (&rse, &loop);
2325 rse.ss = loop.temp_ss;
2326 lse.ss = lss;
2328 gfc_conv_tmp_array_ref (&rse);
2329 gfc_advance_se_ss_chain (&rse);
2330 gfc_conv_expr (&lse, expr1);
2332 gcc_assert (lse.ss == gfc_ss_terminator
2333 && rse.ss == gfc_ss_terminator);
2335 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2336 gfc_add_expr_to_block (&body, tmp);
2338 /* Generate the copying loops. */
2339 gfc_trans_scalarizing_loops (&loop, &body);
2341 /* Wrap the whole thing up. */
2342 gfc_add_block_to_block (&block, &loop.pre);
2343 gfc_add_block_to_block (&block, &loop.post);
2345 gfc_cleanup_loop (&loop);
2348 return gfc_finish_block (&block);
2351 tree
2352 gfc_trans_assign (gfc_code * code)
2354 return gfc_trans_assignment (code->expr, code->expr2);