trans-expr.c 172 KB
Newer Older
dnovillo's avatar
 
dnovillo committed
1
/* Expression translation
2
   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
pault's avatar
pault committed
3
   Free Software Foundation, Inc.
dnovillo's avatar
 
dnovillo committed
4 5 6
   Contributed by Paul Brook <paul@nowt.org>
   and Steven Bosscher <s.bosscher@student.tudelft.nl>

7
This file is part of GCC.
dnovillo's avatar
 
dnovillo committed
8

9 10
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
11
Software Foundation; either version 3, or (at your option) any later
12
version.
dnovillo's avatar
 
dnovillo committed
13

14 15 16 17
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.
dnovillo's avatar
 
dnovillo committed
18 19

You should have received a copy of the GNU General Public License
20 21
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */
dnovillo's avatar
 
dnovillo committed
22 23 24 25 26 27 28

/* trans-expr.c-- generate GENERIC trees for gfc_expr.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
29
#include "diagnostic-core.h"	/* For fatal_error.  */
fxcoudert's avatar
fxcoudert committed
30
#include "langhooks.h"
dnovillo's avatar
 
dnovillo committed
31 32
#include "flags.h"
#include "gfortran.h"
33
#include "arith.h"
34
#include "constructor.h"
dnovillo's avatar
 
dnovillo committed
35 36 37 38 39 40
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
#include "trans-stmt.h"
rsandifo's avatar
rsandifo committed
41
#include "dependency.h"
dnovillo's avatar
 
dnovillo committed
42

pbrook's avatar
pbrook committed
43
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
44
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
rsandifo's avatar
rsandifo committed
45
						 gfc_expr *);
dnovillo's avatar
 
dnovillo committed
46 47 48 49 50 51 52 53 54 55 56

/* Copy the scalarization loop variables.  */

static void
gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
{
  dest->ss = src->ss;
  dest->loop = src->loop;
}


57
/* Initialize a simple expression holder.
dnovillo's avatar
 
dnovillo committed
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77

   Care must be taken when multiple se are created with the same parent.
   The child se must be kept in sync.  The easiest way is to delay creation
   of a child se until after after the previous se has been translated.  */

void
gfc_init_se (gfc_se * se, gfc_se * parent)
{
  memset (se, 0, sizeof (gfc_se));
  gfc_init_block (&se->pre);
  gfc_init_block (&se->post);

  se->parent = parent;

  if (parent)
    gfc_copy_se_loopvars (se, parent);
}


/* Advances to the next SS in the chain.  Use this rather than setting
78
   se->ss = se->ss->next because all the parents needs to be kept in sync.
dnovillo's avatar
 
dnovillo committed
79 80 81 82 83 84 85
   See gfc_init_se.  */

void
gfc_advance_se_ss_chain (gfc_se * se)
{
  gfc_se *p;

pbrook's avatar
pbrook committed
86
  gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
87 88 89 90 91

  p = se;
  /* Walk down the parent chain.  */
  while (p != NULL)
    {
92
      /* Simple consistency check.  */
pbrook's avatar
pbrook committed
93
      gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
dnovillo's avatar
 
dnovillo committed
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109

      p->ss = p->ss->next;

      p = p->parent;
    }
}


/* Ensures the result of the expression as either a temporary variable
   or a constant so that it can be used repeatedly.  */

void
gfc_make_safe_expr (gfc_se * se)
{
  tree var;

110
  if (CONSTANT_CLASS_P (se->expr))
dnovillo's avatar
 
dnovillo committed
111 112
    return;

113
  /* We need a temporary for this result.  */
dnovillo's avatar
 
dnovillo committed
114
  var = gfc_create_var (TREE_TYPE (se->expr), NULL);
115
  gfc_add_modify (&se->pre, var, se->expr);
dnovillo's avatar
 
dnovillo committed
116 117 118 119
  se->expr = var;
}


120 121
/* Return an expression which determines if a dummy parameter is present.
   Also used for arguments to procedures with multiple entry points.  */
dnovillo's avatar
 
dnovillo committed
122 123 124 125

tree
gfc_conv_expr_present (gfc_symbol * sym)
{
126
  tree decl, cond;
dnovillo's avatar
 
dnovillo committed
127

128
  gcc_assert (sym->attr.dummy);
dnovillo's avatar
 
dnovillo committed
129 130 131 132 133 134

  decl = gfc_get_symbol_decl (sym);
  if (TREE_CODE (decl) != PARM_DECL)
    {
      /* Array parameters use a temporary descriptor, we want the real
         parameter.  */
pbrook's avatar
pbrook committed
135
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
dnovillo's avatar
 
dnovillo committed
136 137 138
             || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
    }
139

140 141
  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
			  fold_convert (TREE_TYPE (decl), null_pointer_node));
142 143 144 145 146 147 148 149 150 151 152

  /* Fortran 2008 allows to pass null pointers and non-associated pointers
     as actual argument to denote absent dummies. For array descriptors,
     we thus also need to check the array descriptor.  */
  if (!sym->attr.pointer && !sym->attr.allocatable
      && sym->as && sym->as->type == AS_ASSUMED_SHAPE
      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
    {
      tree tmp;
      tmp = build_fold_indirect_ref_loc (input_location, decl);
      tmp = gfc_conv_array_data (tmp);
153 154 155 156
      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
			     fold_convert (TREE_TYPE (tmp), null_pointer_node));
      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
			      boolean_type_node, cond, tmp);
157 158 159
    }

  return cond;
dnovillo's avatar
 
dnovillo committed
160 161 162
}


163 164 165
/* Converts a missing, dummy argument into a null or zero.  */

void
166
gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
167 168 169 170 171
{
  tree present;
  tree tmp;

  present = gfc_conv_expr_present (arg->symtree->n.sym);
172

173 174
  if (kind > 0)
    {
175
      /* Create a temporary and convert it to the correct type.  */
176
      tmp = gfc_get_int_type (kind);
177 178
      tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
							se->expr));
179 180
    
      /* Test for a NULL value.  */
181 182
      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
			tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
183
      tmp = gfc_evaluate_now (tmp, &se->pre);
184
      se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
185 186 187
    }
  else
    {
188 189
      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
			present, se->expr,
froydnj's avatar
gcc/  
froydnj committed
190
			build_zero_cst (TREE_TYPE (se->expr)));
191 192
      tmp = gfc_evaluate_now (tmp, &se->pre);
      se->expr = tmp;
193
    }
194

195 196
  if (ts.type == BT_CHARACTER)
    {
197
      tmp = build_int_cst (gfc_charlen_type_node, 0);
198 199
      tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
			     present, se->string_length, tmp);
200 201 202 203 204 205 206
      tmp = gfc_evaluate_now (tmp, &se->pre);
      se->string_length = tmp;
    }
  return;
}


207 208 209 210 211 212 213 214 215 216 217 218 219 220
/* Get the character length of an expression, looking through gfc_refs
   if necessary.  */

tree
gfc_get_expr_charlen (gfc_expr *e)
{
  gfc_ref *r;
  tree length;

  gcc_assert (e->expr_type == EXPR_VARIABLE 
	      && e->ts.type == BT_CHARACTER);
  
  length = NULL; /* To silence compiler warning.  */

221
  if (is_subref_array (e) && e->ts.u.cl->length)
222 223 224
    {
      gfc_se tmpse;
      gfc_init_se (&tmpse, NULL);
225 226
      gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
      e->ts.u.cl->backend_decl = tmpse.expr;
227 228 229
      return tmpse.expr;
    }

230 231
  /* First candidate: if the variable is of type CHARACTER, the
     expression's length could be the length of the character
232
     variable.  */
233
  if (e->symtree->n.sym->ts.type == BT_CHARACTER)
234
    length = e->symtree->n.sym->ts.u.cl->backend_decl;
235 236 237 238 239 240 241 242

  /* Look through the reference chain for component references.  */
  for (r = e->ref; r; r = r->next)
    {
      switch (r->type)
	{
	case REF_COMPONENT:
	  if (r->u.c.component->ts.type == BT_CHARACTER)
243
	    length = r->u.c.component->ts.u.cl->backend_decl;
244 245 246 247 248 249 250 251 252 253
	  break;

	case REF_ARRAY:
	  /* Do nothing.  */
	  break;

	default:
	  /* We should never got substring references here.  These will be
	     broken down by the scalarizer.  */
	  gcc_unreachable ();
254
	  break;
255 256 257 258 259 260 261
	}
    }

  gcc_assert (length != NULL);
  return length;
}

domob's avatar
domob committed
262

263
/* For each character array constructor subexpression without a ts.u.cl->length,
domob's avatar
domob committed
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295
   replace it by its first element (if there aren't any elements, the length
   should already be set to zero).  */

static void
flatten_array_ctors_without_strlen (gfc_expr* e)
{
  gfc_actual_arglist* arg;
  gfc_constructor* c;

  if (!e)
    return;

  switch (e->expr_type)
    {

    case EXPR_OP:
      flatten_array_ctors_without_strlen (e->value.op.op1); 
      flatten_array_ctors_without_strlen (e->value.op.op2); 
      break;

    case EXPR_COMPCALL:
      /* TODO: Implement as with EXPR_FUNCTION when needed.  */
      gcc_unreachable ();

    case EXPR_FUNCTION:
      for (arg = e->value.function.actual; arg; arg = arg->next)
	flatten_array_ctors_without_strlen (arg->expr);
      break;

    case EXPR_ARRAY:

      /* We've found what we're looking for.  */
296
      if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
domob's avatar
domob committed
297
	{
298
	  gfc_constructor *c;
domob's avatar
domob committed
299
	  gfc_expr* new_expr;
300

domob's avatar
domob committed
301 302
	  gcc_assert (e->value.constructor);

303 304 305
	  c = gfc_constructor_first (e->value.constructor);
	  new_expr = c->expr;
	  c->expr = NULL;
domob's avatar
domob committed
306 307 308 309 310 311 312 313

	  flatten_array_ctors_without_strlen (new_expr);
	  gfc_replace_expr (e, new_expr);
	  break;
	}

      /* Otherwise, fall through to handle constructor elements.  */
    case EXPR_STRUCTURE:
314 315
      for (c = gfc_constructor_first (e->value.constructor);
	   c; c = gfc_constructor_next (c))
domob's avatar
domob committed
316 317 318 319 320 321 322 323 324
	flatten_array_ctors_without_strlen (c->expr);
      break;

    default:
      break;

    }
}

325

dnovillo's avatar
 
dnovillo committed
326
/* Generate code to initialize a string length variable. Returns the
domob's avatar
domob committed
327 328 329
   value.  For array constructors, cl->length might be NULL and in this case,
   the first element of the constructor is needed.  expr is the original
   expression so we can access it but can be NULL if this is not needed.  */
dnovillo's avatar
 
dnovillo committed
330 331

void
domob's avatar
domob committed
332
gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
dnovillo's avatar
 
dnovillo committed
333 334 335 336
{
  gfc_se se;

  gfc_init_se (&se, NULL);
domob's avatar
domob committed
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361

  /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
     "flatten" array constructors by taking their first element; all elements
     should be the same length or a cl->length should be present.  */
  if (!cl->length)
    {
      gfc_expr* expr_flat;
      gcc_assert (expr);

      expr_flat = gfc_copy_expr (expr);
      flatten_array_ctors_without_strlen (expr_flat);
      gfc_resolve_expr (expr_flat);

      gfc_conv_expr (&se, expr_flat);
      gfc_add_block_to_block (pblock, &se.pre);
      cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);

      gfc_free_expr (expr_flat);
      return;
    }

  /* Convert cl->length.  */

  gcc_assert (cl->length);

tobi's avatar
tobi committed
362
  gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
363 364
  se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
			     se.expr, build_int_cst (gfc_charlen_type_node, 0));
dnovillo's avatar
 
dnovillo committed
365 366
  gfc_add_block_to_block (pblock, &se.pre);

367
  if (cl->backend_decl)
368
    gfc_add_modify (pblock, cl->backend_decl, se.expr);
369 370
  else
    cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
dnovillo's avatar
 
dnovillo committed
371 372
}

373

dnovillo's avatar
 
dnovillo committed
374
static void
burnus's avatar
burnus committed
375 376
gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
		    const char *name, locus *where)
dnovillo's avatar
 
dnovillo committed
377 378 379
{
  tree tmp;
  tree type;
burnus's avatar
burnus committed
380
  tree fault;
dnovillo's avatar
 
dnovillo committed
381 382
  gfc_se start;
  gfc_se end;
burnus's avatar
burnus committed
383
  char *msg;
dnovillo's avatar
 
dnovillo committed
384 385 386 387 388

  type = gfc_get_character_type (kind, ref->u.ss.length);
  type = build_pointer_type (type);

  gfc_init_se (&start, se);
tobi's avatar
tobi committed
389
  gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
dnovillo's avatar
 
dnovillo committed
390 391 392
  gfc_add_block_to_block (&se->pre, &start.pre);

  if (integer_onep (start.expr))
393
    gfc_conv_string_parameter (se);
dnovillo's avatar
 
dnovillo committed
394 395
  else
    {
396 397
      tmp = start.expr;
      STRIP_NOPS (tmp);
fxcoudert's avatar
fxcoudert committed
398
      /* Avoid multiple evaluation of substring start.  */
399
      if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
fxcoudert's avatar
fxcoudert committed
400 401
	start.expr = gfc_evaluate_now (start.expr, &se->pre);

dnovillo's avatar
 
dnovillo committed
402 403 404 405
      /* Change the start of the string.  */
      if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
	tmp = se->expr;
      else
406 407
	tmp = build_fold_indirect_ref_loc (input_location,
				       se->expr);
408
      tmp = gfc_build_array_ref (tmp, start.expr, NULL);
dnovillo's avatar
 
dnovillo committed
409 410 411 412 413 414 415 416 417
      se->expr = gfc_build_addr_expr (type, tmp);
    }

  /* Length = end + 1 - start.  */
  gfc_init_se (&end, se);
  if (ref->u.ss.end == NULL)
    end.expr = se->string_length;
  else
    {
tobi's avatar
tobi committed
418
      gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
dnovillo's avatar
 
dnovillo committed
419 420
      gfc_add_block_to_block (&se->pre, &end.pre);
    }
421 422 423
  tmp = end.expr;
  STRIP_NOPS (tmp);
  if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
fxcoudert's avatar
fxcoudert committed
424 425
    end.expr = gfc_evaluate_now (end.expr, &se->pre);

426
  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
burnus's avatar
burnus committed
427
    {
428 429 430
      tree nonempty = fold_build2_loc (input_location, LE_EXPR,
				       boolean_type_node, start.expr,
				       end.expr);
tobi's avatar
tobi committed
431

burnus's avatar
burnus committed
432
      /* Check lower bound.  */
433 434 435 436 437
      fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
			       start.expr,
			       build_int_cst (gfc_charlen_type_node, 1));
      fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
			       boolean_type_node, nonempty, fault);
burnus's avatar
burnus committed
438
      if (name)
fxcoudert's avatar
fxcoudert committed
439
	asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
burnus's avatar
burnus committed
440 441
		  "is less than one", name);
      else
fxcoudert's avatar
fxcoudert committed
442
	asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
burnus's avatar
burnus committed
443
		  "is less than one");
444
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fxcoudert's avatar
fxcoudert committed
445 446
			       fold_convert (long_integer_type_node,
					     start.expr));
burnus's avatar
burnus committed
447 448 449
      gfc_free (msg);

      /* Check upper bound.  */
450 451 452 453
      fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
			       end.expr, se->string_length);
      fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
			       boolean_type_node, nonempty, fault);
burnus's avatar
burnus committed
454
      if (name)
fxcoudert's avatar
fxcoudert committed
455 456
	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
		  "exceeds string length (%%ld)", name);
burnus's avatar
burnus committed
457
      else
fxcoudert's avatar
fxcoudert committed
458 459
	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
		  "exceeds string length (%%ld)");
460
      gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fxcoudert's avatar
fxcoudert committed
461 462 463
			       fold_convert (long_integer_type_node, end.expr),
			       fold_convert (long_integer_type_node,
					     se->string_length));
burnus's avatar
burnus committed
464 465 466
      gfc_free (msg);
    }

467 468 469 470 471 472 473 474 475 476 477 478 479 480
  /* If the start and end expressions are equal, the length is one.  */
  if (ref->u.ss.end
      && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
    tmp = build_int_cst (gfc_charlen_type_node, 1);
  else
    {
      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
			     end.expr, start.expr);
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
			     build_int_cst (gfc_charlen_type_node, 1), tmp);
      tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
			     tmp, build_int_cst (gfc_charlen_type_node, 0));
    }

481
  se->string_length = tmp;
dnovillo's avatar
 
dnovillo committed
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
}


/* Convert a derived type component reference.  */

static void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
  gfc_component *c;
  tree tmp;
  tree decl;
  tree field;

  c = ref->u.c.component;

pbrook's avatar
pbrook committed
497
  gcc_assert (c->backend_decl);
dnovillo's avatar
 
dnovillo committed
498 499

  field = c->backend_decl;
pbrook's avatar
pbrook committed
500
  gcc_assert (TREE_CODE (field) == FIELD_DECL);
dnovillo's avatar
 
dnovillo committed
501
  decl = se->expr;
502 503
  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
			 decl, field, NULL_TREE);
dnovillo's avatar
 
dnovillo committed
504 505 506

  se->expr = tmp;

507
  if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
dnovillo's avatar
 
dnovillo committed
508
    {
509
      tmp = c->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
510
      /* Components must always be constant length.  */
pbrook's avatar
pbrook committed
511
      gcc_assert (tmp && INTEGER_CST_P (tmp));
dnovillo's avatar
 
dnovillo committed
512 513 514
      se->string_length = tmp;
    }

burnus's avatar
burnus committed
515 516
  if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
       && c->ts.type != BT_CHARACTER)
517
      || c->attr.proc_pointer)
518 519
    se->expr = build_fold_indirect_ref_loc (input_location,
					se->expr);
dnovillo's avatar
 
dnovillo committed
520 521 522
}


pault's avatar
pault committed
523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541
/* This function deals with component references to components of the
   parent type for derived type extensons.  */
static void
conv_parent_component_references (gfc_se * se, gfc_ref * ref)
{
  gfc_component *c;
  gfc_component *cmp;
  gfc_symbol *dt;
  gfc_ref parent;

  dt = ref->u.c.sym;
  c = ref->u.c.component;

  /* Build a gfc_ref to recursively call gfc_conv_component_ref.  */
  parent.type = REF_COMPONENT;
  parent.next = NULL;
  parent.u.c.sym = dt;
  parent.u.c.component = dt->components;

542 543 544
  if (dt->backend_decl == NULL)
    gfc_get_derived_type (dt);

pault's avatar
pault committed
545 546
  if (dt->attr.extension && dt->components)
    {
burnus's avatar
burnus committed
547 548 549 550
      if (dt->attr.is_class)
	cmp = dt->components;
      else
	cmp = dt->components->next;
pault's avatar
pault committed
551
      /* Return if the component is not in the parent type.  */
burnus's avatar
burnus committed
552
      for (; cmp; cmp = cmp->next)
pault's avatar
pault committed
553 554 555 556 557
	if (strcmp (c->name, cmp->name) == 0)
	  return;
	
      /* Otherwise build the reference and call self.  */
      gfc_conv_component_ref (se, &parent);
558
      parent.u.c.sym = dt->components->ts.u.derived;
pault's avatar
pault committed
559 560 561 562 563
      parent.u.c.component = c;
      conv_parent_component_references (se, &parent);
    }
}

dnovillo's avatar
 
dnovillo committed
564 565 566 567 568 569 570 571
/* Return the contents of a variable. Also handles reference/pointer
   variables (all Fortran pointer references are implicit).  */

static void
gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
  gfc_ref *ref;
  gfc_symbol *sym;
572
  tree parent_decl = NULL_TREE;
573 574 575 576
  int parent_flag;
  bool return_value;
  bool alternate_entry;
  bool entry_master;
dnovillo's avatar
 
dnovillo committed
577 578 579 580 581

  sym = expr->symtree->n.sym;
  if (se->ss != NULL)
    {
      /* Check that something hasn't gone horribly wrong.  */
pbrook's avatar
pbrook committed
582 583
      gcc_assert (se->ss != gfc_ss_terminator);
      gcc_assert (se->ss->expr == expr);
dnovillo's avatar
 
dnovillo committed
584 585 586

      /* A scalarized term.  We already know the descriptor.  */
      se->expr = se->ss->data.info.descriptor;
pbrook's avatar
pbrook committed
587
      se->string_length = se->ss->string_length;
rsandifo's avatar
rsandifo committed
588 589 590
      for (ref = se->ss->data.info.ref; ref; ref = ref->next)
	if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
	  break;
dnovillo's avatar
 
dnovillo committed
591 592 593
    }
  else
    {
594 595
      tree se_expr = NULL_TREE;

596
      se->expr = gfc_get_symbol_decl (sym);
dnovillo's avatar
 
dnovillo committed
597

598 599 600 601
      /* Deal with references to a parent results or entries by storing
	 the current_function_decl and moving to the parent_decl.  */
      return_value = sym->attr.function && sym->result == sym;
      alternate_entry = sym->attr.function && sym->attr.entry
602
			&& sym->result == sym;
603
      entry_master = sym->attr.result
604 605
		     && sym->ns->proc_name->attr.entry_master
		     && !gfc_return_by_reference (sym->ns->proc_name);
606 607
      if (current_function_decl)
	parent_decl = DECL_CONTEXT (current_function_decl);
608 609

      if ((se->expr == parent_decl && return_value)
610
	   || (sym->ns && sym->ns->proc_name
611
	       && parent_decl
612 613
	       && sym->ns->proc_name->backend_decl == parent_decl
	       && (alternate_entry || entry_master)))
614 615 616 617
	parent_flag = 1;
      else
	parent_flag = 0;

618 619
      /* Special case for assigning the return value of a function.
	 Self recursive functions must have an explicit return value.  */
620
      if (return_value && (se->expr == current_function_decl || parent_flag))
621
	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
622 623

      /* Similarly for alternate entry points.  */
624
      else if (alternate_entry 
625 626
	       && (sym->ns->proc_name->backend_decl == current_function_decl
		   || parent_flag))
627 628 629 630 631 632
	{
	  gfc_entry_list *el = NULL;

	  for (el = sym->ns->entries; el; el = el->next)
	    if (sym == el->sym)
	      {
633
		se_expr = gfc_get_fake_result_decl (sym, parent_flag);
634 635 636 637
		break;
	      }
	}

638
      else if (entry_master
639 640
	       && (sym->ns->proc_name->backend_decl == current_function_decl
		   || parent_flag))
641
	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
642 643 644 645

      if (se_expr)
	se->expr = se_expr;

dnovillo's avatar
 
dnovillo committed
646
      /* Procedure actual arguments.  */
647 648
      else if (sym->attr.flavor == FL_PROCEDURE
	       && se->expr != current_function_decl)
dnovillo's avatar
 
dnovillo committed
649
	{
650
	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
dnovillo's avatar
 
dnovillo committed
651
	    {
pbrook's avatar
pbrook committed
652
	      gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
653
	      se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
dnovillo's avatar
 
dnovillo committed
654 655
	    }
	  return;
kazu's avatar
kazu committed
656 657 658 659 660 661 662 663
	}


      /* Dereference the expression, where needed. Since characters
	 are entirely different from other types, they are treated 
	 separately.  */
      if (sym->ts.type == BT_CHARACTER)
	{
664
	  /* Dereference character pointer dummy arguments
665
	     or results.  */
kazu's avatar
kazu committed
666
	  if ((sym->attr.pointer || sym->attr.allocatable)
667 668 669
	      && (sym->attr.dummy
		  || sym->attr.function
		  || sym->attr.result))
670 671
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
672

kazu's avatar
kazu committed
673
	}
674
      else if (!sym->attr.value)
kazu's avatar
kazu committed
675
	{
kazu's avatar
kazu committed
676
          /* Dereference non-character scalar dummy arguments.  */
677
	  if (sym->attr.dummy && !sym->attr.dimension)
678 679
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
kazu's avatar
kazu committed
680

681
          /* Dereference scalar hidden result.  */
682
	  if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
kazu's avatar
kazu committed
683
	      && (sym->attr.function || sym->attr.result)
fxcoudert's avatar
fxcoudert committed
684 685
	      && !sym->attr.dimension && !sym->attr.pointer
	      && !sym->attr.always_explicit)
686 687
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
kazu's avatar
kazu committed
688

domob's avatar
domob committed
689
	  /* Dereference non-character pointer variables. 
kazu's avatar
kazu committed
690
	     These must be dummies, results, or scalars.  */
domob's avatar
domob committed
691 692
	  if ((sym->attr.pointer || sym->attr.allocatable
	       || gfc_is_associate_pointer (sym))
693 694 695 696
	      && (sym->attr.dummy
		  || sym->attr.function
		  || sym->attr.result
		  || !sym->attr.dimension))
697 698
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
kazu's avatar
kazu committed
699 700
	}

dnovillo's avatar
 
dnovillo committed
701 702 703 704 705 706
      ref = expr->ref;
    }

  /* For character variables, also get the length.  */
  if (sym->ts.type == BT_CHARACTER)
    {
eedelman's avatar
eedelman committed
707 708
      /* If the character length of an entry isn't set, get the length from
         the master function instead.  */
709 710
      if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
        se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
eedelman's avatar
eedelman committed
711
      else
712
        se->string_length = sym->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
713
      gcc_assert (se->string_length);
dnovillo's avatar
 
dnovillo committed
714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730
    }

  while (ref)
    {
      switch (ref->type)
	{
	case REF_ARRAY:
	  /* Return the descriptor if that's what we want and this is an array
	     section reference.  */
	  if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
	    return;
/* TODO: Pointers to single elements of array sections, eg elemental subs.  */
	  /* Return the descriptor for array pointers and allocations.  */
	  if (se->want_pointer
	      && ref->next == NULL && (se->descriptor_only))
	    return;

731
	  gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
dnovillo's avatar
 
dnovillo committed
732 733 734 735
	  /* Return a pointer to an element.  */
	  break;

	case REF_COMPONENT:
pault's avatar
pault committed
736 737 738
	  if (ref->u.c.sym->attr.extension)
	    conv_parent_component_references (se, ref);

dnovillo's avatar
 
dnovillo committed
739 740 741 742
	  gfc_conv_component_ref (se, ref);
	  break;

	case REF_SUBSTRING:
burnus's avatar
burnus committed
743 744
	  gfc_conv_substring (se, ref, expr->ts.kind,
			      expr->symtree->name, &expr->where);
dnovillo's avatar
 
dnovillo committed
745 746 747
	  break;

	default:
pbrook's avatar
pbrook committed
748
	  gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
749 750 751 752 753
	  break;
	}
      ref = ref->next;
    }
  /* Pointer assignment, allocation or pass by reference.  Arrays are handled
754
     separately.  */
dnovillo's avatar
 
dnovillo committed
755 756
  if (se->want_pointer)
    {
757
      if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
dnovillo's avatar
 
dnovillo committed
758 759
	gfc_conv_string_parameter (se);
      else 
760
	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
dnovillo's avatar
 
dnovillo committed
761 762 763 764 765 766 767 768 769 770 771 772
    }
}


/* Unary ops are easy... Or they would be if ! was a valid op.  */

static void
gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
{
  gfc_se operand;
  tree type;

pbrook's avatar
pbrook committed
773
  gcc_assert (expr->ts.type != BT_CHARACTER);
dnovillo's avatar
 
dnovillo committed
774 775
  /* Initialize the operand.  */
  gfc_init_se (&operand, se);
776
  gfc_conv_expr_val (&operand, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
777 778 779 780 781 782
  gfc_add_block_to_block (&se->pre, &operand.pre);

  type = gfc_typenode_for_spec (&expr->ts);

  /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
     We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
783
     All other unary operators have an equivalent GIMPLE unary operator.  */
dnovillo's avatar
 
dnovillo committed
784
  if (code == TRUTH_NOT_EXPR)
785 786
    se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
				build_int_cst (type, 0));
dnovillo's avatar
 
dnovillo committed
787
  else
788
    se->expr = fold_build1_loc (input_location, code, type, operand.expr);
dnovillo's avatar
 
dnovillo committed
789 790 791

}

