gcc/fortran/trans-expr.c

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