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