792
/* Expand power operator to optimal multiplications when a value is raised
793
   to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
794 795 796 797 798 799 800 801 802 803
   Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
   Programming", 3rd Edition, 1998.  */

/* This code is mostly duplicated from expand_powi in the backend.
   We establish the "optimal power tree" lookup table with the defined size.
   The items in the table are the exponents used to calculate the index
   exponents. Any integer n less than the value can get an "addition chain",
   with the first node being one.  */
#define POWI_TABLE_SIZE 256

804
/* The table is from builtins.c.  */
805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840
static const unsigned char powi_table[POWI_TABLE_SIZE] =
  {
      0,   1,   1,   2,   2,   3,   3,   4,  /*   0 -   7 */
      4,   6,   5,   6,   6,  10,   7,   9,  /*   8 -  15 */
      8,  16,   9,  16,  10,  12,  11,  13,  /*  16 -  23 */
     12,  17,  13,  18,  14,  24,  15,  26,  /*  24 -  31 */
     16,  17,  17,  19,  18,  33,  19,  26,  /*  32 -  39 */
     20,  25,  21,  40,  22,  27,  23,  44,  /*  40 -  47 */
     24,  32,  25,  34,  26,  29,  27,  44,  /*  48 -  55 */
     28,  31,  29,  34,  30,  60,  31,  36,  /*  56 -  63 */
     32,  64,  33,  34,  34,  46,  35,  37,  /*  64 -  71 */
     36,  65,  37,  50,  38,  48,  39,  69,  /*  72 -  79 */
     40,  49,  41,  43,  42,  51,  43,  58,  /*  80 -  87 */
     44,  64,  45,  47,  46,  59,  47,  76,  /*  88 -  95 */
     48,  65,  49,  66,  50,  67,  51,  66,  /*  96 - 103 */
     52,  70,  53,  74,  54, 104,  55,  74,  /* 104 - 111 */
     56,  64,  57,  69,  58,  78,  59,  68,  /* 112 - 119 */
     60,  61,  61,  80,  62,  75,  63,  68,  /* 120 - 127 */
     64,  65,  65, 128,  66, 129,  67,  90,  /* 128 - 135 */
     68,  73,  69, 131,  70,  94,  71,  88,  /* 136 - 143 */
     72, 128,  73,  98,  74, 132,  75, 121,  /* 144 - 151 */
     76, 102,  77, 124,  78, 132,  79, 106,  /* 152 - 159 */
     80,  97,  81, 160,  82,  99,  83, 134,  /* 160 - 167 */
     84,  86,  85,  95,  86, 160,  87, 100,  /* 168 - 175 */
     88, 113,  89,  98,  90, 107,  91, 122,  /* 176 - 183 */
     92, 111,  93, 102,  94, 126,  95, 150,  /* 184 - 191 */
     96, 128,  97, 130,  98, 133,  99, 195,  /* 192 - 199 */
    100, 128, 101, 123, 102, 164, 103, 138,  /* 200 - 207 */
    104, 145, 105, 146, 106, 109, 107, 149,  /* 208 - 215 */
    108, 200, 109, 146, 110, 170, 111, 157,  /* 216 - 223 */
    112, 128, 113, 130, 114, 182, 115, 132,  /* 224 - 231 */
    116, 200, 117, 132, 118, 158, 119, 206,  /* 232 - 239 */
    120, 240, 121, 162, 122, 147, 123, 152,  /* 240 - 247 */
    124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
  };

841 842
/* If n is larger than lookup table's max index, we use the "window 
   method".  */
843 844
#define POWI_WINDOW_SIZE 3

845 846
/* Recursive function to expand the power operator. The temporary 
   values are put in tmpvar. The function returns tmpvar[1] ** n.  */
847
static tree
fxcoudert's avatar
fxcoudert committed
848
gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
dnovillo's avatar
 
dnovillo committed
849
{
850 851
  tree op0;
  tree op1;
dnovillo's avatar
 
dnovillo committed
852
  tree tmp;
853
  int digit;
dnovillo's avatar
 
dnovillo committed
854

855
  if (n < POWI_TABLE_SIZE)
dnovillo's avatar
 
dnovillo committed
856
    {
857 858
      if (tmpvar[n])
        return tmpvar[n];
dnovillo's avatar
 
dnovillo committed
859

860 861 862 863 864 865 866 867
      op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
      op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
    }
  else if (n & 1)
    {
      digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
      op0 = gfc_conv_powi (se, n - digit, tmpvar);
      op1 = gfc_conv_powi (se, digit, tmpvar);
dnovillo's avatar
 
dnovillo committed
868 869 870
    }
  else
    {
871 872
      op0 = gfc_conv_powi (se, n >> 1, tmpvar);
      op1 = op0;
dnovillo's avatar
 
dnovillo committed
873 874
    }

875
  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
876
  tmp = gfc_evaluate_now (tmp, &se->pre);
dnovillo's avatar
 
dnovillo committed
877

878 879
  if (n < POWI_TABLE_SIZE)
    tmpvar[n] = tmp;
dnovillo's avatar
 
dnovillo committed
880

881 882
  return tmp;
}
dnovillo's avatar
 
dnovillo committed
883

884 885 886 887

/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
   return 1. Else return 0 and a call to runtime library functions
   will have to be built.  */
888 889 890 891 892 893 894
static int
gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
{
  tree cond;
  tree tmp;
  tree type;
  tree vartmp[POWI_TABLE_SIZE];
fxcoudert's avatar
fxcoudert committed
895 896
  HOST_WIDE_INT m;
  unsigned HOST_WIDE_INT n;
897
  int sgn;
dnovillo's avatar
 
dnovillo committed
898

fxcoudert's avatar
fxcoudert committed
899 900 901 902 903 904 905 906 907 908
  /* If exponent is too large, we won't expand it anyway, so don't bother
     with large integer values.  */
  if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
    return 0;

  m = double_int_to_shwi (TREE_INT_CST (rhs));
  /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
     of the asymmetric range of the integer type.  */
  n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
  
909 910
  type = TREE_TYPE (lhs);
  sgn = tree_int_cst_sgn (rhs);
dnovillo's avatar
 
dnovillo committed
911

fxcoudert's avatar
fxcoudert committed
912 913
  if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
       || optimize_size) && (m > 2 || m < -1))
914
    return 0;
dnovillo's avatar
 
dnovillo committed
915

916 917 918 919 920 921
  /* rhs == 0  */
  if (sgn == 0)
    {
      se->expr = gfc_build_const (type, integer_one_node);
      return 1;
    }
fxcoudert's avatar
fxcoudert committed
922

923 924 925
  /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1.  */
  if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
    {
926 927 928 929
      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
			     lhs, build_int_cst (TREE_TYPE (lhs), -1));
      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
			      lhs, build_int_cst (TREE_TYPE (lhs), 1));
930

931
      /* If rhs is even,
932
	 result = (lhs == 1 || lhs == -1) ? 1 : 0.  */
933 934
      if ((n & 1) == 0)
        {
935 936 937 938 939
	  tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
				 boolean_type_node, tmp, cond);
	  se->expr = fold_build3_loc (input_location, COND_EXPR, type,
				      tmp, build_int_cst (type, 1),
				      build_int_cst (type, 0));
940 941
	  return 1;
	}
942
      /* If rhs is odd,
943
	 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0.  */
944 945 946 947 948
      tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
			     build_int_cst (type, -1),
			     build_int_cst (type, 0));
      se->expr = fold_build3_loc (input_location, COND_EXPR, type,
				  cond, build_int_cst (type, 1), tmp);
949 950
      return 1;
    }
dnovillo's avatar
 
dnovillo committed
951

952 953 954 955 956
  memset (vartmp, 0, sizeof (vartmp));
  vartmp[1] = lhs;
  if (sgn == -1)
    {
      tmp = gfc_build_const (type, integer_one_node);
957 958
      vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
				   vartmp[1]);
959
    }
960 961 962

  se->expr = gfc_conv_powi (se, n, vartmp);

963
  return 1;
dnovillo's avatar
 
dnovillo committed
964 965 966
}


967
/* Power op (**).  Constant integer exponent has special handling.  */
dnovillo's avatar
 
dnovillo committed
968 969 970 971

static void
gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
{
972
  tree gfc_int4_type_node;
dnovillo's avatar
 
dnovillo committed
973
  int kind;
974
  int ikind;
dnovillo's avatar
 
dnovillo committed
975 976
  gfc_se lse;
  gfc_se rse;
977
  tree fndecl = NULL;
dnovillo's avatar
 
dnovillo committed
978 979

  gfc_init_se (&lse, se);
980
  gfc_conv_expr_val (&lse, expr->value.op.op1);
981
  lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
dnovillo's avatar
 
dnovillo committed
982 983 984
  gfc_add_block_to_block (&se->pre, &lse.pre);

  gfc_init_se (&rse, se);
985
  gfc_conv_expr_val (&rse, expr->value.op.op2);
dnovillo's avatar
 
dnovillo committed
986 987
  gfc_add_block_to_block (&se->pre, &rse.pre);

988
  if (expr->value.op.op2->ts.type == BT_INTEGER
jb's avatar
jb committed
989
      && expr->value.op.op2->expr_type == EXPR_CONSTANT)
990
    if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
jb's avatar
jb committed
991
      return;
dnovillo's avatar
 
dnovillo committed
992

993 994
  gfc_int4_type_node = gfc_get_int_type (4);

995 996
  kind = expr->value.op.op1->ts.kind;
  switch (expr->value.op.op2->ts.type)
dnovillo's avatar
 
dnovillo committed
997 998
    {
    case BT_INTEGER:
999
      ikind = expr->value.op.op2->ts.kind;
1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014
      switch (ikind)
	{
	case 1:
	case 2:
	  rse.expr = convert (gfc_int4_type_node, rse.expr);
	  /* Fall through.  */

	case 4:
	  ikind = 0;
	  break;
	  
	case 8:
	  ikind = 1;
	  break;

fxcoudert's avatar
fxcoudert committed
1015 1016 1017 1018
	case 16:
	  ikind = 2;
	  break;

1019
	default:
pbrook's avatar
pbrook committed
1020
	  gcc_unreachable ();
1021 1022 1023 1024 1025
	}
      switch (kind)
	{
	case 1:
	case 2:
1026
	  if (expr->value.op.op1->ts.type == BT_INTEGER)
1027 1028
	    lse.expr = convert (gfc_int4_type_node, lse.expr);
	  else
pbrook's avatar
pbrook committed
1029
	    gcc_unreachable ();
1030 1031 1032 1033 1034 1035 1036 1037 1038 1039
	  /* Fall through.  */

	case 4:
	  kind = 0;
	  break;
	  
	case 8:
	  kind = 1;
	  break;

fxcoudert's avatar
fxcoudert committed
1040 1041 1042 1043 1044 1045 1046 1047
	case 10:
	  kind = 2;
	  break;

	case 16:
	  kind = 3;
	  break;

1048
	default:
pbrook's avatar
pbrook committed
1049
	  gcc_unreachable ();
1050 1051
	}
      
1052
      switch (expr->value.op.op1->ts.type)
1053 1054
	{
	case BT_INTEGER:
fxcoudert's avatar
fxcoudert committed
1055 1056
	  if (kind == 3) /* Case 16 was not handled properly above.  */
	    kind = 2;
1057 1058 1059 1060
	  fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
	  break;

	case BT_REAL:
jb's avatar
jb committed
1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077
	  /* Use builtins for real ** int4.  */
	  if (ikind == 0)
	    {
	      switch (kind)
		{
		case 0:
		  fndecl = built_in_decls[BUILT_IN_POWIF];
		  break;
		
		case 1:
		  fndecl = built_in_decls[BUILT_IN_POWI];
		  break;

		case 2:
		  fndecl = built_in_decls[BUILT_IN_POWIL];
		  break;

1078 1079 1080 1081 1082 1083 1084
		case 3:
		  /* Use the __builtin_powil() only if real(kind=16) is 
		     actually the C long double type.  */
		  if (!gfc_real16_is_float128)
		    fndecl = built_in_decls[BUILT_IN_POWIL];
		  break;

jb's avatar
jb committed
1085 1086 1087 1088
		default:
		  gcc_unreachable ();
		}
	    }
1089 1090 1091 1092

	  /* If we don't have a good builtin for this, go for the 
	     library function.  */
	  if (!fndecl)
jb's avatar
jb committed
1093
	    fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1094 1095 1096 1097 1098 1099 1100
	  break;

	case BT_COMPLEX:
	  fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
	  break;

	default:
pbrook's avatar
pbrook committed
1101
	  gcc_unreachable ();
1102 1103
 	}
      break;
dnovillo's avatar
 
dnovillo committed
1104 1105

    case BT_REAL:
1106
      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
dnovillo's avatar
 
dnovillo committed
1107 1108 1109
      break;

    case BT_COMPLEX:
1110
      fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
dnovillo's avatar
 
dnovillo committed
1111 1112 1113
      break;

    default:
pbrook's avatar
pbrook committed
1114
      gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
1115 1116 1117
      break;
    }

1118 1119
  se->expr = build_call_expr_loc (input_location,
			      fndecl, 2, lse.expr, rse.expr);
dnovillo's avatar
 
dnovillo committed
1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133
}


/* Generate code to allocate a string temporary.  */

tree
gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
{
  tree var;
  tree tmp;

  if (gfc_can_put_var_on_stack (len))
    {
      /* Create a temporary variable to hold the result.  */
1134 1135 1136
      tmp = fold_build2_loc (input_location, MINUS_EXPR,
			     gfc_charlen_type_node, len,
			     build_int_cst (gfc_charlen_type_node, 1));
1137
      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
fxcoudert's avatar
fxcoudert committed
1138 1139 1140 1141 1142 1143

      if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
	tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
      else
	tmp = build_array_type (TREE_TYPE (type), tmp);

dnovillo's avatar
 
dnovillo committed
1144 1145 1146 1147 1148 1149 1150
      var = gfc_create_var (tmp, "str");
      var = gfc_build_addr_expr (type, var);
    }
  else
    {
      /* Allocate a temporary to hold the result.  */
      var = gfc_create_var (type, "pstr");
1151
      tmp = gfc_call_malloc (&se->pre, type,
1152 1153 1154 1155
			     fold_build2_loc (input_location, MULT_EXPR,
					      TREE_TYPE (len), len,
					      fold_convert (TREE_TYPE (len),
							    TYPE_SIZE (type))));
1156
      gfc_add_modify (&se->pre, var, tmp);
dnovillo's avatar
 
dnovillo committed
1157 1158

      /* Free the temporary afterwards.  */
1159
      tmp = gfc_call_free (convert (pvoid_type_node, var));
dnovillo's avatar
 
dnovillo committed
1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172
      gfc_add_expr_to_block (&se->post, tmp);
    }

  return var;
}


/* Handle a string concatenation operation.  A temporary will be allocated to
   hold the result.  */

static void
gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
{
1173 1174
  gfc_se lse, rse;
  tree len, type, var, tmp, fndecl;
dnovillo's avatar
 
dnovillo committed
1175

1176
  gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1177
	      && expr->value.op.op2->ts.type == BT_CHARACTER);
1178
  gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
dnovillo's avatar
 
dnovillo committed
1179 1180

  gfc_init_se (&lse, se);
1181
  gfc_conv_expr (&lse, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
1182 1183
  gfc_conv_string_parameter (&lse);
  gfc_init_se (&rse, se);
1184
  gfc_conv_expr (&rse, expr->value.op.op2);
dnovillo's avatar
 
dnovillo committed
1185 1186 1187 1188 1189
  gfc_conv_string_parameter (&rse);

  gfc_add_block_to_block (&se->pre, &lse.pre);
  gfc_add_block_to_block (&se->pre, &rse.pre);

1190
  type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
dnovillo's avatar
 
dnovillo committed
1191 1192 1193
  len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
  if (len == NULL_TREE)
    {
1194 1195 1196
      len = fold_build2_loc (input_location, PLUS_EXPR,
			     TREE_TYPE (lse.string_length),
			     lse.string_length, rse.string_length);
dnovillo's avatar
 
dnovillo committed
1197 1198 1199 1200 1201 1202 1203
    }

  type = build_pointer_type (type);

  var = gfc_conv_string_tmp (se, type, len);

  /* Do the actual concatenation.  */
1204 1205 1206 1207 1208 1209 1210
  if (expr->ts.kind == 1)
    fndecl = gfor_fndecl_concat_string;
  else if (expr->ts.kind == 4)
    fndecl = gfor_fndecl_concat_string_char4;
  else
    gcc_unreachable ();

1211 1212
  tmp = build_call_expr_loc (input_location,
			 fndecl, 6, len, var, lse.string_length, lse.expr,
1213
			 rse.string_length, rse.expr);
dnovillo's avatar
 
dnovillo committed
1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226
  gfc_add_expr_to_block (&se->pre, tmp);

  /* Add the cleanup for the operands.  */
  gfc_add_block_to_block (&se->pre, &rse.post);
  gfc_add_block_to_block (&se->pre, &lse.post);

  se->expr = var;
  se->string_length = len;
}

/* Translates an op expression. Common (binary) cases are handled by this
   function, others are passed on. Recursion is used in either case.
   We use the fact that (op1.ts == op2.ts) (except for the power
1227
   operator **).
dnovillo's avatar
 
dnovillo committed
1228
   Operators need no special handling for scalarized expressions as long as
1229
   they call gfc_conv_simple_val to get their operands.
dnovillo's avatar
 
dnovillo committed
1230 1231 1232 1233 1234 1235 1236 1237
   Character strings get special handling.  */

static void
gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
{
  enum tree_code code;
  gfc_se lse;
  gfc_se rse;
fxcoudert's avatar
fxcoudert committed
1238
  tree tmp, type;
dnovillo's avatar
 
dnovillo committed
1239 1240 1241 1242 1243
  int lop;
  int checkstring;

  checkstring = 0;
  lop = 0;
1244
  switch (expr->value.op.op)
dnovillo's avatar
 
dnovillo committed
1245
    {
tobi's avatar
tobi committed
1246
    case INTRINSIC_PARENTHESES:
1247 1248 1249
      if ((expr->ts.type == BT_REAL
	   || expr->ts.type == BT_COMPLEX)
	  && gfc_option.flag_protect_parens)
1250 1251 1252 1253 1254 1255 1256 1257
	{
	  gfc_conv_unary_op (PAREN_EXPR, se, expr);
	  gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
	  return;
	}

      /* Fallthrough.  */
    case INTRINSIC_UPLUS:
1258
      gfc_conv_expr (se, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309
      return;

    case INTRINSIC_UMINUS:
      gfc_conv_unary_op (NEGATE_EXPR, se, expr);
      return;

    case INTRINSIC_NOT:
      gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
      return;

    case INTRINSIC_PLUS:
      code = PLUS_EXPR;
      break;

    case INTRINSIC_MINUS:
      code = MINUS_EXPR;
      break;

    case INTRINSIC_TIMES:
      code = MULT_EXPR;
      break;

    case INTRINSIC_DIVIDE:
      /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
         an integer, we must round towards zero, so we use a
         TRUNC_DIV_EXPR.  */
      if (expr->ts.type == BT_INTEGER)
	code = TRUNC_DIV_EXPR;
      else
	code = RDIV_EXPR;
      break;

    case INTRINSIC_POWER:
      gfc_conv_power_op (se, expr);
      return;

    case INTRINSIC_CONCAT:
      gfc_conv_concat_op (se, expr);
      return;

    case INTRINSIC_AND:
      code = TRUTH_ANDIF_EXPR;
      lop = 1;
      break;

    case INTRINSIC_OR:
      code = TRUTH_ORIF_EXPR;
      lop = 1;
      break;

      /* EQV and NEQV only work on logicals, but since we represent them
dnovillo's avatar
 
dnovillo committed
1310
         as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
dnovillo's avatar
 
dnovillo committed
1311
    case INTRINSIC_EQ:
dfranke's avatar
dfranke committed
1312
    case INTRINSIC_EQ_OS:
dnovillo's avatar
 
dnovillo committed
1313 1314 1315 1316 1317 1318 1319
    case INTRINSIC_EQV:
      code = EQ_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_NE:
dfranke's avatar
dfranke committed
1320
    case INTRINSIC_NE_OS:
dnovillo's avatar
 
dnovillo committed
1321 1322 1323 1324 1325 1326 1327
    case INTRINSIC_NEQV:
      code = NE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_GT:
dfranke's avatar
dfranke committed
1328
    case INTRINSIC_GT_OS:
dnovillo's avatar
 
dnovillo committed
1329 1330 1331 1332 1333 1334
      code = GT_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_GE:
dfranke's avatar
dfranke committed
1335
    case INTRINSIC_GE_OS:
dnovillo's avatar
 
dnovillo committed
1336 1337 1338 1339 1340 1341
      code = GE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_LT:
dfranke's avatar
dfranke committed
1342
    case INTRINSIC_LT_OS:
dnovillo's avatar
 
dnovillo committed
1343 1344 1345 1346 1347 1348
      code = LT_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_LE:
dfranke's avatar
dfranke committed
1349
    case INTRINSIC_LE_OS:
dnovillo's avatar
 
dnovillo committed
1350 1351 1352 1353 1354 1355 1356 1357
      code = LE_EXPR;
      checkstring = 1;
      lop = 1;
      break;

    case INTRINSIC_USER:
    case INTRINSIC_ASSIGN:
      /* These should be converted into function calls by the frontend.  */
pbrook's avatar
pbrook committed
1358
      gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
1359 1360 1361 1362 1363 1364

    default:
      fatal_error ("Unknown intrinsic op");
      return;
    }

1365
  /* The only exception to this is **, which is handled separately anyway.  */
1366
  gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
dnovillo's avatar
 
dnovillo committed
1367

1368
  if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
dnovillo's avatar
 
dnovillo committed
1369 1370 1371 1372
    checkstring = 0;

  /* lhs */
  gfc_init_se (&lse, se);
1373
  gfc_conv_expr (&lse, expr->value.op.op1);
dnovillo's avatar
 
dnovillo committed
1374 1375 1376 1377
  gfc_add_block_to_block (&se->pre, &lse.pre);

  /* rhs */
  gfc_init_se (&rse, se);
1378
  gfc_conv_expr (&rse, expr->value.op.op2);
dnovillo's avatar
 
dnovillo committed
1379 1380 1381 1382 1383 1384 1385
  gfc_add_block_to_block (&se->pre, &rse.pre);

  if (checkstring)
    {
      gfc_conv_string_parameter (&lse);
      gfc_conv_string_parameter (&rse);

fengwang's avatar
fengwang committed
1386
      lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1387
					   rse.string_length, rse.expr,
1388 1389
					   expr->value.op.op1->ts.kind,
					   code);
1390
      rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
fengwang's avatar
fengwang committed
1391
      gfc_add_block_to_block (&lse.post, &rse.post);
dnovillo's avatar
 
dnovillo committed
1392 1393 1394 1395 1396 1397 1398
    }

  type = gfc_typenode_for_spec (&expr->ts);

  if (lop)
    {
      /* The result of logical ops is always boolean_type_node.  */
1399 1400
      tmp = fold_build2_loc (input_location, code, boolean_type_node,
			     lse.expr, rse.expr);
dnovillo's avatar
 
dnovillo committed
1401 1402 1403
      se->expr = convert (type, tmp);
    }
  else
1404
    se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
dnovillo's avatar
 
dnovillo committed
1405 1406 1407 1408 1409 1410

  /* Add the post blocks.  */
  gfc_add_block_to_block (&se->post, &rse.post);
  gfc_add_block_to_block (&se->post, &lse.post);
}

fengwang's avatar
fengwang committed
1411 1412
/* If a string's length is one, we convert it to a single character.  */

1413 1414
tree
gfc_string_to_single_character (tree len, tree str, int kind)
fengwang's avatar
fengwang committed
1415 1416 1417
{
  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));

1418 1419 1420 1421
  if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
    return NULL_TREE;

  if (TREE_INT_CST_LOW (len) == 1)
fengwang's avatar
fengwang committed
1422
    {
1423
      str = fold_convert (gfc_get_pchar_type (kind), str);
1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442
      return build_fold_indirect_ref_loc (input_location, str);
    }

  if (kind == 1
      && TREE_CODE (str) == ADDR_EXPR
      && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
      && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
      && array_ref_low_bound (TREE_OPERAND (str, 0))
	 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
      && TREE_INT_CST_LOW (len) > 1
      && TREE_INT_CST_LOW (len)
	 == (unsigned HOST_WIDE_INT)
	    TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
    {
      tree ret = fold_convert (gfc_get_pchar_type (kind), str);
      ret = build_fold_indirect_ref_loc (input_location, ret);
      if (TREE_CODE (ret) == INTEGER_CST)
	{
	  tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
1443
	  int i, length = TREE_STRING_LENGTH (string_cst);
1444 1445
	  const char *ptr = TREE_STRING_POINTER (string_cst);

1446
	  for (i = 1; i < length; i++)
1447 1448 1449 1450 1451
	    if (ptr[i] != ' ')
	      return NULL_TREE;

	  return ret;
	}
fengwang's avatar
fengwang committed
1452 1453 1454 1455 1456
    }

  return NULL_TREE;
}

1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481

void
gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
{

  if (sym->backend_decl)
    {
      /* This becomes the nominal_type in
	 function.c:assign_parm_find_data_types.  */
      TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
      /* This becomes the passed_type in
	 function.c:assign_parm_find_data_types.  C promotes char to
	 integer for argument passing.  */
      DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;

      DECL_BY_REFERENCE (sym->backend_decl) = 0;
    }

  if (expr != NULL)
    {
      /* If we have a constant character expression, make it into an
	 integer.  */
      if ((*expr)->expr_type == EXPR_CONSTANT)
        {
	  gfc_typespec ts;
1482
          gfc_clear_ts (&ts);
1483

1484 1485
	  *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
				    (int)(*expr)->value.character.string[0]);
1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498
	  if ((*expr)->ts.kind != gfc_c_int_kind)
	    {
  	      /* The expr needs to be compatible with a C int.  If the 
		 conversion fails, then the 2 causes an ICE.  */
	      ts.type = BT_INTEGER;
	      ts.kind = gfc_c_int_kind;
	      gfc_convert_type (*expr, &ts, 2);
	    }
	}
      else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
        {
	  if ((*expr)->ref == NULL)
	    {
1499
	      se->expr = gfc_string_to_single_character
1500
		(build_int_cst (integer_type_node, 1),
1501
		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1502
				      gfc_get_symbol_decl
1503 1504
				      ((*expr)->symtree->n.sym)),
		 (*expr)->ts.kind);
1505 1506 1507 1508
	    }
	  else
	    {
	      gfc_conv_variable (se, *expr);
1509
	      se->expr = gfc_string_to_single_character
1510
		(build_int_cst (integer_type_node, 1),
1511 1512 1513
		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
				      se->expr),
		 (*expr)->ts.kind);
1514 1515 1516 1517 1518
	    }
	}
    }
}

1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552
/* Helper function for gfc_build_compare_string.  Return LEN_TRIM value
   if STR is a string literal, otherwise return -1.  */

static int
gfc_optimize_len_trim (tree len, tree str, int kind)
{
  if (kind == 1
      && TREE_CODE (str) == ADDR_EXPR
      && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
      && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
      && array_ref_low_bound (TREE_OPERAND (str, 0))
	 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
      && TREE_INT_CST_LOW (len) >= 1
      && TREE_INT_CST_LOW (len)
	 == (unsigned HOST_WIDE_INT)
	    TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
    {
      tree folded = fold_convert (gfc_get_pchar_type (kind), str);
      folded = build_fold_indirect_ref_loc (input_location, folded);
      if (TREE_CODE (folded) == INTEGER_CST)
	{
	  tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
	  int length = TREE_STRING_LENGTH (string_cst);
	  const char *ptr = TREE_STRING_POINTER (string_cst);

	  for (; length > 0; length--)
	    if (ptr[length - 1] != ' ')
	      break;

	  return length;
	}
    }
  return -1;
}
1553

fengwang's avatar
fengwang committed
1554 1555 1556 1557
/* Compare two strings. If they are all single characters, the result is the
   subtraction of them. Otherwise, we build a library call.  */

tree
1558 1559
gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
			  enum tree_code code)
fengwang's avatar
fengwang committed
1560 1561 1562
{
  tree sc1;
  tree sc2;
1563
  tree fndecl;
fengwang's avatar
fengwang committed
1564 1565 1566 1567

  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));

1568 1569
  sc1 = gfc_string_to_single_character (len1, str1, kind);
  sc2 = gfc_string_to_single_character (len2, str2, kind);
fengwang's avatar
fengwang committed
1570 1571 1572

  if (sc1 != NULL_TREE && sc2 != NULL_TREE)
    {
1573
      /* Deal with single character specially.  */
fxcoudert's avatar
fxcoudert committed
1574 1575
      sc1 = fold_convert (integer_type_node, sc1);
      sc2 = fold_convert (integer_type_node, sc2);
1576 1577
      return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
			      sc1, sc2);
fengwang's avatar
fengwang committed
1578
    }
1579

1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592
  if ((code == EQ_EXPR || code == NE_EXPR)
      && optimize
      && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
    {
      /* If one string is a string literal with LEN_TRIM longer
	 than the length of the second string, the strings
	 compare unequal.  */
      int len = gfc_optimize_len_trim (len1, str1, kind);
      if (len > 0 && compare_tree_int (len2, len) < 0)
	return integer_one_node;
      len = gfc_optimize_len_trim (len2, str2, kind);
      if (len > 0 && compare_tree_int (len1, len) < 0)
	return integer_one_node;
1593 1594
    }

1595 1596 1597 1598 1599 1600 1601 1602 1603 1604
  /* Build a call for the comparison.  */
  if (kind == 1)
    fndecl = gfor_fndecl_compare_string;
  else if (kind == 4)
    fndecl = gfor_fndecl_compare_string_char4;
  else
    gcc_unreachable ();

  return build_call_expr_loc (input_location, fndecl, 4,
			      len1, str1, len2, str2);
fengwang's avatar
fengwang committed
1605
}
1606

1607 1608 1609 1610 1611 1612 1613 1614

/* Return the backend_decl for a procedure pointer component.  */

static tree
get_proc_ptr_comp (gfc_expr *e)
{
  gfc_se comp_se;
  gfc_expr *e2;
1615 1616
  expr_t old_type;

1617 1618
  gfc_init_se (&comp_se, NULL);
  e2 = gfc_copy_expr (e);
1619 1620 1621 1622
  /* We have to restore the expr type later so that gfc_free_expr frees
     the exact same thing that was allocated.
     TODO: This is ugly.  */
  old_type = e2->expr_type;
1623 1624
  e2->expr_type = EXPR_VARIABLE;
  gfc_conv_expr (&comp_se, e2);
1625
  e2->expr_type = old_type;
1626
  gfc_free_expr (e2);
1627 1628 1629 1630
  return build_fold_addr_expr_loc (input_location, comp_se.expr);
}


dnovillo's avatar
 
dnovillo committed
1631
static void
1632
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
dnovillo's avatar
 
dnovillo committed
1633 1634 1635
{
  tree tmp;

1636
  if (gfc_is_proc_ptr_comp (expr, NULL))
1637
    tmp = get_proc_ptr_comp (expr);
1638
  else if (sym->attr.dummy)
dnovillo's avatar
 
dnovillo committed
1639 1640
    {
      tmp = gfc_get_symbol_decl (sym);
1641
      if (sym->attr.proc_pointer)
1642 1643
        tmp = build_fold_indirect_ref_loc (input_location,
				       tmp);
pbrook's avatar
pbrook committed
1644
      gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
dnovillo's avatar
 
dnovillo committed
1645 1646 1647 1648 1649 1650 1651 1652
	      && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
    }
  else
    {
      if (!sym->backend_decl)
	sym->backend_decl = gfc_get_extern_function_decl (sym);

      tmp = sym->backend_decl;
1653

1654
      if (sym->attr.cray_pointee)
1655 1656 1657 1658 1659 1660 1661 1662 1663
	{
	  /* TODO - make the cray pointee a pointer to a procedure,
	     assign the pointer to it and use it for the call.  This
	     will do for now!  */
	  tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
			 gfc_get_symbol_decl (sym->cp_pointer));
	  tmp = gfc_evaluate_now (tmp, &se->pre);
	}

rsandifo's avatar
rsandifo committed
1664 1665 1666
      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
	{
	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1667
	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
rsandifo's avatar
rsandifo committed
1668 1669 1670 1671 1672 1673 1674 1675
	}
    }
  se->expr = tmp;
}


/* Initialize MAPPING.  */

rsandifo's avatar
rsandifo committed
1676
void
rsandifo's avatar
rsandifo committed
1677 1678 1679 1680 1681 1682 1683 1684 1685
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
{
  mapping->syms = NULL;
  mapping->charlens = NULL;
}


/* Free all memory held by MAPPING (but not MAPPING itself).  */

rsandifo's avatar
rsandifo committed
1686
void
rsandifo's avatar
rsandifo committed
1687 1688 1689 1690 1691 1692 1693 1694 1695 1696
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
{
  gfc_interface_sym_mapping *sym;
  gfc_interface_sym_mapping *nextsym;
  gfc_charlen *cl;
  gfc_charlen *nextcl;

  for (sym = mapping->syms; sym; sym = nextsym)
    {
      nextsym = sym->next;
1697
      sym->new_sym->n.sym->formal = NULL;
ghazi's avatar
ghazi committed
1698
      gfc_free_symbol (sym->new_sym->n.sym);
1699
      gfc_free_expr (sym->expr);
ghazi's avatar
ghazi committed
1700
      gfc_free (sym->new_sym);
rsandifo's avatar
rsandifo committed
1701 1702 1703 1704 1705 1706 1707
      gfc_free (sym);
    }
  for (cl = mapping->charlens; cl; cl = nextcl)
    {
      nextcl = cl->next;
      gfc_free_expr (cl->length);
      gfc_free (cl);
dnovillo's avatar
 
dnovillo committed
1708 1709 1710 1711
    }
}


rsandifo's avatar
rsandifo committed
1712 1713 1714 1715 1716 1717 1718
/* Return a copy of gfc_charlen CL.  Add the returned structure to
   MAPPING so that it will be freed by gfc_free_interface_mapping.  */

static gfc_charlen *
gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
				   gfc_charlen * cl)
{
ghazi's avatar
ghazi committed
1719
  gfc_charlen *new_charlen;
rsandifo's avatar
rsandifo committed
1720

ghazi's avatar
ghazi committed
1721 1722 1723
  new_charlen = gfc_get_charlen ();
  new_charlen->next = mapping->charlens;
  new_charlen->length = gfc_copy_expr (cl->length);
rsandifo's avatar
rsandifo committed
1724

ghazi's avatar
ghazi committed
1725 1726
  mapping->charlens = new_charlen;
  return new_charlen;
rsandifo's avatar
rsandifo committed
1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737
}


/* A subroutine of gfc_add_interface_mapping.  Return a descriptorless
   array variable that can be used as the actual argument for dummy
   argument SYM.  Add any initialization code to BLOCK.  PACKED is as
   for gfc_get_nodesc_array_type and DATA points to the first element
   in the passed array.  */

static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
tobi's avatar
tobi committed
1738
				 gfc_packed packed, tree data)
rsandifo's avatar
rsandifo committed
1739 1740 1741 1742 1743
{
  tree type;
  tree var;

  type = gfc_typenode_for_spec (&sym->ts);
1744 1745 1746
  type = gfc_get_nodesc_array_type (type, sym->as, packed,
				    !sym->attr.target && !sym->attr.pointer
				    && !sym->attr.proc_pointer);
rsandifo's avatar
rsandifo committed
1747

1748
  var = gfc_create_var (type, "ifm");
1749
  gfc_add_modify (block, var, fold_convert (type, data));
rsandifo's avatar
rsandifo committed
1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769

  return var;
}


/* A subroutine of gfc_add_interface_mapping.  Set the stride, upper bounds
   and offset of descriptorless array type TYPE given that it has the same
   size as DESC.  Add any set-up code to BLOCK.  */

static void
gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
{
  int n;
  tree dim;
  tree offset;
  tree tmp;

  offset = gfc_index_zero_node;
  for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
    {
1770
      dim = gfc_rank_cst[n];
rsandifo's avatar
rsandifo committed
1771
      GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1772 1773 1774
      if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
	{
	  GFC_TYPE_ARRAY_LBOUND (type, n)
1775
		= gfc_conv_descriptor_lbound_get (desc, dim);
1776
	  GFC_TYPE_ARRAY_UBOUND (type, n)
1777
		= gfc_conv_descriptor_ubound_get (desc, dim);
1778 1779
	}
      else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
rsandifo's avatar
rsandifo committed
1780
	{
1781 1782 1783 1784 1785 1786 1787
	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
				 gfc_array_index_type,
				 gfc_conv_descriptor_ubound_get (desc, dim),
				 gfc_conv_descriptor_lbound_get (desc, dim));
	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
				 gfc_array_index_type,
				 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
rsandifo's avatar
rsandifo committed
1788 1789 1790
	  tmp = gfc_evaluate_now (tmp, block);
	  GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
	}
1791 1792 1793 1794 1795
      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
			     GFC_TYPE_ARRAY_LBOUND (type, n),
			     GFC_TYPE_ARRAY_STRIDE (type, n));
      offset = fold_build2_loc (input_location, MINUS_EXPR,
				gfc_array_index_type, offset, tmp);
rsandifo's avatar
rsandifo committed
1796 1797 1798 1799 1800 1801 1802 1803 1804 1805
    }
  offset = gfc_evaluate_now (offset, block);
  GFC_TYPE_ARRAY_OFFSET (type) = offset;
}


/* Extend MAPPING so that it maps dummy argument SYM to the value stored
   in SE.  The caller may still use se->expr and se->string_length after
   calling this function.  */

rsandifo's avatar
rsandifo committed
1806
void
rsandifo's avatar
rsandifo committed
1807
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1808 1809
			   gfc_symbol * sym, gfc_se * se,
			   gfc_expr *expr)
rsandifo's avatar
rsandifo committed
1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821
{
  gfc_interface_sym_mapping *sm;
  tree desc;
  tree tmp;
  tree value;
  gfc_symbol *new_sym;
  gfc_symtree *root;
  gfc_symtree *new_symtree;

  /* Create a new symbol to represent the actual argument.  */
  new_sym = gfc_new_symbol (sym->name, NULL);
  new_sym->ts = sym->ts;
domob's avatar
domob committed
1822
  new_sym->as = gfc_copy_array_spec (sym->as);
rsandifo's avatar
rsandifo committed
1823 1824
  new_sym->attr.referenced = 1;
  new_sym->attr.dimension = sym->attr.dimension;
1825
  new_sym->attr.contiguous = sym->attr.contiguous;
1826
  new_sym->attr.codimension = sym->attr.codimension;
rsandifo's avatar
rsandifo committed
1827
  new_sym->attr.pointer = sym->attr.pointer;
eedelman's avatar
eedelman committed
1828
  new_sym->attr.allocatable = sym->attr.allocatable;
rsandifo's avatar
rsandifo committed
1829
  new_sym->attr.flavor = sym->attr.flavor;
1830
  new_sym->attr.function = sym->attr.function;
rsandifo's avatar
rsandifo committed
1831

1832 1833 1834 1835
  /* Ensure that the interface is available and that
     descriptors are passed for array actual arguments.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    {
1836
      new_sym->formal = expr->symtree->n.sym->formal;
1837 1838 1839 1840
      new_sym->attr.always_explicit
	    = expr->symtree->n.sym->attr.always_explicit;
    }

rsandifo's avatar
rsandifo committed
1841 1842 1843 1844 1845 1846 1847
  /* Create a fake symtree for it.  */
  root = NULL;
  new_symtree = gfc_new_symtree (&root, sym->name);
  new_symtree->n.sym = new_sym;
  gcc_assert (new_symtree == root);

  /* Create a dummy->actual mapping.  */
1848
  sm = XCNEW (gfc_interface_sym_mapping);
rsandifo's avatar
rsandifo committed
1849 1850
  sm->next = mapping->syms;
  sm->old = sym;
ghazi's avatar
ghazi committed
1851
  sm->new_sym = new_symtree;
1852
  sm->expr = gfc_copy_expr (expr);
rsandifo's avatar
rsandifo committed
1853 1854 1855
  mapping->syms = sm;

  /* Stabilize the argument's value.  */
1856 1857
  if (!sym->attr.function && se)
    se->expr = gfc_evaluate_now (se->expr, &se->pre);
rsandifo's avatar
rsandifo committed
1858 1859 1860 1861

  if (sym->ts.type == BT_CHARACTER)
    {
      /* Create a copy of the dummy argument's length.  */
1862 1863
      new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
      sm->expr->ts.u.cl = new_sym->ts.u.cl;
rsandifo's avatar
rsandifo committed
1864 1865 1866 1867

      /* If the length is specified as "*", record the length that
	 the caller is passing.  We should use the callee's length
	 in all other cases.  */
1868
      if (!new_sym->ts.u.cl->length && se)
rsandifo's avatar
rsandifo committed
1869 1870
	{
	  se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1871
	  new_sym->ts.u.cl->backend_decl = se->string_length;
rsandifo's avatar
rsandifo committed
1872 1873 1874
	}
    }

1875 1876 1877
  if (!se)
    return;

rsandifo's avatar
rsandifo committed
1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888
  /* Use the passed value as-is if the argument is a function.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    value = se->expr;

  /* If the argument is either a string or a pointer to a string,
     convert it to a boundless character type.  */
  else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
    {
      tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
      tmp = build_pointer_type (tmp);
      if (sym->attr.pointer)
1889 1890
        value = build_fold_indirect_ref_loc (input_location,
					 se->expr);
1891 1892 1893
      else
        value = se->expr;
      value = fold_convert (tmp, value);
rsandifo's avatar
rsandifo committed
1894 1895
    }

eedelman's avatar
eedelman committed
1896 1897 1898
  /* If the argument is a scalar, a pointer to an array or an allocatable,
     dereference it.  */
  else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1899 1900
    value = build_fold_indirect_ref_loc (input_location,
				     se->expr);
1901 1902
  
  /* For character(*), use the actual argument's descriptor.  */  
1903
  else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
1904 1905
    value = build_fold_indirect_ref_loc (input_location,
				     se->expr);
rsandifo's avatar
rsandifo committed
1906 1907 1908 1909 1910 1911 1912

  /* If the argument is an array descriptor, use it to determine
     information about the actual argument's shape.  */
  else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
	   && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
    {
      /* Get the actual argument's descriptor.  */
1913 1914
      desc = build_fold_indirect_ref_loc (input_location,
				      se->expr);
rsandifo's avatar
rsandifo committed
1915 1916 1917

      /* Create the replacement variable.  */
      tmp = gfc_conv_descriptor_data_get (desc);
tobi's avatar
tobi committed
1918 1919
      value = gfc_get_interface_mapping_array (&se->pre, sym,
					       PACKED_NO, tmp);
rsandifo's avatar
rsandifo committed
1920 1921 1922 1923 1924 1925

      /* Use DESC to work out the upper bounds, strides and offset.  */
      gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
    }
  else
    /* Otherwise we have a packed array.  */
tobi's avatar
tobi committed
1926 1927
    value = gfc_get_interface_mapping_array (&se->pre, sym,
					     PACKED_FULL, se->expr);
rsandifo's avatar
rsandifo committed
1928 1929 1930 1931 1932 1933 1934 1935 1936 1937

  new_sym->backend_decl = value;
}


/* Called once all dummy argument mappings have been added to MAPPING,
   but before the mapping is used to evaluate expressions.  Pre-evaluate
   the length of each argument, adding any initialization code to PRE and
   any finalization code to POST.  */

rsandifo's avatar
rsandifo committed
1938
void
rsandifo's avatar
rsandifo committed
1939 1940 1941 1942 1943 1944 1945 1946
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
			      stmtblock_t * pre, stmtblock_t * post)
{
  gfc_interface_sym_mapping *sym;
  gfc_expr *expr;
  gfc_se se;

  for (sym = mapping->syms; sym; sym = sym->next)
ghazi's avatar
ghazi committed
1947
    if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1948
	&& !sym->new_sym->n.sym->ts.u.cl->backend_decl)
rsandifo's avatar
rsandifo committed
1949
      {
1950
	expr = sym->new_sym->n.sym->ts.u.cl->length;
rsandifo's avatar
rsandifo committed
1951 1952 1953
	gfc_apply_interface_mapping_to_expr (mapping, expr);
	gfc_init_se (&se, NULL);
	gfc_conv_expr (&se, expr);
1954
	se.expr = fold_convert (gfc_charlen_type_node, se.expr);
rsandifo's avatar
rsandifo committed
1955 1956 1957 1958
	se.expr = gfc_evaluate_now (se.expr, &se.pre);
	gfc_add_block_to_block (pre, &se.pre);
	gfc_add_block_to_block (post, &se.post);

1959
	sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
rsandifo's avatar
rsandifo committed
1960 1961 1962 1963 1964 1965 1966 1967 1968
      }
}


/* Like gfc_apply_interface_mapping_to_expr, but applied to
   constructor C.  */

static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1969
				     gfc_constructor_base base)
rsandifo's avatar
rsandifo committed
1970
{
1971 1972
  gfc_constructor *c;
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
rsandifo's avatar
rsandifo committed
1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017
    {
      gfc_apply_interface_mapping_to_expr (mapping, c->expr);
      if (c->iterator)
	{
	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
	  gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
	}
    }
}


/* Like gfc_apply_interface_mapping_to_expr, but applied to
   reference REF.  */

static void
gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
				    gfc_ref * ref)
{
  int n;

  for (; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
	for (n = 0; n < ref->u.ar.dimen; n++)
	  {
	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
	    gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
	  }
	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
	break;

      case REF_COMPONENT:
	break;

      case REF_SUBSTRING:
	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
	gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
	break;
      }
}


2018
/* Convert intrinsic function calls into result expressions.  */
domob's avatar
domob committed
2019

2020
static bool
domob's avatar
domob committed
2021
gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034
{
  gfc_symbol *sym;
  gfc_expr *new_expr;
  gfc_expr *arg1;
  gfc_expr *arg2;
  int d, dup;

  arg1 = expr->value.function.actual->expr;
  if (expr->value.function.actual->next)
    arg2 = expr->value.function.actual->next->expr;
  else
    arg2 = NULL;

domob's avatar
domob committed
2035
  sym = arg1->symtree->n.sym;
2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046

  if (sym->attr.dummy)
    return false;

  new_expr = NULL;

  switch (expr->value.function.isym->id)
    {
    case GFC_ISYM_LEN:
      /* TODO figure out why this condition is necessary.  */
      if (sym->attr.function
2047 2048 2049
	  && (arg1->ts.u.cl->length == NULL
	      || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
		  && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
2050 2051
	return false;

2052
      new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
2053 2054 2055
      break;

    case GFC_ISYM_SIZE:
2056
      if (!sym->as || sym->as->rank == 0)
2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072
	return false;

      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
	{
	  dup = mpz_get_si (arg2->value.integer);
	  d = dup - 1;
	}
      else
	{
	  dup = sym->as->rank;
	  d = 0;
	}

      for (; d < dup; d++)
	{
	  gfc_expr *tmp;
domob's avatar
domob committed
2073 2074 2075 2076 2077 2078 2079

	  if (!sym->as->upper[d] || !sym->as->lower[d])
	    {
	      gfc_free_expr (new_expr);
	      return false;
	    }

2080 2081 2082
	  tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
					gfc_get_int_expr (gfc_default_integer_kind,
							  NULL, 1));
2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095
	  tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
	  if (new_expr)
	    new_expr = gfc_multiply (new_expr, tmp);
	  else
	    new_expr = tmp;
	}
      break;

    case GFC_ISYM_LBOUND:
    case GFC_ISYM_UBOUND:
	/* TODO These implementations of lbound and ubound do not limit if
	   the size < 0, according to F95's 13.14.53 and 13.14.113.  */

2096
      if (!sym->as || sym->as->rank == 0)
2097 2098 2099 2100 2101 2102 2103 2104 2105 2106
	return false;

      if (arg2 && arg2->expr_type == EXPR_CONSTANT)
	d = mpz_get_si (arg2->value.integer) - 1;
      else
	/* TODO: If the need arises, this could produce an array of
	   ubound/lbounds.  */
	gcc_unreachable ();

      if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
domob's avatar
domob committed
2107 2108 2109 2110
	{
	  if (sym->as->lower[d])
	    new_expr = gfc_copy_expr (sym->as->lower[d]);
	}
2111
      else
domob's avatar
domob committed
2112 2113 2114 2115
	{
	  if (sym->as->upper[d])
	    new_expr = gfc_copy_expr (sym->as->upper[d]);
	}
2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166
      break;

    default:
      break;
    }

  gfc_apply_interface_mapping_to_expr (mapping, new_expr);
  if (!new_expr)
    return false;

  gfc_replace_expr (expr, new_expr);
  return true;
}


static void
gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
			      gfc_interface_mapping * mapping)
{
  gfc_formal_arglist *f;
  gfc_actual_arglist *actual;

  actual = expr->value.function.actual;
  f = map_expr->symtree->n.sym->formal;

  for (; f && actual; f = f->next, actual = actual->next)
    {
      if (!actual->expr)
	continue;

      gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
    }

  if (map_expr->symtree->n.sym->attr.dimension)
    {
      int d;
      gfc_array_spec *as;

      as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);

      for (d = 0; d < as->rank; d++)
	{
	  gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
	  gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
	}

      expr->value.function.esym->as = as;
    }

  if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
    {
2167 2168
      expr->value.function.esym->ts.u.cl->length
	= gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
2169 2170

      gfc_apply_interface_mapping_to_expr (mapping,
2171
			expr->value.function.esym->ts.u.cl->length);
2172 2173 2174 2175
    }
}


rsandifo's avatar
rsandifo committed
2176 2177 2178 2179 2180
/* EXPR is a copy of an expression that appeared in the interface
   associated with MAPPING.  Walk it recursively looking for references to
   dummy arguments that MAPPING maps to actual arguments.  Replace each such
   reference with a reference to the associated actual argument.  */

2181
static void
rsandifo's avatar
rsandifo committed
2182 2183 2184 2185 2186 2187 2188
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
				     gfc_expr * expr)
{
  gfc_interface_sym_mapping *sym;
  gfc_actual_arglist *actual;

  if (!expr)
2189
    return;
rsandifo's avatar
rsandifo committed
2190 2191

  /* Copying an expression does not copy its length, so do that here.  */
2192
  if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
rsandifo's avatar
rsandifo committed
2193
    {
2194 2195
      expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
      gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
rsandifo's avatar
rsandifo committed
2196 2197 2198 2199 2200 2201
    }

  /* Apply the mapping to any references.  */
  gfc_apply_interface_mapping_to_ref (mapping, expr->ref);

  /* ...and to the expression's symbol, if it has one.  */
2202
  /* TODO Find out why the condition on expr->symtree had to be moved into
rwild's avatar
rwild committed
2203
     the loop rather than being outside it, as originally.  */
2204 2205 2206
  for (sym = mapping->syms; sym; sym = sym->next)
    if (expr->symtree && sym->old == expr->symtree->n.sym)
      {
ghazi's avatar
ghazi committed
2207 2208
	if (sym->new_sym->n.sym->backend_decl)
	  expr->symtree = sym->new_sym;
2209 2210 2211
	else if (sym->expr)
	  gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
      }
rsandifo's avatar
rsandifo committed
2212

2213
      /* ...and to subexpressions in expr->value.  */
rsandifo's avatar
rsandifo committed
2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227
  switch (expr->expr_type)
    {
    case EXPR_VARIABLE:
    case EXPR_CONSTANT:
    case EXPR_NULL:
    case EXPR_SUBSTRING:
      break;

    case EXPR_OP:
      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
      gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
      break;

    case EXPR_FUNCTION:
2228 2229 2230
      for (actual = expr->value.function.actual; actual; actual = actual->next)
	gfc_apply_interface_mapping_to_expr (mapping, actual->expr);

2231
      if (expr->value.function.esym == NULL
2232
	    && expr->value.function.isym != NULL
2233 2234 2235
	    && expr->value.function.actual->expr->symtree
	    && gfc_map_intrinsic_function (expr, mapping))
	break;
2236

rsandifo's avatar
rsandifo committed
2237 2238
      for (sym = mapping->syms; sym; sym = sym->next)
	if (sym->old == expr->value.function.esym)
2239
	  {
ghazi's avatar
ghazi committed
2240
	    expr->value.function.esym = sym->new_sym->n.sym;
2241
	    gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
ghazi's avatar
ghazi committed
2242
	    expr->value.function.esym->result = sym->new_sym->n.sym;
2243
	  }
rsandifo's avatar
rsandifo committed
2244 2245 2246 2247 2248 2249
      break;

    case EXPR_ARRAY:
    case EXPR_STRUCTURE:
      gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
      break;
domob's avatar
domob committed
2250 2251

    case EXPR_COMPCALL:
2252
    case EXPR_PPC:
domob's avatar
domob committed
2253 2254
      gcc_unreachable ();
      break;
rsandifo's avatar
rsandifo committed
2255
    }
2256 2257

  return;
rsandifo's avatar
rsandifo committed
2258 2259 2260 2261 2262 2263
}


/* Evaluate interface expression EXPR using MAPPING.  Store the result
   in SE.  */

rsandifo's avatar
rsandifo committed
2264
void
rsandifo's avatar
rsandifo committed
2265 2266 2267 2268 2269 2270 2271 2272 2273 2274
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
			     gfc_se * se, gfc_expr * expr)
{
  expr = gfc_copy_expr (expr);
  gfc_apply_interface_mapping_to_expr (mapping, expr);
  gfc_conv_expr (se, expr);
  se->expr = gfc_evaluate_now (se->expr, &se->pre);
  gfc_free_expr (expr);
}

2275

2276 2277
/* Returns a reference to a temporary array into which a component of
   an actual argument derived type array is copied and then returned
2278
   after the function call.  */
2279
void
2280 2281
gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
			   sym_intent intent, bool formal_ptr)
2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293
{
  gfc_se lse;
  gfc_se rse;
  gfc_ss *lss;
  gfc_ss *rss;
  gfc_loopinfo loop;
  gfc_loopinfo loop2;
  gfc_ss_info *info;
  tree offset;
  tree tmp_index;
  tree tmp;
  tree base_type;
2294
  tree size;
2295 2296
  stmtblock_t body;
  int n;
jakub's avatar
jakub committed
2297
  int dimen;
2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316

  gcc_assert (expr->expr_type == EXPR_VARIABLE);

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  /* Walk the argument expression.  */
  rss = gfc_walk_expr (expr);

  gcc_assert (rss != gfc_ss_terminator);
 
  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop);
  gfc_add_ss_to_loop (&loop, rss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop);

  /* Build an ss for the temporary.  */
2317 2318
  if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
    gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
2319

2320 2321 2322 2323 2324 2325 2326 2327 2328 2329
  base_type = gfc_typenode_for_spec (&expr->ts);
  if (GFC_ARRAY_TYPE_P (base_type)
		|| GFC_DESCRIPTOR_TYPE_P (base_type))
    base_type = gfc_get_element_type (base_type);

  loop.temp_ss = gfc_get_ss ();;
  loop.temp_ss->type = GFC_SS_TEMP;
  loop.temp_ss->data.temp.type = base_type;

  if (expr->ts.type == BT_CHARACTER)
2330
    loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
2331 2332
  else
    loop.temp_ss->string_length = NULL;
2333

2334
  parmse->string_length = loop.temp_ss->string_length;
2335 2336 2337 2338 2339 2340 2341
  loop.temp_ss->data.temp.dimen = loop.dimen;
  loop.temp_ss->next = gfc_ss_terminator;

  /* Associate the SS with the loop.  */
  gfc_add_ss_to_loop (&loop, loop.temp_ss);

  /* Setup the scalarizing loops.  */
2342
  gfc_conv_loop_setup (&loop, &expr->where);
2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364

  /* Pass the temporary descriptor back to the caller.  */
  info = &loop.temp_ss->data.info;
  parmse->expr = info->descriptor;

  /* Setup the gfc_se structures.  */
  gfc_copy_loopinfo_to_se (&lse, &loop);
  gfc_copy_loopinfo_to_se (&rse, &loop);

  rse.ss = rss;
  lse.ss = loop.temp_ss;
  gfc_mark_ss_chain_used (rss, 1);
  gfc_mark_ss_chain_used (loop.temp_ss, 1);

  /* Start the scalarized loop body.  */
  gfc_start_scalarized_body (&loop, &body);

  /* Translate the expression.  */
  gfc_conv_expr (&rse, expr);

  gfc_conv_tmp_array_ref (&lse);

2365 2366
  if (intent != INTENT_OUT)
    {
2367
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
2368 2369 2370 2371
      gfc_add_expr_to_block (&body, tmp);
      gcc_assert (rse.ss == gfc_ss_terminator);
      gfc_trans_scalarizing_loops (&loop, &body);
    }
2372 2373
  else
    {
2374 2375 2376 2377 2378 2379 2380 2381
      /* Make sure that the temporary declaration survives by merging
       all the loop declarations into the current context.  */
      for (n = 0; n < loop.dimen; n++)
	{
	  gfc_merge_block_scope (&body);
	  body = loop.code[loop.order[n]];
	}
      gfc_merge_block_scope (&body);
2382
    }
2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405

  /* Add the post block after the second loop, so that any
     freeing of allocated memory is done at the right time.  */
  gfc_add_block_to_block (&parmse->pre, &loop.pre);

  /**********Copy the temporary back again.*********/

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  /* Walk the argument expression.  */
  lss = gfc_walk_expr (expr);
  rse.ss = loop.temp_ss;
  lse.ss = lss;

  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop2);
  gfc_add_ss_to_loop (&loop2, lss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop2);

  /* Setup the scalarizing loops.  */
2406
  gfc_conv_loop_setup (&loop2, &expr->where);
2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422

  gfc_copy_loopinfo_to_se (&lse, &loop2);
  gfc_copy_loopinfo_to_se (&rse, &loop2);

  gfc_mark_ss_chain_used (lss, 1);
  gfc_mark_ss_chain_used (loop.temp_ss, 1);

  /* Declare the variable to hold the temporary offset and start the
     scalarized loop body.  */
  offset = gfc_create_var (gfc_array_index_type, NULL);
  gfc_start_scalarized_body (&loop2, &body);

  /* Build the offsets for the temporary from the loop variables.  The
     temporary array has lbounds of zero and strides of one in all
     dimensions, so this is very simple.  The offset is only computed
     outside the innermost loop, so the overall transfer could be
2423
     optimized further.  */
2424
  info = &rse.ss->data.info;
jakub's avatar
jakub committed
2425
  dimen = info->dimen;
2426 2427

  tmp_index = gfc_index_zero_node;
jakub's avatar
jakub committed
2428
  for (n = dimen - 1; n > 0; n--)
2429 2430 2431
    {
      tree tmp_str;
      tmp = rse.loop->loopvar[n];
2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445
      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
			     tmp, rse.loop->from[n]);
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
			     tmp, tmp_index);

      tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
				 gfc_array_index_type,
				 rse.loop->to[n-1], rse.loop->from[n-1]);
      tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
				 gfc_array_index_type,
				 tmp_str, gfc_index_one_node);

      tmp_index = fold_build2_loc (input_location, MULT_EXPR,
				   gfc_array_index_type, tmp, tmp_str);
2446 2447
    }

2448 2449 2450
  tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
			       gfc_array_index_type,
			       tmp_index, rse.loop->from[0]);
2451
  gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2452

2453 2454 2455
  tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
			       gfc_array_index_type,
			       rse.loop->loopvar[0], offset);
2456 2457

  /* Now use the offset for the reference.  */
2458 2459
  tmp = build_fold_indirect_ref_loc (input_location,
				 info->data);
2460
  rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2461 2462

  if (expr->ts.type == BT_CHARACTER)
2463
    rse.string_length = expr->ts.u.cl->backend_decl;
2464 2465 2466 2467 2468

  gfc_conv_expr (&lse, expr);

  gcc_assert (lse.ss == gfc_ss_terminator);

2469
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
2470 2471 2472 2473 2474 2475
  gfc_add_expr_to_block (&body, tmp);
  
  /* Generate the copying loops.  */
  gfc_trans_scalarizing_loops (&loop2, &body);

  /* Wrap the whole thing up by adding the second loop to the post-block
2476
     and following it by the post-block of the first loop.  In this way,
2477
     if the temporary needs freeing, it is done after use!  */
2478 2479 2480 2481 2482
  if (intent != INTENT_IN)
    {
      gfc_add_block_to_block (&parmse->post, &loop2.pre);
      gfc_add_block_to_block (&parmse->post, &loop2.post);
    }
2483 2484 2485 2486 2487 2488 2489 2490

  gfc_add_block_to_block (&parmse->post, &loop.post);

  gfc_cleanup_loop (&loop);
  gfc_cleanup_loop (&loop2);

  /* Pass the string length to the argument expression.  */
  if (expr->ts.type == BT_CHARACTER)
2491
    parmse->string_length = expr->ts.u.cl->backend_decl;
2492

2493 2494 2495 2496 2497 2498
  /* Determine the offset for pointer formal arguments and set the
     lbounds to one.  */
  if (formal_ptr)
    {
      size = gfc_index_one_node;
      offset = gfc_index_zero_node;  
jakub's avatar
jakub committed
2499
      for (n = 0; n < dimen; n++)
2500 2501 2502
	{
	  tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
						gfc_rank_cst[n]);
2503 2504 2505
	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
				 gfc_array_index_type, tmp,
				 gfc_index_one_node);
2506 2507 2508 2509 2510 2511 2512 2513 2514
	  gfc_conv_descriptor_ubound_set (&parmse->pre,
					  parmse->expr,
					  gfc_rank_cst[n],
					  tmp);
	  gfc_conv_descriptor_lbound_set (&parmse->pre,
					  parmse->expr,
					  gfc_rank_cst[n],
					  gfc_index_one_node);
	  size = gfc_evaluate_now (size, &parmse->pre);
2515 2516 2517
	  offset = fold_build2_loc (input_location, MINUS_EXPR,
				    gfc_array_index_type,
				    offset, size);
2518
	  offset = gfc_evaluate_now (offset, &parmse->pre);
2519 2520 2521 2522 2523 2524 2525 2526
	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
				 gfc_array_index_type,
				 rse.loop->to[n], rse.loop->from[n]);
	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
				 gfc_array_index_type,
				 tmp, gfc_index_one_node);
	  size = fold_build2_loc (input_location, MULT_EXPR,
				  gfc_array_index_type, size, tmp);
2527 2528 2529 2530 2531 2532
	}

      gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
				      offset);
    }

2533 2534 2535 2536 2537
  /* We want either the address for the data or the address of the descriptor,
     depending on the mode of passing array arguments.  */
  if (g77)
    parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
  else
2538
    parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2539 2540 2541 2542

  return;
}

rsandifo's avatar
rsandifo committed
2543

2544 2545 2546 2547 2548 2549 2550 2551 2552 2553
/* Generate the code for argument list functions.  */

static void
conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
{
  /* Pass by value for g77 %VAL(arg), pass the address
     indirectly for %LOC, else by reference.  Thus %REF
     is a "do-nothing" and %LOC is the same as an F95
     pointer.  */
  if (strncmp (name, "%VAL", 4) == 0)
2554
    gfc_conv_expr (se, expr);
2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566
  else if (strncmp (name, "%LOC", 4) == 0)
    {
      gfc_conv_expr_reference (se, expr);
      se->expr = gfc_build_addr_expr (NULL, se->expr);
    }
  else if (strncmp (name, "%REF", 4) == 0)
    gfc_conv_expr_reference (se, expr);
  else
    gfc_error ("Unknown argument list function at %L", &expr->where);
}


janus's avatar
janus committed
2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586
/* Takes a derived type expression and returns the address of a temporary
   class object of the 'declared' type.  */ 
static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
			   gfc_typespec class_ts)
{
  gfc_component *cmp;
  gfc_symbol *vtab;
  gfc_symbol *declared = class_ts.u.derived;
  gfc_ss *ss;
  tree ctree;
  tree var;
  tree tmp;

  /* The derived type needs to be converted to a temporary
     CLASS object.  */
  tmp = gfc_typenode_for_spec (&class_ts);
  var = gfc_create_var (tmp, "class");

  /* Set the vptr.  */
2587
  cmp = gfc_find_component (declared, "_vptr", true, true);
2588 2589 2590
  ctree = fold_build3_loc (input_location, COMPONENT_REF,
			   TREE_TYPE (cmp->backend_decl),
			   var, cmp->backend_decl, NULL_TREE);
janus's avatar
janus committed
2591 2592

  /* Remember the vtab corresponds to the derived type
2593 2594
     not to the class declared type.  */
  vtab = gfc_find_derived_vtab (e->ts.u.derived);
janus's avatar
janus committed
2595 2596 2597 2598 2599 2600
  gcc_assert (vtab);
  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
  gfc_add_modify (&parmse->pre, ctree,
		  fold_convert (TREE_TYPE (ctree), tmp));

  /* Now set the data field.  */
2601
  cmp = gfc_find_component (declared, "_data", true, true);
2602 2603 2604
  ctree = fold_build3_loc (input_location, COMPONENT_REF,
			   TREE_TYPE (cmp->backend_decl),
			   var, cmp->backend_decl, NULL_TREE);
janus's avatar
janus committed
2605 2606 2607
  ss = gfc_walk_expr (e);
  if (ss == gfc_ss_terminator)
    {
2608
      parmse->ss = NULL;
janus's avatar
janus committed
2609 2610 2611 2612 2613 2614
      gfc_conv_expr_reference (parmse, e);
      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
      gfc_add_modify (&parmse->pre, ctree, tmp);
    }
  else
    {
2615
      parmse->ss = ss;
janus's avatar
janus committed
2616 2617 2618 2619 2620 2621 2622 2623 2624
      gfc_conv_expr (parmse, e);
      gfc_add_modify (&parmse->pre, ctree, parmse->expr);
    }

  /* Pass the address of the class object.  */
  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}


2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709
/* The following routine generates code for the intrinsic
   procedures from the ISO_C_BINDING module:
    * C_LOC           (function)
    * C_FUNLOC        (function)
    * C_F_POINTER     (subroutine)
    * C_F_PROCPOINTER (subroutine)
    * C_ASSOCIATED    (function)
   One exception which is not handled here is C_F_POINTER with non-scalar
   arguments. Returns 1 if the call was replaced by inline code (else: 0).  */

static int
conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
			    gfc_actual_arglist * arg)
{
  gfc_symbol *fsym;
  gfc_ss *argss;
    
  if (sym->intmod_sym_id == ISOCBINDING_LOC)
    {
      if (arg->expr->rank == 0)
	gfc_conv_expr_reference (se, arg->expr);
      else
	{
	  int f;
	  /* This is really the actual arg because no formal arglist is
	     created for C_LOC.	 */
	  fsym = arg->expr->symtree->n.sym;

	  /* We should want it to do g77 calling convention.  */
	  f = (fsym != NULL)
	    && !(fsym->attr.pointer || fsym->attr.allocatable)
	    && fsym->as->type != AS_ASSUMED_SHAPE;
	  f = f || !sym->attr.always_explicit;
      
	  argss = gfc_walk_expr (arg->expr);
	  gfc_conv_array_parameter (se, arg->expr, argss, f,
				    NULL, NULL, NULL);
	}

      /* TODO -- the following two lines shouldn't be necessary, but if
	 they're removed, a bug is exposed later in the code path.
	 This workaround was thus introduced, but will have to be
	 removed; please see PR 35150 for details about the issue.  */
      se->expr = convert (pvoid_type_node, se->expr);
      se->expr = gfc_evaluate_now (se->expr, &se->pre);

      return 1;
    }
  else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
    {
      arg->expr->ts.type = sym->ts.u.derived->ts.type;
      arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
      arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
      gfc_conv_expr_reference (se, arg->expr);
  
      return 1;
    }
  else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
	    && arg->next->expr->rank == 0)
	   || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
    {
      /* Convert c_f_pointer if fptr is a scalar
	 and convert c_f_procpointer.  */
      gfc_se cptrse;
      gfc_se fptrse;

      gfc_init_se (&cptrse, NULL);
      gfc_conv_expr (&cptrse, arg->expr);
      gfc_add_block_to_block (&se->pre, &cptrse.pre);
      gfc_add_block_to_block (&se->post, &cptrse.post);

      gfc_init_se (&fptrse, NULL);
      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
	  || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
	fptrse.want_pointer = 1;

      gfc_conv_expr (&fptrse, arg->next->expr);
      gfc_add_block_to_block (&se->pre, &fptrse.pre);
      gfc_add_block_to_block (&se->post, &fptrse.post);
      
      if (arg->next->expr->symtree->n.sym->attr.proc_pointer
	  && arg->next->expr->symtree->n.sym->attr.dummy)
	fptrse.expr = build_fold_indirect_ref_loc (input_location,
						   fptrse.expr);
      
2710 2711 2712 2713 2714
      se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
				  TREE_TYPE (fptrse.expr),
				  fptrse.expr,
				  fold_convert (TREE_TYPE (fptrse.expr),
						cptrse.expr));
2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734

      return 1;
    }
  else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
    {
      gfc_se arg1se;
      gfc_se arg2se;

      /* Build the addr_expr for the first argument.  The argument is
	 already an *address* so we don't need to set want_pointer in
	 the gfc_se.  */
      gfc_init_se (&arg1se, NULL);
      gfc_conv_expr (&arg1se, arg->expr);
      gfc_add_block_to_block (&se->pre, &arg1se.pre);
      gfc_add_block_to_block (&se->post, &arg1se.post);

      /* See if we were given two arguments.  */
      if (arg->next == NULL)
	/* Only given one arg so generate a null and do a
	   not-equal comparison against the first arg.  */
2735 2736 2737 2738
	se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
				    arg1se.expr,
				    fold_convert (TREE_TYPE (arg1se.expr),
						  null_pointer_node));
2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750
      else
	{
	  tree eq_expr;
	  tree not_null_expr;
	  
	  /* Given two arguments so build the arg2se from second arg.  */
	  gfc_init_se (&arg2se, NULL);
	  gfc_conv_expr (&arg2se, arg->next->expr);
	  gfc_add_block_to_block (&se->pre, &arg2se.pre);
	  gfc_add_block_to_block (&se->post, &arg2se.post);

	  /* Generate test to compare that the two args are equal.  */
2751 2752
	  eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
				     arg1se.expr, arg2se.expr);
2753
	  /* Generate test to ensure that the first arg is not null.  */
2754 2755 2756
	  not_null_expr = fold_build2_loc (input_location, NE_EXPR,
					   boolean_type_node,
					   arg1se.expr, null_pointer_node);
2757 2758 2759

	  /* Finally, the generated test must check that both arg1 is not
	     NULL and that it is equal to the second arg.  */
2760 2761 2762
	  se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
				      boolean_type_node,
				      not_null_expr, eq_expr);
2763 2764 2765 2766 2767 2768 2769 2770 2771
	}

      return 1;
    }
    
  /* Nothing was done.  */
  return 0;
}

dnovillo's avatar
 
dnovillo committed
2772
/* Generate code for a procedure call.  Note can return se->post != NULL.
2773
   If se->direct_byref is set then se->expr contains the return parameter.
2774 2775
   Return nonzero, if the call has alternate specifiers.
   'expr' is only needed for procedure pointer components.  */
dnovillo's avatar
 
dnovillo committed
2776

2777
int
2778
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
2779
			 gfc_actual_arglist * args, gfc_expr * expr,
froydnj's avatar
gcc/  
froydnj committed
2780
			 VEC(tree,gc) *append_args)
dnovillo's avatar
 
dnovillo committed
2781
{
rsandifo's avatar
rsandifo committed
2782
  gfc_interface_mapping mapping;
froydnj's avatar
gcc/  
froydnj committed
2783 2784
  VEC(tree,gc) *arglist;
  VEC(tree,gc) *retargs;
dnovillo's avatar
 
dnovillo committed
2785 2786 2787 2788 2789 2790
  tree tmp;
  tree fntype;
  gfc_se parmse;
  gfc_ss *argss;
  gfc_ss_info *info;
  int byref;
2791
  int parm_kind;
dnovillo's avatar
 
dnovillo committed
2792 2793 2794
  tree type;
  tree var;
  tree len;
froydnj's avatar
gcc/  
froydnj committed
2795
  VEC(tree,gc) *stringargs;
2796
  tree result = NULL;
dnovillo's avatar
 
dnovillo committed
2797
  gfc_formal_arglist *formal;
2798
  gfc_actual_arglist *arg;
2799
  int has_alternate_specifier = 0;
rsandifo's avatar
rsandifo committed
2800
  bool need_interface_mapping;
eedelman's avatar
eedelman committed
2801
  bool callee_alloc;
rsandifo's avatar
rsandifo committed
2802 2803
  gfc_typespec ts;
  gfc_charlen cl;
2804 2805
  gfc_expr *e;
  gfc_symbol *fsym;
2806
  stmtblock_t post;
2807
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2808
  gfc_component *comp = NULL;
froydnj's avatar
gcc/  
froydnj committed
2809
  int arglen;
dnovillo's avatar
 
dnovillo committed
2810

froydnj's avatar
gcc/  
froydnj committed
2811 2812 2813
  arglist = NULL;
  retargs = NULL;
  stringargs = NULL;
dnovillo's avatar
 
dnovillo committed
2814 2815
  var = NULL_TREE;
  len = NULL_TREE;
2816
  gfc_clear_ts (&ts);
dnovillo's avatar
 
dnovillo committed
2817

2818
  if (sym->from_intmod == INTMOD_ISO_C_BINDING
2819
      && conv_isocbinding_procedure (se, sym, args))
2820
    return 0;
2821 2822 2823

  gfc_is_proc_ptr_comp (expr, &comp);

dnovillo's avatar
 
dnovillo committed
2824 2825 2826 2827
  if (se->ss != NULL)
    {
      if (!sym->attr.elemental)
	{
pbrook's avatar
pbrook committed
2828
	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2829 2830
	  if (se->ss->useflags)
	    {
2831 2832 2833
	      gcc_assert ((!comp && gfc_return_by_reference (sym)
			   && sym->result->attr.dimension)
			  || (comp && comp->attr.dimension));
2834
	      gcc_assert (se->loop != NULL);
dnovillo's avatar
 
dnovillo committed
2835

2836 2837 2838 2839
	      /* Access the previously obtained result.  */
	      gfc_conv_tmp_array_ref (se);
	      return 0;
	    }
dnovillo's avatar
 
dnovillo committed
2840 2841 2842 2843 2844 2845
	}
      info = &se->ss->data.info;
    }
  else
    info = NULL;

2846
  gfc_init_block (&post);
rsandifo's avatar
rsandifo committed
2847
  gfc_init_interface_mapping (&mapping);
2848 2849 2850 2851 2852 2853 2854 2855 2856
  if (!comp)
    {
      formal = sym->formal;
      need_interface_mapping = sym->attr.dimension ||
			       (sym->ts.type == BT_CHARACTER
				&& sym->ts.u.cl->length
				&& sym->ts.u.cl->length->expr_type
				   != EXPR_CONSTANT);
    }
2857
  else
2858 2859 2860 2861 2862 2863 2864 2865 2866
    {
      formal = comp->formal;
      need_interface_mapping = comp->attr.dimension ||
			       (comp->ts.type == BT_CHARACTER
				&& comp->ts.u.cl->length
				&& comp->ts.u.cl->length->expr_type
				   != EXPR_CONSTANT);
    }

dnovillo's avatar
 
dnovillo committed
2867
  /* Evaluate the arguments.  */
2868 2869
  for (arg = args; arg != NULL;
       arg = arg->next, formal = formal ? formal->next : NULL)
dnovillo's avatar
 
dnovillo committed
2870
    {
2871 2872
      e = arg->expr;
      fsym = formal ? formal->sym : NULL;
2873
      parm_kind = MISSING;
2874

2875
      if (e == NULL)
dnovillo's avatar
 
dnovillo committed
2876 2877 2878 2879 2880 2881 2882 2883 2884
	{
	  if (se->ignore_optional)
	    {
	      /* Some intrinsics have already been resolved to the correct
	         parameters.  */
	      continue;
	    }
	  else if (arg->label)
	    {
2885 2886
	      has_alternate_specifier = 1;
	      continue;
dnovillo's avatar
 
dnovillo committed
2887 2888 2889 2890 2891 2892
	    }
	  else
	    {
	      /* Pass a NULL pointer for an absent arg.  */
	      gfc_init_se (&parmse, NULL);
	      parmse.expr = null_pointer_node;
2893
	      if (arg->missing_arg_type == BT_CHARACTER)
2894
		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
dnovillo's avatar
 
dnovillo committed
2895 2896
	    }
	}
2897 2898 2899 2900 2901 2902 2903 2904 2905
      else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
	{
	  /* Pass a NULL pointer to denote an absent arg.  */
	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
	  gfc_init_se (&parmse, NULL);
	  parmse.expr = null_pointer_node;
	  if (arg->missing_arg_type == BT_CHARACTER)
	    parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
	}
burnus's avatar
burnus committed
2906 2907 2908 2909 2910 2911
      else if (fsym && fsym->ts.type == BT_CLASS
		 && e->ts.type == BT_DERIVED)
	{
	  /* The derived type needs to be converted to a temporary
	     CLASS object.  */
	  gfc_init_se (&parmse, se);
janus's avatar
janus committed
2912
	  gfc_conv_derived_to_class (&parmse, e, fsym->ts);
burnus's avatar
burnus committed
2913
	}
dnovillo's avatar
 
dnovillo committed
2914 2915 2916
      else if (se->ss && se->ss->useflags)
	{
	  /* An elemental function inside a scalarized loop.  */
2917 2918
	  gfc_init_se (&parmse, se);
	  gfc_conv_expr_reference (&parmse, e);
2919
	  parm_kind = ELEMENTAL;
dnovillo's avatar
 
dnovillo committed
2920 2921 2922 2923 2924
	}
      else
	{
	  /* A scalar or transformational function.  */
	  gfc_init_se (&parmse, NULL);
2925
	  argss = gfc_walk_expr (e);
dnovillo's avatar
 
dnovillo committed
2926 2927

	  if (argss == gfc_ss_terminator)
2928
	    {
2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940
	      if (e->expr_type == EXPR_VARIABLE
		    && e->symtree->n.sym->attr.cray_pointee
		    && fsym && fsym->attr.flavor == FL_PROCEDURE)
		{
		    /* The Cray pointer needs to be converted to a pointer to
		       a type given by the expression.  */
		    gfc_conv_expr (&parmse, e);
		    type = build_pointer_type (TREE_TYPE (parmse.expr));
		    tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
		    parmse.expr = convert (type, tmp);
		}
 	      else if (fsym && fsym->attr.value)
2941
		{
2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953
		  if (fsym->ts.type == BT_CHARACTER
		      && fsym->ts.is_c_interop
		      && fsym->ns->proc_name != NULL
		      && fsym->ns->proc_name->attr.is_bind_c)
		    {
		      parmse.expr = NULL;
		      gfc_conv_scalar_char_value (fsym, &parmse, &e);
		      if (parmse.expr == NULL)
			gfc_conv_expr (&parmse, e);
		    }
		  else
		    gfc_conv_expr (&parmse, e);
2954
		}
2955 2956 2957 2958
	      else if (arg->name && arg->name[0] == '%')
		/* Argument list functions %VAL, %LOC and %REF are signalled
		   through arg->name.  */
		conv_arglist_function (&parmse, arg->expr, arg->name);
2959
	      else if ((e->expr_type == EXPR_FUNCTION)
2960 2961 2962 2963 2964
			&& ((e->value.function.esym
			     && e->value.function.esym->result->attr.pointer)
			    || (!e->value.function.esym
				&& e->symtree->n.sym->attr.pointer))
			&& fsym && fsym->attr.target)
2965 2966
		{
		  gfc_conv_expr (&parmse, e);
2967
		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2968
		}
2969 2970
	      else if (e->expr_type == EXPR_FUNCTION
		       && e->symtree->n.sym->result
2971
		       && e->symtree->n.sym->result != e->symtree->n.sym
2972 2973 2974 2975 2976 2977 2978
		       && e->symtree->n.sym->result->attr.proc_pointer)
		{
		  /* Functions returning procedure pointers.  */
		  gfc_conv_expr (&parmse, e);
		  if (fsym && fsym->attr.proc_pointer)
		    parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
		}
2979 2980 2981
	      else
		{
		  gfc_conv_expr_reference (&parmse, e);
2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993

		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
		     allocated on entry, it must be deallocated.  */
		  if (fsym && fsym->attr.allocatable
		      && fsym->attr.intent == INTENT_OUT)
		    {
		      stmtblock_t block;

		      gfc_init_block  (&block);
		      tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
							true, NULL);
		      gfc_add_expr_to_block (&block, tmp);
2994 2995 2996
		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
					     void_type_node, parmse.expr,
					     null_pointer_node);
2997 2998 2999 3000 3001 3002
		      gfc_add_expr_to_block (&block, tmp);

		      if (fsym->attr.optional
			  && e->expr_type == EXPR_VARIABLE
			  && e->symtree->n.sym->attr.optional)
			{
3003 3004
			  tmp = fold_build3_loc (input_location, COND_EXPR,
				     void_type_node,
3005 3006 3007 3008 3009 3010 3011 3012 3013 3014
				     gfc_conv_expr_present (e->symtree->n.sym),
					    gfc_finish_block (&block),
					    build_empty_stmt (input_location));
			}
		      else
			tmp = gfc_finish_block (&block);

		      gfc_add_expr_to_block (&se->pre, tmp);
		    }

3015 3016 3017
		  if (fsym && e->expr_type != EXPR_NULL
		      && ((fsym->attr.pointer
			   && fsym->attr.flavor != FL_PROCEDURE)
3018 3019
			  || (fsym->attr.proc_pointer
			      && !(e->expr_type == EXPR_VARIABLE
3020
			      && e->symtree->n.sym->attr.dummy))
3021
			  || (e->expr_type == EXPR_VARIABLE
3022 3023
			      && gfc_is_proc_ptr_comp (e, NULL))
			  || fsym->attr.allocatable))
3024 3025 3026 3027 3028
		    {
		      /* Scalar pointer dummy args require an extra level of
			 indirection. The null pointer already contains
			 this level of indirection.  */
		      parm_kind = SCALAR_POINTER;
3029
		      parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
3030 3031 3032
		    }
		}
	    }
dnovillo's avatar
 
dnovillo committed
3033 3034
	  else
	    {
eedelman's avatar
eedelman committed
3035 3036 3037 3038 3039 3040
              /* If the procedure requires an explicit interface, the actual
                 argument is passed according to the corresponding formal
                 argument.  If the corresponding formal argument is a POINTER,
                 ALLOCATABLE or assumed shape, we do not use g77's calling
                 convention, and pass the address of the array descriptor
                 instead. Otherwise we use g77's calling convention.  */
3041
	      bool f;
3042 3043
	      f = (fsym != NULL)
		  && !(fsym->attr.pointer || fsym->attr.allocatable)
3044
		  && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
3045 3046 3047 3048
	      if (comp)
		f = f || !comp->attr.always_explicit;
	      else
		f = f || !sym->attr.always_explicit;
3049

3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067
	      /* If the argument is a function call that may not create
		 a temporary for the result, we have to check that we
		 can do it, i.e. that there is no alias between this 
		 argument and another one.  */
	      if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
		{
		  sym_intent intent;

		  if (fsym != NULL)
		    intent = fsym->attr.intent;
		  else
		    intent = INTENT_UNKNOWN;

		  if (gfc_check_fncall_dependency (e, intent, sym, args,
						   NOT_ELEMENTAL))
		    parmse.force_tmp = 1;
		}

3068
	      if (e->expr_type == EXPR_VARIABLE
3069
		    && is_subref_array (e))
3070 3071 3072 3073
		/* The actual argument is a component reference to an
		   array of derived types.  In this case, the argument
		   is converted to a temporary, which is passed and then
		   written back after the procedure call.  */
3074
		gfc_conv_subref_array_arg (&parmse, e, f,
3075 3076
				fsym ? fsym->attr.intent : INTENT_INOUT,
				fsym && fsym->attr.pointer);
3077
	      else
3078
	        gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
jakub's avatar
jakub committed
3079
					  sym->name, NULL);
eedelman's avatar
eedelman committed
3080

3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091
	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
		 allocated on entry, it must be deallocated.  */
	      if (fsym && fsym->attr.allocatable
		  && fsym->attr.intent == INTENT_OUT)
		{
		  tmp = build_fold_indirect_ref_loc (input_location,
						     parmse.expr);
		  tmp = gfc_trans_dealloc_allocated (tmp);
		  if (fsym->attr.optional
		      && e->expr_type == EXPR_VARIABLE
		      && e->symtree->n.sym->attr.optional)
3092 3093
		    tmp = fold_build3_loc (input_location, COND_EXPR,
				     void_type_node,
3094 3095 3096 3097
				     gfc_conv_expr_present (e->symtree->n.sym),
				       tmp, build_empty_stmt (input_location));
		  gfc_add_expr_to_block (&se->pre, tmp);
		}
dnovillo's avatar
 
dnovillo committed
3098 3099 3100
	    } 
	}

fxcoudert's avatar
fxcoudert committed
3101 3102 3103 3104 3105 3106
      /* The case with fsym->attr.optional is that of a user subroutine
	 with an interface indicating an optional argument.  When we call
	 an intrinsic subroutine, however, fsym is NULL, but we might still
	 have an optional argument, so we proceed to the substitution
	 just in case.  */
      if (e && (fsym == NULL || fsym->attr.optional))
3107
	{
fxcoudert's avatar
fxcoudert committed
3108
	  /* If an optional argument is itself an optional dummy argument,
3109 3110 3111 3112
	     check its presence and substitute a null if absent.  This is
	     only needed when passing an array to an elemental procedure
	     as then array elements are accessed - or no NULL pointer is
	     allowed and a "1" or "0" should be passed if not present.
3113 3114 3115 3116 3117 3118
	     When passing a non-array-descriptor full array to a
	     non-array-descriptor dummy, no check is needed. For
	     array-descriptor actual to array-descriptor dummy, see
	     PR 41911 for why a check has to be inserted.
	     fsym == NULL is checked as intrinsics required the descriptor
	     but do not always set fsym.  */
fxcoudert's avatar
fxcoudert committed
3119
	  if (e->expr_type == EXPR_VARIABLE
3120 3121 3122
	      && e->symtree->n.sym->attr.optional
	      && ((e->rank > 0 && sym->attr.elemental)
		  || e->representation.length || e->ts.type == BT_CHARACTER
3123 3124 3125
		  || (e->rank > 0
		      && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
			  || fsym->as->type == AS_DEFERRED))))
3126 3127
	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
				    e->representation.length);
fxcoudert's avatar
fxcoudert committed
3128 3129 3130 3131 3132 3133 3134 3135 3136 3137
	}

      if (fsym && e)
	{
	  /* Obtain the character length of an assumed character length
	     length procedure from the typespec.  */
	  if (fsym->ts.type == BT_CHARACTER
	      && parmse.string_length == NULL_TREE
	      && e->ts.type == BT_PROCEDURE
	      && e->symtree->n.sym->ts.type == BT_CHARACTER
3138 3139
	      && e->symtree->n.sym->ts.u.cl->length != NULL
	      && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3140
	    {
3141 3142
	      gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
	      parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
3143 3144
	    }
	}
rsandifo's avatar
rsandifo committed
3145

3146
      if (fsym && need_interface_mapping && e)
3147
	gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
fxcoudert's avatar
fxcoudert committed
3148

dnovillo's avatar
 
dnovillo committed
3149
      gfc_add_block_to_block (&se->pre, &parmse.pre);
3150
      gfc_add_block_to_block (&post, &parmse.post);
dnovillo's avatar
 
dnovillo committed
3151

3152
      /* Allocated allocatable components of derived types must be
3153 3154
	 deallocated for non-variable scalars.  Non-variable arrays are
	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
3155
      if (e && e->ts.type == BT_DERIVED
3156
	    && e->ts.u.derived->attr.alloc_comp
3157
	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
3158
	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
3159 3160
        {
	  int parm_rank;
3161 3162
	  tmp = build_fold_indirect_ref_loc (input_location,
					 parmse.expr);
3163 3164 3165 3166 3167 3168 3169 3170 3171
	  parm_rank = e->rank;
	  switch (parm_kind)
	    {
	    case (ELEMENTAL):
	    case (SCALAR):
	      parm_rank = 0;
	      break;

	    case (SCALAR_POINTER):
3172 3173
              tmp = build_fold_indirect_ref_loc (input_location,
					     tmp);
3174 3175 3176
	      break;
	    }

3177 3178 3179 3180 3181 3182
	  if (e->expr_type == EXPR_OP
		&& e->value.op.op == INTRINSIC_PARENTHESES
		&& e->value.op.op1->expr_type == EXPR_VARIABLE)
	    {
	      tree local_tmp;
	      local_tmp = gfc_evaluate_now (tmp, &se->pre);
3183
	      local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
3184 3185 3186
	      gfc_add_expr_to_block (&se->post, local_tmp);
	    }

3187
	  tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
3188

3189
	  gfc_add_expr_to_block (&se->post, tmp);
3190 3191
        }

3192 3193 3194
      /* Add argument checking of passing an unallocated/NULL actual to
         a nonallocatable/nonpointer dummy.  */

3195
      if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
3196
        {
3197
	  symbol_attribute attr;
3198 3199 3200
	  char *msg;
	  tree cond;

3201 3202
	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
	    attr = gfc_expr_attr (e);
3203 3204 3205
	  else
	    goto end_pointer_check;

3206
          if (attr.optional)
3207 3208 3209 3210 3211 3212
	    {
              /* If the actual argument is an optional pointer/allocatable and
		 the formal argument takes an nonpointer optional value,
		 it is invalid to pass a non-present argument on, even
		 though there is no technical reason for this in gfortran.
		 See Fortran 2003, Section 12.4.1.6 item (7)+(8).  */
jason's avatar
jason committed
3213
	      tree present, null_ptr, type;
3214

3215
	      if (attr.allocatable
3216 3217 3218
		  && (fsym == NULL || !fsym->attr.allocatable))
		asprintf (&msg, "Allocatable actual argument '%s' is not "
			  "allocated or not present", e->symtree->n.sym->name);
3219
	      else if (attr.pointer
3220 3221 3222 3223
		       && (fsym == NULL || !fsym->attr.pointer))
		asprintf (&msg, "Pointer actual argument '%s' is not "
			  "associated or not present",
			  e->symtree->n.sym->name);
3224
	      else if (attr.proc_pointer
3225 3226 3227 3228 3229 3230 3231 3232 3233
		       && (fsym == NULL || !fsym->attr.proc_pointer))
		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
			  "associated or not present",
			  e->symtree->n.sym->name);
	      else
		goto end_pointer_check;

	      present = gfc_conv_expr_present (e->symtree->n.sym);
	      type = TREE_TYPE (present);
3234 3235 3236 3237
	      present = fold_build2_loc (input_location, EQ_EXPR,
					 boolean_type_node, present,
					 fold_convert (type,
						       null_pointer_node));
3238
	      type = TREE_TYPE (parmse.expr);
3239 3240 3241 3242 3243 3244
	      null_ptr = fold_build2_loc (input_location, EQ_EXPR,
					  boolean_type_node, parmse.expr,
					  fold_convert (type,
							null_pointer_node));
	      cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
				      boolean_type_node, present, null_ptr);
3245 3246 3247
	    }
          else
	    {
3248
	      if (attr.allocatable
3249 3250 3251
		  && (fsym == NULL || !fsym->attr.allocatable))
		asprintf (&msg, "Allocatable actual argument '%s' is not "
		      "allocated", e->symtree->n.sym->name);
3252
	      else if (attr.pointer
3253 3254 3255
		       && (fsym == NULL || !fsym->attr.pointer))
		asprintf (&msg, "Pointer actual argument '%s' is not "
		      "associated", e->symtree->n.sym->name);
3256
	      else if (attr.proc_pointer
3257 3258 3259 3260 3261 3262 3263
		       && (fsym == NULL || !fsym->attr.proc_pointer))
		asprintf (&msg, "Proc-pointer actual argument '%s' is not "
		      "associated", e->symtree->n.sym->name);
	      else
		goto end_pointer_check;


3264 3265 3266 3267
	      cond = fold_build2_loc (input_location, EQ_EXPR,
				      boolean_type_node, parmse.expr,
				      fold_convert (TREE_TYPE (parmse.expr),
						    null_pointer_node));
3268
	    }
3269 3270 3271 3272 3273 3274 3275 3276
 
	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
				   msg);
	  gfc_free (msg);
        }
      end_pointer_check:


3277
      /* Character strings are passed as two parameters, a length and a
3278 3279
         pointer - except for Bind(c) which only passes the pointer.  */
      if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
froydnj's avatar
gcc/  
froydnj committed
3280
	VEC_safe_push (tree, gc, stringargs, parmse.string_length);
dnovillo's avatar
 
dnovillo committed
3281

froydnj's avatar
gcc/  
froydnj committed
3282
      VEC_safe_push (tree, gc, arglist, parmse.expr);
dnovillo's avatar
 
dnovillo committed
3283
    }
rsandifo's avatar
rsandifo committed
3284 3285
  gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);

3286 3287 3288 3289 3290
  if (comp)
    ts = comp->ts;
  else
   ts = sym->ts;

3291 3292 3293
  if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
    se->string_length = build_int_cst (gfc_charlen_type_node, 1);
  else if (ts.type == BT_CHARACTER)
rsandifo's avatar
rsandifo committed
3294
    {
3295
      if (ts.u.cl->length == NULL)
3296 3297 3298
	{
	  /* Assumed character length results are not allowed by 5.1.1.5 of the
	     standard and are trapped in resolve.c; except in the case of SPREAD
3299 3300 3301 3302 3303
	     (and other intrinsics?) and dummy functions.  In the case of SPREAD,
	     we take the character length of the first argument for the result.
	     For dummies, we have to look through the formal argument list for
	     this function and use the character length found there.*/
	  if (!sym->attr.dummy)
froydnj's avatar
gcc/  
froydnj committed
3304
	    cl.backend_decl = VEC_index (tree, stringargs, 0);
3305 3306 3307 3308 3309
	  else
	    {
	      formal = sym->ns->proc_name->formal;
	      for (; formal; formal = formal->next)
		if (strcmp (formal->sym->name, sym->name) == 0)
3310
		  cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
3311 3312
	    }
        }
3313
      else
3314
        {
fxcoudert's avatar
fxcoudert committed
3315 3316
	  tree tmp;

3317 3318 3319
	  /* Calculate the length of the returned string.  */
	  gfc_init_se (&parmse, NULL);
	  if (need_interface_mapping)
3320
	    gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
3321
	  else
3322
	    gfc_conv_expr (&parmse, ts.u.cl->length);
3323 3324
	  gfc_add_block_to_block (&se->pre, &parmse.pre);
	  gfc_add_block_to_block (&se->post, &parmse.post);
fxcoudert's avatar
fxcoudert committed
3325 3326
	  
	  tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
3327 3328 3329
	  tmp = fold_build2_loc (input_location, MAX_EXPR,
				 gfc_charlen_type_node, tmp,
				 build_int_cst (gfc_charlen_type_node, 0));
fxcoudert's avatar
fxcoudert committed
3330
	  cl.backend_decl = tmp;
3331
	}
rsandifo's avatar
rsandifo committed
3332 3333 3334 3335

      /* Set up a charlen structure for it.  */
      cl.next = NULL;
      cl.length = NULL;
3336
      ts.u.cl = &cl;
rsandifo's avatar
rsandifo committed
3337 3338 3339 3340

      len = cl.backend_decl;
    }

3341
  byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
3342
	  || (!comp && gfc_return_by_reference (sym));
rsandifo's avatar
rsandifo committed
3343 3344 3345
  if (byref)
    {
      if (se->direct_byref)
3346
	{
rwild's avatar
rwild committed
3347
	  /* Sometimes, too much indirection can be applied; e.g. for
3348 3349 3350 3351 3352
	     function_result = array_valued_recursive_function.  */
	  if (TREE_TYPE (TREE_TYPE (se->expr))
		&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
		&& GFC_DESCRIPTOR_TYPE_P
			(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
3353 3354
	    se->expr = build_fold_indirect_ref_loc (input_location,
						se->expr);
3355

3356 3357
	  result = build_fold_indirect_ref_loc (input_location,
						se->expr);
froydnj's avatar
gcc/  
froydnj committed
3358
	  VEC_safe_push (tree, gc, retargs, se->expr);
3359
	}
3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379
      else if (comp && comp->attr.dimension)
	{
	  gcc_assert (se->loop && info);

	  /* Set the type of the array.  */
	  tmp = gfc_typenode_for_spec (&comp->ts);
	  info->dimen = se->loop->dimen;

	  /* Evaluate the bounds of the result, if known.  */
	  gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);

	  /* Create a temporary to store the result.  In case the function
	     returns a pointer, the temporary will be a shallow copy and
	     mustn't be deallocated.  */
	  callee_alloc = comp->attr.allocatable || comp->attr.pointer;
	  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
				       NULL_TREE, false, !comp->attr.pointer,
				       callee_alloc, &se->ss->expr->where);

	  /* Pass the temporary as the first argument.  */
3380 3381
	  result = info->descriptor;
	  tmp = gfc_build_addr_expr (NULL_TREE, result);
froydnj's avatar
gcc/  
froydnj committed
3382
	  VEC_safe_push (tree, gc, retargs, tmp);
3383
	}
3384
      else if (!comp && sym->result->attr.dimension)
rsandifo's avatar
rsandifo committed
3385 3386 3387 3388 3389 3390 3391
	{
	  gcc_assert (se->loop && info);

	  /* Set the type of the array.  */
	  tmp = gfc_typenode_for_spec (&ts);
	  info->dimen = se->loop->dimen;

rsandifo's avatar
rsandifo committed
3392 3393 3394
	  /* Evaluate the bounds of the result, if known.  */
	  gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);

eedelman's avatar
eedelman committed
3395 3396 3397 3398 3399
	  /* Create a temporary to store the result.  In case the function
	     returns a pointer, the temporary will be a shallow copy and
	     mustn't be deallocated.  */
	  callee_alloc = sym->attr.allocatable || sym->attr.pointer;
	  gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
domob's avatar
domob committed
3400 3401
				       NULL_TREE, false, !sym->attr.pointer,
				       callee_alloc, &se->ss->expr->where);
rsandifo's avatar
rsandifo committed
3402 3403

	  /* Pass the temporary as the first argument.  */
3404 3405
	  result = info->descriptor;
	  tmp = gfc_build_addr_expr (NULL_TREE, result);
froydnj's avatar
gcc/  
froydnj committed
3406
	  VEC_safe_push (tree, gc, retargs, tmp);
rsandifo's avatar
rsandifo committed
3407 3408 3409 3410
	}
      else if (ts.type == BT_CHARACTER)
	{
	  /* Pass the string length.  */
3411
	  type = gfc_get_character_type (ts.kind, ts.u.cl);
rsandifo's avatar
rsandifo committed
3412 3413 3414 3415
	  type = build_pointer_type (type);

	  /* Return an address to a char[0:len-1]* temporary for
	     character pointers.  */
3416 3417
	  if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
	       || (comp && (comp->attr.pointer || comp->attr.allocatable)))
rsandifo's avatar
rsandifo committed
3418
	    {
3419
	      var = gfc_create_var (type, "pstr");
rsandifo's avatar
rsandifo committed
3420

3421 3422 3423 3424 3425 3426
	      if ((!comp && sym->attr.allocatable)
		  || (comp && comp->attr.allocatable))
		gfc_add_modify (&se->pre, var,
				fold_convert (TREE_TYPE (var),
					      null_pointer_node));

rsandifo's avatar
rsandifo committed
3427
	      /* Provide an address expression for the function arguments.  */
3428
	      var = gfc_build_addr_expr (NULL_TREE, var);
rsandifo's avatar
rsandifo committed
3429 3430 3431 3432
	    }
	  else
	    var = gfc_conv_string_tmp (se, type, len);

froydnj's avatar
gcc/  
froydnj committed
3433
	  VEC_safe_push (tree, gc, retargs, var);
rsandifo's avatar
rsandifo committed
3434 3435 3436 3437 3438 3439
	}
      else
	{
	  gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);

	  type = gfc_get_complex_type (ts.kind);
3440
	  var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
froydnj's avatar
gcc/  
froydnj committed
3441
	  VEC_safe_push (tree, gc, retargs, var);
rsandifo's avatar
rsandifo committed
3442 3443 3444 3445
	}

      /* Add the string length to the argument list.  */
      if (ts.type == BT_CHARACTER)
froydnj's avatar
gcc/  
froydnj committed
3446
	VEC_safe_push (tree, gc, retargs, len);
rsandifo's avatar
rsandifo committed
3447
    }
rsandifo's avatar
rsandifo committed
3448
  gfc_free_interface_mapping (&mapping);
rsandifo's avatar
rsandifo committed
3449

froydnj's avatar
gcc/  
froydnj committed
3450 3451 3452 3453 3454
  /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS.  */
  arglen = (VEC_length (tree, arglist)
	    + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
  VEC_reserve_exact (tree, gc, retargs, arglen);

rsandifo's avatar
rsandifo committed
3455
  /* Add the return arguments.  */
froydnj's avatar
gcc/  
froydnj committed
3456
  VEC_splice (tree, retargs, arglist);
dnovillo's avatar
 
dnovillo committed
3457 3458

  /* Add the hidden string length parameters to the arguments.  */
froydnj's avatar
gcc/  
froydnj committed
3459
  VEC_splice (tree, retargs, stringargs);
dnovillo's avatar
 
dnovillo committed
3460

fxcoudert's avatar
fxcoudert committed
3461 3462
  /* We may want to append extra arguments here.  This is used e.g. for
     calls to libgfortran_matmul_??, which need extra information.  */
froydnj's avatar
gcc/  
froydnj committed
3463 3464 3465
  if (!VEC_empty (tree, append_args))
    VEC_splice (tree, retargs, append_args);
  arglist = retargs;
fxcoudert's avatar
fxcoudert committed
3466

dnovillo's avatar
 
dnovillo committed
3467
  /* Generate the actual call.  */
3468
  conv_function_val (se, sym, expr);
3469

dnovillo's avatar
 
dnovillo committed
3470
  /* If there are alternate return labels, function type should be
3471
     integer.  Can't modify the type in place though, since it can be shared
3472 3473
     with other functions.  For dummy arguments, the typing is done to
     to this result, even if it has to be repeated for each call.  */
3474 3475 3476
  if (has_alternate_specifier
      && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
    {
3477 3478 3479 3480 3481
      if (!sym->attr.dummy)
	{
	  TREE_TYPE (sym->backend_decl)
		= build_function_type (integer_type_node,
		      TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
3482
	  se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
3483 3484 3485
	}
      else
	TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
3486
    }
dnovillo's avatar
 
dnovillo committed
3487 3488

  fntype = TREE_TYPE (TREE_TYPE (se->expr));
froydnj's avatar
gcc/  
froydnj committed
3489
  se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
dnovillo's avatar
 
dnovillo committed
3490

tobi's avatar
tobi committed
3491 3492 3493 3494
  /* If we have a pointer function, but we don't want a pointer, e.g.
     something like
        x = f()
     where f is pointer valued, we have to dereference the result.  */
3495 3496
  if (!se->want_pointer && !byref
      && (sym->attr.pointer || sym->attr.allocatable)
3497
      && !gfc_is_proc_ptr_comp (expr, NULL))
3498 3499
    se->expr = build_fold_indirect_ref_loc (input_location,
					se->expr);
tobi's avatar
tobi committed
3500

tobi's avatar
tobi committed
3501 3502 3503 3504 3505 3506 3507 3508 3509
  /* f2c calling conventions require a scalar default real function to
     return a double precision result.  Convert this back to default
     real.  We only care about the cases that can happen in Fortran 77.
  */
  if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
      && sym->ts.kind == gfc_default_real_kind
      && !sym->attr.always_explicit)
    se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);

3510 3511
  /* A pure function may still have side-effects - it may modify its
     parameters.  */
dnovillo's avatar
 
dnovillo committed
3512 3513 3514 3515 3516 3517
  TREE_SIDE_EFFECTS (se->expr) = 1;
#if 0
  if (!sym->attr.pure)
    TREE_SIDE_EFFECTS (se->expr) = 1;
#endif

3518
  if (byref)
dnovillo's avatar
 
dnovillo committed
3519
    {
3520
      /* Add the function call to the pre chain.  There is no expression.  */
dnovillo's avatar
 
dnovillo committed
3521
      gfc_add_expr_to_block (&se->pre, se->expr);
3522
      se->expr = NULL_TREE;
dnovillo's avatar
 
dnovillo committed
3523

3524
      if (!se->direct_byref)
dnovillo's avatar
 
dnovillo committed
3525
	{
3526
	  if (sym->attr.dimension || (comp && comp->attr.dimension))
dnovillo's avatar
 
dnovillo committed
3527
	    {
3528
	      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3529 3530 3531
		{
		  /* Check the data pointer hasn't been modified.  This would
		     happen in a function returning a pointer.  */
3532
		  tmp = gfc_conv_descriptor_data_get (info->descriptor);
3533 3534 3535
		  tmp = fold_build2_loc (input_location, NE_EXPR,
					 boolean_type_node,
					 tmp, info->data);
3536 3537
		  gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
					   gfc_msg_fault);
3538 3539
		}
	      se->expr = info->descriptor;
3540 3541
	      /* Bundle in the string length.  */
	      se->string_length = len;
dnovillo's avatar
 
dnovillo committed
3542
	    }
3543
	  else if (ts.type == BT_CHARACTER)
kazu's avatar
kazu committed
3544
	    {
3545
	      /* Dereference for character pointer results.  */
3546 3547 3548
	      if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
		  || (comp && (comp->attr.pointer || comp->attr.allocatable)))
		se->expr = build_fold_indirect_ref_loc (input_location, var);
kazu's avatar
kazu committed
3549
	      else
3550 3551
	        se->expr = var;

3552 3553 3554
	      se->string_length = len;
	    }
	  else
tobi's avatar
tobi committed
3555
	    {
3556 3557
	      gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
	      se->expr = build_fold_indirect_ref_loc (input_location, var);
tobi's avatar
tobi committed
3558
	    }
dnovillo's avatar
 
dnovillo committed
3559 3560
	}
    }
3561

3562 3563
  /* Follow the function call with the argument post block.  */
  if (byref)
3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593
    {
      gfc_add_block_to_block (&se->pre, &post);

      /* Transformational functions of derived types with allocatable
         components must have the result allocatable components copied.  */
      arg = expr->value.function.actual;
      if (result && arg && expr->rank
	    && expr->value.function.isym
	    && expr->value.function.isym->transformational
	    && arg->expr->ts.type == BT_DERIVED
	    && arg->expr->ts.u.derived->attr.alloc_comp)
	{
	  tree tmp2;
	  /* Copy the allocatable components.  We have to use a
	     temporary here to prevent source allocatable components
	     from being corrupted.  */
	  tmp2 = gfc_evaluate_now (result, &se->pre);
	  tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
				     result, tmp2, expr->rank);
	  gfc_add_expr_to_block (&se->pre, tmp);
	  tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
				           expr->rank);
	  gfc_add_expr_to_block (&se->pre, tmp);

	  /* Finally free the temporary's data field.  */
	  tmp = gfc_conv_descriptor_data_get (tmp2);
	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
	  gfc_add_expr_to_block (&se->pre, tmp);
	}
    }
3594 3595 3596
  else
    gfc_add_block_to_block (&se->post, &post);

3597
  return has_alternate_specifier;
dnovillo's avatar
 
dnovillo committed
3598 3599 3600
}


3601 3602 3603 3604 3605 3606 3607 3608 3609 3610
/* Fill a character string with spaces.  */

static tree
fill_with_spaces (tree start, tree type, tree size)
{
  stmtblock_t block, loop;
  tree i, el, exit_label, cond, tmp;

  /* For a simple char type, we can call memset().  */
  if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3611 3612
    return build_call_expr_loc (input_location,
			    built_in_decls[BUILT_IN_MEMSET], 3, start,
3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624
			    build_int_cst (gfc_get_int_type (gfc_c_int_kind),
					   lang_hooks.to_target_charset (' ')),
			    size);

  /* Otherwise, we use a loop:
	for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
	  *el = (type) ' ';
   */

  /* Initialize variables.  */
  gfc_init_block (&block);
  i = gfc_create_var (sizetype, "i");
3625
  gfc_add_modify (&block, i, fold_convert (sizetype, size));
3626
  el = gfc_create_var (build_pointer_type (type), "el");
3627
  gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3628 3629 3630 3631 3632 3633 3634 3635
  exit_label = gfc_build_label_decl (NULL_TREE);
  TREE_USED (exit_label) = 1;


  /* Loop body.  */
  gfc_init_block (&loop);

  /* Exit condition.  */
3636
  cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
froydnj's avatar
gcc/  
froydnj committed
3637
			  build_zero_cst (sizetype));
3638
  tmp = build1_v (GOTO_EXPR, exit_label);
3639 3640
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
			 build_empty_stmt (input_location));
3641 3642 3643
  gfc_add_expr_to_block (&loop, tmp);

  /* Assignment.  */
3644 3645 3646
  gfc_add_modify (&loop,
		  fold_build1_loc (input_location, INDIRECT_REF, type, el),
		  build_int_cst (type, lang_hooks.to_target_charset (' ')));
3647 3648

  /* Increment loop variables.  */
3649 3650 3651 3652 3653 3654
  gfc_add_modify (&loop, i,
		  fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
				   TYPE_SIZE_UNIT (type)));
  gfc_add_modify (&loop, el,
		  fold_build2_loc (input_location, POINTER_PLUS_EXPR,
				   TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669

  /* Making the loop... actually loop!  */
  tmp = gfc_finish_block (&loop);
  tmp = build1_v (LOOP_EXPR, tmp);
  gfc_add_expr_to_block (&block, tmp);

  /* The exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (&block, tmp);


  return gfc_finish_block (&block);
}


pbrook's avatar
pbrook committed
3670 3671
/* Generate code to copy a string.  */

3672
void
3673
gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3674
		       int dkind, tree slength, tree src, int skind)
pbrook's avatar
pbrook committed
3675
{
3676
  tree tmp, dlen, slen;
fengwang's avatar
fengwang committed
3677 3678
  tree dsc;
  tree ssc;
fxcoudert's avatar
fxcoudert committed
3679
  tree cond;
fxcoudert's avatar
fxcoudert committed
3680 3681 3682 3683
  tree cond2;
  tree tmp2;
  tree tmp3;
  tree tmp4;
3684
  tree chartype;
fxcoudert's avatar
fxcoudert committed
3685
  stmtblock_t tempblock;
fengwang's avatar
fengwang committed
3686

3687 3688
  gcc_assert (dkind == skind);

3689 3690 3691
  if (slength != NULL_TREE)
    {
      slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3692
      ssc = gfc_string_to_single_character (slen, src, skind);
3693 3694 3695 3696 3697 3698 3699 3700 3701 3702
    }
  else
    {
      slen = build_int_cst (size_type_node, 1);
      ssc =  src;
    }

  if (dlength != NULL_TREE)
    {
      dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3703
      dsc = gfc_string_to_single_character (dlen, dest, dkind);
3704 3705 3706 3707 3708 3709 3710
    }
  else
    {
      dlen = build_int_cst (size_type_node, 1);
      dsc =  dest;
    }

3711 3712
  /* Assign directly if the types are compatible.  */
  if (dsc != NULL_TREE && ssc != NULL_TREE
3713
      && TREE_TYPE (dsc) == TREE_TYPE (ssc))
fengwang's avatar
fengwang committed
3714
    {
3715
      gfc_add_modify (block, dsc, ssc);
fengwang's avatar
fengwang committed
3716 3717
      return;
    }
pbrook's avatar
pbrook committed
3718

fxcoudert's avatar
fxcoudert committed
3719
  /* Do nothing if the destination length is zero.  */
3720 3721
  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
			  build_int_cst (size_type_node, 0));
fxcoudert's avatar
fxcoudert committed
3722

fxcoudert's avatar
fxcoudert committed
3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744
  /* The following code was previously in _gfortran_copy_string:

       // The two strings may overlap so we use memmove.
       void
       copy_string (GFC_INTEGER_4 destlen, char * dest,
                    GFC_INTEGER_4 srclen, const char * src)
       {
         if (srclen >= destlen)
           {
             // This will truncate if too long.
             memmove (dest, src, destlen);
           }
         else
           {
             memmove (dest, src, srclen);
             // Pad with spaces.
             memset (&dest[srclen], ' ', destlen - srclen);
           }
       }

     We're now doing it here for better optimization, but the logic
     is the same.  */
3745

3746 3747 3748
  /* For non-default character kinds, we have to multiply the string
     length by the base type size.  */
  chartype = gfc_get_char_type (dkind);
3749 3750 3751 3752 3753 3754 3755 3756
  slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
			  fold_convert (size_type_node, slen),
			  fold_convert (size_type_node,
					TYPE_SIZE_UNIT (chartype)));
  dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
			  fold_convert (size_type_node, dlen),
			  fold_convert (size_type_node,
					TYPE_SIZE_UNIT (chartype)));
3757

3758 3759 3760 3761 3762 3763 3764 3765 3766
  if (dlength)
    dest = fold_convert (pvoid_type_node, dest);
  else
    dest = gfc_build_addr_expr (pvoid_type_node, dest);

  if (slength)
    src = fold_convert (pvoid_type_node, src);
  else
    src = gfc_build_addr_expr (pvoid_type_node, src);
3767

fxcoudert's avatar
fxcoudert committed
3768
  /* Truncate string if source is too long.  */
3769 3770
  cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
			   dlen);
3771 3772
  tmp2 = build_call_expr_loc (input_location,
			  built_in_decls[BUILT_IN_MEMMOVE],
3773
			  3, dest, src, dlen);
fxcoudert's avatar
fxcoudert committed
3774 3775

  /* Else copy and pad with spaces.  */
3776 3777
  tmp3 = build_call_expr_loc (input_location,
			  built_in_decls[BUILT_IN_MEMMOVE],
3778
			  3, dest, src, slen);
fxcoudert's avatar
fxcoudert committed
3779

3780 3781
  tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
			  dest, fold_convert (sizetype, slen));
3782
  tmp4 = fill_with_spaces (tmp4, chartype,
3783 3784
			   fold_build2_loc (input_location, MINUS_EXPR,
					    TREE_TYPE(dlen), dlen, slen));
fxcoudert's avatar
fxcoudert committed
3785 3786 3787 3788 3789 3790 3791

  gfc_init_block (&tempblock);
  gfc_add_expr_to_block (&tempblock, tmp3);
  gfc_add_expr_to_block (&tempblock, tmp4);
  tmp3 = gfc_finish_block (&tempblock);

  /* The whole copy_string function is there.  */
3792 3793 3794 3795
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
			 tmp2, tmp3);
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
			 build_empty_stmt (input_location));
pbrook's avatar
pbrook committed
3796 3797 3798 3799
  gfc_add_expr_to_block (block, tmp);
}


dnovillo's avatar
 
dnovillo committed
3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813
/* Translate a statement function.
   The value of a statement function reference is obtained by evaluating the
   expression using the values of the actual arguments for the values of the
   corresponding dummy arguments.  */

static void
gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
{
  gfc_symbol *sym;
  gfc_symbol *fsym;
  gfc_formal_arglist *fargs;
  gfc_actual_arglist *args;
  gfc_se lse;
  gfc_se rse;
pbrook's avatar
pbrook committed
3814 3815 3816 3817 3818
  gfc_saved_var *saved_vars;
  tree *temp_vars;
  tree type;
  tree tmp;
  int n;
dnovillo's avatar
 
dnovillo committed
3819 3820 3821 3822 3823 3824

  sym = expr->symtree->n.sym;
  args = expr->value.function.actual;
  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

pbrook's avatar
pbrook committed
3825
  n = 0;
dnovillo's avatar
 
dnovillo committed
3826
  for (fargs = sym->formal; fargs; fargs = fargs->next)
pbrook's avatar
pbrook committed
3827 3828 3829 3830 3831
    n++;
  saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
  temp_vars = (tree *)gfc_getmem (n * sizeof (tree));

  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
dnovillo's avatar
 
dnovillo committed
3832 3833 3834
    {
      /* Each dummy shall be specified, explicitly or implicitly, to be
         scalar.  */
pbrook's avatar
pbrook committed
3835
      gcc_assert (fargs->sym->attr.dimension == 0);
dnovillo's avatar
 
dnovillo committed
3836 3837
      fsym = fargs->sym;

pbrook's avatar
pbrook committed
3838 3839 3840 3841 3842
      /* Create a temporary to hold the value.  */
      type = gfc_typenode_for_spec (&fsym->ts);
      temp_vars[n] = gfc_create_var (type, fsym->name);

      if (fsym->ts.type == BT_CHARACTER)
dnovillo's avatar
 
dnovillo committed
3843
        {
pbrook's avatar
pbrook committed
3844 3845
	  /* Copy string arguments.  */
          tree arglen;
dnovillo's avatar
 
dnovillo committed
3846

3847 3848
          gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
		      && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
dnovillo's avatar
 
dnovillo committed
3849

pbrook's avatar
pbrook committed
3850 3851 3852
          arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
          tmp = gfc_build_addr_expr (build_pointer_type (type),
				     temp_vars[n]);
dnovillo's avatar
 
dnovillo committed
3853 3854 3855 3856 3857 3858

          gfc_conv_expr (&rse, args->expr);
          gfc_conv_string_parameter (&rse);
          gfc_add_block_to_block (&se->pre, &lse.pre);
          gfc_add_block_to_block (&se->pre, &rse.pre);

3859 3860
	  gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
				 rse.string_length, rse.expr, fsym->ts.kind);
dnovillo's avatar
 
dnovillo committed
3861 3862 3863 3864 3865 3866 3867 3868 3869
          gfc_add_block_to_block (&se->pre, &lse.post);
          gfc_add_block_to_block (&se->pre, &rse.post);
        }
      else
        {
          /* For everything else, just evaluate the expression.  */
          gfc_conv_expr (&lse, args->expr);

          gfc_add_block_to_block (&se->pre, &lse.pre);
3870
          gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
dnovillo's avatar
 
dnovillo committed
3871 3872
          gfc_add_block_to_block (&se->pre, &lse.post);
        }
pbrook's avatar
pbrook committed
3873

dnovillo's avatar
 
dnovillo committed
3874 3875
      args = args->next;
    }
pbrook's avatar
pbrook committed
3876 3877 3878 3879 3880

  /* Use the temporary variables in place of the real ones.  */
  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
    gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);

dnovillo's avatar
 
dnovillo committed
3881
  gfc_conv_expr (se, sym->value);
pbrook's avatar
pbrook committed
3882 3883 3884

  if (sym->ts.type == BT_CHARACTER)
    {
3885
      gfc_conv_const_charlen (sym->ts.u.cl);
pbrook's avatar
pbrook committed
3886 3887 3888 3889

      /* Force the expression to the correct length.  */
      if (!INTEGER_CST_P (se->string_length)
	  || tree_int_cst_lt (se->string_length,
3890
			      sym->ts.u.cl->backend_decl))
pbrook's avatar
pbrook committed
3891
	{
3892
	  type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
pbrook's avatar
pbrook committed
3893 3894
	  tmp = gfc_create_var (type, sym->name);
	  tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3895
	  gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
3896 3897
				 sym->ts.kind, se->string_length, se->expr,
				 sym->ts.kind);
pbrook's avatar
pbrook committed
3898 3899
	  se->expr = tmp;
	}
3900
      se->string_length = sym->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
3901 3902
    }

3903
  /* Restore the original variables.  */
pbrook's avatar
pbrook committed
3904 3905 3906
  for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
    gfc_restore_sym (fargs->sym, &saved_vars[n]);
  gfc_free (saved_vars);
dnovillo's avatar
 
dnovillo committed
3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922
}


/* Translate a function expression.  */

static void
gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
{
  gfc_symbol *sym;

  if (expr->value.function.isym)
    {
      gfc_conv_intrinsic_function (se, expr);
      return;
    }

3923
  /* We distinguish statement functions from general functions to improve
dnovillo's avatar
 
dnovillo committed
3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935
     runtime performance.  */
  if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
    {
      gfc_conv_statement_function (se, expr);
      return;
    }

  /* expr.value.function.esym is the resolved (specific) function symbol for
     most functions.  However this isn't set for dummy procedures.  */
  sym = expr->value.function.esym;
  if (!sym)
    sym = expr->symtree->n.sym;
3936

froydnj's avatar
gcc/  
froydnj committed
3937
  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
dnovillo's avatar
 
dnovillo committed
3938 3939
}

3940

3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977
/* Determine whether the given EXPR_CONSTANT is a zero initializer.  */

static bool
is_zero_initializer_p (gfc_expr * expr)
{
  if (expr->expr_type != EXPR_CONSTANT)
    return false;

  /* We ignore constants with prescribed memory representations for now.  */
  if (expr->representation.string)
    return false;

  switch (expr->ts.type)
    {
    case BT_INTEGER:
      return mpz_cmp_si (expr->value.integer, 0) == 0;

    case BT_REAL:
      return mpfr_zero_p (expr->value.real)
	     && MPFR_SIGN (expr->value.real) >= 0;

    case BT_LOGICAL:
      return expr->value.logical == 0;

    case BT_COMPLEX:
      return mpfr_zero_p (mpc_realref (expr->value.complex))
	     && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
             && mpfr_zero_p (mpc_imagref (expr->value.complex))
	     && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;

    default:
      break;
    }
  return false;
}


dnovillo's avatar
 
dnovillo committed
3978 3979 3980
static void
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
{
pbrook's avatar
pbrook committed
3981 3982
  gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
  gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
dnovillo's avatar
 
dnovillo committed
3983 3984 3985 3986 3987

  gfc_conv_tmp_array_ref (se);
}


3988
/* Build a static initializer.  EXPR is the expression for the initial value.
3989 3990
   The other parameters describe the variable of the component being 
   initialized. EXPR may be null.  */
dnovillo's avatar
 
dnovillo committed
3991

3992 3993
tree
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3994
		      bool array, bool pointer, bool procptr)
3995 3996 3997
{
  gfc_se se;

3998
  if (!(expr || pointer || procptr))
3999 4000
    return NULL_TREE;

4001 4002 4003 4004
  /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
     (these are the only two iso_c_binding derived types that can be
     used as initialization expressions).  If so, we need to modify
     the 'expr' to be that for a (void *).  */
4005
  if (expr != NULL && expr->ts.type == BT_DERIVED
4006
      && expr->ts.is_iso_c && expr->ts.u.derived)
4007
    {
4008
      gfc_symbol *derived = expr->ts.u.derived;
4009 4010 4011

      /* The derived symbol has already been converted to a (void *).  Use
	 its kind.  */
4012
      expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
4013
      expr->ts.f90_type = derived->ts.f90_type;
4014 4015 4016

      gfc_init_se (&se, NULL);
      gfc_conv_constant (&se, expr);
4017
      gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4018
      return se.expr;
4019
    }
4020
  
4021
  if (array && !procptr)
4022
    {
4023
      tree ctor;
4024 4025
      /* Arrays need special handling.  */
      if (pointer)
4026
	ctor = gfc_build_null_descriptor (type);
4027 4028
      /* Special case assigning an array to zero.  */
      else if (is_zero_initializer_p (expr))
4029
        ctor = build_constructor (type, NULL);
4030
      else
4031 4032 4033
	ctor = gfc_conv_array_initializer (type, expr);
      TREE_STATIC (ctor) = 1;
      return ctor;
4034
    }
4035
  else if (pointer || procptr)
4036 4037 4038 4039 4040 4041 4042 4043
    {
      if (!expr || expr->expr_type == EXPR_NULL)
	return fold_convert (type, null_pointer_node);
      else
	{
	  gfc_init_se (&se, NULL);
	  se.want_pointer = 1;
	  gfc_conv_expr (&se, expr);
4044
          gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4045 4046 4047
	  return se.expr;
	}
    }
4048 4049 4050 4051 4052
  else
    {
      switch (ts->type)
	{
	case BT_DERIVED:
burnus's avatar
burnus committed
4053
	case BT_CLASS:
4054
	  gfc_init_se (&se, NULL);
4055 4056 4057 4058
	  if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
	    gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
	  else
	    gfc_conv_structure (&se, expr, 1);
4059 4060
	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
	  TREE_STATIC (se.expr) = 1;
4061 4062 4063
	  return se.expr;

	case BT_CHARACTER:
4064 4065 4066 4067 4068
	  {
	    tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
	    TREE_STATIC (ctor) = 1;
	    return ctor;
	  }
4069 4070 4071 4072

	default:
	  gfc_init_se (&se, NULL);
	  gfc_conv_constant (&se, expr);
4073
	  gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
4074 4075 4076 4077 4078
	  return se.expr;
	}
    }
}
  
pbrook's avatar
pbrook committed
4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
  gfc_se rse;
  gfc_se lse;
  gfc_ss *rss;
  gfc_ss *lss;
  stmtblock_t body;
  stmtblock_t block;
  gfc_loopinfo loop;
  int n;
  tree tmp;

  gfc_start_block (&block);

  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop);

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  /* Walk the rhs.  */
  rss = gfc_walk_expr (expr);
  if (rss == gfc_ss_terminator)
    {
      /* The rhs is scalar.  Add a ss for the expression.  */
      rss = gfc_get_ss ();
      rss->next = gfc_ss_terminator;
      rss->type = GFC_SS_SCALAR;
      rss->expr = expr;
    }

  /* Create a SS for the destination.  */
  lss = gfc_get_ss ();
  lss->type = GFC_SS_COMPONENT;
  lss->expr = NULL;
  lss->shape = gfc_get_shape (cm->as->rank);
  lss->next = gfc_ss_terminator;
  lss->data.info.dimen = cm->as->rank;
  lss->data.info.descriptor = dest;
  lss->data.info.data = gfc_conv_array_data (dest);
  lss->data.info.offset = gfc_conv_array_offset (dest);
  for (n = 0; n < cm->as->rank; n++)
    {
      lss->data.info.dim[n] = n;
      lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
      lss->data.info.stride[n] = gfc_index_one_node;

      mpz_init (lss->shape[n]);
      mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
	       cm->as->lower[n]->value.integer);
      mpz_add_ui (lss->shape[n], lss->shape[n], 1);
    }
  
  /* Associate the SS with the loop.  */
  gfc_add_ss_to_loop (&loop, lss);
  gfc_add_ss_to_loop (&loop, rss);

  /* Calculate the bounds of the scalarization.  */
  gfc_conv_ss_startstride (&loop);

  /* Setup the scalarizing loops.  */
4141
  gfc_conv_loop_setup (&loop, &expr->where);
pbrook's avatar
pbrook committed
4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155

  /* Setup the gfc_se structures.  */
  gfc_copy_loopinfo_to_se (&lse, &loop);
  gfc_copy_loopinfo_to_se (&rse, &loop);

  rse.ss = rss;
  gfc_mark_ss_chain_used (rss, 1);
  lse.ss = lss;
  gfc_mark_ss_chain_used (lss, 1);

  /* Start the scalarized loop body.  */
  gfc_start_scalarized_body (&loop, &body);

  gfc_conv_tmp_array_ref (&lse);
4156
  if (cm->ts.type == BT_CHARACTER)
4157
    lse.string_length = cm->ts.u.cl->backend_decl;
4158

pbrook's avatar
pbrook committed
4159 4160
  gfc_conv_expr (&rse, expr);

4161
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
pbrook's avatar
pbrook committed
4162 4163
  gfc_add_expr_to_block (&body, tmp);

pbrook's avatar
pbrook committed
4164
  gcc_assert (rse.ss == gfc_ss_terminator);
pbrook's avatar
pbrook committed
4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176

  /* Generate the copying loops.  */
  gfc_trans_scalarizing_loops (&loop, &body);

  /* Wrap the whole thing up.  */
  gfc_add_block_to_block (&block, &loop.pre);
  gfc_add_block_to_block (&block, &loop.post);

  for (n = 0; n < cm->as->rank; n++)
    mpz_clear (lss->shape[n]);
  gfc_free (lss->shape);

pbrook's avatar
pbrook committed
4177 4178
  gfc_cleanup_loop (&loop);

pbrook's avatar
pbrook committed
4179 4180 4181
  return gfc_finish_block (&block);
}

4182

4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
				 gfc_expr * expr)
{
  gfc_se se;
  gfc_ss *rss;
  stmtblock_t block;
  tree offset;
  int n;
  tree tmp;
  tree tmp2;
  gfc_array_spec *as;
  gfc_expr *arg = NULL;

  gfc_start_block (&block);
  gfc_init_se (&se, NULL);

  /* Get the descriptor for the expressions.  */ 
  rss = gfc_walk_expr (expr);
  se.want_pointer = 0;
  gfc_conv_expr_descriptor (&se, expr, rss);
  gfc_add_block_to_block (&block, &se.pre);
  gfc_add_modify (&block, dest, se.expr);

  /* Deal with arrays of derived types with allocatable components.  */
  if (cm->ts.type == BT_DERIVED
	&& cm->ts.u.derived->attr.alloc_comp)
    tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
			       se.expr, dest,
			       cm->as->rank);
  else
    tmp = gfc_duplicate_allocatable (dest, se.expr,
				     TREE_TYPE(cm->backend_decl),
				     cm->as->rank);

  gfc_add_expr_to_block (&block, tmp);
  gfc_add_block_to_block (&block, &se.post);

  if (expr->expr_type != EXPR_VARIABLE)
    gfc_conv_descriptor_data_set (&block, se.expr,
				  null_pointer_node);

  /* We need to know if the argument of a conversion function is a
     variable, so that the correct lower bound can be used.  */
  if (expr->expr_type == EXPR_FUNCTION
	&& expr->value.function.isym
	&& expr->value.function.isym->conversion
	&& expr->value.function.actual->expr
	&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
    arg = expr->value.function.actual->expr;

  /* Obtain the array spec of full array references.  */
  if (arg)
    as = gfc_get_full_arrayspec_from_expr (arg);
  else
    as = gfc_get_full_arrayspec_from_expr (expr);

  /* Shift the lbound and ubound of temporaries to being unity,
     rather than zero, based. Always calculate the offset.  */
  offset = gfc_conv_descriptor_offset_get (dest);
  gfc_add_modify (&block, offset, gfc_index_zero_node);
  tmp2 =gfc_create_var (gfc_array_index_type, NULL);

  for (n = 0; n < expr->rank; n++)
    {
      tree span;
      tree lbound;

      /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
	 TODO It looks as if gfc_conv_expr_descriptor should return
	 the correct bounds and that the following should not be
	 necessary.  This would simplify gfc_conv_intrinsic_bound
	 as well.  */
      if (as && as->lower[n])
	{
	  gfc_se lbse;
	  gfc_init_se (&lbse, NULL);
	  gfc_conv_expr (&lbse, as->lower[n]);
	  gfc_add_block_to_block (&block, &lbse.pre);
	  lbound = gfc_evaluate_now (lbse.expr, &block);
	}
      else if (as && arg)
	{
	  tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
	  lbound = gfc_conv_descriptor_lbound_get (tmp,
					gfc_rank_cst[n]);
	}
      else if (as)
	lbound = gfc_conv_descriptor_lbound_get (dest,
						gfc_rank_cst[n]);
      else
	lbound = gfc_index_one_node;

      lbound = fold_convert (gfc_array_index_type, lbound);

      /* Shift the bounds and set the offset accordingly.  */
      tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
4280 4281 4282 4283
      span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
		tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
			     span, lbound);
4284 4285 4286 4287 4288
      gfc_conv_descriptor_ubound_set (&block, dest,
				      gfc_rank_cst[n], tmp);
      gfc_conv_descriptor_lbound_set (&block, dest,
				      gfc_rank_cst[n], lbound);

4289
      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4290 4291 4292 4293 4294
			 gfc_conv_descriptor_lbound_get (dest,
							 gfc_rank_cst[n]),
			 gfc_conv_descriptor_stride_get (dest,
							 gfc_rank_cst[n]));
      gfc_add_modify (&block, tmp2, tmp);
4295 4296
      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
			     offset, tmp2);
4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315
      gfc_conv_descriptor_offset_set (&block, dest, tmp);
    }

  if (arg)
    {
      /* If a conversion expression has a null data pointer
	 argument, nullify the allocatable component.  */
      tree non_null_expr;
      tree null_expr;

      if (arg->symtree->n.sym->attr.allocatable
	    || arg->symtree->n.sym->attr.pointer)
	{
	  non_null_expr = gfc_finish_block (&block);
	  gfc_start_block (&block);
	  gfc_conv_descriptor_data_set (&block, dest,
					null_pointer_node);
	  null_expr = gfc_finish_block (&block);
	  tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
4316 4317
	  tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
			    fold_convert (TREE_TYPE (tmp), null_pointer_node));
4318 4319 4320 4321 4322 4323 4324 4325 4326
	  return build3_v (COND_EXPR, tmp,
			   null_expr, non_null_expr);
	}
    }

  return gfc_finish_block (&block);
}


pbrook's avatar
pbrook committed
4327 4328 4329 4330 4331 4332
/* Assign a single component of a derived type constructor.  */

static tree
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
  gfc_se se;
4333
  gfc_se lse;
pbrook's avatar
pbrook committed
4334 4335 4336 4337 4338
  gfc_ss *rss;
  stmtblock_t block;
  tree tmp;

  gfc_start_block (&block);
4339

4340
  if (cm->attr.pointer)
pbrook's avatar
pbrook committed
4341 4342 4343
    {
      gfc_init_se (&se, NULL);
      /* Pointer component.  */
4344
      if (cm->attr.dimension)
pbrook's avatar
pbrook committed
4345 4346 4347
	{
	  /* Array pointer.  */
	  if (expr->expr_type == EXPR_NULL)
4348
	    gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
pbrook's avatar
pbrook committed
4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364
	  else
	    {
	      rss = gfc_walk_expr (expr);
	      se.direct_byref = 1;
	      se.expr = dest;
	      gfc_conv_expr_descriptor (&se, expr, rss);
	      gfc_add_block_to_block (&block, &se.pre);
	      gfc_add_block_to_block (&block, &se.post);
	    }
	}
      else
	{
	  /* Scalar pointers.  */
	  se.want_pointer = 1;
	  gfc_conv_expr (&se, expr);
	  gfc_add_block_to_block (&block, &se.pre);
4365
	  gfc_add_modify (&block, dest,
pbrook's avatar
pbrook committed
4366 4367 4368 4369
			       fold_convert (TREE_TYPE (dest), se.expr));
	  gfc_add_block_to_block (&block, &se.post);
	}
    }
burnus's avatar
burnus committed
4370 4371 4372 4373
  else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
    {
      /* NULL initialization for CLASS components.  */
      tmp = gfc_trans_structure_assign (dest,
4374
					gfc_class_null_initializer (&cm->ts));
burnus's avatar
burnus committed
4375 4376
      gfc_add_expr_to_block (&block, tmp);
    }
4377
  else if (cm->attr.dimension)
pbrook's avatar
pbrook committed
4378
    {
4379
      if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
4380
 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
4381
      else if (cm->attr.allocatable)
4382
	{
4383
	  tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
4384 4385
	  gfc_add_expr_to_block (&block, tmp);
	}
4386
      else
4387
	{
4388 4389
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
	  gfc_add_expr_to_block (&block, tmp);
4390
	}
pbrook's avatar
pbrook committed
4391 4392 4393
    }
  else if (expr->ts.type == BT_DERIVED)
    {
4394 4395 4396 4397
      if (expr->expr_type != EXPR_STRUCTURE)
	{
	  gfc_init_se (&se, NULL);
	  gfc_conv_expr (&se, expr);
4398
	  gfc_add_block_to_block (&block, &se.pre);
4399
	  gfc_add_modify (&block, dest,
4400
			       fold_convert (TREE_TYPE (dest), se.expr));
4401
	  gfc_add_block_to_block (&block, &se.post);
4402 4403 4404 4405 4406 4407 4408
	}
      else
	{
	  /* Nested constructors.  */
	  tmp = gfc_trans_structure_assign (dest, expr);
	  gfc_add_expr_to_block (&block, tmp);
	}
pbrook's avatar
pbrook committed
4409 4410 4411 4412 4413 4414 4415 4416 4417
    }
  else
    {
      /* Scalar component.  */
      gfc_init_se (&se, NULL);
      gfc_init_se (&lse, NULL);

      gfc_conv_expr (&se, expr);
      if (cm->ts.type == BT_CHARACTER)
4418
	lse.string_length = cm->ts.u.cl->backend_decl;
pbrook's avatar
pbrook committed
4419
      lse.expr = dest;
4420
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
pbrook's avatar
pbrook committed
4421 4422 4423 4424 4425
      gfc_add_expr_to_block (&block, tmp);
    }
  return gfc_finish_block (&block);
}

4426
/* Assign a derived type constructor to a variable.  */
pbrook's avatar
pbrook committed
4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437

static tree
gfc_trans_structure_assign (tree dest, gfc_expr * expr)
{
  gfc_constructor *c;
  gfc_component *cm;
  stmtblock_t block;
  tree field;
  tree tmp;

  gfc_start_block (&block);
4438
  cm = expr->ts.u.derived->components;
4439 4440
  for (c = gfc_constructor_first (expr->value.constructor);
       c; c = gfc_constructor_next (c), cm = cm->next)
pbrook's avatar
pbrook committed
4441 4442 4443
    {
      /* Skip absent members in default initializers.  */
      if (!c->expr)
4444 4445
	continue;

4446 4447 4448 4449
      /* Handle c_null_(fun)ptr.  */
      if (c && c->expr && c->expr->ts.is_iso_c)
	{
	  field = cm->backend_decl;
4450 4451 4452 4453 4454 4455
	  tmp = fold_build3_loc (input_location, COMPONENT_REF,
				 TREE_TYPE (field),
				 dest, field, NULL_TREE);
	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
				 tmp, fold_convert (TREE_TYPE (tmp),
						    null_pointer_node));
4456 4457 4458 4459
	  gfc_add_expr_to_block (&block, tmp);
	  continue;
	}

pbrook's avatar
pbrook committed
4460
      field = cm->backend_decl;
4461 4462
      tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
			     dest, field, NULL_TREE);
pbrook's avatar
pbrook committed
4463 4464 4465 4466 4467 4468
      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
      gfc_add_expr_to_block (&block, tmp);
    }
  return gfc_finish_block (&block);
}

dnovillo's avatar
 
dnovillo committed
4469 4470 4471 4472 4473 4474 4475 4476 4477 4478
/* Build an expression for a constructor. If init is nonzero then
   this is part of a static variable initializer.  */

void
gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
{
  gfc_constructor *c;
  gfc_component *cm;
  tree val;
  tree type;
pbrook's avatar
pbrook committed
4479
  tree tmp;
4480
  VEC(constructor_elt,gc) *v = NULL;
dnovillo's avatar
 
dnovillo committed
4481

pbrook's avatar
pbrook committed
4482 4483
  gcc_assert (se->ss == NULL);
  gcc_assert (expr->expr_type == EXPR_STRUCTURE);
dnovillo's avatar
 
dnovillo committed
4484
  type = gfc_typenode_for_spec (&expr->ts);
pbrook's avatar
pbrook committed
4485 4486 4487 4488

  if (!init)
    {
      /* Create a temporary variable and fill it in.  */
4489
      se->expr = gfc_create_var (type, expr->ts.u.derived->name);
pbrook's avatar
pbrook committed
4490 4491 4492 4493 4494
      tmp = gfc_trans_structure_assign (se->expr, expr);
      gfc_add_expr_to_block (&se->pre, tmp);
      return;
    }

4495
  cm = expr->ts.u.derived->components;
4496

4497 4498
  for (c = gfc_constructor_first (expr->value.constructor);
       c; c = gfc_constructor_next (c), cm = cm->next)
dnovillo's avatar
 
dnovillo committed
4499
    {
4500 4501 4502 4503
      /* Skip absent members in default initializers and allocatable
	 components.  Although the latter have a default initializer
	 of EXPR_NULL,... by default, the static nullify is not needed
	 since this is done every time we come into scope.  */
4504
      if (!c->expr || cm->attr.allocatable)
dnovillo's avatar
 
dnovillo committed
4505 4506
        continue;

4507
      if (strcmp (cm->name, "_size") == 0)
janus's avatar
janus committed
4508 4509 4510 4511 4512
	{
	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
	}
      else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
4513
	       && strcmp (cm->name, "_extends") == 0)
janus's avatar
janus committed
4514
	{
4515
	  tree vtab;
janus's avatar
janus committed
4516 4517
	  gfc_symbol *vtabs;
	  vtabs = cm->initializer->symtree->n.sym;
4518 4519
	  vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
burnus's avatar
burnus committed
4520 4521 4522 4523
	}
      else
	{
	  val = gfc_conv_initializer (c->expr, &cm->ts,
4524 4525 4526
				      TREE_TYPE (cm->backend_decl),
				      cm->attr.dimension, cm->attr.pointer,
				      cm->attr.proc_pointer);
dnovillo's avatar
 
dnovillo committed
4527

burnus's avatar
burnus committed
4528 4529 4530
	  /* Append it to the constructor list.  */
	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
	}
dnovillo's avatar
 
dnovillo committed
4531
    }
4532
  se->expr = build_constructor (type, v);
4533
  if (init) 
4534
    TREE_CONSTANT (se->expr) = 1;
dnovillo's avatar
 
dnovillo committed
4535 4536 4537
}


4538
/* Translate a substring expression.  */
dnovillo's avatar
 
dnovillo committed
4539 4540 4541 4542 4543 4544 4545 4546

static void
gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
{
  gfc_ref *ref;

  ref = expr->ref;

fxcoudert's avatar
fxcoudert committed
4547
  gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
dnovillo's avatar
 
dnovillo committed
4548

4549 4550 4551
  se->expr = gfc_build_wide_string_const (expr->ts.kind,
					  expr->value.character.length,
					  expr->value.character.string);
4552

dnovillo's avatar
 
dnovillo committed
4553
  se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
fxcoudert's avatar
fxcoudert committed
4554
  TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
dnovillo's avatar
 
dnovillo committed
4555

fxcoudert's avatar
fxcoudert committed
4556 4557
  if (ref)
    gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
dnovillo's avatar
 
dnovillo committed
4558 4559 4560
}


4561 4562 4563
/* Entry point for expression translation.  Evaluates a scalar quantity.
   EXPR is the expression to be translated, and SE is the state structure if
   called from within the scalarized.  */
dnovillo's avatar
 
dnovillo committed
4564 4565 4566 4567 4568 4569 4570

void
gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
  if (se->ss && se->ss->expr == expr
      && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
    {
pbrook's avatar
pbrook committed
4571
      /* Substitute a scalar expression evaluated outside the scalarization
dnovillo's avatar
 
dnovillo committed
4572 4573
         loop.  */
      se->expr = se->ss->data.scalar.expr;
4574 4575
      if (se->ss->type == GFC_SS_REFERENCE)
	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
pbrook's avatar
pbrook committed
4576
      se->string_length = se->ss->string_length;
dnovillo's avatar
 
dnovillo committed
4577 4578 4579 4580
      gfc_advance_se_ss_chain (se);
      return;
    }

4581 4582 4583 4584 4585
  /* We need to convert the expressions for the iso_c_binding derived types.
     C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
     null_pointer_node.  C_PTR and C_FUNPTR are converted to match the
     typespec for the C_PTR and C_FUNPTR symbols, which has already been
     updated to be an integer with a kind equal to the size of a (void *).  */
4586 4587
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->attr.is_iso_c)
4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599
    {
      if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
          || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
        {
	  /* Set expr_type to EXPR_NULL, which will result in
	     null_pointer_node being used below.  */
          expr->expr_type = EXPR_NULL;
        }
      else
        {
          /* Update the type/kind of the expression to be what the new
             type/kind are for the updated symbols of C_PTR/C_FUNPTR.  */
4600 4601 4602
          expr->ts.type = expr->ts.u.derived->ts.type;
          expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
          expr->ts.kind = expr->ts.u.derived->ts.kind;
4603 4604 4605
        }
    }
  
dnovillo's avatar
 
dnovillo committed
4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640
  switch (expr->expr_type)
    {
    case EXPR_OP:
      gfc_conv_expr_op (se, expr);
      break;

    case EXPR_FUNCTION:
      gfc_conv_function_expr (se, expr);
      break;

    case EXPR_CONSTANT:
      gfc_conv_constant (se, expr);
      break;

    case EXPR_VARIABLE:
      gfc_conv_variable (se, expr);
      break;

    case EXPR_NULL:
      se->expr = null_pointer_node;
      break;

    case EXPR_SUBSTRING:
      gfc_conv_substring_expr (se, expr);
      break;

    case EXPR_STRUCTURE:
      gfc_conv_structure (se, expr, 0);
      break;

    case EXPR_ARRAY:
      gfc_conv_array_constructor_expr (se, expr);
      break;

    default:
pbrook's avatar
pbrook committed
4641
      gcc_unreachable ();
dnovillo's avatar
 
dnovillo committed
4642 4643 4644 4645
      break;
    }
}

4646 4647
/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
   of an assignment.  */
dnovillo's avatar
 
dnovillo committed
4648 4649 4650 4651
void
gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
{
  gfc_conv_expr (se, expr);
4652
  /* All numeric lvalues should have empty post chains.  If not we need to
dnovillo's avatar
 
dnovillo committed
4653
     figure out a way of rewriting an lvalue so that it has no post chain.  */
4654
  gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
dnovillo's avatar
 
dnovillo committed
4655 4656
}

4657
/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
jakub's avatar
jakub committed
4658
   numeric expressions.  Used for scalar values where inserting cleanup code
4659
   is inconvenient.  */
dnovillo's avatar
 
dnovillo committed
4660 4661 4662 4663 4664
void
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
{
  tree val;

pbrook's avatar
pbrook committed
4665
  gcc_assert (expr->ts.type != BT_CHARACTER);
dnovillo's avatar
 
dnovillo committed
4666 4667 4668 4669
  gfc_conv_expr (se, expr);
  if (se->post.head)
    {
      val = gfc_create_var (TREE_TYPE (se->expr), NULL);
4670
      gfc_add_modify (&se->pre, val, se->expr);
4671 4672
      se->expr = val;
      gfc_add_block_to_block (&se->pre, &se->post);
dnovillo's avatar
 
dnovillo committed
4673 4674 4675
    }
}

4676
/* Helper to translate an expression and convert it to a particular type.  */
dnovillo's avatar
 
dnovillo committed
4677 4678 4679 4680 4681 4682 4683 4684
void
gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
{
  gfc_conv_expr_val (se, expr);
  se->expr = convert (type, se->expr);
}


4685
/* Converts an expression so that it can be passed by reference.  Scalar
dnovillo's avatar
 
dnovillo committed
4686 4687 4688 4689 4690 4691 4692 4693 4694 4695
   values only.  */

void
gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
{
  tree var;

  if (se->ss && se->ss->expr == expr
      && se->ss->type == GFC_SS_REFERENCE)
    {
4696 4697 4698
      /* Returns a reference to the scalar evaluated outside the loop
	 for this case.  */
      gfc_conv_expr (se, expr);
dnovillo's avatar
 
dnovillo committed
4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715
      return;
    }

  if (expr->ts.type == BT_CHARACTER)
    {
      gfc_conv_expr (se, expr);
      gfc_conv_string_parameter (se);
      return;
    }

  if (expr->expr_type == EXPR_VARIABLE)
    {
      se->want_pointer = 1;
      gfc_conv_expr (se, expr);
      if (se->post.head)
	{
	  var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4716
	  gfc_add_modify (&se->pre, var, se->expr);
dnovillo's avatar
 
dnovillo committed
4717 4718 4719 4720 4721 4722
	  gfc_add_block_to_block (&se->pre, &se->post);
	  se->expr = var;
	}
      return;
    }

4723
  if (expr->expr_type == EXPR_FUNCTION
4724 4725 4726 4727 4728 4729
      && ((expr->value.function.esym
	   && expr->value.function.esym->result->attr.pointer
	   && !expr->value.function.esym->result->attr.dimension)
	  || (!expr->value.function.esym
	      && expr->symtree->n.sym->attr.pointer
	      && !expr->symtree->n.sym->attr.dimension)))
4730 4731 4732 4733
    {
      se->want_pointer = 1;
      gfc_conv_expr (se, expr);
      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4734
      gfc_add_modify (&se->pre, var, se->expr);
4735 4736 4737 4738 4739
      se->expr = var;
      return;
    }


dnovillo's avatar
 
dnovillo committed
4740 4741 4742
  gfc_conv_expr (se, expr);

  /* Create a temporary var to hold the value.  */
4743 4744
  if (TREE_CONSTANT (se->expr))
    {
4745 4746
      tree tmp = se->expr;
      STRIP_TYPE_NOPS (tmp);
aldyh's avatar
aldyh committed
4747 4748
      var = build_decl (input_location,
			CONST_DECL, NULL, TREE_TYPE (tmp));
4749
      DECL_INITIAL (var) = tmp;
4750
      TREE_STATIC (var) = 1;
4751 4752 4753 4754 4755
      pushdecl (var);
    }
  else
    {
      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4756
      gfc_add_modify (&se->pre, var, se->expr);
4757
    }
dnovillo's avatar
 
dnovillo committed
4758 4759 4760
  gfc_add_block_to_block (&se->pre, &se->post);

  /* Take the address of that value.  */
4761
  se->expr = gfc_build_addr_expr (NULL_TREE, var);
dnovillo's avatar
 
dnovillo committed
4762 4763 4764 4765 4766 4767
}


tree
gfc_trans_pointer_assign (gfc_code * code)
{
4768
  return gfc_trans_pointer_assignment (code->expr1, code->expr2);
dnovillo's avatar
 
dnovillo committed
4769 4770 4771
}


4772 4773
/* Generate code for a pointer assignment.  */

dnovillo's avatar
 
dnovillo committed
4774 4775 4776 4777 4778 4779 4780 4781
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
  gfc_se lse;
  gfc_se rse;
  gfc_ss *lss;
  gfc_ss *rss;
  stmtblock_t block;
rsandifo's avatar
rsandifo committed
4782 4783
  tree desc;
  tree tmp;
4784 4785
  tree decl;

dnovillo's avatar
 
dnovillo committed
4786 4787 4788 4789 4790 4791 4792 4793
  gfc_start_block (&block);

  gfc_init_se (&lse, NULL);

  lss = gfc_walk_expr (expr1);
  rss = gfc_walk_expr (expr2);
  if (lss == gfc_ss_terminator)
    {
4794
      /* Scalar pointers.  */
dnovillo's avatar
 
dnovillo committed
4795 4796
      lse.want_pointer = 1;
      gfc_conv_expr (&lse, expr1);
pbrook's avatar
pbrook committed
4797
      gcc_assert (rss == gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
4798 4799 4800
      gfc_init_se (&rse, NULL);
      rse.want_pointer = 1;
      gfc_conv_expr (&rse, expr2);
4801 4802 4803

      if (expr1->symtree->n.sym->attr.proc_pointer
	  && expr1->symtree->n.sym->attr.dummy)
4804 4805
	lse.expr = build_fold_indirect_ref_loc (input_location,
					    lse.expr);
4806

4807 4808
      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
	  && expr2->symtree->n.sym->attr.dummy)
4809 4810
	rse.expr = build_fold_indirect_ref_loc (input_location,
					    rse.expr);
4811

dnovillo's avatar
 
dnovillo committed
4812 4813
      gfc_add_block_to_block (&block, &lse.pre);
      gfc_add_block_to_block (&block, &rse.pre);
domob's avatar
domob committed
4814 4815 4816

      /* Check character lengths if character expression.  The test is only
	 really added if -fbounds-check is enabled.  */
4817 4818 4819
      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
	  && !expr1->symtree->n.sym->attr.proc_pointer
	  && !gfc_is_proc_ptr_comp (expr1, NULL))
domob's avatar
domob committed
4820 4821 4822 4823 4824 4825 4826 4827
	{
	  gcc_assert (expr2->ts.type == BT_CHARACTER);
	  gcc_assert (lse.string_length && rse.string_length);
	  gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
				       lse.string_length, rse.string_length,
				       &block);
	}

4828
      gfc_add_modify (&block, lse.expr,
4829
			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
domob's avatar
domob committed
4830

dnovillo's avatar
 
dnovillo committed
4831 4832 4833 4834 4835
      gfc_add_block_to_block (&block, &rse.post);
      gfc_add_block_to_block (&block, &lse.post);
    }
  else
    {
domob's avatar
domob committed
4836 4837
      gfc_ref* remap;
      bool rank_remap;
domob's avatar
domob committed
4838 4839 4840
      tree strlen_lhs;
      tree strlen_rhs = NULL_TREE;

domob's avatar
domob committed
4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853
      /* Array pointer.  Find the last reference on the LHS and if it is an
	 array section ref, we're dealing with bounds remapping.  In this case,
	 set it to AR_FULL so that gfc_conv_expr_descriptor does
	 not see it and process the bounds remapping afterwards explicitely.  */
      for (remap = expr1->ref; remap; remap = remap->next)
	if (!remap->next && remap->type == REF_ARRAY
	    && remap->u.ar.type == AR_SECTION)
	  {  
	    remap->u.ar.type = AR_FULL;
	    break;
	  }
      rank_remap = (remap && remap->u.ar.end[0]);

dnovillo's avatar
 
dnovillo committed
4854
      gfc_conv_expr_descriptor (&lse, expr1, lss);
domob's avatar
domob committed
4855
      strlen_lhs = lse.string_length;
domob's avatar
domob committed
4856 4857 4858
      desc = lse.expr;

      if (expr2->expr_type == EXPR_NULL)
rsandifo's avatar
rsandifo committed
4859 4860
	{
	  /* Just set the data pointer to null.  */
4861
	  gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
domob's avatar
domob committed
4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875
	}
      else if (rank_remap)
	{
	  /* If we are rank-remapping, just get the RHS's descriptor and
	     process this later on.  */
	  gfc_init_se (&rse, NULL);
	  rse.direct_byref = 1;
	  rse.byref_noassign = 1;
	  gfc_conv_expr_descriptor (&rse, expr2, rss);
	  strlen_rhs = rse.string_length;
	}
      else if (expr2->expr_type == EXPR_VARIABLE)
	{
	  /* Assign directly to the LHS's descriptor.  */
domob's avatar
domob committed
4876
	  lse.direct_byref = 1;
rsandifo's avatar
rsandifo committed
4877
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
domob's avatar
domob committed
4878
	  strlen_rhs = lse.string_length;
4879 4880

	  /* If this is a subreference array pointer assignment, use the rhs
4881
	     descriptor element size for the lhs span.  */
4882 4883 4884
	  if (expr1->symtree->n.sym->attr.subref_array_pointer)
	    {
	      decl = expr1->symtree->n.sym->backend_decl;
4885 4886 4887 4888 4889 4890
	      gfc_init_se (&rse, NULL);
	      rse.descriptor_only = 1;
	      gfc_conv_expr (&rse, expr2);
	      tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
	      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
	      if (!INTEGER_CST_P (tmp))
domob's avatar
domob committed
4891
		gfc_add_block_to_block (&lse.post, &rse.pre);
4892
	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4893
	    }
domob's avatar
domob committed
4894 4895 4896
	}
      else
	{
rsandifo's avatar
rsandifo committed
4897 4898 4899 4900 4901 4902 4903
	  /* Assign to a temporary descriptor and then copy that
	     temporary to the pointer.  */
	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");

	  lse.expr = tmp;
	  lse.direct_byref = 1;
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
domob's avatar
domob committed
4904
	  strlen_rhs = lse.string_length;
4905
	  gfc_add_modify (&lse.pre, desc, tmp);
domob's avatar
domob committed
4906 4907
	}

dnovillo's avatar
 
dnovillo committed
4908
      gfc_add_block_to_block (&block, &lse.pre);
domob's avatar
domob committed
4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945
      if (rank_remap)
	gfc_add_block_to_block (&block, &rse.pre);

      /* If we do bounds remapping, update LHS descriptor accordingly.  */
      if (remap)
	{
	  int dim;
	  gcc_assert (remap->u.ar.dimen == expr1->rank);

	  if (rank_remap)
	    {
	      /* Do rank remapping.  We already have the RHS's descriptor
		 converted in rse and now have to build the correct LHS
		 descriptor for it.  */

	      tree dtype, data;
	      tree offs, stride;
	      tree lbound, ubound;

	      /* Set dtype.  */
	      dtype = gfc_conv_descriptor_dtype (desc);
	      tmp = gfc_get_dtype (TREE_TYPE (desc));
	      gfc_add_modify (&block, dtype, tmp);

	      /* Copy data pointer.  */
	      data = gfc_conv_descriptor_data_get (rse.expr);
	      gfc_conv_descriptor_data_set (&block, desc, data);

	      /* Copy offset but adjust it such that it would correspond
		 to a lbound of zero.  */
	      offs = gfc_conv_descriptor_offset_get (rse.expr);
	      for (dim = 0; dim < expr2->rank; ++dim)
		{
		  stride = gfc_conv_descriptor_stride_get (rse.expr,
							   gfc_rank_cst[dim]);
		  lbound = gfc_conv_descriptor_lbound_get (rse.expr,
							   gfc_rank_cst[dim]);
4946 4947 4948 4949
		  tmp = fold_build2_loc (input_location, MULT_EXPR,
					 gfc_array_index_type, stride, lbound);
		  offs = fold_build2_loc (input_location, PLUS_EXPR,
					  gfc_array_index_type, offs, tmp);
domob's avatar
domob committed
4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994
		}
	      gfc_conv_descriptor_offset_set (&block, desc, offs);

	      /* Set the bounds as declared for the LHS and calculate strides as
		 well as another offset update accordingly.  */
	      stride = gfc_conv_descriptor_stride_get (rse.expr,
						       gfc_rank_cst[0]);
	      for (dim = 0; dim < expr1->rank; ++dim)
		{
		  gfc_se lower_se;
		  gfc_se upper_se;

		  gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);

		  /* Convert declared bounds.  */
		  gfc_init_se (&lower_se, NULL);
		  gfc_init_se (&upper_se, NULL);
		  gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
		  gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);

		  gfc_add_block_to_block (&block, &lower_se.pre);
		  gfc_add_block_to_block (&block, &upper_se.pre);

		  lbound = fold_convert (gfc_array_index_type, lower_se.expr);
		  ubound = fold_convert (gfc_array_index_type, upper_se.expr);

		  lbound = gfc_evaluate_now (lbound, &block);
		  ubound = gfc_evaluate_now (ubound, &block);

		  gfc_add_block_to_block (&block, &lower_se.post);
		  gfc_add_block_to_block (&block, &upper_se.post);

		  /* Set bounds in descriptor.  */
		  gfc_conv_descriptor_lbound_set (&block, desc,
						  gfc_rank_cst[dim], lbound);
		  gfc_conv_descriptor_ubound_set (&block, desc,
						  gfc_rank_cst[dim], ubound);

		  /* Set stride.  */
		  stride = gfc_evaluate_now (stride, &block);
		  gfc_conv_descriptor_stride_set (&block, desc,
						  gfc_rank_cst[dim], stride);

		  /* Update offset.  */
		  offs = gfc_conv_descriptor_offset_get (desc);
4995 4996 4997 4998
		  tmp = fold_build2_loc (input_location, MULT_EXPR,
					 gfc_array_index_type, lbound, stride);
		  offs = fold_build2_loc (input_location, MINUS_EXPR,
					  gfc_array_index_type, offs, tmp);
domob's avatar
domob committed
4999 5000 5001 5002 5003
		  offs = gfc_evaluate_now (offs, &block);
		  gfc_conv_descriptor_offset_set (&block, desc, offs);

		  /* Update stride.  */
		  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5004 5005
		  stride = fold_build2_loc (input_location, MULT_EXPR,
					    gfc_array_index_type, stride, tmp);
domob's avatar
domob committed
5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029
		}
	    }
	  else
	    {
	      /* Bounds remapping.  Just shift the lower bounds.  */

	      gcc_assert (expr1->rank == expr2->rank);

	      for (dim = 0; dim < remap->u.ar.dimen; ++dim)
		{
		  gfc_se lbound_se;

		  gcc_assert (remap->u.ar.start[dim]);
		  gcc_assert (!remap->u.ar.end[dim]);
		  gfc_init_se (&lbound_se, NULL);
		  gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);

		  gfc_add_block_to_block (&block, &lbound_se.pre);
		  gfc_conv_shift_descriptor_lbound (&block, desc,
						    dim, lbound_se.expr);
		  gfc_add_block_to_block (&block, &lbound_se.post);
		}
	    }
	}
domob's avatar
domob committed
5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040

      /* Check string lengths if applicable.  The check is only really added
	 to the output code if -fbounds-check is enabled.  */
      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
	{
	  gcc_assert (expr2->ts.type == BT_CHARACTER);
	  gcc_assert (strlen_lhs && strlen_rhs);
	  gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
				       strlen_lhs, strlen_rhs, &block);
	}

domob's avatar
domob committed
5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053
      /* If rank remapping was done, check with -fcheck=bounds that
	 the target is at least as large as the pointer.  */
      if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
	{
	  tree lsize, rsize;
	  tree fault;
	  const char* msg;

	  lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
	  rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);

	  lsize = gfc_evaluate_now (lsize, &block);
	  rsize = gfc_evaluate_now (rsize, &block);
5054 5055
	  fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
				   rsize, lsize);
domob's avatar
domob committed
5056 5057 5058 5059 5060 5061

	  msg = _("Target of rank remapping is too small (%ld < %ld)");
	  gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
				   msg, rsize, lsize);
	}

dnovillo's avatar
 
dnovillo committed
5062
      gfc_add_block_to_block (&block, &lse.post);
domob's avatar
domob committed
5063 5064
      if (rank_remap)
	gfc_add_block_to_block (&block, &rse.post);
dnovillo's avatar
 
dnovillo committed
5065
    }
domob's avatar
domob committed
5066

dnovillo's avatar
 
dnovillo committed
5067 5068 5069 5070 5071
  return gfc_finish_block (&block);
}


/* Makes sure se is suitable for passing as a function string parameter.  */
rwild's avatar
rwild committed
5072
/* TODO: Need to check all callers of this function.  It may be abused.  */
dnovillo's avatar
 
dnovillo committed
5073 5074 5075 5076 5077 5078 5079 5080

void
gfc_conv_string_parameter (gfc_se * se)
{
  tree type;

  if (TREE_CODE (se->expr) == STRING_CST)
    {
5081 5082
      type = TREE_TYPE (TREE_TYPE (se->expr));
      se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
dnovillo's avatar
 
dnovillo committed
5083 5084 5085
      return;
    }

5086
  if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
dnovillo's avatar
 
dnovillo committed
5087
    {
5088
      if (TREE_CODE (se->expr) != INDIRECT_REF)
5089 5090 5091 5092
	{
	  type = TREE_TYPE (se->expr);
          se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
	}
5093 5094 5095 5096 5097 5098 5099
      else
	{
	  type = gfc_get_character_type_len (gfc_default_character_kind,
					     se->string_length);
	  type = build_pointer_type (type);
	  se->expr = gfc_build_addr_expr (type, se->expr);
	}
dnovillo's avatar
 
dnovillo committed
5100 5101
    }

pbrook's avatar
pbrook committed
5102 5103
  gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
  gcc_assert (se->string_length
dnovillo's avatar
 
dnovillo committed
5104 5105 5106 5107 5108
	  && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
}


/* Generate code for assignment of scalar variables.  Includes character
5109 5110
   strings and derived types with allocatable components.
   If you know that the LHS has no allocations, set dealloc to false.  */
dnovillo's avatar
 
dnovillo committed
5111 5112

tree
5113
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
5114
			 bool l_is_temp, bool r_is_var, bool dealloc)
dnovillo's avatar
 
dnovillo committed
5115 5116
{
  stmtblock_t block;
5117 5118
  tree tmp;
  tree cond;
dnovillo's avatar
 
dnovillo committed
5119 5120 5121

  gfc_init_block (&block);

5122
  if (ts.type == BT_CHARACTER)
dnovillo's avatar
 
dnovillo committed
5123
    {
5124 5125
      tree rlen = NULL;
      tree llen = NULL;
dnovillo's avatar
 
dnovillo committed
5126

5127 5128 5129 5130 5131 5132
      if (lse->string_length != NULL_TREE)
	{
	  gfc_conv_string_parameter (lse);
	  gfc_add_block_to_block (&block, &lse->pre);
	  llen = lse->string_length;
	}
dnovillo's avatar
 
dnovillo committed
5133

5134 5135 5136 5137 5138 5139 5140
      if (rse->string_length != NULL_TREE)
	{
	  gcc_assert (rse->string_length != NULL_TREE);
	  gfc_conv_string_parameter (rse);
	  gfc_add_block_to_block (&block, &rse->pre);
	  rlen = rse->string_length;
	}
dnovillo's avatar
 
dnovillo committed
5141

5142 5143
      gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
			     rse->expr, ts.kind);
dnovillo's avatar
 
dnovillo committed
5144
    }
5145
  else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
5146 5147 5148 5149 5150 5151
    {
      cond = NULL_TREE;
	
      /* Are the rhs and the lhs the same?  */
      if (r_is_var)
	{
5152 5153 5154
	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
				  gfc_build_addr_expr (NULL_TREE, lse->expr),
				  gfc_build_addr_expr (NULL_TREE, rse->expr));
5155 5156 5157 5158
	  cond = gfc_evaluate_now (cond, &lse->pre);
	}

      /* Deallocate the lhs allocated components as long as it is not
5159 5160 5161
	 the same as the rhs.  This must be done following the assignment
	 to prevent deallocating data that could be used in the rhs
	 expression.  */
5162
      if (!l_is_temp && dealloc)
5163
	{
5164
	  tmp = gfc_evaluate_now (lse->expr, &lse->pre);
5165
	  tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
5166
	  if (r_is_var)
aldyh's avatar
aldyh committed
5167 5168
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
			    tmp);
5169
	  gfc_add_expr_to_block (&lse->post, tmp);
5170
	}
5171

5172 5173
      gfc_add_block_to_block (&block, &rse->pre);
      gfc_add_block_to_block (&block, &lse->pre);
5174

5175
      gfc_add_modify (&block, lse->expr,
5176 5177 5178
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));

      /* Do a deep copy if the rhs is a variable, if it is not the
5179
	 same as the lhs.  */
5180 5181
      if (r_is_var)
	{
5182
	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
aldyh's avatar
aldyh committed
5183 5184
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
			  tmp);
5185 5186 5187
	  gfc_add_expr_to_block (&block, tmp);
	}
    }
5188
  else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
5189 5190 5191
    {
      gfc_add_block_to_block (&block, &lse->pre);
      gfc_add_block_to_block (&block, &rse->pre);
5192 5193
      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
			     TREE_TYPE (lse->expr), rse->expr);
5194 5195
      gfc_add_modify (&block, lse->expr, tmp);
    }
dnovillo's avatar
 
dnovillo committed
5196 5197 5198 5199 5200
  else
    {
      gfc_add_block_to_block (&block, &lse->pre);
      gfc_add_block_to_block (&block, &rse->pre);

5201
      gfc_add_modify (&block, lse->expr,
5202
		      fold_convert (TREE_TYPE (lse->expr), rse->expr));
dnovillo's avatar
 
dnovillo committed
5203 5204 5205 5206 5207 5208 5209 5210 5211
    }

  gfc_add_block_to_block (&block, &lse->post);
  gfc_add_block_to_block (&block, &rse->post);

  return gfc_finish_block (&block);
}


5212 5213
/* There are quite a lot of restrictions on the optimisation in using an
   array function assign without a temporary.  */
dnovillo's avatar
 
dnovillo committed
5214

5215 5216
static bool
arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
dnovillo's avatar
 
dnovillo committed
5217
{
5218 5219
  gfc_ref * ref;
  bool seen_array_ref;
5220
  bool c = false;
5221
  gfc_symbol *sym = expr1->symtree->n.sym;
dnovillo's avatar
 
dnovillo committed
5222 5223 5224

  /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
  if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
5225
    return true;
dnovillo's avatar
 
dnovillo committed
5226

5227 5228 5229
  /* Elemental functions are scalarized so that they don't need a
     temporary in gfc_trans_assignment_1, so return a true.  Otherwise,
     they would need special treatment in gfc_trans_arrayfunc_assign.  */
tobi's avatar
 
tobi committed
5230 5231
  if (expr2->value.function.esym != NULL
      && expr2->value.function.esym->attr.elemental)
5232
    return true;
dnovillo's avatar
 
dnovillo committed
5233

5234
  /* Need a temporary if rhs is not FULL or a contiguous section.  */
5235
  if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
5236
    return true;
5237

5238
  /* Need a temporary if EXPR1 can't be expressed as a descriptor.  */
rsandifo's avatar
rsandifo committed
5239
  if (gfc_ref_needs_temporary_p (expr1->ref))
5240
    return true;
rsandifo's avatar
rsandifo committed
5241

eedelman's avatar
eedelman committed
5242
  /* Functions returning pointers need temporaries.  */
eedelman's avatar
eedelman committed
5243 5244
  if (expr2->symtree->n.sym->attr.pointer 
      || expr2->symtree->n.sym->attr.allocatable)
5245
    return true;
eedelman's avatar
eedelman committed
5246

5247 5248 5249 5250
  /* Character array functions need temporaries unless the
     character lengths are the same.  */
  if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
    {
5251 5252
      if (expr1->ts.u.cl->length == NULL
	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5253
	return true;
5254

5255 5256
      if (expr2->ts.u.cl->length == NULL
	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5257
	return true;
5258

5259 5260
      if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
		     expr2->ts.u.cl->length->value.integer) != 0)
5261
	return true;
5262 5263
    }

5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274
  /* Check that no LHS component references appear during an array
     reference. This is needed because we do not have the means to
     span any arbitrary stride with an array descriptor. This check
     is not needed for the rhs because the function result has to be
     a complete type.  */
  seen_array_ref = false;
  for (ref = expr1->ref; ref; ref = ref->next)
    {
      if (ref->type == REF_ARRAY)
	seen_array_ref= true;
      else if (ref->type == REF_COMPONENT && seen_array_ref)
5275
	return true;
5276 5277
    }

dnovillo's avatar
 
dnovillo committed
5278
  /* Check for a dependency.  */
rsandifo's avatar
rsandifo committed
5279 5280
  if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
				   expr2->value.function.esym,
5281 5282
				   expr2->value.function.actual,
				   NOT_ELEMENTAL))
5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314
    return true;

  /* If we have reached here with an intrinsic function, we do not
     need a temporary.  */
  if (expr2->value.function.isym)
    return false;

  /* If the LHS is a dummy, we need a temporary if it is not
     INTENT(OUT).  */
  if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
    return true;

  /* A PURE function can unconditionally be called without a temporary.  */
  if (expr2->value.function.esym != NULL
      && expr2->value.function.esym->attr.pure)
    return false;

  /* TODO a function that could correctly be declared PURE but is not
     could do with returning false as well.  */

  if (!sym->attr.use_assoc
	&& !sym->attr.in_common
	&& !sym->attr.pointer
	&& !sym->attr.target
	&& expr2->value.function.esym)
    {
      /* A temporary is not needed if the function is not contained and
	 the variable is local or host associated and not a pointer or
	 a target. */
      if (!expr2->value.function.esym->attr.contained)
	return false;

5315 5316 5317 5318 5319
      /* A temporary is not needed if the lhs has never been host
	 associated and the procedure is contained.  */
      else if (!sym->attr.host_assoc)
	return false;

5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343
      /* A temporary is not needed if the variable is local and not
	 a pointer, a target or a result.  */
      if (sym->ns->parent
	    && expr2->value.function.esym->ns == sym->ns->parent)
	return false;
    }

  /* Default to temporary use.  */
  return true;
}


/* Try to translate array(:) = func (...), where func is a transformational
   array function, without using a temporary.  Returns NULL if this isn't the
   case.  */

static tree
gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
{
  gfc_se se;
  gfc_ss *ss;
  gfc_component *comp = NULL;

  if (arrayfunc_assign_needs_temporary (expr1, expr2))
dnovillo's avatar
 
dnovillo committed
5344 5345 5346 5347
    return NULL;

  /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
     functions.  */
pbrook's avatar
pbrook committed
5348
  gcc_assert (expr2->value.function.isym
5349
	      || (gfc_is_proc_ptr_comp (expr2, &comp)
5350
		  && comp && comp->attr.dimension)
5351
	      || (!comp && gfc_return_by_reference (expr2->value.function.esym)
5352
		  && expr2->value.function.esym->result->attr.dimension));
dnovillo's avatar
 
dnovillo committed
5353 5354

  ss = gfc_walk_expr (expr1);
pbrook's avatar
pbrook committed
5355
  gcc_assert (ss != gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5356 5357 5358 5359
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);
  se.want_pointer = 1;

5360
  gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
dnovillo's avatar
 
dnovillo committed
5361

5362 5363 5364 5365 5366 5367 5368 5369 5370
  if (expr1->ts.type == BT_DERIVED
	&& expr1->ts.u.derived->attr.alloc_comp)
    {
      tree tmp;
      tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
				       expr1->rank);
      gfc_add_expr_to_block (&se.pre, tmp);
    }

dnovillo's avatar
 
dnovillo committed
5371 5372
  se.direct_byref = 1;
  se.ss = gfc_walk_expr (expr2);
pbrook's avatar
pbrook committed
5373
  gcc_assert (se.ss != gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5374 5375 5376 5377 5378 5379
  gfc_conv_function_expr (&se, expr2);
  gfc_add_block_to_block (&se.pre, &se.post);

  return gfc_finish_block (&se.pre);
}

sayle's avatar
 
sayle committed
5380 5381 5382 5383 5384 5385 5386 5387

/* Try to efficiently translate array(:) = 0.  Return NULL if this
   can't be done.  */

static tree
gfc_trans_zero_assign (gfc_expr * expr)
{
  tree dest, len, type;
5388
  tree tmp;
sayle's avatar
 
sayle committed
5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404
  gfc_symbol *sym;

  sym = expr->symtree->n.sym;
  dest = gfc_get_symbol_decl (sym);

  type = TREE_TYPE (dest);
  if (POINTER_TYPE_P (type))
    type = TREE_TYPE (type);
  if (!GFC_ARRAY_TYPE_P (type))
    return NULL_TREE;

  /* Determine the length of the array.  */
  len = GFC_TYPE_ARRAY_SIZE (type);
  if (!len || TREE_CODE (len) != INTEGER_CST)
    return NULL_TREE;

fxcoudert's avatar
fxcoudert committed
5405
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
5406 5407
  len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
			 fold_convert (gfc_array_index_type, tmp));
sayle's avatar
 
sayle committed
5408

5409 5410
  /* If we are zeroing a local array avoid taking its address by emitting
     a = {} instead.  */
sayle's avatar
 
sayle committed
5411
  if (!POINTER_TYPE_P (TREE_TYPE (dest)))
5412 5413
    return build2_loc (input_location, MODIFY_EXPR, void_type_node,
		       dest, build_constructor (TREE_TYPE (dest), NULL));
5414 5415 5416

  /* Convert arguments to the correct types.  */
  dest = fold_convert (pvoid_type_node, dest);
sayle's avatar
 
sayle committed
5417 5418 5419
  len = fold_convert (size_type_node, len);

  /* Construct call to __builtin_memset.  */
5420 5421
  tmp = build_call_expr_loc (input_location,
			 built_in_decls[BUILT_IN_MEMSET],
5422
			 3, dest, integer_zero_node, len);
sayle's avatar
 
sayle committed
5423 5424
  return fold_convert (void_type_node, tmp);
}
dnovillo's avatar
 
dnovillo committed
5425

sayle's avatar
 
sayle committed
5426 5427 5428 5429

/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
   that constructs the call to __builtin_memcpy.  */

domob's avatar
domob committed
5430
tree
sayle's avatar
 
sayle committed
5431 5432
gfc_build_memcpy_call (tree dst, tree src, tree len)
{
5433
  tree tmp;
sayle's avatar
 
sayle committed
5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448

  /* Convert arguments to the correct types.  */
  if (!POINTER_TYPE_P (TREE_TYPE (dst)))
    dst = gfc_build_addr_expr (pvoid_type_node, dst);
  else
    dst = fold_convert (pvoid_type_node, dst);

  if (!POINTER_TYPE_P (TREE_TYPE (src)))
    src = gfc_build_addr_expr (pvoid_type_node, src);
  else
    src = fold_convert (pvoid_type_node, src);

  len = fold_convert (size_type_node, len);

  /* Construct call to __builtin_memcpy.  */
5449 5450
  tmp = build_call_expr_loc (input_location,
			 built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
sayle's avatar
 
sayle committed
5451 5452 5453 5454
  return fold_convert (void_type_node, tmp);
}


sayle's avatar
 
sayle committed
5455 5456 5457 5458
/* Try to efficiently translate dst(:) = src(:).  Return NULL if this
   can't be done.  EXPR1 is the destination/lhs and EXPR2 is the
   source/rhs, both are gfc_full_array_ref_p which have been checked for
   dependencies.  */
dnovillo's avatar
 
dnovillo committed
5459

sayle's avatar
 
sayle committed
5460 5461 5462 5463 5464
static tree
gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
{
  tree dst, dlen, dtype;
  tree src, slen, stype;
fxcoudert's avatar
fxcoudert committed
5465
  tree tmp;
sayle's avatar
 
sayle committed
5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483

  dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
  src = gfc_get_symbol_decl (expr2->symtree->n.sym);

  dtype = TREE_TYPE (dst);
  if (POINTER_TYPE_P (dtype))
    dtype = TREE_TYPE (dtype);
  stype = TREE_TYPE (src);
  if (POINTER_TYPE_P (stype))
    stype = TREE_TYPE (stype);

  if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
    return NULL_TREE;

  /* Determine the lengths of the arrays.  */
  dlen = GFC_TYPE_ARRAY_SIZE (dtype);
  if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
    return NULL_TREE;
fxcoudert's avatar
fxcoudert committed
5484
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5485 5486
  dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
			  dlen, fold_convert (gfc_array_index_type, tmp));
sayle's avatar
 
sayle committed
5487 5488 5489 5490

  slen = GFC_TYPE_ARRAY_SIZE (stype);
  if (!slen || TREE_CODE (slen) != INTEGER_CST)
    return NULL_TREE;
fxcoudert's avatar
fxcoudert committed
5491
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
5492 5493
  slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
			  slen, fold_convert (gfc_array_index_type, tmp));
sayle's avatar
 
sayle committed
5494 5495 5496 5497 5498 5499

  /* Sanity check that they are the same.  This should always be
     the case, as we should already have checked for conformance.  */
  if (!tree_int_cst_equal (slen, dlen))
    return NULL_TREE;

sayle's avatar
 
sayle committed
5500 5501
  return gfc_build_memcpy_call (dst, src, dlen);
}
sayle's avatar
 
sayle committed
5502 5503


sayle's avatar
 
sayle committed
5504 5505 5506
/* Try to efficiently translate array(:) = (/ ... /).  Return NULL if
   this can't be done.  EXPR1 is the destination/lhs for which
   gfc_full_array_ref_p is true, and EXPR2 is the source/rhs.  */
sayle's avatar
 
sayle committed
5507

sayle's avatar
 
sayle committed
5508 5509 5510 5511 5512 5513 5514
static tree
gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
{
  unsigned HOST_WIDE_INT nelem;
  tree dst, dtype;
  tree src, stype;
  tree len;
fxcoudert's avatar
fxcoudert committed
5515
  tree tmp;
sayle's avatar
 
sayle committed
5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536

  nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
  if (nelem == 0)
    return NULL_TREE;

  dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
  dtype = TREE_TYPE (dst);
  if (POINTER_TYPE_P (dtype))
    dtype = TREE_TYPE (dtype);
  if (!GFC_ARRAY_TYPE_P (dtype))
    return NULL_TREE;

  /* Determine the lengths of the array.  */
  len = GFC_TYPE_ARRAY_SIZE (dtype);
  if (!len || TREE_CODE (len) != INTEGER_CST)
    return NULL_TREE;

  /* Confirm that the constructor is the same size.  */
  if (compare_tree_int (len, nelem) != 0)
    return NULL_TREE;

fxcoudert's avatar
fxcoudert committed
5537
  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
5538 5539
  len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
			 fold_convert (gfc_array_index_type, tmp));
sayle's avatar
 
sayle committed
5540 5541 5542 5543 5544 5545 5546 5547 5548

  stype = gfc_typenode_for_spec (&expr2->ts);
  src = gfc_build_constant_array_constructor (expr2, stype);

  stype = TREE_TYPE (src);
  if (POINTER_TYPE_P (stype))
    stype = TREE_TYPE (stype);

  return gfc_build_memcpy_call (dst, src, len);
sayle's avatar
 
sayle committed
5549 5550 5551
}


5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572
/* Tells whether the expression is to be treated as a variable reference.  */

static bool
expr_is_variable (gfc_expr *expr)
{
  gfc_expr *arg;

  if (expr->expr_type == EXPR_VARIABLE)
    return true;

  arg = gfc_get_noncopying_intrinsic_argument (expr);
  if (arg)
    {
      gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
      return expr_is_variable (arg);
    }

  return false;
}


sayle's avatar
 
sayle committed
5573
/* Subroutine of gfc_trans_assignment that actually scalarizes the
5574 5575 5576
   assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
   init_flag indicates initialization expressions and dealloc that no
   deallocate prior assignment is needed (if in doubt, set true).  */
sayle's avatar
 
sayle committed
5577 5578

static tree
5579 5580
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
			bool dealloc)
dnovillo's avatar
 
dnovillo committed
5581 5582 5583 5584 5585 5586 5587 5588 5589 5590
{
  gfc_se lse;
  gfc_se rse;
  gfc_ss *lss;
  gfc_ss *lss_section;
  gfc_ss *rss;
  gfc_loopinfo loop;
  tree tmp;
  stmtblock_t block;
  stmtblock_t body;
5591
  bool l_is_temp;
5592
  bool scalar_to_array;
5593
  tree string_length;
5594
  int n;
dnovillo's avatar
 
dnovillo committed
5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606

  /* Assignment of the form lhs = rhs.  */
  gfc_start_block (&block);

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);

  /* Walk the lhs.  */
  lss = gfc_walk_expr (expr1);
  rss = NULL;
  if (lss != gfc_ss_terminator)
    {
jakub's avatar
jakub committed
5607 5608 5609 5610
      /* Allow the scalarizer to workshare array assignments.  */
      if (ompws_flags & OMPWS_WORKSHARE_FLAG)
	ompws_flags |= OMPWS_SCALARIZER_WS;

dnovillo's avatar
 
dnovillo committed
5611 5612 5613 5614 5615 5616 5617 5618
      /* The assignment needs scalarization.  */
      lss_section = lss;

      /* Find a non-scalar SS from the lhs.  */
      while (lss_section != gfc_ss_terminator
	     && lss_section->type != GFC_SS_SECTION)
	lss_section = lss_section->next;

pbrook's avatar
pbrook committed
5619
      gcc_assert (lss_section != gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639

      /* Initialize the scalarizer.  */
      gfc_init_loopinfo (&loop);

      /* Walk the rhs.  */
      rss = gfc_walk_expr (expr2);
      if (rss == gfc_ss_terminator)
	{
	  /* The rhs is scalar.  Add a ss for the expression.  */
	  rss = gfc_get_ss ();
	  rss->next = gfc_ss_terminator;
	  rss->type = GFC_SS_SCALAR;
	  rss->expr = expr2;
	}
      /* Associate the SS with the loop.  */
      gfc_add_ss_to_loop (&loop, lss);
      gfc_add_ss_to_loop (&loop, rss);

      /* Calculate the bounds of the scalarization.  */
      gfc_conv_ss_startstride (&loop);
5640 5641 5642
      /* Enable loop reversal.  */
      for (n = 0; n < loop.dimen; n++)
	loop.reverse[n] = GFC_REVERSE_NOT_SET;
dnovillo's avatar
 
dnovillo committed
5643
      /* Resolve any data dependencies in the statement.  */
5644
      gfc_conv_resolve_dependencies (&loop, lss, rss);
dnovillo's avatar
 
dnovillo committed
5645
      /* Setup the scalarizing loops.  */
5646
      gfc_conv_loop_setup (&loop, &expr2->where);
dnovillo's avatar
 
dnovillo committed
5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671

      /* Setup the gfc_se structures.  */
      gfc_copy_loopinfo_to_se (&lse, &loop);
      gfc_copy_loopinfo_to_se (&rse, &loop);

      rse.ss = rss;
      gfc_mark_ss_chain_used (rss, 1);
      if (loop.temp_ss == NULL)
	{
	  lse.ss = lss;
	  gfc_mark_ss_chain_used (lss, 1);
	}
      else
	{
	  lse.ss = loop.temp_ss;
	  gfc_mark_ss_chain_used (lss, 3);
	  gfc_mark_ss_chain_used (loop.temp_ss, 3);
	}

      /* Start the scalarized loop body.  */
      gfc_start_scalarized_body (&loop, &body);
    }
  else
    gfc_init_block (&body);

5672 5673
  l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);

dnovillo's avatar
 
dnovillo committed
5674 5675 5676
  /* Translate the expression.  */
  gfc_conv_expr (&rse, expr2);

5677 5678 5679 5680 5681 5682
  /* Stabilize a string length for temporaries.  */
  if (expr2->ts.type == BT_CHARACTER)
    string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
  else
    string_length = NULL_TREE;

5683
  if (l_is_temp)
dnovillo's avatar
 
dnovillo committed
5684 5685
    {
      gfc_conv_tmp_array_ref (&lse);
5686 5687
      if (expr2->ts.type == BT_CHARACTER)
	lse.string_length = string_length;
dnovillo's avatar
 
dnovillo committed
5688 5689 5690
    }
  else
    gfc_conv_expr (&lse, expr1);
kazu's avatar
kazu committed
5691

5692 5693 5694 5695
  /* Assignments of scalar derived types with allocatable components
     to arrays must be done with a deep copy and the rhs temporary
     must have its components deallocated afterwards.  */
  scalar_to_array = (expr2->ts.type == BT_DERIVED
5696
		       && expr2->ts.u.derived->attr.alloc_comp
5697
		       && !expr_is_variable (expr2)
5698 5699
		       && !gfc_is_constant_expr (expr2)
		       && expr1->rank && !expr2->rank);
5700
  if (scalar_to_array && dealloc)
5701
    {
5702
      tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
5703 5704 5705
      gfc_add_expr_to_block (&loop.post, tmp);
    }

5706 5707
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
				 l_is_temp || init_flag,
5708 5709
				 expr_is_variable (expr2) || scalar_to_array,
				 dealloc);
dnovillo's avatar
 
dnovillo committed
5710 5711 5712 5713 5714 5715 5716 5717 5718
  gfc_add_expr_to_block (&body, tmp);

  if (lss == gfc_ss_terminator)
    {
      /* Use the scalar assignment as is.  */
      gfc_add_block_to_block (&block, &body);
    }
  else
    {
pbrook's avatar
pbrook committed
5719 5720
      gcc_assert (lse.ss == gfc_ss_terminator
		  && rse.ss == gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5721

5722
      if (l_is_temp)
dnovillo's avatar
 
dnovillo committed
5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737
	{
	  gfc_trans_scalarized_loop_boundary (&loop, &body);

	  /* We need to copy the temporary to the actual lhs.  */
	  gfc_init_se (&lse, NULL);
	  gfc_init_se (&rse, NULL);
	  gfc_copy_loopinfo_to_se (&lse, &loop);
	  gfc_copy_loopinfo_to_se (&rse, &loop);

	  rse.ss = loop.temp_ss;
	  lse.ss = lss;

	  gfc_conv_tmp_array_ref (&rse);
	  gfc_conv_expr (&lse, expr1);

pbrook's avatar
pbrook committed
5738 5739
	  gcc_assert (lse.ss == gfc_ss_terminator
		      && rse.ss == gfc_ss_terminator);
dnovillo's avatar
 
dnovillo committed
5740

5741 5742 5743
	  if (expr2->ts.type == BT_CHARACTER)
	    rse.string_length = string_length;

5744
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5745
					 false, false, dealloc);
dnovillo's avatar
 
dnovillo committed
5746 5747
	  gfc_add_expr_to_block (&body, tmp);
	}
5748

dnovillo's avatar
 
dnovillo committed
5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761
      /* Generate the copying loops.  */
      gfc_trans_scalarizing_loops (&loop, &body);

      /* Wrap the whole thing up.  */
      gfc_add_block_to_block (&block, &loop.pre);
      gfc_add_block_to_block (&block, &loop.post);

      gfc_cleanup_loop (&loop);
    }

  return gfc_finish_block (&block);
}

sayle's avatar
 
sayle committed
5762

5763
/* Check whether EXPR is a copyable array.  */
sayle's avatar
 
sayle committed
5764 5765 5766 5767

static bool
copyable_array_p (gfc_expr * expr)
{
5768 5769 5770
  if (expr->expr_type != EXPR_VARIABLE)
    return false;

sayle's avatar
 
sayle committed
5771
  /* First check it's an array.  */
5772 5773 5774
  if (expr->rank < 1 || !expr->ref || expr->ref->next)
    return false;

5775
  if (!gfc_full_array_ref_p (expr->ref, NULL))
sayle's avatar
 
sayle committed
5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786
    return false;

  /* Next check that it's of a simple enough type.  */
  switch (expr->ts.type)
    {
    case BT_INTEGER:
    case BT_REAL:
    case BT_COMPLEX:
    case BT_LOGICAL:
      return true;

sayle's avatar
 
sayle committed
5787 5788 5789 5790
    case BT_CHARACTER:
      return false;

    case BT_DERIVED:
5791
      return !expr->ts.u.derived->attr.alloc_comp;
sayle's avatar
 
sayle committed
5792

sayle's avatar
 
sayle committed
5793 5794 5795 5796 5797 5798 5799 5800 5801 5802
    default:
      break;
    }

  return false;
}

/* Translate an assignment.  */

tree
5803 5804
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
		      bool dealloc)
sayle's avatar
 
sayle committed
5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816
{
  tree tmp;

  /* Special case a single function returning an array.  */
  if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
    {
      tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
      if (tmp)
	return tmp;
    }

  /* Special case assigning an array to zero.  */
5817
  if (copyable_array_p (expr1)
sayle's avatar
 
sayle committed
5818 5819 5820 5821 5822 5823 5824 5825
      && is_zero_initializer_p (expr2))
    {
      tmp = gfc_trans_zero_assign (expr1);
      if (tmp)
        return tmp;
    }

  /* Special case copying one array to another.  */
5826
  if (copyable_array_p (expr1)
sayle's avatar
 
sayle committed
5827 5828 5829 5830 5831 5832 5833 5834 5835
      && copyable_array_p (expr2)
      && gfc_compare_types (&expr1->ts, &expr2->ts)
      && !gfc_check_dependency (expr1, expr2, 0))
    {
      tmp = gfc_trans_array_copy (expr1, expr2);
      if (tmp)
        return tmp;
    }

sayle's avatar
 
sayle committed
5836
  /* Special case initializing an array from a constant array constructor.  */
5837
  if (copyable_array_p (expr1)
sayle's avatar
 
sayle committed
5838 5839 5840 5841 5842 5843 5844 5845
      && expr2->expr_type == EXPR_ARRAY
      && gfc_compare_types (&expr1->ts, &expr2->ts))
    {
      tmp = gfc_trans_array_constructor_copy (expr1, expr2);
      if (tmp)
	return tmp;
    }

sayle's avatar
 
sayle committed
5846
  /* Fallback to the scalarizer to generate explicit loops.  */
5847
  return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
sayle's avatar
 
sayle committed
5848 5849
}

5850 5851 5852
tree
gfc_trans_init_assign (gfc_code * code)
{
5853
  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
5854 5855
}

dnovillo's avatar
 
dnovillo committed
5856 5857 5858
tree
gfc_trans_assign (gfc_code * code)
{
5859
  return gfc_trans_assignment (code->expr1, code->expr2, false, true);
dnovillo's avatar
 
dnovillo committed
5860
}
5861 5862


5863 5864 5865
/* Special case for initializing a polymorphic dummy with INTENT(OUT).
   A MEMCPY is needed to copy the full data from the default initializer
   of the dynamic type.  */
5866 5867 5868 5869 5870

tree
gfc_trans_class_init_assign (gfc_code *code)
{
  stmtblock_t block;
5871 5872 5873 5874
  tree tmp;
  gfc_se dst,src,memsz;
  gfc_expr *lhs,*rhs,*sz;

5875
  gfc_start_block (&block);
5876 5877

  lhs = gfc_copy_expr (code->expr1);
5878
  gfc_add_data_component (lhs);
5879 5880

  rhs = gfc_copy_expr (code->expr1);
5881 5882
  gfc_add_vptr_component (rhs);
  gfc_add_def_init_component (rhs);
5883 5884

  sz = gfc_copy_expr (code->expr1);
5885 5886
  gfc_add_vptr_component (sz);
  gfc_add_size_component (sz);
5887

5888 5889
  gfc_init_se (&dst, NULL);
  gfc_init_se (&src, NULL);
5890 5891 5892 5893
  gfc_init_se (&memsz, NULL);
  gfc_conv_expr (&dst, lhs);
  gfc_conv_expr (&src, rhs);
  gfc_conv_expr (&memsz, sz);
5894
  gfc_add_block_to_block (&block, &src.pre);
5895
  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
5896 5897 5898 5899 5900 5901
  gfc_add_expr_to_block (&block, tmp);
  
  return gfc_finish_block (&block);
}


5902 5903 5904 5905
/* Translate an assignment to a CLASS object
   (pointer or ordinary assignment).  */

tree
5906
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
5907 5908 5909
{
  stmtblock_t block;
  tree tmp;
janus's avatar
janus committed
5910 5911
  gfc_expr *lhs;
  gfc_expr *rhs;
5912 5913 5914

  gfc_start_block (&block);

5915
  if (expr2->ts.type != BT_CLASS)
5916
    {
5917
      /* Insert an additional assignment which sets the '_vptr' field.  */
5918
      lhs = gfc_copy_expr (expr1);
5919
      gfc_add_vptr_component (lhs);
5920
      if (expr2->ts.type == BT_DERIVED)
5921
	{
janus's avatar
janus committed
5922 5923
	  gfc_symbol *vtab;
	  gfc_symtree *st;
5924
	  vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
janus's avatar
janus committed
5925 5926 5927
	  gcc_assert (vtab);
	  rhs = gfc_get_expr ();
	  rhs->expr_type = EXPR_VARIABLE;
5928
	  gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
janus's avatar
janus committed
5929 5930
	  rhs->symtree = st;
	  rhs->ts = vtab->ts;
5931
	}
5932
      else if (expr2->expr_type == EXPR_NULL)
5933
	rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
5934 5935 5936
      else
	gcc_unreachable ();

janus's avatar
janus committed
5937 5938 5939
      tmp = gfc_trans_pointer_assignment (lhs, rhs);
      gfc_add_expr_to_block (&block, tmp);

5940 5941 5942 5943 5944
      gfc_free_expr (lhs);
      gfc_free_expr (rhs);
    }

  /* Do the actual CLASS assignment.  */
5945 5946
  if (expr2->ts.type == BT_CLASS)
    op = EXEC_ASSIGN;
5947
  else
5948
    gfc_add_data_component (expr1);
5949

5950 5951 5952 5953
  if (op == EXEC_ASSIGN)
    tmp = gfc_trans_assignment (expr1, expr2, false, true);
  else if (op == EXEC_POINTER_ASSIGN)
    tmp = gfc_trans_pointer_assignment (expr1, expr2);
5954 5955 5956 5957 5958 5959 5960
  else
    gcc_unreachable();

  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}